February 2006 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

18 Feb '06

Author: hhubner Date: 2006-02-18 04:02:10 -0600 (Sat, 18 Feb 2006) New Revision: 1846 Added: vendor/portableaserve/ vendor/portableaserve/.cvsignore vendor/portableaserve/CVS/ vendor/portableaserve/CVS/Entries vendor/portableaserve/CVS/Entries.Log vendor/portableaserve/CVS/Repository vendor/portableaserve/CVS/Root vendor/portableaserve/ChangeLog vendor/portableaserve/INSTALL.lisp vendor/portableaserve/README vendor/portableaserve/README.cmucl vendor/portableaserve/acl-compat/ vendor/portableaserve/acl-compat/.cvsignore vendor/portableaserve/acl-compat/CREDITS vendor/portableaserve/acl-compat/CVS/ vendor/portableaserve/acl-compat/CVS/Entries vendor/portableaserve/acl-compat/CVS/Entries.Log vendor/portableaserve/acl-compat/CVS/Repository vendor/portableaserve/acl-compat/CVS/Root vendor/portableaserve/acl-compat/ChangeLog vendor/portableaserve/acl-compat/README vendor/portableaserve/acl-compat/acl-compat-cmu.system vendor/portableaserve/acl-compat/acl-compat-common-lisp-lw.lisp vendor/portableaserve/acl-compat/acl-compat-corman.lisp vendor/portableaserve/acl-compat/acl-compat.asd vendor/portableaserve/acl-compat/acl-excl-common.lisp vendor/portableaserve/acl-compat/acl-excl-corman.lisp vendor/portableaserve/acl-compat/acl-mp-corman.lisp vendor/portableaserve/acl-compat/acl-mp-package.lisp vendor/portableaserve/acl-compat/acl-socket-corman.lisp vendor/portableaserve/acl-compat/acl-ssl-streams.lisp vendor/portableaserve/acl-compat/acl-ssl.lisp vendor/portableaserve/acl-compat/allegro/ vendor/portableaserve/acl-compat/allegro/.cvsignore vendor/portableaserve/acl-compat/allegro/CVS/ vendor/portableaserve/acl-compat/allegro/CVS/Entries vendor/portableaserve/acl-compat/allegro/CVS/Repository vendor/portableaserve/acl-compat/allegro/CVS/Root vendor/portableaserve/acl-compat/allegro/acl-excl.lisp vendor/portableaserve/acl-compat/allegro/acl-mp.lisp vendor/portableaserve/acl-compat/allegro/acl-socket.lisp vendor/portableaserve/acl-compat/allegro/acl-sys.lisp vendor/portableaserve/acl-compat/chunked-stream-mixin.lisp vendor/portableaserve/acl-compat/chunked.lisp vendor/portableaserve/acl-compat/clisp/ vendor/portableaserve/acl-compat/clisp/.cvsignore vendor/portableaserve/acl-compat/clisp/CVS/ vendor/portableaserve/acl-compat/clisp/CVS/Entries vendor/portableaserve/acl-compat/clisp/CVS/Repository vendor/portableaserve/acl-compat/clisp/CVS/Root vendor/portableaserve/acl-compat/clisp/acl-excl.lisp vendor/portableaserve/acl-compat/clisp/acl-mp.lisp vendor/portableaserve/acl-compat/clisp/acl-socket.lisp vendor/portableaserve/acl-compat/clisp/acl-sys.lisp vendor/portableaserve/acl-compat/cmucl/ vendor/portableaserve/acl-compat/cmucl/.cvsignore vendor/portableaserve/acl-compat/cmucl/CVS/ vendor/portableaserve/acl-compat/cmucl/CVS/Entries vendor/portableaserve/acl-compat/cmucl/CVS/Repository vendor/portableaserve/acl-compat/cmucl/CVS/Root vendor/portableaserve/acl-compat/cmucl/acl-excl.lisp vendor/portableaserve/acl-compat/cmucl/acl-mp.lisp vendor/portableaserve/acl-compat/cmucl/acl-socket.lisp vendor/portableaserve/acl-compat/cmucl/acl-sys.lisp vendor/portableaserve/acl-compat/defsys.lisp vendor/portableaserve/acl-compat/lispworks/ vendor/portableaserve/acl-compat/lispworks/.cvsignore vendor/portableaserve/acl-compat/lispworks/CVS/ vendor/portableaserve/acl-compat/lispworks/CVS/Entries vendor/portableaserve/acl-compat/lispworks/CVS/Repository vendor/portableaserve/acl-compat/lispworks/CVS/Root vendor/portableaserve/acl-compat/lispworks/acl-excl.lisp vendor/portableaserve/acl-compat/lispworks/acl-mp.lisp vendor/portableaserve/acl-compat/lispworks/acl-socket.lisp vendor/portableaserve/acl-compat/lispworks/acl-sys.lisp vendor/portableaserve/acl-compat/lw-buffering.lisp vendor/portableaserve/acl-compat/mcl/ vendor/portableaserve/acl-compat/mcl/.cvsignore vendor/portableaserve/acl-compat/mcl/CVS/ vendor/portableaserve/acl-compat/mcl/CVS/Entries vendor/portableaserve/acl-compat/mcl/CVS/Repository vendor/portableaserve/acl-compat/mcl/CVS/Root vendor/portableaserve/acl-compat/mcl/acl-excl.lisp vendor/portableaserve/acl-compat/mcl/acl-mp.lisp vendor/portableaserve/acl-compat/mcl/acl-socket-mcl.lisp vendor/portableaserve/acl-compat/mcl/acl-socket-openmcl.lisp vendor/portableaserve/acl-compat/mcl/acl-sys.lisp vendor/portableaserve/acl-compat/mcl/mcl-stream-fix.lisp vendor/portableaserve/acl-compat/mcl/mcl-timers.lisp vendor/portableaserve/acl-compat/openmcl/ vendor/portableaserve/acl-compat/openmcl/CVS/ vendor/portableaserve/acl-compat/openmcl/CVS/Entries vendor/portableaserve/acl-compat/openmcl/CVS/Repository vendor/portableaserve/acl-compat/openmcl/CVS/Root vendor/portableaserve/acl-compat/packages.lisp vendor/portableaserve/acl-compat/sbcl/ vendor/portableaserve/acl-compat/sbcl/.cvsignore vendor/portableaserve/acl-compat/sbcl/CVS/ vendor/portableaserve/acl-compat/sbcl/CVS/Entries vendor/portableaserve/acl-compat/sbcl/CVS/Repository vendor/portableaserve/acl-compat/sbcl/CVS/Root vendor/portableaserve/acl-compat/sbcl/acl-excl.lisp vendor/portableaserve/acl-compat/sbcl/acl-mp.lisp vendor/portableaserve/acl-compat/sbcl/acl-socket.lisp vendor/portableaserve/acl-compat/sbcl/acl-sys.lisp vendor/portableaserve/acl-compat/scl/ vendor/portableaserve/acl-compat/scl/.cvsignore vendor/portableaserve/acl-compat/scl/CVS/ vendor/portableaserve/acl-compat/scl/CVS/Entries vendor/portableaserve/acl-compat/scl/CVS/Repository vendor/portableaserve/acl-compat/scl/CVS/Root vendor/portableaserve/acl-compat/scl/acl-excl.lisp vendor/portableaserve/acl-compat/scl/acl-mp.lisp vendor/portableaserve/acl-compat/scl/acl-socket.lisp vendor/portableaserve/acl-compat/scl/acl-sys.lisp vendor/portableaserve/acl-compat/test-acl-socket.lisp vendor/portableaserve/aserve/ vendor/portableaserve/aserve/.cvsignore vendor/portableaserve/aserve/CVS/ vendor/portableaserve/aserve/CVS/Entries vendor/portableaserve/aserve/CVS/Entries.Log vendor/portableaserve/aserve/CVS/Repository vendor/portableaserve/aserve/CVS/Root vendor/portableaserve/aserve/ChangeLog vendor/portableaserve/aserve/aserve-cmu.system vendor/portableaserve/aserve/aserve-corman.lisp vendor/portableaserve/aserve/aserve-mcl.system vendor/portableaserve/aserve/aserve.asd vendor/portableaserve/aserve/authorize.cl vendor/portableaserve/aserve/cgi.cl vendor/portableaserve/aserve/client.cl vendor/portableaserve/aserve/decode.cl vendor/portableaserve/aserve/defsys.cl vendor/portableaserve/aserve/doc/ vendor/portableaserve/aserve/doc/.cvsignore vendor/portableaserve/aserve/doc/CVS/ vendor/portableaserve/aserve/doc/CVS/Entries vendor/portableaserve/aserve/doc/CVS/Repository vendor/portableaserve/aserve/doc/CVS/Root vendor/portableaserve/aserve/doc/aserve.html vendor/portableaserve/aserve/doc/cvs.html vendor/portableaserve/aserve/doc/htmlgen.html vendor/portableaserve/aserve/doc/rfc2396.txt vendor/portableaserve/aserve/doc/tutorial.html vendor/portableaserve/aserve/example.cl vendor/portableaserve/aserve/examples/ vendor/portableaserve/aserve/examples/.cvsignore vendor/portableaserve/aserve/examples/.pics/ vendor/portableaserve/aserve/examples/.pics/.cvsignore vendor/portableaserve/aserve/examples/.pics/CVS/ vendor/portableaserve/aserve/examples/.pics/CVS/Entries vendor/portableaserve/aserve/examples/.pics/CVS/Entries.Log vendor/portableaserve/aserve/examples/.pics/CVS/Repository vendor/portableaserve/aserve/examples/.pics/CVS/Root vendor/portableaserve/aserve/examples/.pics/med/ vendor/portableaserve/aserve/examples/.pics/med/.cvsignore vendor/portableaserve/aserve/examples/.pics/med/CVS/ vendor/portableaserve/aserve/examples/.pics/med/CVS/Entries vendor/portableaserve/aserve/examples/.pics/med/CVS/Repository vendor/portableaserve/aserve/examples/.pics/med/CVS/Root vendor/portableaserve/aserve/examples/.pics/med/Marble01.jpg vendor/portableaserve/aserve/examples/.pics/med/aservelogo.gif vendor/portableaserve/aserve/examples/.pics/med/fresh.jpg vendor/portableaserve/aserve/examples/.pics/med/prfile9.jpg vendor/portableaserve/aserve/examples/.xvpics/ vendor/portableaserve/aserve/examples/.xvpics/CVS/ vendor/portableaserve/aserve/examples/.xvpics/CVS/Entries vendor/portableaserve/aserve/examples/.xvpics/CVS/Repository vendor/portableaserve/aserve/examples/.xvpics/CVS/Root vendor/portableaserve/aserve/examples/.xvpics/aservelogo.gif vendor/portableaserve/aserve/examples/CVS/ vendor/portableaserve/aserve/examples/CVS/Entries vendor/portableaserve/aserve/examples/CVS/Entries.Log vendor/portableaserve/aserve/examples/CVS/Repository vendor/portableaserve/aserve/examples/CVS/Root vendor/portableaserve/aserve/examples/aservelogo.gif vendor/portableaserve/aserve/examples/aservepowered.gif vendor/portableaserve/aserve/examples/cgitest.sh vendor/portableaserve/aserve/examples/chat.cl vendor/portableaserve/aserve/examples/examples.cl vendor/portableaserve/aserve/examples/file2000.txt vendor/portableaserve/aserve/examples/foo.txt vendor/portableaserve/aserve/examples/fresh.jpg vendor/portableaserve/aserve/examples/prfile9.jpg vendor/portableaserve/aserve/examples/puzzle.cl vendor/portableaserve/aserve/examples/tutorial.cl vendor/portableaserve/aserve/examples/urian.cl vendor/portableaserve/aserve/headers.cl vendor/portableaserve/aserve/htmlgen/ vendor/portableaserve/aserve/htmlgen/.cvsignore vendor/portableaserve/aserve/htmlgen/CVS/ vendor/portableaserve/aserve/htmlgen/CVS/Entries vendor/portableaserve/aserve/htmlgen/CVS/Repository vendor/portableaserve/aserve/htmlgen/CVS/Root vendor/portableaserve/aserve/htmlgen/ChangeLog vendor/portableaserve/aserve/htmlgen/htmlgen.asd vendor/portableaserve/aserve/htmlgen/htmlgen.cl vendor/portableaserve/aserve/htmlgen/test.cl vendor/portableaserve/aserve/license-allegroserve.txt vendor/portableaserve/aserve/license-lgpl.txt vendor/portableaserve/aserve/load.cl vendor/portableaserve/aserve/loadonly.cl vendor/portableaserve/aserve/log.cl vendor/portableaserve/aserve/macs.cl vendor/portableaserve/aserve/main.cl vendor/portableaserve/aserve/packages.cl vendor/portableaserve/aserve/parse.cl vendor/portableaserve/aserve/proxy.cl vendor/portableaserve/aserve/publish.cl vendor/portableaserve/aserve/test/ vendor/portableaserve/aserve/test/.csvignore vendor/portableaserve/aserve/test/CVS/ vendor/portableaserve/aserve/test/CVS/Entries vendor/portableaserve/aserve/test/CVS/Entries.Log vendor/portableaserve/aserve/test/CVS/Repository vendor/portableaserve/aserve/test/CVS/Root vendor/portableaserve/aserve/test/server.pem vendor/portableaserve/aserve/test/t-aserve.cl vendor/portableaserve/aserve/test/testdir/ vendor/portableaserve/aserve/test/testdir/CVS/ vendor/portableaserve/aserve/test/testdir/CVS/Entries vendor/portableaserve/aserve/test/testdir/CVS/Entries.Log vendor/portableaserve/aserve/test/testdir/CVS/Repository vendor/portableaserve/aserve/test/testdir/CVS/Root vendor/portableaserve/aserve/test/testdir/aaa.foo vendor/portableaserve/aserve/test/testdir/access.cl vendor/portableaserve/aserve/test/testdir/bbb.ign vendor/portableaserve/aserve/test/testdir/ccc.html vendor/portableaserve/aserve/test/testdir/readme vendor/portableaserve/aserve/test/testdir/suba/ vendor/portableaserve/aserve/test/testdir/suba/CVS/ vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries.Log vendor/portableaserve/aserve/test/testdir/suba/CVS/Repository vendor/portableaserve/aserve/test/testdir/suba/CVS/Root vendor/portableaserve/aserve/test/testdir/suba/access.cl vendor/portableaserve/aserve/test/testdir/suba/foo.html vendor/portableaserve/aserve/test/testdir/suba/subd/ vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/ vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Entries vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Repository vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Root vendor/portableaserve/aserve/test/testdir/suba/subd/ddd.html vendor/portableaserve/aserve/test/testdir/suba/subsuba/ vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/ vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Entries vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Repository vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Root vendor/portableaserve/aserve/test/testdir/suba/subsuba/foo.html vendor/portableaserve/aserve/test/testdir/subb/ vendor/portableaserve/aserve/test/testdir/subb/CVS/ vendor/portableaserve/aserve/test/testdir/subb/CVS/Entries vendor/portableaserve/aserve/test/testdir/subb/CVS/Repository vendor/portableaserve/aserve/test/testdir/subb/CVS/Root vendor/portableaserve/aserve/test/testdir/subb/access.cl vendor/portableaserve/aserve/test/testdir/subb/foo.html vendor/portableaserve/aserve/test/testdir/subc/ vendor/portableaserve/aserve/test/testdir/subc/CVS/ vendor/portableaserve/aserve/test/testdir/subc/CVS/Entries vendor/portableaserve/aserve/test/testdir/subc/CVS/Repository vendor/portableaserve/aserve/test/testdir/subc/CVS/Root vendor/portableaserve/aserve/test/testdir/subc/ccc.html vendor/portableaserve/aserve/test/testdir/subd/ vendor/portableaserve/aserve/test/testdir/subd/CVS/ vendor/portableaserve/aserve/test/testdir/subd/CVS/Entries vendor/portableaserve/aserve/test/testdir/subd/CVS/Repository vendor/portableaserve/aserve/test/testdir/subd/CVS/Root vendor/portableaserve/aserve/test/testdir/subd/ddee.html vendor/portableaserve/aserve/webactions/ vendor/portableaserve/aserve/webactions/.cvsignore vendor/portableaserve/aserve/webactions/CVS/ vendor/portableaserve/aserve/webactions/CVS/Entries vendor/portableaserve/aserve/webactions/CVS/Entries.Log vendor/portableaserve/aserve/webactions/CVS/Repository vendor/portableaserve/aserve/webactions/CVS/Root vendor/portableaserve/aserve/webactions/ChangeLog vendor/portableaserve/aserve/webactions/clpage.cl vendor/portableaserve/aserve/webactions/clpcode/ vendor/portableaserve/aserve/webactions/clpcode/.cvsignore vendor/portableaserve/aserve/webactions/clpcode/CVS/ vendor/portableaserve/aserve/webactions/clpcode/CVS/Entries vendor/portableaserve/aserve/webactions/clpcode/CVS/Repository vendor/portableaserve/aserve/webactions/clpcode/CVS/Root vendor/portableaserve/aserve/webactions/clpcode/clp.cl vendor/portableaserve/aserve/webactions/clpcode/http.cl vendor/portableaserve/aserve/webactions/clpcode/time.cl vendor/portableaserve/aserve/webactions/clpcode/wa.cl vendor/portableaserve/aserve/webactions/doc/ vendor/portableaserve/aserve/webactions/doc/.cvsignore vendor/portableaserve/aserve/webactions/doc/CVS/ vendor/portableaserve/aserve/webactions/doc/CVS/Entries vendor/portableaserve/aserve/webactions/doc/CVS/Repository vendor/portableaserve/aserve/webactions/doc/CVS/Root vendor/portableaserve/aserve/webactions/doc/using-webactions.html vendor/portableaserve/aserve/webactions/doc/webactions.html vendor/portableaserve/aserve/webactions/load.cl vendor/portableaserve/aserve/webactions/test/ vendor/portableaserve/aserve/webactions/test/.cvsignore vendor/portableaserve/aserve/webactions/test/CVS/ vendor/portableaserve/aserve/webactions/test/CVS/Entries vendor/portableaserve/aserve/webactions/test/CVS/Entries.Log vendor/portableaserve/aserve/webactions/test/CVS/Repository vendor/portableaserve/aserve/webactions/test/CVS/Root vendor/portableaserve/aserve/webactions/test/sitea/ vendor/portableaserve/aserve/webactions/test/sitea/CVS/ vendor/portableaserve/aserve/webactions/test/sitea/CVS/Entries vendor/portableaserve/aserve/webactions/test/sitea/CVS/Repository vendor/portableaserve/aserve/webactions/test/sitea/CVS/Root vendor/portableaserve/aserve/webactions/test/sitea/file1.clp vendor/portableaserve/aserve/webactions/test/sitea/file2.clp vendor/portableaserve/aserve/webactions/test/sitea/file3.clp vendor/portableaserve/aserve/webactions/test/sitea/project.cl vendor/portableaserve/aserve/webactions/test/t-webactions.cl vendor/portableaserve/aserve/webactions/webact.cl vendor/portableaserve/aserve/webactions/webactions.asd vendor/portableaserve/aserve/webactions/websession.cl vendor/portableaserve/build-aserve-lw.lisp vendor/portableaserve/clean.sh vendor/portableaserve/compile-aserve-lw.lisp vendor/portableaserve/contrib/ vendor/portableaserve/contrib/.cvsignore vendor/portableaserve/contrib/CVS/ vendor/portableaserve/contrib/CVS/Entries vendor/portableaserve/contrib/CVS/Repository vendor/portableaserve/contrib/CVS/Root vendor/portableaserve/contrib/example.lsp vendor/portableaserve/contrib/lsp.lisp vendor/portableaserve/contrib/session.lisp vendor/portableaserve/debian/ vendor/portableaserve/debian/.cvsignore vendor/portableaserve/debian/CVS/ vendor/portableaserve/debian/CVS/Entries vendor/portableaserve/debian/CVS/Repository vendor/portableaserve/debian/CVS/Root vendor/portableaserve/debian/README.Debian vendor/portableaserve/debian/changelog vendor/portableaserve/debian/cl-acl-compat.README.Debian vendor/portableaserve/debian/cl-acl-compat.postinst vendor/portableaserve/debian/cl-acl-compat.preinst vendor/portableaserve/debian/cl-acl-compat.prerm vendor/portableaserve/debian/cl-aserve.doc-base vendor/portableaserve/debian/cl-aserve.docs vendor/portableaserve/debian/cl-aserve.postinst vendor/portableaserve/debian/cl-aserve.preinst vendor/portableaserve/debian/cl-aserve.prerm vendor/portableaserve/debian/cl-htmlgen.docs vendor/portableaserve/debian/cl-htmlgen.postinst vendor/portableaserve/debian/cl-htmlgen.preinst vendor/portableaserve/debian/cl-htmlgen.prerm vendor/portableaserve/debian/control vendor/portableaserve/debian/copyright vendor/portableaserve/debian/rules vendor/portableaserve/libs/ vendor/portableaserve/libs/.cvsignore vendor/portableaserve/libs/CVS/ vendor/portableaserve/libs/CVS/Entries vendor/portableaserve/libs/CVS/Entries.Log vendor/portableaserve/libs/CVS/Repository vendor/portableaserve/libs/CVS/Root vendor/portableaserve/libs/README vendor/portableaserve/libs/asdf.lisp vendor/portableaserve/libs/cl-ppcre/ vendor/portableaserve/libs/cl-ppcre/CHANGELOG vendor/portableaserve/libs/cl-ppcre/CVS/ vendor/portableaserve/libs/cl-ppcre/CVS/Entries vendor/portableaserve/libs/cl-ppcre/CVS/Entries.Log vendor/portableaserve/libs/cl-ppcre/CVS/Repository vendor/portableaserve/libs/cl-ppcre/CVS/Root vendor/portableaserve/libs/cl-ppcre/README vendor/portableaserve/libs/cl-ppcre/api.lisp vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.asd vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.system vendor/portableaserve/libs/cl-ppcre/cl-ppcre.asd vendor/portableaserve/libs/cl-ppcre/cl-ppcre.system vendor/portableaserve/libs/cl-ppcre/closures.lisp vendor/portableaserve/libs/cl-ppcre/convert.lisp vendor/portableaserve/libs/cl-ppcre/doc/ vendor/portableaserve/libs/cl-ppcre/doc/CVS/ vendor/portableaserve/libs/cl-ppcre/doc/CVS/Entries vendor/portableaserve/libs/cl-ppcre/doc/CVS/Repository vendor/portableaserve/libs/cl-ppcre/doc/CVS/Root vendor/portableaserve/libs/cl-ppcre/doc/benchmarks.2002-12-22.txt vendor/portableaserve/libs/cl-ppcre/doc/index.html vendor/portableaserve/libs/cl-ppcre/errors.lisp vendor/portableaserve/libs/cl-ppcre/lexer.lisp vendor/portableaserve/libs/cl-ppcre/load.lisp vendor/portableaserve/libs/cl-ppcre/optimize.lisp vendor/portableaserve/libs/cl-ppcre/packages.lisp vendor/portableaserve/libs/cl-ppcre/parser.lisp vendor/portableaserve/libs/cl-ppcre/perltest.pl vendor/portableaserve/libs/cl-ppcre/ppcre-tests.lisp vendor/portableaserve/libs/cl-ppcre/regex-class.lisp vendor/portableaserve/libs/cl-ppcre/repetition-closures.lisp vendor/portableaserve/libs/cl-ppcre/scanner.lisp vendor/portableaserve/libs/cl-ppcre/specials.lisp vendor/portableaserve/libs/cl-ppcre/testdata vendor/portableaserve/libs/cl-ppcre/testinput vendor/portableaserve/libs/cl-ppcre/util.lisp vendor/portableaserve/libs/puri-1.3.1/ vendor/portableaserve/libs/puri-1.3.1/.cvsignore vendor/portableaserve/libs/puri-1.3.1/CVS/ vendor/portableaserve/libs/puri-1.3.1/CVS/Entries vendor/portableaserve/libs/puri-1.3.1/CVS/Repository vendor/portableaserve/libs/puri-1.3.1/CVS/Root vendor/portableaserve/libs/puri-1.3.1/LICENSE vendor/portableaserve/libs/puri-1.3.1/README vendor/portableaserve/libs/puri-1.3.1/puri.asd vendor/portableaserve/libs/puri-1.3.1/src.lisp vendor/portableaserve/libs/puri-1.3.1/tests.lisp vendor/portableaserve/libs/puri-1.3.1/uri.html vendor/portableaserve/logical-hostnames.lisp Log: importing current portableaserve Added: vendor/portableaserve/.cvsignore =================================================================== --- vendor/portableaserve/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/CVS/Entries =================================================================== --- vendor/portableaserve/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,10 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:03 2004// +/ChangeLog/1.32/Sat Jan 21 16:51:45 2006// +/INSTALL.lisp/1.17/Thu Jun 10 03:52:10 2004// +/README/1.9/Sun Aug 31 18:42:28 2003// +/README.cmucl/1.5/Sun Nov 24 13:20:46 2002// +/build-aserve-lw.lisp/1.2/Fri Dec 28 15:55:27 2001// +/clean.sh/1.1/Mon Feb 9 11:40:01 2004// +/compile-aserve-lw.lisp/1.1/Wed Aug 15 09:24:31 2001// +/logical-hostnames.lisp/1.3/Mon Apr 8 14:18:10 2002// +D Added: vendor/portableaserve/CVS/Entries.Log =================================================================== --- vendor/portableaserve/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +A D/acl-compat//// +A D/aserve//// +A D/contrib//// +A D/debian//// +A D/libs//// Added: vendor/portableaserve/CVS/Repository =================================================================== --- vendor/portableaserve/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve Added: vendor/portableaserve/CVS/Root =================================================================== --- vendor/portableaserve/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/ChangeLog =================================================================== --- vendor/portableaserve/ChangeLog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/ChangeLog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,189 @@ +2006-01-21 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/proxy.cl (write-body-buffers): initialize len to numeric + value in all cases + +2005-07-05 Klaus Harbo <klaus(a)mu.dk> + + * acl-compat/lispworks/acl-socket.lisp (make-ssl-client-stream): + Support for LispWorks' own SSL facilities. + +2005-06-17 Edi Weitz <edi(a)agharta.de> + + * acl-compat/lispworks/acl-excl.lisp (filesys-inode): + Conditionalize. It's only used on Unix and otherwise the code + won't even compile on Windows. + +2004-10-01 Kevin Rosenberg <kevin(a)rosenberg.net> + * acl-compat/mcl/acl-mp: Apply portability patch from Gary Byers + to fix filesys-inode for linux + +2004-09-24 Kevin Rosenberg <kevin(a)rosenberg.net> + * acl-compat/sbcl/acl-mp.lisp: Apply patch from Gabor Melis + to fix type [portableaserve-discuss(a)lists.sourceforge.net] + +2004-08-31 Kevin Rosenberg <kevin(a)rosenberg.net> + * Fix ipaddr-to-hostname for SBCL + * Fix for request-query-value for SBCL + +2004-08-30 Kevin Rosenberg <kevin(a)rosenberg.net> + * Fixes for compilation on SBCL + * Add support for :cookie-domain for webactions + +2004-08-04 Kevin Rosenberg <kevin(a)rosenberg.net> + * Commit patch from Chaskiel M Grundman <cg2v(a)andrew.cmu.edu> + for better Allegro support + +2004-06-09 Kevin Rosenberg <kevin(a)rosenberg.net> + * Commit patch from Nick Levin addressing compilation on Lispworks + +2004-04-26 Kevin Rosenberg <kevin(a)rosenberg.net> + * aserve/webactions: Commit patch, with modifications, from + Ivan Toshkov + * aserve/load.cl: Add implemenatation of compile-file-if-needed + +2004-02-16 Rudi Schlatte <rudi(a)constantly.at> + + * libs/cl-ppcre/: Import Edi Weitz's cl-ppcre library. + + * INSTALL.lisp: load it. + + * aserve/test/t-aserve.cl (test-publish-directory): Correct + directory regexp (put some more leaning toothpicks in) + + * aserve/main.cl: Remove meta-based date-to-universal-time + function; the shiny new match-regexp can handle these expressions. + +2004-02-08 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/webactions/webact.cl, aserve/webactions/clpage.cl, + aserve/test/t-aserve.cl, aserve/proxy.cl, aserve/main.cl, + aserve/log.cl, aserve/chat.cl, aserve/client.cl, aserve/cgi.cl: + Use package puri throughout. + + * INSTALL.lisp: Removed warnings for loading the provided-by-us + versions of asdf et al. Load puri library before acl-compat. + Remove MCL-specific handling. + +2004-01-27 Rudi Schlatte <rudi(a)constantly.at> + + * INSTALL.lisp: clean up a bit, merge sbcl, cmu and lispworks + loading code. + + * Replaced package prefix excl: with acl-compat.excl: throughout. + + * aserve/main.cl (connection-reset-error): Hackishly implement for + OpenMCL and conditionalize allegro-specific function call -- this + should fix stray hangs (caused by threads wanting to enter the + debugger) on all platforms. + +2004-01-21 Rudi Schlatte <rudi(a)constantly.at> + + * contrib/asdf.lisp: New upstream version. + +2004-01-11 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/cgi.cl: Frob package references to acl-compat ones. + + * aserve/main.cl: Added setuid / setgid for sbcl. + +2003-12-02 Rudi Schlatte <rudi(a)constantly.at> + + * Update to upstream version 1.2.33 + +2003-12-01 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/log.cl (log-request): Don't output request string via format. + +2003-11-27 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/test/t-aserve.cl: Don't assume that long-site-name + returns a FQDN; better fixes than just using "localhost" welcome + (but these will be implementation-specific, I fear...) + +2003-11-06 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/htmlgen/htmlgen.cl (html-standard-print): Fix bug + reported by Sean Ross to portableaserve-help (2003-11-06): output + the closing tags to the given stream, not standard-output + +2003-08-31 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/test/t-aserve.cl: First steps for activating test code, + using kmr's port of Franz's tester + +2003-04-27 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/parse.cl (read-headers-into-buffer): (Finally) merge + debug code fix from Walter C. Pelissero + +2003-04-02 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/example.cl: Prettified aserve/example.cl: make sensible + start-server, start-simple-server functions (Allegro's original + examples are in aserve/examples/ nowadays) + +2003-03-24 Rudi Schlatte <rudi(a)constantly.at> + + * aserve/client.cl (do-http-request): Restore :format :text + behavior (broke this last summer.. sorrysorrybowbow) + +2003-02-28 Rudi Schlatte <rudi(a)constantly.at> + + * INSTALL.lisp: Support sbcl 0.7.13 single-threaded + +2002-07-19 Rudi Schlatte <rudi(a)constantly.at> + + * contrib/lsp.lisp (Module): Lisp Server Pages, contributed by + John Wiseman via http://lemonodor.com/archives/000128.html + + * contrib/session.lisp (Module): Session support, contributed by + Brendan Burns to Franz's opensource list + +2002-07-07 Rudi Schlatte <rudi(a)constantly.at> + +* cmucl version now uses asdf instead of mk-defsystem: + +** Added directory contrib, contrib/asdf.lisp + +** Added acl-compat/acl-compat.asd, aserve/aserve.asd, + aserve/htmlgen/htmlgen.asd (thanks to David Lichteblau for the asd + files) + +** Updated README.cmucl, README + +* Changed client.cl to use http/1.0 (Remember to revert this when chunking + is implemented!) (Thanks to David Lichteblau for bug report & patch) + +Changes in Portable AllegroServe 1.2.5a (2001-08-30) +- Chunking implemented for Lispworks. +- Fixed problem in Lispworks port with accepting too many connections + (and consequently running out of file descriptors) under heavy load. +- Incorporated changes in AllegroServe between versions 1.2.3 and 1.2.5. + +Changes in Portable AServe 1.2.3b (09.08.2001) +- Fixed bug with POST requests +- General code cleanup +- implemented some missing ACL-COMPAT functions + +Changes in AServe for LW 1.2.3a (06.08.2001) +- Rudolf Schlatte's changes for supporting CMUCL + merged. +- Several critical bugs fixed (like the lockup of worker-threads + that occured on higher load). + (Thanks go to Vebjorn Ljosa for finding and fixing this and other + critical bugs) +- Updated Portable AllegroServe to the changes in Franz AllegroServe 1.2.3 + +Changes in AServe for LW 1.1.41b (02.06.2001) +- Fixed reloading of pages + Wade Humeniuk kindly contributed a DATE-TO-UNIVERSAL-TIME + function that doesn't use MATCH-REGEXP. + +Changes in ACL-COMPAT (02.06.2001) +- MATCH-REGEXP got a Keyword argument :return +- Much improved MP:WITH-TIMEOUT using LispWorks timers and not + a new process for each timer. +- Fixed a bug in scan-macros.lisp where complementing of charsets + did not really work. + Added: vendor/portableaserve/INSTALL.lisp =================================================================== --- vendor/portableaserve/INSTALL.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/INSTALL.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,96 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- + +(in-package "CL-USER") + +(defun ensure-asdf () + #+asdf (return-from ensure-asdf t) + #+sbcl (require :asdf) + #-sbcl (let ((asdf-pathname + (merge-pathnames (make-pathname + :directory '(:relative "libs") + :name "asdf" + :case :local) + *load-truename*))) + (load asdf-pathname))) + +(ensure-asdf) + +(progn + (flet ((find-or-load-system (system path) + (let ((path (merge-pathnames path *load-truename*))) + (unless (asdf:find-system system nil) + (load path))))) + (find-or-load-system :puri + (make-pathname + :directory '(:relative "libs" "puri-1.3.1") + :name "puri" :type "asd" :case :local)) + (find-or-load-system :cl-ppcre + (make-pathname + :directory '(:relative "libs" "cl-ppcre") + :name "cl-ppcre" :type "asd" :case :local)) + (find-or-load-system :acl-compat + (make-pathname + :directory '(:relative "acl-compat") + :name "acl-compat" :type "asd" :case :local)) + (find-or-load-system :htmlgen + (make-pathname + :directory '(:relative "aserve" "htmlgen") + :name "htmlgen" :type "asd" :case :local)) + (find-or-load-system :aserve + (make-pathname + :directory '(:relative "aserve") + :name "aserve" :type "asd" :case :local)) + (find-or-load-system :webactions + (make-pathname + :directory '(:relative "aserve" "webactions") + :name "webactions" :type "asd" :case :local))) + ;; Compile and load the ASERVE system + (asdf:operate 'asdf:load-op :aserve) + (asdf:operate 'asdf:load-op :webactions) + + ;; Startup multiprocessing. + ;; + ;; this isn't strictly necessary, but scheduling feels very coarse + ;; before the evaluation of (startup-idle-and-top-level-loops) -- + ;; answer delays of about 1s per http request. + ;; + ;; KLUDGE: startup-idle-and-top-level-loops can only be evaluated + ;; once, so we look for something resembling an existing idle loop + ;; before invoking it. + #|| + #+mp + (unless (find-if + #'(lambda (proc) (string= (mp:process-name proc) "Idle Loop")) + (mp:all-processes)) + (mp::startup-idle-and-top-level-loops)) + ||# + ;; DOUBLE KLUDGE: The preceding (commented-out) form caused the + ;; loading of INSTALL.lisp to abort silently (!), so we do the + ;; following, pilfered from eclipse the window manager: + #+(and cmu mp) + (setf mp::*idle-process* mp::*initial-process*) + + ) + + +#|| +;;; To test the installation, evaluate the following: + +;;; Load example.lisp in the aserve directory. +(load "aserve:example.cl") + +;;; Select example package +(in-package :aserve-example) + +;;; This option enables extended debug message output +(net.aserve::debug-on :info) + +;;; This option enables to enter the debugger if an error +;;; occurs. (instead of simply logging and ignoring it) +(net.aserve::debug-on :notrap) + +;;; Start example server (in multiprocessing) on port 2001 +(start-server :port 2001) + +;MCL/OpenMCL note: chunking is not yet implemented so use (start-server :port 2001 :chunking nil) +||# Added: vendor/portableaserve/README =================================================================== --- vendor/portableaserve/README 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/README 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,32 @@ +README -- + +This is a short description of what you will find +in the subdirectories of this archive + + ./acl-compat/ Several ACL compatibility hacks + ./aserve/ The AServe source + ./debian/ Debian package files + ./contrib/ Additional useful (?) code contributed by users + ./logical-hostnames.lisp Some logical-pathname-translations needed by defsys + ./README This file + ./README.cmucl Additional documentation for CMU Common Lisp + ./INSTALL.lisp Quick installation + + The quick-installation script compiles and loads Portable AllegroServe. + + Loading the file aserve:example.cl and evaluating + (aserve-example::start-server :port 2001) starts an AllegroServe + server on http://localhost:2001 that shows off some of the things + possible with AllegroServe. Depending on the Lisp implementation, it + might be necessary to give additional arguments :chunking nil and/or + :listeners 0, since chunked transfer encoding and multi-threading are + not supported everywhere. + + +Regards, +Jochen Schmidt + +-- +jsc(a)dataheaven.de +http://www.dataheaven.de + Added: vendor/portableaserve/README.cmucl =================================================================== --- vendor/portableaserve/README.cmucl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/README.cmucl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,99 @@ +Hey emacs, this is -*- text -*- + + +CMU Common Lisp-specific requirements + + + +0. Executive summary + + + To begin, just load INSTALL.lisp. Then, load + aserve/examples/examples.cl and start the server with + +(net.aserve:start :port 8080) + + If you experience problems or want to get rid of some annoying + warnings, read on. + + + +1. Man, this is S_L_O_W! This is unusable! + + + Chances are you are an experienced user and loaded aserve through + asdf (see next section on some words about that) instead of loading + INSTALL.lisp. If so, you will likely be experiencing request + answer times of about 1 second -- per request, so you can see these + 1 pixel transparent GIFs arrive one after the other ... + + Take a look at INSTALL.lisp or the function + cl-user::init-aserve-cmu in aserve.asd. Once the multiprocessing + is initialized by one of these methods, the server will be quite a + bit more responsive. + + + +2. asdf (Another System Definition Facility) + + + asdf is Dan Barlow's CLOSsy defsystem facility. A defsystem is the + Lisp equivalent of the Unix "make" utility; i.e. we can tell it to + compile / load a system, and it knows what files to operate on in + what order. For further information about asdf, start at + <URL:http://ww.telent.net/cliki/asdf>. + + Since asdf is not (yet?) included with Common Lisp implementations, + we have placed it in the contrib/ directory. The maintainers will + try to keep the included version synched with upstream. Please + write to portableaserve-discuss(a)lists.sourceforge.net if you notice + our version has grown old! + + If you want to get rid of the (harmless) warnings during + INSTALL.lisp, load asdf in your Lisp initialisation file + ~/.cmucl-init. If you do that, you might also want to add a + location for ASDF systems to the variable ASDF:*CENTRAL-REGISTRY*, + for example + +(push "/home/rudi/lisp/systems/" asdf:*central-registry*) + + Then link all the asd files to that path, with something like: + +$ ln -sf /home/rudi/lisp/portableaserve/acl-compat/acl-compat.asd ~/systems/ +$ ln -sf /home/rudi/lisp/portableaserve/aserve/aserve.asd ~/systems/ +$ ln -sf /home/rudi/lisp/portableaserve/aserve/htmlgen/htmlgen.asd ~/systems/ + + After all that hassle, what's in it for you? Well, from then on, + you can just evaluate + +(asdf:operate 'asdf:load-op :aserve) + + to load AllegroServe, and systems of your own can depend on aserve + if they use it, so that it gets loaded automatically when needed. + In that case, have a look at the multiprocessing workarounds in + INSTALL.lisp or the function cl-user::init-aserve-cmu (defined in + aserve.asd); one of these is needed, or you will be unhappy with + the request answer times you get :) + + + +3. Gray streams + + + Portable Allegroserve needs Gray stream support in the Lisp image + it's running in. The file acl-compat.asd should load the required + files automatically, if gray streams are not yet present in the + Lisp image during system compile / load. If you experience + problems, please report them to the portableaserve mailing list; be + sure to include your version of cmucl, where you obtained it, where + its files are placed in your system, etc. Failing to cleanly load + acl-compat.asd is considered a bug; don't hesitate to report it as + such. As it is, users reported success both on Debian systems and + with the cmucl distribution from cons.org, so it will likely Just + Work (tm). + + +Have fun, + +Rudi Schlatte +rudi(a)constantly.at Added: vendor/portableaserve/acl-compat/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/CREDITS =================================================================== --- vendor/portableaserve/acl-compat/CREDITS 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/CREDITS 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,59 @@ +-*- text -*- + +CREDITS; a.k.a. the history of Portable AllegroServe + +This was written by Rudi Schlatte, who (knowing himself) is sure he +forgot some important contributors. Please mail me (rudi at +constantly.at) to point out any inconsistencies, don't be shy! + +* Corman Lisp + +The code that started it all. Chris Double took Allegro's +open-sourced code, got it to run on Corman Lisp and released the +code.. After Portable AllegroServe got off the ground, he re-arranged +his port so that it fit in the structure of acl-compat. + +* Xanalys LispWorks + +Jochen Schmidt ported Chris Double's AllegroServe port to LispWorks, +laid the groundwork for the "Portable" part of paserve and started +the SourceForge project. + +* cmucl + +cmucl was the third Lisp implementation to run Portable +AllegroServe. The port was done by Rudi Schlatte during his military +service out of sheer boredom. + +* Digitool MCL + +John DeSoi contributed this port and kept it working when the antics +of other developers broke his code once again. + +* OpenMCL + +Also done by John DeSoi. Gary Byers himself later contributed code to +support OpenMCL's OS-level threads (OpenMCL version 14 and up) in an +efficient way. + +* sbcl + +This port was done by Rudi Schlatte, using Daniel Barlow's sbcl +multiprocessing code in the McCLIM GUI project as inspiration. + +* clisp + +Also by Rudi Schlatte. Since clisp has no support for threads, +neither does acl-compat on this platform. Code can still be +compiled, however. + +* Scieneer Common Lisp + +This port was contributed by Douglas Crosher. + +* Allegro Common Lisp + +It may seem strange to implement an API on top of itself, but Kevin +Rosenberg's implementation makes it possible to run systems that use +acl-compat on ACL itself without source changes. + Added: vendor/portableaserve/acl-compat/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,22 @@ +/.cvsignore/1.7/Mon Feb 9 14:11:03 2004// +/CREDITS/1.1/Sun Jan 18 16:29:15 2004// +/ChangeLog/1.51/Sun Jan 22 13:01:22 2006// +/README/1.1/Sun Jan 18 16:29:15 2004// +/acl-compat-cmu.system/1.4/Mon Nov 25 11:57:24 2002// +/acl-compat-common-lisp-lw.lisp/1.1/Mon Apr 8 21:53:51 2002// +/acl-compat-corman.lisp/1.1/Fri Jan 3 15:02:09 2003// +/acl-compat.asd/1.53/Thu Aug 5 04:46:47 2004// +/acl-excl-common.lisp/1.7/Fri Feb 18 20:24:30 2005// +/acl-excl-corman.lisp/1.2/Sun Jan 18 16:29:15 2004// +/acl-mp-corman.lisp/1.1/Fri Jan 3 15:02:09 2003// +/acl-mp-package.lisp/1.3/Fri Dec 5 22:36:32 2003// +/acl-socket-corman.lisp/1.1/Fri Jan 3 15:02:09 2003// +/acl-ssl-streams.lisp/1.7/Wed Feb 4 19:47:34 2004// +/acl-ssl.lisp/1.3/Sat Jan 4 11:33:15 2003// +/chunked-stream-mixin.lisp/1.16/Sat Feb 14 11:35:22 2004// +/chunked.lisp/1.6/Sun Jul 7 10:15:07 2002// +/defsys.lisp/1.9/Thu Jun 20 06:39:44 2002// +/lw-buffering.lisp/1.14/Mon Dec 15 15:10:41 2003// +/packages.lisp/1.27/Thu Oct 20 07:54:06 2005// +/test-acl-socket.lisp/1.2/Tue Feb 26 16:22:53 2002// +D Added: vendor/portableaserve/acl-compat/CVS/Entries.Log =================================================================== --- vendor/portableaserve/acl-compat/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,8 @@ +A D/allegro//// +A D/clisp//// +A D/cmucl//// +A D/lispworks//// +A D/mcl//// +A D/openmcl//// +A D/sbcl//// +A D/scl//// Added: vendor/portableaserve/acl-compat/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat Added: vendor/portableaserve/acl-compat/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/ChangeLog =================================================================== --- vendor/portableaserve/acl-compat/ChangeLog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/ChangeLog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,354 @@ +2006-01-22 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (defun/sb-thread): silence compilation style + warning on single-threaded sbcl + + * sbcl/acl-excl.lisp (filesys-type): Fix bogus variable name :( + +2006-01-21 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-excl.lisp (filesys-type, filesys-inode): use sb-posix + instead of sbcl internals + +2005-08-05 Gabor Melis <mega(a)hotpop.com> + + * sbcl/acl-mp.lisp: updated to use the thread object api + available since sbcl 0.9.2 + +2004-02-17 Rudi Schlatte <rudi(a)SLAW40.kfunigraz.ac.at> + + * acl-excl-common.lisp (match-regexp): Make :return :index return + values same as ACL + +2004-02-16 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-compat.asd: + - Add some meta-information to system definition + - Fix bug: all but the first :depends-on arguments are silently + ignored. :/ + +2004-02-16 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: Remove references to nregex package. + + * acl-excl-common.lisp (match-regexp, compile-regexp): Implement + using cl-ppcre. + + * acl-compat.asd: Eliminate meta and nregex, use cl-ppcre instead. + +2004-02-14 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Make Gray streams loading on cmucl a little bit + saner (but only a little bit) + + * chunked-stream-mixin.lisp: Don't add to *features*, remove + provide form. + +2004-02-08 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Introduce dependency on puri, remove meta and + uri.lisp + +2004-02-02 Rudi Schlatte <rudi(a)constantly.at> + + * cmucl/acl-mp.lisp (process-run-function): Give the new process + a run reason, so that it doesn't hang from the start. + + * cmucl/acl-socket.lisp (get-fd): Added method for server-socket. + +2004-01-28 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: excl -> acl-compat.excl + + * lispworks/acl-socket.lisp: ditto. + +2004-01-27 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp: replace excl: package prefix with + acl-compat.excl: + +2004-01-26 Rudi Schlatte <rudi(a)constantly.at> + + * mcl/acl-excl.lisp (fixnump): new function. + + * packages.lisp (:acl-compat.excl): Remove "excl" nickname. + + * clisp/acl-excl.lisp (fixnump): new function. + +2004-01-24 Rudi Schlatte <rudi(a)constantly.at> + + * acl-excl-common.lisp (string-to-octets): null-terminate vector + when asked to. + + * cmucl/acl-excl.lisp, lispworks/acl-excl.lisp, mcl/acl-excl.lisp, + sbcl/acl-excl.lisp, scl/acl-excl.lisp: Move write-vector, + string-to-octets to commmon file. + + * acl-excl-common.lisp: Moved write-vector, string-to-octets from + implementation-specific files. + +2004-01-19 Rudi Schlatte <rudi(a)constantly.at> + + * scl/acl-excl.lisp, sbcl/acl-excl.lisp, mcl/acl-excl.lisp, + lispworks/acl-excl.lisp, cmucl/acl-excl.lisp, + clisp/acl-excl.lisp: Remove common functionality from + implementation-specific files, dammit! + + * acl-compat.asd: Added acl-excl-common. + + * acl-excl-common.lisp: New file. + +2004-01-18 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-excl-corman.lisp (intern*), sbcl/acl-excl.lisp (intern*), + mcl/acl-excl.lisp (intern*), lispworks/acl-excl.lisp (intern*), + cmucl/acl-excl.lisp (intern*), clisp/acl-excl.lisp (intern*), + scl/acl-excl.lisp (intern*): Don't upcase symbol before interning + (thanks to Marco Baringer, whose code was broken by this). Now + I'm motivated to factor out common code from all the backends ... + + * cmucl/acl-mp.lisp (apply-with-bindings): Fix "How did this ever + work" typo; thanks to Marco Baringer. + +2004-01-11 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-socket.lisp (make-socket): Handle :local-port nil, + don't bind socket in that case (let os choose a port) + +2004-01-11 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp (defpackage acl-compat.excl): Export some symbols + for mcl, too + + * mcl/acl-excl.lisp (run-shell-command): Implement (largely + untested for now, needed for cgi support) + + * mcl/acl-sys.lisp (command-line-argument, + command-line-arguments): Implement for OpenMCL + + * mcl/acl-mp.lisp (wait-for-input-available): Implement. Needed + for cgi support. + + * mcl/acl-socket-openmcl.lisp (server-socket): Remove :type slot + argument. + + * sbcl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * cmucl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * acl-compat.asd: Load sb-posix for sbcl. + +2003-12-15 Rudi Schlatte <rudi(a)constantly.at> + + NOTE: this checkin has a reasonable chance of breaking (and mcl + (not openmcl)) + + * mcl/acl-socket-openmcl.lisp: Remove package definition, + implement chunked transfer encoding (accepting a speed loss in the + process) + + * mcl/acl-excl.lisp, mcl/acl-mp.lisp, mcl/acl-sys.lisp: remove + package definitions + + * uri.lisp: deftype also at load time; openmcl breaks otherwise + + * packages.lisp: mcl doesn't have stream-(read,write)-sequence + + * lw-buffering.lisp: formatting frobs. + + * acl-compat.asd: Merge mcl defsystem with the others. + + * sbcl/acl-socket.lisp: Use acl-compat.socket package name. + +2003-12-02 Rudi Schlatte <rudi(a)SLAW40.kfunigraz.ac.at> + + * meta.lisp (enable-meta-syntax): Save current readtable before + installing *meta-readtable*. + +2003-12-01 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp: Merge Lispworks patch from Edi Weitz + (paserve-help 2003-11-28) + +2003-11-27 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + LispWorks refill-buffer does not always return the amount of + bytes read (reported by Edi Weitz to paserve-discuss + 2003-11-26). Treat its return value as a boolean. + + * lw-buffering.lisp (stream-fill-buffer): Remove cmucl-specific + read-n-bytes call because it does block after all :( + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Fix + for Lispworks client mode contributed by Edi Weitz to + paserve-discuss list on 2003-11-25 + + * sbcl/acl-mp.lisp: Single-threaded "implementation" of process-name + +2003-09-19 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp: Merged threading patch from Brian Downing + (posted to portableaserve-discuss 2003-09-12) + + * clisp/acl-excl.lisp, clisp/acl-socket.lisp: Eliminate compile + failures, activate chunked support for clisp (forwarded by Kevin + M. Rosenberg from Debian) + +2003-08-31 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Remove old cmu-read-sequence cruft, bug is fixed + in reasonably recent cmucl + + * lw-buffering.lisp (stream-fill-buffer): Use package-external + symbol that doesn't break on CVS cmucl + +2003-08-30 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * cmucl/acl-socket.lisp (make-socket): set reuse-address option. + + * lw-buffering.lisp (stream-fill-buffer): Implement b/nb semantics + for cmucl as well. client mode should now neither hang trying to + read closed streams nor give spurious errors for slow servers. + +2003-08-17 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Eliminate unused-variable + warning. + +2003-05-13 Rudi Schlatte <rudi(a)constantly.at> + + * cmucl/acl-sys.lisp, cmucl/acl-socket.lisp, cmucl/acl-excl.lisp: + Use correct package names in in-package forms (Reported by Johan + Parin) + + * packages.lisp (acl-compat.system): Add nickname acl-compat.sys, + remove commented-out nicknames. + + * lispworks/acl-sys.lisp: push MSWINDOWS onto *features* if + appropriate (Thanks to Alain Picard for the report). + +2003-05-11 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Don't load read-/write-sequence patches on cmucl + 18e. + +2003-05-06 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-fill-buffer): Implement + blocking/non-blocking semantics (read at least one byte per + fill-buffer call). Otherwise we'd get spurious EOFs with slow + servers. + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + Return a sensible value (amount of bytes that can be read before + next call to fill-buffer). + +2003-05-03 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Make + input-chunking work, refactor somewhat to make all slot changes in + one place. + +2003-05-02 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd (acl-compat): Current cmucl versions handle Gray + streams in (read,write)-sequence -- remove hack + +2003-04-30 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Use timeout symbols from the + ext package; latest cvs exports them + + * cmucl/acl-mp.lisp: Use acl-compat.mp package name. + + * acl-compat.asd et al: The Great Renaming: begin move of + implementation-dependent files into subdirectories + +2003-04-27 Rudi Schlatte <rudi(a)constantly.at> + + * acl-socket-sbcl.lisp: Implemented peername lookup (by storing + the socket in the plist of the bivalent stream object for now) + +2003-04-26 Rudi Schlatte <rudi(a)constantly.at> + + * acl-mp-sbcl.lisp: Add initial support for multi-threaded sbcl + +2003-04-08 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri): Reinstate with-output-to-string logic; + render-uri has to handle nil as a stream value. + +2003-04-03 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri, print-object): Further frob printing of + URIs, inspired by patch of Harley Gorrell + +2003-04-02 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri): Fix printing URIs in the presence of #\~ + (Thanks to Harley Gorrell) + +2003-03-24 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-write-buffer, stream-flush-buffer): + Eliminate "wait" parameter to regain api-compatibility with lispworks + (stream-finish-output, stream-force-output): Call (finish|force)-output + here instead of using "wait" parameter of stream-flush-buffer + + * chunked-stream-mixin.lisp: some documentation added, formatting, + eliminate use of "wait" parameter on stream-write-buffer etc. + +2003-02-28 Rudi Schlatte <rudi(a)constantly.at> + + * acl-socket-sbcl.lisp: + (remote-host, remote-port, local-host, local-port): Change return + value to something convertible to an (invalid) inet address + + * acl-compat.asd, packages.lisp: Support sbcl 0.7.13 single-threaded + +2002-12-26 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (write-elements): end argument value can be + nil (fix contributed by Simon Andras 2002-12-24) + + * meta.lisp: Switch to new-style eval-when times + + * lw-buffering.lisp: Switch to new-style eval-when times + (defstruct buffer-state): Add type declarations + (stream-fill-buffer): Remove bug for non-cmucl case (need + unblocking read-sequence) + + * chunked-stream-mixin.lisp: Add defgeneric forms + + * acl-socket-sbcl.lisp: Enable chunked transfer encoding support + +2002-12-23 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp, acl-sys-sbcl.lisp: Various sbcl fixes + +2002-12-18 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: Add package definition of + de.dataheaven.chunked-stream-mixin, remove nicknames for + acl-compat.system + +2002-12-17 Rudi Schlatte <rudi(a)constantly.at> + + * (Module): Added first stab at sbcl support (some stub + functions, basic page serving works) + +2002-12-13 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-write-sequence): Make publish-multi + work (provide default value for start arg). + + * acl-excl-cmu.lisp (write-vector): ditto. + +2002-12-03 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: load lw-buffering in every implementation except + lispworks + + * packages.lisp: define gray-stream package for every + implementation Added: vendor/portableaserve/acl-compat/README =================================================================== --- vendor/portableaserve/acl-compat/README 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/README 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,33 @@ +-*- text -*- + +acl-compat is a library that implements parts of the Allegro Common +Lisp (ACL) API for areas that are not covered by the ANSI Common Lisp +standard itself (e.g. sockets, threading). The motivation for +creating and maintaining acl-compat is to get the web server +AllegroServe (that was released by Franz Inc under the LLGPL) running +on a wide range of Lisp implementations, with as few source changes to +its core code as possible. + +acl-compat names its packages by prepending the corresponding ACL +package name with the string "ACL-COMPAT.". For example, the ACL +threading API symbols are exported from the package ACL-COMPAT.MP. +Ideally, ACL-specific code could run on any supported Lisp +implementation only by changing package references. + +Of course, the present situation is not ideal. :( Functionality is +only implemented on an as-needed basis, implemented functions don't +handle all argument combinations properly, etc. On the other hand, +enough is implemented to support a web and application server that +exercises a wide range of functionality (client and server sockets, +threading, etc.). + + +To load acl-compat: + +- install asdf (see < http://www.cliki.net/asdf >) and make sure it's + loaded. + +- load acl-compat.asd + +- evaluate (asdf:operate 'asdf:load-op :acl-compat) + Added: vendor/portableaserve/acl-compat/acl-compat-cmu.system =================================================================== --- vendor/portableaserve/acl-compat/acl-compat-cmu.system 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-compat-cmu.system 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,36 @@ +;;; -*- mode: lisp -*- + +(in-package :CL-USER) + +;; Stig: we're a debian-package if clc is present +;; Rudi: Not if kludge-no-cclan is also present +#+(and common-lisp-controller (not kludge-no-cclan)) +(setf (logical-pathname-translations "acl-compat") + '(("**;*.*.*" "cl-library:;acl-compat;**;*.*.*"))) + +(mk:defsystem "ACL-COMPAT" + :source-pathname (make-pathname :directory + (pathname-directory *load-truename*)) ;"acl-compat:" +; :source-extension "lisp" +; :binary-pathname nil +; :binary-extension nil + :components ((:file "nregex") + (:file "packages" :depends-on ("nregex")) + (:file "lw-buffering" :depends-on ("packages")) + (:file "acl-mp-cmu" :depends-on ("packages")) + (:file "acl-excl-cmu" :depends-on ("packages" "nregex")) + (:file "cmu-read-sequence") + (:file "acl-socket-cmu" + :depends-on ("packages" "acl-excl-cmu" + "chunked-stream-mixin" + "cmu-read-sequence")) + (:file "acl-sys-cmu" :depends-on ("packages")) + (:file "meta") + (:file "uri" :depends-on ("meta")) + (:file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl-cmu" + "lw-buffering"))) + ;; Stig: if we're CMU and a debian-package, we need graystreams + #+(and cmu common-lisp-controller) + :depends-on + #+(and cmu common-lisp-controller) (cmucl-graystream)) Added: vendor/portableaserve/acl-compat/acl-compat-common-lisp-lw.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-compat-common-lisp-lw.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-compat-common-lisp-lw.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,21 @@ +(defpackage acl-compat-common-lisp + (:use common-lisp) + (:shadow make-hash-table) + (:export make-hash-table)) + +(in-package :acl-compat-common-lisp) + +(defun make-hash-table (&rest args &key test size rehash-size rehash-threshold (hash-function nil h-f-p) + (values t) weak-keys) + (declare (ignore hash-function)) + (when h-f-p (error "User defined hash-functions are not supported.")) + (let ((table (apply #'cl:make-hash-table :allow-other-keys t args))) + (hcl:set-hash-table-weak table + (if weak-keys + (if (eq values :weak) + :both + :key) + (if (eq values :weak) + :value + nil))) + table)) \ No newline at end of file Added: vendor/portableaserve/acl-compat/acl-compat-corman.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-compat-corman.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-compat-corman.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,13 @@ +(require 'gray-streams) +(in-package :cl-user) + +(defvar *acl-compat-directory* "d:/projects/lisp/portableaserve/acl-compat/") +(load (concatenate 'string *acl-compat-directory* "nregex.lisp")) +(load (concatenate 'string *acl-compat-directory* "meta.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-excl-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-mp-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-socket-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "uri.lisp")) +(load (concatenate 'string *acl-compat-directory* "packages.lisp")) + +(pushnew :acl-compat *features*) \ No newline at end of file Added: vendor/portableaserve/acl-compat/acl-compat.asd =================================================================== --- vendor/portableaserve/acl-compat/acl-compat.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-compat.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,181 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; This as an ASDF system for ACL-COMPAT, meant to replace +;;;; acl-compat-cmu.system, but could replace all other systems, too. +;;;; (hint, hint) + +(defpackage #:acl-compat-system + (:use #:cl #:asdf)) +(in-package #:acl-compat-system) + +;;;; gray stream support for cmucl: Debian/common-lisp-controller has +;;;; a `cmucl-graystream' system; if this is not found, we assume a +;;;; cmucl downloaded from cons.org, where Gray stream support resides +;;;; in the subsystems/ directory. + + +#+cmu +(progn + +(defclass precompiled-file (static-file) + ()) + +(defmethod perform ((operation load-op) (c precompiled-file)) + (load (component-pathname c))) + +(defmethod operation-done-p ((operation load-op) (c precompiled-file)) + nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (asdf:find-system :cmucl-graystream nil) + (asdf:defsystem cmucl-graystream + :pathname (make-pathname + :name nil :type nil :version nil + :defaults (truename "library:subsystems/gray-streams-library.x86f")) + :components ((:precompiled-file "gray-streams-library.x86f"))))) +) + +;;;; ignore warnings +;;;; +;;;; FIXME: should better fix warnings instead of ignoring them +;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code + +(defclass legacy-cl-source-file (cl-source-file) + () + (:documentation + "Common Lisp source code module with (non-style) warnings. +In contrast to CL-SOURCE-FILE, this class does not think that such warnings +indicate failure.")) + +(defmethod perform ((operation compile-op) (c legacy-cl-source-file)) + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c))) + (warnings-p nil) + (failure-p nil)) + (setf (asdf::component-property c 'last-compiled) nil) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (setq warnings-p t))) + ;; _not_ (or error (and warning (not style-warning))) + (error (lambda (c) + (declare (ignore c)) + (setq failure-p t)))) + (compile-file source-file + :output-file output-file)) + ;; rest of this method is as for CL-SOURCE-FILE + (setf (asdf::component-property c 'last-compiled) (file-write-date output-file)) + (when warnings-p + (case (asdf::operation-on-warnings operation) + (:warn (warn "COMPILE-FILE warned while performing ~A on ~A" + c operation)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (asdf::operation-on-failure operation) + (:warn (warn "COMPILE-FILE failed while performing ~A on ~A" + c operation)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))))) + +;;; +;;; This is thought to reduce reader-conditionals in the system definition +;;; +(defclass unportable-cl-source-file (cl-source-file) () + (:documentation + "This is for files which contain lisp-system dependent code. Until now those +are marked by a -system postfix but we could later change that to a directory per +lisp-system")) + +(defmethod perform ((op load-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod perform ((op compile-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod source-file-type ((c unportable-cl-source-file) (s module)) + "lisp") + + +(defun lisp-system-shortname () + #+allegro :allegro #+lispworks :lispworks #+cmu :cmucl + #+mcl :mcl #+clisp :clisp #+scl :scl #+sbcl :sbcl) ;mcl/openmcl use the same directory + +(defmethod component-pathname ((component unportable-cl-source-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +;;;; system + +#+(and mcl (not openmcl)) (require :ansi-make-load-form) + +(defsystem acl-compat + :name "acl-compat" + :author "The acl-compat team" + :version "0.1.1" + :description + "A reimplementation of parts of the ACL API, mainly to get + AllegroServe running on various machines, but might be useful + in other projects as well." + :properties + ((("system" "author" "email") . "portableaserve-discuss(a)lists.sourceforge.net") + (("albert" "presentation" "output-dir") . "docs/") + (("albert" "presentation" "formats") . "docbook") + (("albert" "docbook" "dtd") . "/Users/Shared/DocBook/lib/docbook/docbook-dtd-412/docbookx.dtd") + (("albert" "docbook" "template") . "book")) + :components + ( + ;; packages + (:file "packages") + ;; Our stream class; support for buffering, chunking and (in the + ;; future) unified stream exceptions + #-(or lispworks (and mcl (not openmcl))) + (:file "lw-buffering" :depends-on ("packages")) + #-(or allegro (and mcl (not openmcl))) + (:legacy-cl-source-file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl" + #-lispworks "lw-buffering")) + ;; Multiprocessing + #+mcl (:unportable-cl-source-file "mcl-timers") + (:unportable-cl-source-file "acl-mp" + :depends-on ("packages" #+mcl "mcl-timers")) + ;; Sockets, networking; TODO: de-frob this a bit + #-mcl + (:unportable-cl-source-file + "acl-socket" :depends-on ("packages" "acl-excl" + #-(or allegro (and mcl (not openmcl))) "chunked-stream-mixin")) + #+(and mcl (not openmcl)) + (:unportable-cl-source-file "acl-socket-mcl" :depends-on ("packages")) + #+(and mcl (not openmcl) (not carbon-compat)) + (:unportable-cl-source-file + "mcl-stream-fix" :depends-on ("acl-socket-mcl")) + #+(and mcl openmcl) + (:unportable-cl-source-file + "acl-socket-openmcl" :depends-on ("packages" "chunked-stream-mixin")) + ;; Diverse macros, utility functions + #-allegro (:file "acl-excl-common" :depends-on ("packages")) + (:unportable-cl-source-file "acl-excl" :depends-on + #-allegro ("acl-excl-common") + #+allegro ("packages")) + (:unportable-cl-source-file "acl-sys" :depends-on ("packages")) + ;; SSL + #+(and ssl-available (not (or allegro mcl clisp))) + (:file "acl-ssl" :depends-on ("acl-ssl-streams" "acl-socket")) + #+(and ssl-available (not (or allegro mcl clisp))) + (:file "acl-ssl-streams" :depends-on ("packages"))) + ;; Dependencies + :depends-on (:puri + :cl-ppcre + #+sbcl :sb-bsd-sockets + #+sbcl :sb-posix + #+cmu :cmucl-graystream + #+(and (or cmu lispworks) ssl-available) :cl-ssl + ) + :perform (load-op :after (op acl-compat) + (pushnew :acl-compat cl:*features*))) Added: vendor/portableaserve/acl-compat/acl-excl-common.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-excl-common.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-excl-common.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,193 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; + +;;;; This file was made by Rudi Schlatte to gather +;;;; not-implementation-specific parts of acl-compat in one place. + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; + +(in-package :acl-compat.excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +;this is not used in aserve, but is needed to use the franz xmlutils package with acl-compat +(defvar *current-case-mode* :case-insensitive-upper) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +(defun frob-regexp (regexp) + "This converts from ACL regexps to Perl regexps. The escape + status of (, ) and | is toggled." + (let ((escapees '(#\) #$ #\| ))) + (with-input-from-string (in regexp) + (with-output-to-string (out) + (loop for c = (read-char in nil nil nil) + while c + do (cond ((and (char= c #\$ + (member (peek-char nil in nil nil nil) escapees)) + (setf c (read-char in))) + ((member c escapees) + (princ #\\ out))) + (princ c out)))))) + +;; TODO: a compiler macro for constant string regexps would be nice, +;; so that the create-scanner call at runtime can be evaded. +(defun match-regexp (string-or-regexp string-to-match + &key newlines-special case-fold return + (start 0) end shortest) + "Note: if a regexp compiled with compile-regexp is passed, the + options newlines-special and case-fold shouldn't be used, since + the underlying engine uses them when generating the scanner, + not when executing it." + (when shortest (error "match-regexp: shortest option not supported yet.")) + (unless end (setf end (length string-to-match))) + (let ((scanner (cl-ppcre:create-scanner (frob-regexp string-or-regexp) + :case-insensitive-mode case-fold + :single-line-mode newlines-special))) + (ecase return + (:string ; return t, list of strings + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings scanner string-to-match + :start start :end end) + (if match + (apply #'values t match (coerce regs 'list)) + nil))) + (:index ; return (cons start end) + (multiple-value-bind (start end reg-starts reg-ends) + (cl-ppcre:scan scanner string-to-match :start start :end end) + (and start (apply #'values t (cons start end) + (map 'list #'cons reg-starts reg-ends))))) + ((nil) ; return t + (not (not (cl-ppcre:scan scanner string-to-match + :start start :end end))))))) + + +;; Caution Incompatible APIs! cl-ppcre has options case-insensitive, +;; single-line for create-scanner, ACL has it in match-regexp. +(defun compile-regexp (regexp) + "Note: Take care when using scanners compiled with this option + to not depend on options case-fold and newlines-special in match-regexp." + (cl-ppcre:create-scanner (frob-regexp regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +(defun write-vector (sequence stream &key (start 0) end endian-swap) + (declare (ignore endian-swap)) + (check-type sequence (or string (array (unsigned-byte 8) 1) + (array (signed-byte 8) 1))) + (write-sequence sequence stream :start start :end end)) + Added: vendor/portableaserve/acl-compat/acl-excl-corman.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-excl-corman.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-excl-corman.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,233 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; +;;;; It is not clear to this point if future releases will lead to a combined +;;;; effort - So you may find newer versions of *this* file at +;;;; http://www.dataheaven.de +;;;; + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple implementation of some of the EXCL package from Allegro +;;;; Common Lisp. Intended to be used for porting various ACL packages, +;;;; like AllegroServe. +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris(a)double.co.nz + +(require 'nregex) +(require 'mp) + +(defpackage :excl + (:use :common-lisp :nregex) + (:import-from :common-lisp "FIXNUMP") + (:export + "IF*" + "*INITIAL-TERMINAL-IO*" + "*CL-DEFAULT-SPECIAL-BINDINGS*" + "FILESYS-SIZE" + "FILESYS-WRITE-DATE" + "STREAM-INPUT-FN" + "MATCH-REGEXP" + "COMPILE-REGEXP" + "*CURRENT-CASE-MODE*" + "INTERN*" + "FILESYS-TYPE" + "ERRORSET" + "ATOMICALLY" + "FAST" + "WITHOUT-PACKAGE-LOCKS" + "SOCKET-ERROR" + "RUN-SHELL-COMMAND" + "FIXNUMP" + )) + +(in-package :excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + + +(defun match-regexp (pattern string &key (return :string)) + (let ((res (cond ((stringp pattern) + (regex pattern string)) + ((functionp pattern) (funcall pattern string)) + (t (error "Wrong type for pattern"))))) + (case return + (:string + (values-list (cons (not (null res)) + res))) + (:index (error "REGEXP: INDEX Not implemented")) + (otherwise (not (null res)))))) + +(defun compile-regexp (regexp) + (compile nil (regex-compile regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defun filesys-type (file-or-directory-name) + (if (ccl::directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition socket-error (error) + ((stream :initarg :stream) + (code :initarg :code :initform nil) + (action :initarg :action) + (identifier :initarg :identifier :initform nil)) + (:report (lambda (e s) + (with-slots (identifier code action stream) e + (format s "~S (errno ~A) occured while ~A" + (case identifier + (:connection-refused "Connection refused") + (t identifier)) + code action) + (when stream + (prin1 stream s)) + (format s "."))))) + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + + +(provide 'acl-excl) Added: vendor/portableaserve/acl-compat/acl-mp-corman.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-mp-corman.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-mp-corman.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,52 @@ +;;; This file implements the process functions for AllegroServe in Corman Lisp. + +(require 'mp) + +(defpackage :acl-compat-mp + (:use :common-lisp :mp :sys) + (:export + #:process-interrrupt + #:make-process + #:make-process-lock + #:process-add-run-reason + #:process-kill + #:process-property-list + #:process-revoke-run-reason + #:process-run-function + #:with-process-lock + #:with-timeout + #:without-scheduling + #:*current-process* + #:lock + #:process-allow-schedule + #:process-name + #:process-preset + #:process-run-reasons + #:process-wait + #:without-interrupts + )) + +(in-package :acl-compat-mp) + +; existing stuff from ccl we can reuse directly +;; The following process-property-list implementation was taken from +;; the acl-mp-scl.lisp implementation. +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +;; Dummy implementation of process-wait +(defun process-wait (whostate function &rest args) + "This function suspends the current process (the value of sys:*current-process*) + until applying function to arguments yields true. The whostate argument must be a + string which temporarily replaces the process' whostate for the duration of the wait. + This function returns nil." + (loop until (apply function args) do (sleep 0)) + nil) + Added: vendor/portableaserve/acl-compat/acl-mp-package.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-mp-package.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-mp-package.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-package.lisp +;;;; Revision: 1.0.0 +;;;; Description: Package definition for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(defpackage :acl-compat-mp + (:use :common-lisp) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-active-p ; required by webactions + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + ) + (:nicknames :acl-mp)) + +;; * marked ones are used in Portable Allegroserve Added: vendor/portableaserve/acl-compat/acl-socket-corman.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-socket-corman.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-socket-corman.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,194 @@ +;;;; ACL socket wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple wrapper around the SOCKETS package to present an interface +;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package +;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET +;;;; package see: +;;;; +;;;; http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris(a)double.co.nz +;;;; +;;;; 17/09/2000 - 1.0 +;;;; Initial release. +;;;; +;;;; 20/09/2000 - 1.1 +;;;; Added SOCKET-CONTROL function. +;;;; +;;;; 27/02/2001 - 1.2 +;;;; Added ability to create SSL sockets. Doesn't use +;;;; same interface as Allegro 6 - need to look into +;;;; how that works. +;;;; +;;;; 03/01/2003 - 1.3 +;;;; Added to PortableAllegroServe. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets) + (require :ssl-sockets)) + +(sockets:start-sockets) +(ssl-sockets:start-ssl-sockets) + +(defpackage socket + (:use "COMMON-LISP") + (:export + "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "REMOTE-HOST" + "LOCAL-HOST" + "LOCAL-PORT" + "SOCKET-CONTROL" + )) + +(in-package :socket) + +(defmethod accept-connection ((server-socket sockets::server-socket) + &key (wait t)) + (unless wait + (error "WAIT keyword to ACCEPT-CONNECTION not implemented.")) + (sockets:make-socket-stream + (sockets:accept-socket server-socket))) + +(defun make-socket (&key + (remote-host "0.0.0.0") ;;localhost? + type + local-port + remote-port + (connect :active) + (format :text) + ssl + &allow-other-keys) + (check-type remote-host string) + (when (eq type :datagram) + (error ":DATAGRAM keyword to MAKE-SOCKET not implemented.")) + (when (eq format :binary) + (warn ":BINARY keyword to MAKE-SOCKET partially implemented.")) + + (ecase connect + (:passive + (sockets:make-server-socket + :host remote-host + :port local-port)) + (:active + (sockets:make-socket-stream + (if ssl + (ssl-sockets:make-client-ssl-socket + :host remote-host + :port remote-port) + (sockets:make-client-socket + :host remote-host + :port remote-port)))))) + + +(defun dotted-to-ipaddr (dotted &key errorp) + (when errorp + (warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported.")) + (sockets:host-to-ipaddr dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (when values + (error ":VALUES keyword to IPADDR-TO-DOTTED not supported.")) + (sockets:ipaddr-to-dotted ipaddr)) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (sockets:ipaddr-to-name ipaddr)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (if (stringp host) + (sockets:host-to-ipaddr host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets::remote-socket-ipaddr socket))) + +(defun local-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (if (not (typep socket 'sockets:local-socket)) + 16777343 + (sockets::socket-host-ipaddr socket)))) + +(defun local-port (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets:socket-port socket))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream output-chunking output-chunking-eof input-chunking)) + (warn "SOCKET-CONTROL function not implemented.")) + +;; Some workarounds to get combined text/binary socket streams working +(defvar old-read-byte #'cl::read-byte) + +(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil)) + "Replacement for Corman Lisp READ-BYTE to work with socket streams correctly." + (if (eq (cl::stream-subclass stream) 'sockets::socket-stream) + (char-int (read-char stream eof-error-p eof-value)) + (funcall old-read-byte stream eof-error-p eof-value))) + +(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte) + +(in-package :cl) + +(defun write-sequence (sequence stream &key start end) + (let ((element-type (stream-element-type stream)) + (start (if start start 0)) + (end (if end end (length sequence)))) + (if (eq element-type 'character) + (do ((n start (+ n 1))) + ((= n end)) + (write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream)) + (do ((n start (+ n 1))) + ((= n end)) + (write-byte (elt sequence n) stream)))) ;; recoded to avoid LOOP, because it isn't loaded yet + ;(loop for n from start below end do + ; (write-char (elt sequence n) stream)) + ;(loop for n from start below end do + ; (write-byte (elt sequence n) stream)) + (force-output stream)) + +(provide 'acl-socket) + Added: vendor/portableaserve/acl-compat/acl-ssl-streams.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-ssl-streams.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-ssl-streams.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,293 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;; +;;; Filename: gray-streams-integration.lisp +;;; Author: Jochen Schmidt <jsc(a)dataheaven.de> +;;; Description: Integrate ssl-sockets with the lisp +;;; stream system using gray-streams. +;;; + +(in-package :ssl) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Gray Streams integration ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass ssl-stream-mixin () + ((ssl-socket :accessor ssl-socket :initarg :ssl-socket))) + +(defclass binary-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-binary-input-stream + gray-stream:fundamental-binary-output-stream) + ()) + +(defclass character-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-character-input-stream + gray-stream:fundamental-character-output-stream) + ()) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream)) + '(unsigned-byte 8)) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream)) + 'character) + +(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream)) + nil) + +(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream)) + nil) + +(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0))) + +(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-byte ssl-socket))) + +(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-byte byte ssl-socket))) + +#| +(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + +(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + + +(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream)) + (when (listen socket-stream) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket)))) + +#| +(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + +(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + + + +; Bivalent +(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) + +#| +(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-char socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) + +|# + +;; +;; Why this argument ordering in CMUCL? LW has (stream sequence start end) +;; It would be interesting to know why it is a particular good idea to +;; reinvent APIs every second day in an incompatible way.... *grrr* +;; + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-char socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-byte socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#| +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-byte socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| Alternative implementation? +(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn (format t "Read char on index ~A~%" i) + (force-output t) + (let ((c (stream:stream-read-char socket-stream))) + (format t "The element read was ~A~%" c) c)) + if (eq char :eof) do (progn (format t "premature return on index ~A~%" i) + (force-output t) + (return-from stream:stream-read-sequence i)) + do (setf (elt sequence i) char)) + (format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| +(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) +|# + +#+lispworks +(declaim (inline %reader-function-for-sequence)) +#+lispworks +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +#+lispworks +(declaim (inline %writer-function-for-sequence)) +#+lispworks +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'write-char) + ((array unsigned-byte (*)) #'write-byte) + ((array signed-byte (*)) #'write-byte) + (otherwise #'write-byte))) + +;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE +#+lispworks +(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +#+lispworks +(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::write-elements stream sequence start end (typecase sequence + (string t) + ((array unsigned-byte (*)) nil) + ((array signed-byte (*)) nil) + (otherwise nil)))) + +#+lispworks +(in-package :acl-socket) + +#+lispworks +(defmethod remote-host ((socket ssl::ssl-stream-mixin)) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))) + +#+lispworks +(defmethod remote-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + +#+lispworks +(defmethod local-host ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore port)) + host)) + +#+lispworks +(defmethod local-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + Added: vendor/portableaserve/acl-compat/acl-ssl.lisp =================================================================== --- vendor/portableaserve/acl-compat/acl-ssl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/acl-ssl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,58 @@ +(in-package :ssl) +;;;;;;;;;;;;;;;;;;;;; +;;; ACL style API ;;; +;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-ssl-client-stream ((socket integer) &rest options) + (destructuring-bind (&key (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-client-socket :fd socket))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +#+lispworks +(defmethod make-ssl-client-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-client-stream (comm:socket-stream-socket lw-socket-stream) options)) + +#+cormanlisp +(defmethod make-ssl-client-stream (stream &rest options) + (apply #'make-ssl-client-stream (sockets:socket-descriptor (cl::stream-handle stream)) options)) + +(defmethod make-ssl-server-stream ((socket integer) &rest options) + (destructuring-bind (&key certificate key other-certificates (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-server-socket + :fd socket + :rsa-privatekey-file (or key certificate) + :certificate-file (or certificate key)))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +(defmethod make-ssl-server-stream ((socket ssl-stream-mixin) &rest options) + (warn "SSL socket ~A reused" socket) + socket) + +#+lispworks +(defmethod make-ssl-server-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + + +#+ignore +(defmethod make-ssl-server-stream ((acl-socket acl-socket::server-socket) &rest options) + (apply #'make-ssl-server-stream + (comm::get-fd-from-socket (acl-socket::passive-socket acl-socket)) options)) + +#+ignore +(defmethod make-ssl-server-stream ((lw-socket-stream acl-socket::chunked-socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + Added: vendor/portableaserve/acl-compat/allegro/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/allegro/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/allegro/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/allegro/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:03 2004// +/acl-excl.lisp/1.1/Wed Apr 30 12:59:04 2003// +/acl-mp.lisp/1.3/Thu Aug 5 04:46:47 2004// +/acl-socket.lisp/1.2/Thu Aug 5 04:46:47 2004// +/acl-sys.lisp/1.2/Thu Aug 5 04:46:47 2004// +D Added: vendor/portableaserve/acl-compat/allegro/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/allegro/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/allegro Added: vendor/portableaserve/acl-compat/allegro/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/allegro/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/allegro/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/allegro/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +;;;; ACL-COMPAT - EXCL +;;;; +;;;; Nothing needs to be done Added: vendor/portableaserve/acl-compat/allegro/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/allegro/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +;;; This file implements the process functions for AllegroServe in MCL. + +(in-package :acl-compat.mp) Added: vendor/portableaserve/acl-compat/allegro/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/allegro/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +;;; Allegro layer for ACL sockets. +;;; +(in-package :acl-compat.socket) + + + Added: vendor/portableaserve/acl-compat/allegro/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/allegro/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/allegro/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,4 @@ +;;; Allegro System Package Compatibility file + +;;; Nothing to do +(in-package :acl-compat.system) Added: vendor/portableaserve/acl-compat/chunked-stream-mixin.lisp =================================================================== --- vendor/portableaserve/acl-compat/chunked-stream-mixin.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/chunked-stream-mixin.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,275 @@ +;;;; ; +;;;; (c) 2002 by Jochen Schmidt. +;;;; +;;;; File: chunked-stream-mixin.lisp +;;;; Revision: 0.1 +;;;; Description: ACL style HTTP1.1 I/O chunking +;;;; Date: 08.04.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt +;;;; + +(in-package :de.dataheaven.chunked-stream-mixin) + +(defun buffer-ref (buffer index) + #+lispworks (schar buffer index) + #-lispworks (aref buffer index)) + +(defun (setf buffer-ref) (new-value buffer index) + #-lispworks (setf (aref buffer index) (char-code new-value)) + #+lispworks (setf (schar buffer index) new-value)) + +(defclass chunked-stream-mixin () + ((output-chunking-p :initform nil :accessor output-chunking-p) + (chunk-input-avail :initform nil + :documentation + "Number of octets of the current chunk that are +not yet read into the buffer, or nil if input chunking is disabled") + (real-input-limit :initform 0 + :documentation + "Index of last octet read into buffer +(input-limit points to index of last octet in the current chunk)"))) + +(defgeneric input-chunking-p (stream)) +(defmethod input-chunking-p ((stream chunked-stream-mixin)) + (not (null (slot-value stream 'chunk-input-avail)))) + +(defgeneric (setf input-chunking-p) (new-value stream)) +(defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin)) + (setf (slot-value stream 'chunk-input-avail) (and new-value 0))) + +(define-condition acl-compat.excl::socket-chunking-end-of-file (condition) + ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments) + (acl-compat.excl::format-control :initform "A chunking end of file occured" + :initarg :format-control))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; Input chunking ;;; +;;;;;;;;;;;;;;;;;;;;;; + +;; Input chunking is not tested so far! + +(defgeneric initialize-input-chunking (stream)) +(defmethod initialize-input-chunking ((stream chunked-stream-mixin)) + "This method initializes input chunking. The real-input-limit is nil +in the beginnings because it got not saved yet. Chunk-input-avail is +obviously 0 because no chunk-data got read so far." + (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit) + stream + (with-slots (real-input-limit chunk-input-avail) stream + (setf + ;; Bytes read from stream (valid data in buffer up to here) + real-input-limit input-limit + ;; Bytes available in current chunk block after buffer contents + ;; runs out (trivially zero before first chunk block read) + chunk-input-avail 0 + ;; Last buffer position that can be read before new data has to + ;; be fetched from stream (we must begin with parsing a chunk + ;; immediately; hence set to a value that guarantees this) + input-limit 0 ; or input-index? + )))) + +;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28) +#+lispworks +(defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body) + `(with-slots ((,input-buffer stream::input-buffer) + (,input-index stream::input-index) + (,input-limit stream::input-limit)) + (slot-value ,stream 'stream::buffer-state) + ,@body)) + +(defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin)) + "Refill buffer from stream." + ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no + ;; more data (the index is bigger than the limit). We call out to + ;; the real buffer filling mechanism by calling the next specialized + ;; method. This method is responsible to update the buffer state in + ;; coordination with the chunk-header. + (with-slots (chunk-input-avail real-input-limit) stream + (#-lispworks gray-stream:with-stream-input-buffer + #+lispworks %with-stream-input-buffer + (input-buffer input-index input-limit) stream + (labels + ((pop-char () + (when (and (>= input-index input-limit) ; need new data + (not (call-next-method))) ; couldn't get it + (error "Unexpected end-of-file while reading chunk block")) + (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index)) + #+lispworks (buffer-ref input-buffer input-index) + (incf input-index))) + (read-chunk-header () + (let ((chunk-length 0)) + (tagbody + initial-crlf (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (decf input-index) ; unread char + (go chunk-size)) + ((eq #\Return char) + (if (eq (pop-char) #\Linefeed) + (go chunk-size) + (error "End of chunk-header corrupted: Expected Linefeed"))) + (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit")))) + + chunk-size (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (setf chunk-length + (+ (* 16 chunk-length) + (digit-char-p char 16))) + (go chunk-size)) + (t (decf input-index) ; unread char + (go skip-rest)))) + + skip-rest (if (eq #\Return (pop-char)) + (go check-linefeed) + (go skip-rest)) + + check-linefeed (let ((char (pop-char))) + (case char + (#\Linefeed (go accept)) + (t (error "End of chunk-header corrupted: LF expected, ~A read." char)))) + + accept) + chunk-length))) + + (cond ((not (input-chunking-p stream)) + ;; Chunking not active; just fill buffer normally + (call-next-method)) + ((zerop chunk-input-avail) + ;; We are at the beginning of a new chunk. + (when real-input-limit (setf input-limit real-input-limit)) + (let* ((chunk-length (read-chunk-header)) + (end-of-chunk (+ input-index chunk-length))) + (if (zerop chunk-length) + ;; rfc2616 indicates that input chunking is + ;; turned off after zero-length chunk is read + ;; (see section 19.4.6) -- turn off chunking + (progn (signal 'acl-compat.excl::socket-chunking-end-of-file + :format-arguments stream) + (setf (input-chunking-p stream) nil) + ;; TODO: whoever handles + ;; socket-chunking-end-of-file (client.cl + ;; in AllegroServe's case) should read the + ;; trailer (see section 3.6). All we can + ;; reasonably do here is turn off + ;; chunking, or throw information away. + ) + ;; Now set up stream attributes so that read methods + ;; call refill-buffer both at end of chunk and end of + ;; buffer + (progn + (setf real-input-limit input-limit + input-limit (min real-input-limit end-of-chunk) + chunk-input-avail (max 0 (- end-of-chunk + real-input-limit))) + input-limit)))) + (t + ;; We are in the middle of a chunk; re-fill buffer + (if (call-next-method) + (progn + (setf real-input-limit input-limit) + (setf input-limit + (min real-input-limit chunk-input-avail)) + (setf chunk-input-avail + (max 0 (- chunk-input-avail real-input-limit))) + input-limit) + (error "Unexpected end-of-file in the middle of a chunk")))))))) + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Output chunking ;;; +;;;;;;;;;;;;;;;;;;;;;;; + +;; This constant is the amount of bytes the system reserves for the chunk-header +;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed +;; by a LF +(defconstant +chunk-header-buffer-offset+ 6) + +(defgeneric initialize-output-chunking (stream)) +(defmethod initialize-output-chunking ((stream chunked-stream-mixin)) + "This method initializes output chunking. Actual contents in the output-buffer + get flushed first. A chunk has a header at the start and a CRLF at the end. + The header is the length of the (data) content in the chunk as a string in hexadecimal + digits and a trailing CRLF before the real content begins. We assume that the content + of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning + of the buffer for the header. We reduce the buffer limit by 2 so that we have always + room left in the buffer to attach a CRLF." + (unless (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index +chunk-header-buffer-offset+) + (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return + (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed) + (decf limit 2) + (setf (output-chunking-p stream) t)))) + +(defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin)) + "When there is pending content in the output-buffer then compute the chunk-header and flush + the buffer" + (if (output-chunking-p stream) + (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream + (when (> output-index +chunk-header-buffer-offset+) + (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+))) + (start (- +chunk-header-buffer-offset+ 2 (length chunk-header)))) + (loop for c across chunk-header + for i upfrom start + do (setf (buffer-ref output-buffer i) c)) + (setf (buffer-ref output-buffer output-index) #\Return + (buffer-ref output-buffer (1+ output-index)) #\Linefeed) + (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2)) + (setf output-index +chunk-header-buffer-offset+)))) + (call-next-method))) + + +(defmethod close ((stream chunked-stream-mixin) &key abort) + (unless abort + (disable-output-chunking stream)) + (call-next-method)) + + +(defgeneric disable-output-chunking (stream)) +(defmethod disable-output-chunking ((stream chunked-stream-mixin)) + "When we disable chunking we first try to write out a last pending chunk and after that + reset the buffer-state to normal mode. To end the game we write out a chunk-header with + a chunk-size of zero to notify the peer that chunking ends." + (when (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index 0) + (incf limit 2)) + (setf (output-chunking-p stream) nil + (input-chunking-p stream) nil) + (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed) + (force-output stream))) + + + + Added: vendor/portableaserve/acl-compat/chunked.lisp =================================================================== --- vendor/portableaserve/acl-compat/chunked.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/chunked.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,211 @@ +;;; +;;; Streams with support for "chunked" transfer coding. This module +;;; emulates the support for chunking found in Allegro Common Lisp's +;;; streams. See RFC 2616 for a description of the "chunked" transfer +;;; coding. +;;; +;;; TODO: +;;; - + +(defpackage :com.ljosa.chunked + (:use :common-lisp #+LISPWORKS :stream) + (:export :chunked-mixin :make-chunked-stream :*buffer-size* + :output-chunking :input-chunking :close-chunk)) + +(in-package :com.ljosa.chunked) + +(defparameter *buffer-size* 1024 "Maximum chunk size") + +(defvar *recursive* nil) + +(defclass chunked-mixin () + ((output-chunking :initform nil :accessor output-chunking) + (input-chunking :initform nil :accessor input-chunking) + (output-buffer) + (remaining-input :initform nil))) + +(defmethod shared-initialize :after ((stream chunked-mixin) slots-for-initform + &rest initargs) + (declare (ignore initargs slots-for-initform)) + (with-slots (output-buffer) stream + (setf output-buffer (make-array (list *buffer-size*) + :element-type 'unsigned-byte + :fill-pointer 0)))) + +(define-condition excl::socket-chunking-end-of-file (condition) + ((excl::format-arguments :initform nil) + (excl::format-control :initform "~1@<The stream ~s had a chunking end of file~:@>"))) + +;; (defmethod stream-element-type ((stream chunked-mixin)) +;; (call-next-method)) + +(defun read-chunk-header (stream &aux (x 0) (*recursive* t)) + (tagbody + s0 (let ((char (read-char stream))) + (cond ((digit-char-p char 16) (setf x (+ (* 16 x) (digit-char-p char 16))) + (go s0)) + ((eq #\; char) (go s1)) + ((eq #\; char) (go s2)) + (t (error "Parse error in state s0: ~S." char)))) + s1 (if (eq #\Return (read-char stream)) + (go s2) + (go s1)) + s2 (let ((char (read-char stream))) + (case char + (#\Linefeed (go accept)) + (t (error "Parse error in state s2: ~S." char)))) + accept) + x) + +;; FIXME: What do do when the chunked input stream can't be parsed? + +(defun gobble-crlf (stream &aux (*recursive* t)) + (flet ((expect (expected-char) + (let ((char (read-char stream))) + (unless (eq expected-char char) + (error "Expected ~C, got ~C." expected-char char))))) + (expect #\Return) + (expect #\Linefeed))) + +(defmethod stream-read-char ((stream chunked-mixin)) + (with-slots (input-chunking remaining-input output-chunking) stream + (cond (*recursive* (call-next-method)) + ((not input-chunking) (call-next-method)) + ((not remaining-input) (handler-case + (progn + (setf remaining-input (read-chunk-header stream)) + (stream-read-char stream)) + (end-of-file () :eof))) + ((> remaining-input 0) (decf remaining-input) + (call-next-method)) + ((zerop remaining-input) (handler-case + (progn + (gobble-crlf stream) + (setf remaining-input (read-chunk-header stream)) + (cond ((zerop remaining-input) + (setf input-chunking nil + output-chunking nil) + (signal 'excl::socket-chunking-end-of-file :format-arguments stream) + :eof) + (t (stream-read-char stream)))) + (end-of-file () :eof)))))) + +(defmethod stream-unread-char ((stream chunked-mixin) character) + (with-slots (input-chunking remaining-input) stream + (cond (*recursive* (call-next-method)) + (input-chunking (incf remaining-input) + (call-next-method)) + (t (call-next-method))))) + +(defmethod stream-read-line ((stream chunked-mixin)) + (loop + with chars = nil + for char = (stream-read-char stream) + until (eq char #\Linefeed) + do + (if (eq char :eof) + (if (null chars) + (error 'end-of-file :stream stream) + (return (coerce chars 'string))) + (push char chars)) + finally (return (coerce (nreverse chars) 'string)))) + +(defmethod stream-read-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((char (stream-read-char stream))) + (case char + (:eof (return i)) + (t (setf (elt sequence i) char)))) + finally (return i))) + +(defmethod stream-clear-input ((stream chunked-mixin)) + (with-slots (input-chunking) stream + (cond (*recursive* (call-next-method)) + (input-chunking nil) + (t (call-next-method))))) + +(defmethod stream-write-byte ((stream chunked-mixin) byte) + (check-type byte unsigned-byte) + (if *recursive* + (call-next-method) + (with-slots (output-buffer) stream + (or (vector-push byte output-buffer) + (progn + (stream-force-output stream) + (stream-write-byte stream byte)))))) + +(defmethod stream-write-char ((stream chunked-mixin) character) + (if *recursive* + (call-next-method) + (stream-write-byte stream (char-code character)))) + +(defmethod stream-write-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((e (elt sequence i))) + (etypecase e + (integer (stream-write-byte stream e)) + (character (stream-write-char stream e)))))) + +(defmethod stream-write-string ((stream chunked-mixin) string &optional + (start 0) (end (length string))) + (stream-write-sequence stream string start end)) + +(defmethod write-crlf ((stream stream)) + (let ((*recursive* t)) + (write-char #\Return stream) + (write-char #\Linefeed stream))) + +(defmethod stream-force-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (when (> (fill-pointer output-buffer) 0) + (let ((*recursive* t)) + (when output-chunking + (let ((*print-base* 16)) + (princ (fill-pointer output-buffer) stream)) + (write-crlf stream)) + (write-sequence output-buffer stream) + (setf (fill-pointer output-buffer) 0) + (when output-chunking + (write-crlf stream))))) + (call-next-method)) + +(defmethod stream-finish-output ((stream chunked-mixin)) + (unless *recursive* + (force-output stream)) + (call-next-method)) + +(defmethod stream-clear-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (if (and output-chunking (not *recursive*)) + (setf (fill-pointer output-buffer) 0) + (call-next-method)))) + +(defmethod close ((stream chunked-mixin) &key abort) + (unless abort + (finish-output stream)) + (with-slots (output-chunking output-buffer) stream + (when (and output-chunking + (> (fill-pointer output-buffer) 0)) + (close-chunk stream))) + (call-next-method)) + +(defmethod close-chunk ((stream chunked-mixin)) + (finish-output stream) + (with-slots (output-chunking input-chunking) stream + (if output-chunking + (let ((*recursive* t)) + (princ 0 stream) + (write-crlf stream) + (write-crlf stream) + (finish-output stream) + (setf output-chunking nil + input-chunking nil)) + (error "Chunking is not enabled for output on this stream: ~S." + stream)))) + +(provide :com.ljosa.chunked) + Property changes on: vendor/portableaserve/acl-compat/chunked.lisp ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/acl-compat/clisp/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/clisp/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/clisp/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/clisp/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:03 2004// +/acl-excl.lisp/1.6/Tue Feb 8 09:55:44 2005// +/acl-mp.lisp/1.2/Tue Jul 8 10:13:11 2003// +/acl-socket.lisp/1.3/Sun Jan 18 16:29:14 2004// +/acl-sys.lisp/1.1/Wed Apr 30 12:59:03 2003// +D Added: vendor/portableaserve/acl-compat/clisp/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/clisp/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/clisp Added: vendor/portableaserve/acl-compat/clisp/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/clisp/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/clisp/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/clisp/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,70 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + ;; Taken from clocc's port library, with thanks to Sam Steingold + (if (values + (ignore-errors + (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory + file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + ;; No multiprocessing here, move along... + `(progn ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "clisp unix-signal not implemented yet.")) + +(defmacro without-package-locks (&body forms) + `(ext:without-package-lock ,(list-all-packages) ,@forms)) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: vendor/portableaserve/acl-compat/clisp/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/clisp/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,74 @@ +;; Stubs for multiprocessing functions under clisp. Clisp does not +;; provide threads at the time of writing, so these functions are here +;; only to compile aserve with a minimum of changes in the main code. +;; +;; Written by Rudi Schlatte + + +(in-package :acl-compat-mp) + +(defvar *current-process*) + +(defun process-allow-schedule () + (values)) + +(defun process-allow-scheduling () + (values)) + +(defun process-plist (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-plist) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-reasons (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-run-reasons) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-revoke-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-add-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-function (name function &rest arguments) + (declare (ignore name function arguments)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-kill (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-gensyms (syms &body body) + "Bind symbols to gensyms. First sym is a string - `gensym' prefix. +Inspired by Paul Graham, <On Lisp>, p. 145." + `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms))) + ,@body)) + +(defun interrupt-process (process function &rest args) + (declare (ignore process function args)) + (error "Attempting to use multithreading with clisp.")) + +(defun make-process-lock (&key name) + (declare (ignore name)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) + &body forms) + (declare (ignore lock norecursive whostate timeout)) + `(progn ,@forms)) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (declare (ignore seconds timeout-forms)) + `(progn ,@body)) + +(defmacro without-scheduling (&body body) + `(progn ,@body)) Added: vendor/portableaserve/acl-compat/clisp/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/clisp/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,174 @@ +;; This package is designed for clisp. It implements the +;; ACL-style socket interface on top of clisp. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package :acl-socket) + +(defclass server-socket () + ((port :type fixnum + :initarg :port + :reader port) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")) + (clisp-socket-server :initarg :clisp-socket-server + :reader clisp-socket-server))) + +(defmethod print-object ((server-socket server-socket) stream) + (print-unreadable-object (server-socket stream :type t :identity nil) + (format stream "@port ~d" (port server-socket)))) + +(defun %get-element-type (format) + (ecase format + (:text 'character) + (:binary '(unsigned-byte 8)) + (:bivalent '(unsigned-byte 8))) ) + +(defgeneric accept-connection (server-socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + (when (cond ((numberp wait) + (socket-wait (clisp-socket-server server-socket) wait)) + (wait (socket-wait (clisp-socket-server server-socket))) + (t (socket-wait (clisp-socket-server server-socket) 0))) + (let ((stream (socket-accept (clisp-socket-server server-socket) + :element-type (%get-element-type + (stream-type server-socket)) + ))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive." + (check-type remote-host string) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :clisp-socket-server (socket-server local-port) + :stream-type format)) + (:active + (let ((stream (socket-connect + remote-port remote-host + :element-type (%get-element-type format) + ))) + (if (eq format :bivalent) + (make-bivalent-stream stream) + stream))))) + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-server-close (clisp-socket-server server-socket))) + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (posix::hostent-name (posix:resolve-host-ipaddr ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-clisp-stream (stream)) + +(defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin)) + (gray-stream::native-lisp-stream stream)) + +(defmethod get-clisp-stream ((stream t)) + (the stream stream)) + +(defun remote-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t)))) + +(defun remote-port (socket-stream) + (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t))) + +(defun local-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t)))) + +(defun local-port (socket-stream) + (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/clisp/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/clisp/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/clisp/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,22 @@ + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:without-package-lock () + (let ((sys-package (find-package "SYSTEM"))) + (export (list (intern "COMMAND-LINE-ARGUMENTS" sys-package) + (intern "COMMAND-LINE-ARGUMENT" sys-package) + (intern "REAP-OS-SUBPROCESS" sys-package)) + sys-package)))) + +(ext:without-package-lock () + (defun sys:command-line-arguments () + ext:*args*)) + +(ext:without-package-lock () + (defun sys:command-line-argument (n) + (nth n ext:*args*))) + +(ext:without-package-lock () + (defun sys:reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil)) + Added: vendor/portableaserve/acl-compat/cmucl/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/cmucl/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/cmucl/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/cmucl/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:03 2004// +/acl-excl.lisp/1.7/Tue Feb 8 09:55:44 2005// +/acl-mp.lisp/1.7/Sun Mar 14 14:46:16 2004// +/acl-socket.lisp/1.6/Mon Feb 2 14:42:57 2004// +/acl-sys.lisp/1.2/Tue May 13 09:25:42 2003// +D Added: vendor/portableaserve/acl-compat/cmucl/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/cmucl/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/cmucl Added: vendor/portableaserve/acl-compat/cmucl/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/cmucl/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/cmucl/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/cmucl/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,71 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(defun filesys-inode (path) + (multiple-value-bind (found ign inode) + (unix:unix-lstat path) + (if found + inode + (error "path ~s does not exist" path)))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: vendor/portableaserve/acl-compat/cmucl/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/cmucl/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,170 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat.mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + mp:process-active-p + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + process-active-p + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (etypecase name-or-options + (string (make-process :name name-or-options + :run-reasons '(t))) + (list (apply #'make-process :run-reasons '(t) + name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defun process-lock (lock) + (mp::lock-wait lock (mp:process-whostate mp:*current-process*))) + +(defun process-unlock (lock) + (setf (mp::lock-process lock) nil)) + + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) Added: vendor/portableaserve/acl-compat/cmucl/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/cmucl/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,208 @@ +;; This package is designed for cmucl. It implements the +;; ACL-style socket interface on top of cmucl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package acl-compat.socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port :stream :reuse-address reuse-address) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream gray-stream::native-lisp-stream-mixin)) + (system:fd-stream-fd (gray-stream::native-lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defmethod get-fd ((stream server-socket)) + (fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ()) + + +(defun make-bivalent-stream (lisp-stream) + (make-instance 'chunked-stream :lisp-stream lisp-stream)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/cmucl/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/cmucl/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/cmucl/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +(in-package :acl-compat.system) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: vendor/portableaserve/acl-compat/defsys.lisp =================================================================== --- vendor/portableaserve/acl-compat/defsys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/defsys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,50 @@ +(in-package "CL-USER") + +(defsystem "ACL-COMPAT" + (:default-pathname "ACL-COMPAT:") + :members + ("acl-compat-common-lisp-lw" + "nregex" + "acl-excl-lw" + "acl-mp-package" + "acl-mp-lw" + "gray-stream-package" + "acl-socket-lw" + "acl-sys-lw" + "meta" + "uri" + "chunked-stream-mixin") + + :rules + ((:in-order-to :compile "acl-excl-lw" + (:caused-by (:compile "nregex")) + (:requires (:load "nregex"))) + (:in-order-to :load "acl-excl-lw" + (:requires (:load "nregex"))) + + (:in-order-to :compile "acl-mp-lw" + (:caused-by (:compile "acl-mp-package" "acl-socket-lw")) + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + (:in-order-to :load "acl-mp-lw" + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + + (:in-order-to :compile "acl-socket-lw" + (:caused-by (:compile "chunked-stream-mixin")) + (:requires (:load "chunked-stream-mixin"))) + (:in-order-to :load "acl-socket-lw" + (:requires (:load "chunked-stream-mixin"))) + + (:in-order-to :compile "chunked-stream-mixin" + (:caused-by (:compile "acl-excl-lw" "gray-stream-package")) + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + (:in-order-to :load "chunked-stream-mixin" + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + + (:in-order-to :compile "uri" + (:caused-by (:compile "meta")) + (:requires (:load "meta"))) + (:in-order-to :load "uri" + (:requires (:load "meta"))))) + +(eval-when (:load-toplevel :execute) + (pushnew :acl-compat *features*)) Added: vendor/portableaserve/acl-compat/lispworks/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/lispworks/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/lispworks/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/lispworks/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.3/Mon Feb 9 14:11:03 2004// +/acl-excl.lisp/1.10/Tue Jul 5 17:25:01 2005// +/acl-mp.lisp/1.4/Sun Dec 21 14:59:05 2003// +/acl-socket.lisp/1.6/Thu Oct 20 07:54:06 2005// +/acl-sys.lisp/1.3/Tue May 13 12:47:20 2003// +D Added: vendor/portableaserve/acl-compat/lispworks/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/lispworks/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/lispworks Added: vendor/portableaserve/acl-compat/lispworks/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/lispworks/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/lispworks/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/lispworks/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,85 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + +(defun filesys-type (file-or-directory-name) + (if (lw::file-directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +#-:win32 +(defun filesys-inode (path) + (let ((checked-path (probe-file path))) + (cond + (checked-path (let ((stat (system:get-file-stat checked-path))) + (system:file-stat-inode stat))) + (t (error "path ~a does not exist." path))))) + +(defmacro atomically (&body forms) + `(mp:without-preemption ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + +;; NDL 2004-06-04 -- Missing definition & a package, to allow LispWorks to load webactions + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: vendor/portableaserve/acl-compat/lispworks/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/lispworks/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,209 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-lw.lisp +;;;; Revision: 1.0.0 +;;;; Description: LispWorks implementation for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the LispWorks MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '( + mp:*current-process* + mp:process-kill + mp:process-enable + mp:process-disable + mp::process-preset + mp:process-reset + mp:process-interrupt + mp::process-name + mp:process-wait-function + mp:process-run-reasons + mp:process-arrest-reasons + mp:process-whostate + mp:without-interrupts + mp:process-wait + mp::process-active-p + )) + +(export '( *current-process* + process-kill + process-enable + process-disable + process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-run-reasons + process-arrest-reasons + process-whostate + without-interrupts + process-wait + process-active-p + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Implement missing (and differing) functions ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + (let ((mp:*process-initial-bindings* initial-bindings)) + (mp:create-process name :run-reasons run-reasons :arrest-reasons arrest-reasons))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'mp::process-preset process preset-function preset-arguments) + (push :enable (mp:process-run-reasons process)) + process)) + +(defun process-property-list (process) + (mp:process-plist process)) + +(defun (setf process-property-list) (new-value process) + (setf (mp:process-plist process) new-value)) + +(defun process-name-to-process (name &optional abbrev) + (if abbrev + (let ((length (length name))) + (dolist (process (mp:list-all-processes)) + (when (and (>= (length (process-name process)) length) + (string= name (process-name process) :end2 length)) + (return process)))) + (mp:find-process-from-name (ctypecase name + (symbol (symbol-name name)) + (string name))))) + +(defun process-wait-with-timeout (whostate seconds function &rest args) + (apply #'mp:process-wait-with-timeout whostate seconds function args)) + +(defun wait-for-input-available (streams &key (wait-function #'socket::stream-input-available) whostate timeout) + (let ((collected-fds nil)) + (flet ((fd (stream-or-fd) + (typecase stream-or-fd + (comm:socket-stream (comm:socket-stream-socket stream-or-fd)) + (socket::passive-socket (socket::socket-os-fd stream-or-fd)) + (fixnum stream-or-fd))) + (collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + #+unix + (unwind-protect + (progn + (dolist (stream-or-fd streams) + (mp:notice-fd (fd stream-or-fd))) + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + (dolist (stream-or-fd streams) + (mp:unnotice-fd (fd stream-or-fd)))) + #-unix + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) + +(defmacro without-scheduling (&body forms) + `(mp:without-preemption ,@forms)) + +(defun process-allow-schedule (&optional process) + (declare (ignore process)) + (mp:process-allow-scheduling)) + +(defun process-revoke-run-reason (process object) + (mp:without-preemption + (setf (mp:process-run-reasons process) + (remove object (mp:process-run-reasons process)))) + (when (and (eq process mp:*current-process*) + (not mp:*inhibit-scheduling-flag*)) + (mp:process-allow-scheduling))) + +(defun process-add-run-reason (process object) + (setf (mp:process-run-reasons process) (pushnew object (mp:process-run-reasons process)))) + +;revised version from alain picard +(defun invoke-with-timeout (timeout bodyfn timeoutfn) + (block timeout + (let* ((process mp:*current-process*) + (unsheduled? nil) + (timer (mp:make-timer + #'(lambda () + (mp:process-interrupt process + #'(lambda () + (unless unsheduled? + (return-from timeout + (funcall timeoutfn))))))))) + (mp:schedule-timer-relative timer timeout) + (unwind-protect (funcall bodyfn) + (without-interrupts + (mp:unschedule-timer timer) + (setf unsheduled? t)))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate +and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + +(defun current-process () + "The current process." + mp:*current-process*) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." + (apply #'mp:process-interrupt process function args)) + +(defun make-process-lock (&key name) + (mp:make-lock :name name)) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) + Added: vendor/portableaserve/acl-compat/lispworks/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/lispworks/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,311 @@ +;; This package is designed for LispWorks. It implements the +;; ACL-style socket interface on top of LispWorks. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+cl-ssl +(eval-when (:compile-toplevel :load-toplevel :execute) +(ssl-internal::initialize-ssl-library) +) + +(in-package acl-compat.socket) + +(define-condition stream-error (error) + ((acl-compat.excl::stream :initarg :stream + :reader stream-error-stream) + (acl-compat.excl::action :initarg :action + :reader stream-error-action) + (acl-compat.excl::code :initarg :code + :reader stream-error-code) + (acl-compat.excl::identifier :initarg :identifier + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +#+unix +(defun %socket-error-identifier (code) + (case code + (32 :x-broken-pipe) + (98 :address-in-use) + (99 :address-not-available) + (100 :network-down) + (102 :network-reset) + (103 :connection-aborted) + (104 :connection-reset) + (105 :no-buffer-space) + (108 :shutdown) + (110 :connection-timed-out) + (111 :connection-refused) + (112 :host-down) + (113 :host-unreachable) + (otherwise :unknown))) + +#+win32 +(defun %socket-error-identifier (code) + (case code + (10048 :address-in-use) + (10049 :address-not-available) + (10050 :network-down) + (10052 :network-reset) + (10053 :connection-aborted) + (10054 :connection-reset) + (10055 :no-buffer-space) + (10058 :shutdown) + (10060 :connection-timed-out) + (10061 :connection-refused) + (10064 :host-down) + (10065 :host-unreachable) + (otherwise :unknown))) + +(defun socket-error (stream error-code action format-string &rest format-args) + (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error + (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value)))) + (error 'socket-error :stream stream :code code + :identifier (if (keywordp error-code) + error-code + (%socket-error-identifier error-code)) + :action action))) + + +(defclass socket () + ((passive-socket :type fixnum + :initarg :passive-socket + :reader socket-os-fd))) + +(defclass passive-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type) + (port :type fixnum + :initarg :port + :reader local-port))) + +(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ()) +(defclass input-binary-socket-stream (binary-socket-stream)()) +(defclass output-binary-socket-stream (binary-socket-stream)()) +(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)()) + + +(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args) + (apply #'socket-error stream error-code :IO format-string format-args)) + + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +;; Bivalent socket support for READ-SEQUENCE +(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs +(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end) + (write-string sequence stream :start start :end end)) + +;; ACL Gray-Streams Enhancment Generic Functions + +(defmethod stream-input-fn ((stream input-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod stream-output-fn ((stream output-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod socket-os-fd ((socket comm:socket-stream)) + (comm:socket-stream-socket socket)) + +(defmethod print-object ((passive-socket passive-socket) stream) + (print-unreadable-object (passive-socket stream :type t :identity nil) + (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket)))) + +(defmethod stream-input-available ((fd fixnum)) + (comm::socket-listen fd)) + +(defmethod stream-input-available ((stream stream::os-file-handle-stream)) + (stream-input-available (stream::os-file-handle-stream-file-handle stream))) + +(defmethod stream-input-available ((stream comm:socket-stream)) + (or (comm::socket-listen (comm:socket-stream-socket stream)) + (listen stream))) + +(defmethod stream-input-available ((stream socket::passive-socket)) + (comm::socket-listen (socket::socket-os-fd stream))) + + +(defmethod accept-connection ((passive-socket passive-socket) + &key (wait t)) + (if (or wait (stream-input-available passive-socket)) + (make-instance 'bidirectional-binary-socket-stream + :socket (comm::get-fd-from-socket (socket-os-fd passive-socket)) + :direction :io + :element-type (element-type passive-socket)))) + +(defun %new-passive-socket (local-port) + (multiple-value-bind (socket error-location error-code) + (comm::create-tcp-socket-for-service local-port) + (cond (socket socket) + (t (error 'socket-error :action error-location :code error-code :identifier :unknown))))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + (declare (ignore format)) + (check-type remote-host string) + (ecase connect + (:passive + (let ((comm::*use_so_reuseaddr* reuse-address)) + (make-instance 'passive-socket + :port local-port + :passive-socket (%new-passive-socket local-port) + :element-type '(unsigned-byte 8)))) + (:active + (handler-case + (let ((stream (comm:open-tcp-stream remote-host remote-port + :direction :io + :element-type '(unsigned-byte 8) + :errorp t))) + (change-class stream 'bidirectional-binary-socket-stream)) + (simple-error (condition) + (let ((code (first (last (simple-condition-format-arguments condition))))) + (socket-error condition code + :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition)))))))) + + +(defmethod close ((passive-socket passive-socket) &key abort) + (declare (ignore abort)) + (comm::close-socket (socket-os-fd passive-socket))) + +;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) +; ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + ;(declare (type (unsigned-byte 32) ipaddr)) + (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d))) + (if values (values 0 0 0 0) "0.0.0.0"))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) +(get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (multiple-value-bind (name) + (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name)) + name)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (multiple-value-bind (addr) + (comm:get-host-entry host :fields '(:address)) + addr) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defmethod remote-host ((socket comm:socket-stream)) + (comm:socket-stream-peer-address socket)) + +(defmethod remote-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-peer-address socket) + (declare (ignore host)) + port)) + +(defmethod local-host ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore port)) + host)) + +(defmethod local-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore host)) + port)) + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking))) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options) + (declare (ignore options)) + (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client) + socket-stream) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defun initialize-ssl-library () + ;; Dunno how to force load yet + (comm:ensure-ssl)) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate certificate-password) + (flet ((ctx-configure-callback (ctx) + (comm:ssl-ctx-use-privatekey-file ctx + certificate-password + comm:SSL_FILETYPE_PEM)) + (ssl-configure-callback (ssl) + (comm:ssl-use-certificate-file ssl + certificate + comm:SSL_FILETYPE_PEM))) + (comm:attach-ssl socket-stream + :ssl-side :server + :ctx-configure-callback #'ctx-configure-callback + :ssl-configure-callback #'ssl-configure-callback)) + socket-stream) + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/lispworks/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/lispworks/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lispworks/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,24 @@ +(in-package :sys) +(let ((*handle-warn-on-redefinition* :warn)) +; (*packages-for-warn-on-redefinition* nil)) + + (defun command-line-arguments () + system:*line-arguments-list*) + + (defun command-line-argument (n) + (nth n system:*line-arguments-list*)) + + (defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + + (export 'command-line-arguments) + (export 'command-line-argument) + (export 'reap-os-subprocess)) + +;; Franz uses the MSWINDOWS feature conditional in some of their code; +;; thus, under Windows, ACL-COMPAT should probably push MSWINDOWS +;; onto the *features* list when it detects the presence of WIN32 +;; under Lispworks. +#+WIN32 (eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :mswindows *features*)) Added: vendor/portableaserve/acl-compat/lw-buffering.lisp =================================================================== --- vendor/portableaserve/acl-compat/lw-buffering.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/lw-buffering.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,261 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; LW Style Buffer Protocol for other Lisps ;;; +;;; So far only 8bit byte and character IO works ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :gray-stream) + +(defvar *default-input-buffer-size* 8192) +(defvar *default-output-buffer-size* 8192) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct buffer-state + (input-buffer (make-array *default-input-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (input-index nil) + (input-limit *default-input-buffer-size* :type fixnum) + (output-buffer (make-array *default-output-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (output-index 0) + (output-limit *default-output-buffer-size* :type fixnum))) + +;; Can be used to implement resourcing of buffers later +(defun %allocate-buffer-state (&optional (input-limit *default-input-buffer-size*) (output-limit *default-output-buffer-size*)) + (declare (ignore input-limit output-limit)) + (make-buffer-state)) + +(defun %deallocate-buffer-state (state) + (declare (ignore state))) + +;; Can be used to implement unbuffered encapsulating streams later +(defclass native-lisp-stream-mixin () + ((lisp-stream :initarg :lisp-stream + :reader native-lisp-stream)) + (:documentation "Stream mixin that encapsulates a native stream.")) + +(defclass buffered-stream-mixin (native-lisp-stream-mixin) + ((buffer-state :initform (%allocate-buffer-state))) + (:documentation "Stream mixin that provides buffering for a native lisp stream.")) + +;; fundamental-bivalent-xxx-streams can be used to implement buffered +;; and unbuffered bivalent streams. At the moment, we only implement +;; buffered ones. +(defclass fundamental-bivalent-input-stream + (fundamental-character-input-stream fundamental-binary-input-stream) + ()) + +(defclass fundamental-bivalent-output-stream + (fundamental-character-output-stream fundamental-binary-output-stream) + ()) + +(defclass buffered-bivalent-input-stream + (buffered-stream-mixin fundamental-bivalent-input-stream) + ()) + +(defclass buffered-bivalent-output-stream + (buffered-stream-mixin fundamental-bivalent-output-stream) + ()) + +(defclass buffered-bivalent-stream + (buffered-bivalent-input-stream buffered-bivalent-output-stream) + ()) + +(defmacro with-stream-output-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-output-buffer state)) + (,index ,(list 'buffer-state-output-index state)) + (,limit ,(list 'buffer-state-output-limit state))) + ,@forms)))) + +;;; Encapsulated native streams + +(defmethod close ((stream native-lisp-stream-mixin) &key abort) + (close (native-lisp-stream stream) :abort abort)) + +(defmethod stream-listen ((stream native-lisp-stream-mixin)) + (listen (native-lisp-stream stream))) + +(defmethod open-stream-p ((stream native-lisp-stream-mixin)) + (common-lisp::open-stream-p (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream native-lisp-stream-mixin)) + (clear-output (native-lisp-stream stream))) + +;;; Input streams + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +(defun read-elements (socket-stream sequence start end reader-fn) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (funcall reader-fn socket-stream) + if (eq char :eof) do (return-from read-elements i) + do (setf (elt sequence i) char)) + (+ start chars))) + +(defmacro with-stream-input-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-input-buffer state)) + (,index ,(list 'buffer-state-input-index state)) + (,limit ,(list 'buffer-state-input-limit state))) + ,@forms)))) + +(defgeneric stream-fill-buffer (stream)) +(defmethod stream-fill-buffer ((stream buffered-stream-mixin)) + ;; Implement b/nb semantics: block until at least one byte is read, + ;; but not until the whole buffer is filled. This means it takes at + ;; most n calls to this function to fill a buffer of length n, even + ;; with a slow connection. + (with-stream-input-buffer (buffer index limit) stream + (let* ((the-stream (native-lisp-stream stream)) + (read-bytes + (loop with byte + for n-read from 0 below limit + while (and (if (< 0 n-read) (listen the-stream) t) + (setf byte (read-byte the-stream nil nil))) + do (setf (aref buffer n-read) byte) + count t))) + (if (zerop read-bytes) + nil + (setf index 0 + limit read-bytes))))) + +(defmethod stream-read-byte ((stream buffered-bivalent-input-stream)) + (with-stream-input-buffer (buffer index limit) stream + (unless (and index (< index limit)) + (when (null (stream-fill-buffer stream)) + (return-from stream-read-byte :eof))) + (prog1 (aref buffer index) + (incf index)))) + +(defmethod stream-read-char ((stream buffered-bivalent-input-stream)) + (let ((byte (stream-read-byte stream))) + (if (eq byte :eof) + :eof + (code-char byte)))) + +(defmethod stream-read-char-no-hang ((stream buffered-bivalent-input-stream)) + (if (listen stream) + (read-char stream) + nil)) + +(defmethod stream-unread-char ((stream buffered-bivalent-input-stream) character) + (with-stream-input-buffer (buffer index limit) stream + (let ((new-index (1- index))) + (when (minusp new-index) + (error "Cannot unread char ~A" character)) + (setf (aref buffer new-index) (char-code character) + index new-index))) + nil) + +(defmethod stream-peek-char ((stream buffered-bivalent-input-stream)) + (let ((char (stream-read-char stream))) + (unless (eq char :eof) + (stream-unread-char stream char)) + char)) + + +(defmethod stream-read-line ((stream buffered-bivalent-input-stream)) + (let ((res (make-array 80 :element-type 'character :fill-pointer 0))) + (loop + (let ((ch (stream-read-char stream))) + (cond ((eq ch :eof) + (return (values (copy-seq res) t))) + ((char= ch #\Linefeed) + (return (values (copy-seq res) nil))) + (t + (vector-push-extend ch res))))))) + + +(defmethod stream-read-sequence ((stream buffered-bivalent-input-stream) sequence &optional start end) + (read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;;(defmethod stream-clear-input ((stream buffered-bivalent-input-stream)) +;; (clear-input (native-lisp-stream stream))) + +(defmethod stream-element-type ((stream fundamental-bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +;;; Output streams + +(declaim (inline %writer-function-for-sequence)) +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'stream-write-char) + ((array unsigned-byte (*)) #'stream-write-byte) + ((array signed-byte (*)) #'stream-write-byte) + (otherwise #'stream-write-byte))) + +(defun write-elements (stream sequence start end writer-fn) + (let* ((len (length sequence)) + (start (or start 0)) + (end (or end len))) + (assert (<= 0 start end len)) + (etypecase sequence + (simple-vector (loop for i from start below end + do (funcall writer-fn stream (svref sequence i)))) + (vector (loop for i from start below end + do (funcall writer-fn stream (aref sequence i)))) + (list (loop for i from start below end + for c in (nthcdr start sequence) + do (funcall writer-fn stream c)))))) + +(defgeneric stream-write-buffer (stream buffer start end)) +(defmethod stream-write-buffer ((stream buffered-stream-mixin) buffer start end) + (let ((lisp-stream (native-lisp-stream stream))) + (write-sequence buffer lisp-stream :start start :end end))) + +(defgeneric stream-flush-buffer (stream)) +(defmethod stream-flush-buffer ((stream buffered-stream-mixin)) + (with-stream-output-buffer (buffer index limit) stream + (when (plusp index) + (stream-write-buffer stream buffer 0 index) + (setf index 0)))) + +(defmethod stream-write-byte ((stream buffered-bivalent-output-stream) byte) + (with-stream-output-buffer (buffer index limit) stream + (unless (< index limit) + (stream-flush-buffer stream)) + (setf (aref buffer index) byte) + (incf index))) + +(defmethod stream-write-char ((stream buffered-bivalent-output-stream) character) + (stream-write-byte stream (char-code character))) + +(defmethod stream-write-string ((stream buffered-bivalent-output-stream) string &optional (start 0) end) + (write-elements stream string start end #'stream-write-char)) + +(defmethod stream-write-sequence ((stream buffered-stream-mixin) sequence + &optional (start 0) end) + (write-elements stream sequence start end (%writer-function-for-sequence sequence))) + +(defmethod stream-element-type ((stream fundamental-bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-line-column ((stream fundamental-bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (finish-output (native-lisp-stream stream))) + +(defmethod stream-force-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (force-output (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream buffered-bivalent-output-stream)) + (with-stream-output-buffer (buffer index limit) stream + (setf index 0 + limit 0)) + (call-next-method) ; Clear native stream also + ) + + Added: vendor/portableaserve/acl-compat/mcl/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/mcl/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/mcl/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/mcl/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,9 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:02 2004// +/acl-excl.lisp/1.11/Fri Mar 4 21:00:53 2005// +/acl-mp.lisp/1.6/Sun Jan 11 17:20:34 2004// +/acl-socket-mcl.lisp/1.3/Tue Apr 12 04:42:49 2005// +/acl-socket-openmcl.lisp/1.3/Sun Jan 11 17:20:34 2004// +/acl-sys.lisp/1.3/Sun Jan 11 17:20:34 2004// +/mcl-stream-fix.lisp/1.1/Tue Jun 3 03:57:48 2003// +/mcl-timers.lisp/1.2/Mon Nov 3 02:59:18 2003// +D Added: vendor/portableaserve/acl-compat/mcl/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/mcl/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/mcl Added: vendor/portableaserve/acl-compat/mcl/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/mcl/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/mcl/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,168 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +;#-openmcl +;(defun fixnump (x) +; (ccl::fixnump x)) + +#-openmcl +(import 'ccl::fixnump) + +#+openmcl +(defun filesys-inode (path) + (or (nth-value 4 (ccl::%stat (ccl::native-translated-namestring path))) + (error "path ~s does not exist" path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (ccl:directory-pathname-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(ccl:without-interrupts ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition stream-error (error) + ((stream :initarg :stream + :reader stream-error-stream) + (action :initarg :action + :initform nil + :reader stream-error-action) + (code :initarg :code + :initform nil + :reader stream-error-code) + (identifier :initarg :identifier + :initform nil + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + + + +;! Need to figure out what to do here +(defun fasl-read (filename) + (declare (ignore filename)) + (error "fasl-read not implemented for MCL.") ) + +(defun fasl-write (data stream opt) + (declare (ignore data stream opt)) + (error "fasl-write not implemented for MCL.") ) + + +(defmacro schedule-finalization (object function) + `(ccl:terminate-when-unreachable ,object ,function)) + +(defun run-shell-command (program + &key input output error-output separate-streams + if-input-does-not-exist if-output-exists + if-error-output-exists wait environment show-window) + (declare (ignore show-window)) + ;; KLUDGE: split borrowed from asdf, this shouldn't be done -- it + ;; would be better to use split-sequence or define one ourselves ... + ;; TODO: On Unix, acl also handles a vector of simple-strings as + ;; value for program, with different semantics. + (let* ((program-and-arguments + (delete "" (asdf::split program) :test #'string=)) + (program (car program-and-arguments)) + (arguments (cdr program-and-arguments))) + (when environment + #-unix (error "Don't know how to run program in an environment.") + (setf arguments (append + (list "-i") + (loop for (name . value) in environment + collecting (concatenate 'string name "=" value)) + (list program) + arguments)) + (setf program "env")) + + (let* ((process (run-program program arguments + :input input + :if-input-does-not-exist + if-input-does-not-exist + :output output + :if-output-exists if-output-exists + :error error-output + :if-error-exists if-error-output-exists + :wait wait)) + (in-stream (external-process-input-stream process)) + (out-stream (external-process-output-stream process)) + (err-stream (external-process-error-stream process)) + (pid (external-process-id process))) + (cond + ;; one value: exit status + (wait (nth-value 1 (external-process-status process))) + ;; four values: i/o/e stream, pid + (separate-streams + (values (if (eql input :stream) in-stream nil) + (if (eql output :stream) out-stream nil) + (if (eql error-output :stream) err-stream nil) + pid)) + ;; three values: normal stream, error stream, pid + (t (let ((normal-stream + (cond ((and (eql input :stream) (eql output :stream)) + (make-two-way-stream in-stream out-stream)) + ((eql input :stream) in-stream) + ((eql output :stream) out-stream) + (t nil))) + (error-stream (if (eql error-output :stream) err-stream nil))) + (values normal-stream error-stream pid))))))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: vendor/portableaserve/acl-compat/mcl/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,183 @@ +;;; This file implements the process functions for AllegroServe in MCL. +;;; Based on the the work done for cmucl and Lispworks. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforge.net + + +(in-package :acl-compat.mp) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +; existing stuff from ccl we can reuse directly +(shadowing-import + '(ccl:*current-process* + ccl::lock + ccl:process-allow-schedule + ccl:process-name + ccl:process-preset + #-openmcl-native-threads ccl:process-run-reasons + ccl:process-wait + ccl:process-wait-with-timeout + ccl:without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(export + '(*current-process* + lock + process-allow-schedule + process-name + process-preset + process-run-reasons + process-wait + process-wait-with-timeout + without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defmacro without-scheduling (&body forms) + `(ccl:without-interrupts ,@forms)) + +#| +; more ideas stolen from acl-mp-lw.lisp +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((process *current-process*) + (timer (ccl:process-run-function "with-timeout-timer" + #'(lambda () + (sleep seconds) + (ccl:process-interrupt process + #'(lambda () + (return-from timeout + (funcall timeoutfn)))))))) + (unwind-protect (funcall bodyfn) + (ccl:process-kill timer))))) + +|# + + + +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((timer (ccl::make-timer-request + seconds + #'(lambda () (return-from timeout (funcall timeoutfn)))))) + (ccl::enqueue-timer-request timer) + (unwind-protect (funcall bodyfn) + (ccl::dequeue-timer-request timer))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + + +#+openmcl-native-threads +(progn + +;;; The :INITIAL-BINDINGS arg to process creation functions seems to be +;;; quoted, even when it appears in a list (as in the case of +;;; (process-run-function <args>)) By the time that percolates down +;;; to OpenMCL's process creation functions, it should lose the quote. +;;; +;;; Perhaps I imagined that ... +;;; + +(defun ccl::openmcl-fix-initial-bindings (initial-bindings) + (if (and (consp initial-bindings) + (eq (car initial-bindings) 'quote)) + (cadr initial-bindings) + initial-bindings)) + +) + + +#-openmcl-native-threads +(defmacro process-revoke-run-reason (process reason) + `(ccl:process-disable-run-reason ,process ,reason) ) + +#-openmcl-native-threads +(defmacro process-add-run-reason (process reason) + `(ccl:process-enable-run-reason ,process ,reason) ) + + +(defmacro make-process-lock (&key name) + (if name + `(ccl:make-lock ,name) + `(ccl:make-lock))) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive whostate timeout)) + `(ccl:with-lock-grabbed (,lock) ,@forms)) + + +(defmacro process-kill (process) + `(progn + #-openmcl-native-threads + (unless (ccl:process-active-p ,process) ;won't die unless enabled + (ccl:process-reset-and-enable ,process) ) + (ccl:process-kill ,process))) +) + +(defun process-active-p (process) + (ccl::process-active-p process)) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." +(apply #'ccl:process-interrupt process function args)) + +(defun current-process () + "The current process." + ccl:*current-process*) + + +;property list implementation from acl-mp-cmu.lisp +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +; from acl-mp-lw.lisp +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + #-openmcl-native-threads + (declare (ignore initial-bindings)) ;! need separate lexical bindings for each process? + #+openmcl-native-threads + (declare (ignore run-reasons arrest-reasons)) + ;(let ((acl-mp:*process-initial-bindings* initial-bindings)) + #-openmcl-native-threads + (ccl:make-process name :run-reasons run-reasons :arrest-reasons arrest-reasons) + #+openmcl-native-threads + (ccl:make-process name :initial-bindings (ccl::openmcl-fix-initial-bindings initial-bindings))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (acl-mp:make-process :name name-or-options)) + (list (apply #'acl-mp:make-process name-or-options))))) + (apply #'acl-mp:process-preset process preset-function preset-arguments) + #+openmcl-native-threads (ccl:process-enable process) + #-openmcl-native-threads (process-add-run-reason process :enable) + process)) + +;;; Busy-waiting ... +(defun wait-for-input-available (streams + &key (wait-function #'ccl:stream-listen) + whostate timeout) + (let ((collected-fds nil)) + (flet ((collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + (if timeout + (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) Added: vendor/portableaserve/acl-compat/mcl/acl-socket-mcl.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/acl-socket-mcl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/acl-socket-mcl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,268 @@ +;;; MCL layer for ACL sockets. +;;; Based on acl-socket-cmu.lisp and acl-socket-lw.lisp. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforge.net + + +(defpackage :acl-compat.socket + (:nicknames :socket :acl-socket) + (:use :common-lisp) + (:export #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + )) + +(in-package :socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(require :opentransport) + +;OpenTransport.lisp does not export anything, so do this to make it look a bit cleaner. +(import '(ccl::open-tcp-stream + ccl::opentransport-tcp-stream + ccl::opentransport-binary-tcp-stream + ccl::stream-local-port + ccl::stream-local-host + ccl::stream-local-port + ccl::stream-remote-host + ccl::stream-remote-port + ccl::inet-host-name + ccl::tcp-host-address + ) ) + +(defmacro connection-state (s) + `(ccl::opentransport-stream-connection-state ,s)) + +(defmacro connection-established (s) + `(eq :dataxfer (connection-state ,s)) ) + +) + + +;;; There is a bug in MCL (4.3.1 tested) where read-sequence and +;;; write-sequence fail with binary tcp streams. These two methods +;;; provide a work-around. +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-write-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) end) + (ccl::stream-write-vector s sequence start (or end (length sequence))) + s) + + + +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-read-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) (end (length sequence))) + (ccl::stream-read-bytes-to-vector s sequence (- end start) start) + end) + + + +(defmethod port ((stream opentransport-tcp-stream)) + (stream-local-port stream) ) + +(defmethod local-host ((s opentransport-tcp-stream)) + (stream-local-host s)) + +(defmethod local-port ((s opentransport-tcp-stream)) + (stream-local-port s)) + +(defmethod remote-host ((s opentransport-tcp-stream)) + (stream-remote-host s)) + +(defmethod remote-port ((s opentransport-tcp-stream)) + (stream-remote-port s)) + +;? copied from lispworks - don't think it applies to mcl +(defmethod fd ((s opentransport-tcp-stream)) + (declare (ignore s)) + 42) + + + +(defvar *passive-socket-listener-count* 10 + "Default number of listen streams to use.") + +; With ACL, an unlimited number of connections can be made to the same passive +; socket instance. Nothing like that here, so we have to create our own stream +; listener to create the "real" sockets as connections are made. + + +; Create a class to monitor streams so we have a data structure to pass to process-wait +(defclass passive-socket (stream) ;inherit stream so we can handle close + ((port + :documentation "Port we are listening on." + :initform 80 + :initarg :port + :reader local-port) + (element-type + :documentation "Stream element type." + :initarg :element-type + :initform '(unsigned-byte 8)) + (count + :documentation "Number of listening streams to monitor." + :initform *passive-socket-listener-count*) + (streams + :documentation "Array of listen streams." + :initform nil) + (index + :documentation "Index of the last listen stream checked." + :initform *passive-socket-listener-count*) + (connect-index + :documentation "Index of a connected stream, next for processing." + :initform nil) + ) + (:documentation "Class used to manage listening streams and connections.") ) + + + +(defmethod initialize-instance :after ((listener passive-socket) &rest initargs) + (declare (ignore initargs)) + (with-slots (streams count port element-type) listener + (setf streams (make-array count :initial-element nil :adjustable t)) + (dotimes (i count) + (setf (elt streams i) (new-listen-stream listener)) ) ) ) + + +(defmethod ccl:stream-close ((listener passive-socket)) + (with-slots (streams count) listener + (dotimes (i count) + (close (elt streams i))) + (setf count 0))) + + +(defmethod new-listen-stream ((listener passive-socket)) + (with-slots (port element-type) listener + (open-tcp-stream nil port ;use nil host to get a passive connection + :element-type element-type) ) ) + + +(defmethod local-host ((listener passive-socket)) + (with-slots (streams count) listener + (when (> count 0) + (local-host (elt streams 0))))) + + + +; See if one of the streams is established. +(defmethod find-connection-index ((listener passive-socket)) + (with-slots (count streams index connect-index) listener + (let ((next (if (< (1+ index) count) (1+ index) 0))) + (when (connection-established (elt streams next)) + (setf index next + connect-index next) + connect-index)))) + + +(defmethod process-connected-stream ((listener passive-socket)) + (with-slots (streams connect-index) listener + (if (null connect-index) nil + (let ((s (elt streams connect-index))) ;return the connected stream and set a new one + (setf (elt streams connect-index) (new-listen-stream listener)) + (setf connect-index nil) + s) ) ) ) + + +;! future - determine how many connects we are getting an dynamically increase the number +; of listeners if necessary. +(defmethod accept-connection ((listener passive-socket) &key (wait t)) + (if wait + (ccl:process-wait "accept connection..." #'find-connection-index listener) ;apply repeatedly with process wait + (find-connection-index listener) ) + (process-connected-stream listener) ) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'passive-socket :port local-port :element-type element-type :direction :io)) + (:active + (let ((host (if (integerp remote-host) ;aparently the acl version also accepts an integer + (ipaddr-to-dotted remote-host) + remote-host))) + (check-type host string) + (open-tcp-stream host remote-port + :element-type element-type)))))) + + + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) + +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (inet-host-name ipaddr) ) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (tcp-host-address host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in MCL. Restart the server with argument :chunking nil (turns chunking off).") ) ) + + +(provide 'acl-socket) + + + Added: vendor/portableaserve/acl-compat/mcl/acl-socket-openmcl.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/acl-socket-openmcl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/acl-socket-openmcl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,145 @@ +;;; OpenMCL layer for ACL sockets. +;;; Most everything is already there, just needs to be in the socket package. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforget.net + +(in-package :acl-compat.socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + '(;ccl:make-socket ; use our own version + ccl:accept-connection + ccl:dotted-to-ipaddr + ccl:ipaddr-to-hostname + ccl:lookup-hostname + ccl:remote-host + ccl:remote-port + ccl:local-host + ccl:local-port)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export + '(accept-connection + ipaddr-to-dotted + dotted-to-ipaddr + ipaddr-to-hostname + lookup-hostname + remote-host + remote-port + local-host + local-port + socket-control)) + ) + + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (port :initarg :port + :reader port + :initform (error "No value supplied for port")))) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (let ((stream (accept-connection (socket server-socket) :wait wait))) + (when stream (make-chunked-stream stream)))) + + +(defun make-socket (&rest args + &key (connect :active) port + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. +" + (let ((socket-or-stream (apply #'ccl:make-socket args))) + (if (eq connect :active) + (make-chunked-stream socket-or-stream) + (make-instance 'server-socket :socket socket-or-stream :port port)))) + + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (close (socket server-socket))) + +(defmethod local-host ((server-socket server-socket)) + (local-host (socket server-socket))) + +(defmethod local-port ((server-socket server-socket)) + (local-port (socket server-socket))) + +(defmethod ccl:stream-write-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%writer-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (funcall fn stream (ccl:uvref vector i))))) + +(defmethod ccl:stream-read-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%reader-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((b (funcall fn stream))) + (if (eq b :eof) + (return i) + (setf (ccl:uvref vector i) b)))))) + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + +(defun make-chunked-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + +(defmethod local-host ((chunked-stream chunked-stream)) + (local-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod local-port ((chunked-stream chunked-stream)) + (local-port (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-host ((chunked-stream chunked-stream)) + (remote-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-port ((chunked-stream chunked-stream)) + (remote-port (gray-stream::native-lisp-stream chunked-stream))) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +; OpenMCL has a built-in ipaddr-to-dotted. But it appears that sometimes +; the log function is being called after the connection is closed and +; it causes nil to be passed to ipaddr-to-dotted. So we wrap ipaddr-to-dotten +; to ensure only non-nil values are passed. + +(defun ipaddr-to-dotted (ipaddr &key values) + (unless (null ipaddr) + (ccl:ipaddr-to-dotted ipaddr :values values))) + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/mcl/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,20 @@ + +(in-package :acl-compat.system) + + +(defun command-line-arguments () + #+openmcl (ccl::command-line-arguments) + #-openmcl nil) + +(defun command-line-argument (n) + #+openmcl (nth n (command-line-arguments)) + #-openmcl nil) + +;;; On acl, reap-os-subprocess is needed for (run-shell-command ... +;;; :wait nil), but not on OpenMCL. +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +#+nil +(export '(command-line-arguments command-line-argument reap-os-subprocess)) Added: vendor/portableaserve/acl-compat/mcl/mcl-stream-fix.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/mcl-stream-fix.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/mcl-stream-fix.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,44 @@ + + +(in-package :ccl) + +;;; There are several bugs in MCL functions to read sequences prior to 4.3.5; this fixes them + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(let ((ccl:*warn-if-redefine* nil)) + +(defun %io-buffer-read-bytes-to-vector (io-buffer vector bytes start) + (loop with fill-pointer = start + with bytes-remaining = bytes + until (eql 0 bytes-remaining) + while (if (eql 0 (io-buffer-incount io-buffer)) + (%io-buffer-advance io-buffer t t) ; eof may be signalled through this -- JCMa 5/13/1999. + t) + for buffer = (io-buffer-inptr io-buffer) + for read-bytes = (min (io-buffer-incount io-buffer) bytes-remaining) + do (%copy-ptr-to-ivector buffer 0 vector fill-pointer read-bytes) + (incf fill-pointer read-bytes) + (%incf-ptr (io-buffer-inptr io-buffer) read-bytes) ;; bug fix from akh on 7/28/2002 + (decf bytes-remaining read-bytes) + (decf (io-buffer-incount io-buffer) read-bytes) + (incf (io-buffer-bytes-read io-buffer) read-bytes))) + + +;This function is unchanged, but kept for completeness +(defun io-buffer-read-bytes-to-vector (io-buffer vector bytes &optional (start 0)) + (require-type io-buffer 'io-buffer) + (with-io-buffer-locked (io-buffer) + (multiple-value-bind (v v-offset) + (array-data-and-offset vector) + (%io-buffer-read-bytes-to-vector io-buffer v bytes (+ start v-offset))))) + + +(defmethod stream-read-bytes-to-vector ((stream buffered-output-stream-mixin) vector bytes &optional (start 0)) + (io-buffer-read-bytes-to-vector (stream-io-buffer stream) vector bytes start)) ;original fuction did not get the buffer from the stream + + +) +) \ No newline at end of file Added: vendor/portableaserve/acl-compat/mcl/mcl-timers.lisp =================================================================== --- vendor/portableaserve/acl-compat/mcl/mcl-timers.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/mcl/mcl-timers.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,112 @@ +;;; mcl-timers contributed by Gary Byers + +(in-package "CCL") + + +;;; A simple timer mechanism for MCL/OpenMCL, which uses a +;;; PERIODIC-TASK to check for expired "timer requests". +;;; In MCL and OpenMCL, PERIODIC-TASKS run at specified +;;; intervals via the same preemption mechanism that the +;;; scheduler uses; they run in the execution context of +;;; whatever thread was preempted, and they're assumed to +;;; run pretty quickly. +;;; This code uses doubly-linked-list elements (DLL-NODEs) +;;; to represent a sorted list of "timer requests"; client +;;; processes use timer requests to schedule an interrupt +;;; action at a specified time. A periodic task walks this +;;; list once a second (by default), removing those requests +;;; whose time isn't in the future and interrupting the +;;; corresponding processes. + + +;;; The number of timer interrupts (ticks) per second. +(defmacro ticks-per-second () + #+OpenMCL '*ticks-per-second* + #-OpenMCL 60) + + +(defun expiration-tick-count (seconds) + (+ (round (* seconds (ticks-per-second))) + (get-tick-count))) + +(defstruct (timer-request (:include dll-node) + (:constructor %make-timer-request)) + expiration-tick ; when the timer expires + process ; what process to interrupt + function) ; how to interrupt it + + +(defun make-timer-request (seconds-from-now function) + (check-type seconds-from-now (and unsigned-byte fixnum)) + (check-type function function) + (%make-timer-request + :expiration-tick (expiration-tick-count seconds-from-now) + :process *current-process* + :function function)) + + +;;; the CCL::DEFLOADVAR construct ensures that the variable +;;; will be reinitialized when a saved image is restarted +(defloadvar *timer-request-queue* + #-openmcl-native-threads (make-dll-header) + #+openmcl-native-threads (make-locked-dll-header)) + +;;; Insert the timer request before the first element with a later +;;; expiration time (or at the end of the queue if there's no such +;;; element.) +(defun enqueue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (if (dll-node-succ r) ; Already enqueued. + r ; Or signal an error. + (let* ((r-date (timer-request-expiration-tick r))) + (do* ((node *timer-request-queue* next) + (next (dll-node-succ node) (dll-node-succ next))) + ((or (eq next *timer-request-queue*) + (> (timer-request-expiration-tick next) r-date)) + (insert-dll-node-after r node))))))) + +;;; Remove a timer request. (It's a no-op if the request has already +;;; been removed.) +(defun dequeue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (when (dll-node-succ r) ;enqueued + (remove-dll-node r)) + r)) + +;;; Since this runs in an arbitrary process, it tries to be a little +;;; careful with requests made by the current process (since running +;;; the interrupt function will probably transfer control out of the +;;; periodic task function.) The oldest (hopefully only) request for +;;; the current process is handled after all other pending requests. +(defun process-timer-requests () + (let* ((now (get-tick-count)) + (current-process *current-process*) + (current-process-action ())) + (#-openmcl-native-threads progn + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + + (do-dll-nodes (r *timer-request-queue*) + (when (> (timer-request-expiration-tick r) now) + (return)) ; Anything remaining is + ; in the future. + (dequeue-timer-request r) + (let* ((proc (timer-request-process r)) + (func (timer-request-function r))) + (if (eq proc current-process) + (if (null current-process-action) + (setq current-process-action func)) + (process-interrupt (timer-request-process r) + (timer-request-function r))))) + (when current-process-action + (funcall current-process-action))))) + +(%install-periodic-task + 'process-timer-requests ; Name of periodic task + 'process-timer-requests ; function to call + (ticks-per-second) ; Run once per second + ) Added: vendor/portableaserve/acl-compat/openmcl/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/openmcl/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/openmcl/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +D Added: vendor/portableaserve/acl-compat/openmcl/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/openmcl/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/openmcl/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/openmcl Added: vendor/portableaserve/acl-compat/openmcl/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/openmcl/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/openmcl/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/packages.lisp =================================================================== --- vendor/portableaserve/acl-compat/packages.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/packages.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,272 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; Package definitions for acl-compat. +;;;; +;;;; Package names follow their Allegro CL counterparts -- for an ACL +;;;; package foo, acl-compat defines a package acl-compat.foo +;;;; +;;;; Some packages have nicknames, which were used as package names by +;;;; previous versions of paserve and acl-compat. The nicknames are +;;;; deprecated, but are kept for the benefit of people using +;;;; acl-compat in other projects. New projects should use the +;;;; package names starting with "acl-compat.". +;;;; + +(in-package :common-lisp-user) + +;;; general +(defpackage :acl-compat.excl + (:use #:common-lisp + #+cmu #:ext + #+clisp #:ext + #+sbcl #:sb-ext #+sbcl #:sb-gray + #+(or allegro cormanlisp) :excl + #+mcl :ccl + ) + #+lispworks (:import-from :common-lisp #:fixnump) + #+sbcl (:import-from :sb-int #:fixnump) + #+sbcl (:import-from :sb-ext #:without-package-locks) + #+cmu (:import-from :ext #:without-package-locks) + #+allegro (:shadowing-import-from :excl #:filesys-size + #:filesys-write-date #:intern* #:filesys-type #:atomically #:fast) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:fixnump + #+(or lispworks mcl) #:socket-error + #+(or allegro lispworks mcl) #:run-shell-command + #+(or allegro mcl) #:fasl-read + #+(or allegro mcl) #:fasl-write + #+(or allegro cmu scl mcl lispworks) #:string-to-octets + #+(or allegro cmu scl mcl lispworks) #:write-vector + )) + + +;; general +(defpackage :acl-compat.mp + (:use :common-lisp #+cormanlisp :acl-compat-mp #+allegro :mp) + (:nicknames :acl-mp #-cormanlisp :acl-compat-mp) + #+allegro (:shadowing-import-from :mp #:process-interrupt #:lock) + #+allegro (:shadowing-import-from :excl #:without-interrupts) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-lock + #:process-unlock + + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + #:process-active-p + )) + +(defpackage :de.dataheaven.chunked-stream-mixin + (:use :common-lisp) + (:export #:chunked-stream-mixin + #:output-chunking-p #:input-chunking-p)) + +;; general +(defpackage acl-compat.socket + (:use #:common-lisp + #+(or cmu lispworks scl) #:acl-mp + #+(or lispworks cmu)#:acl-compat.excl + #+clisp #:socket + #+sbcl #:sb-bsd-sockets + #+(or lispworks cmu) #:de.dataheaven.chunked-stream-mixin + #+cormanlisp #:socket + ) + #+cl-ssl (:import-from :ssl #:MAKE-SSL-CLIENT-STREAM #:MAKE-SSL-SERVER-STREAM) + #+lispworks (:shadow socket-stream stream-error) + (:export + #+(or lispworks cmu) #:socket + #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + #+cl-ssl #:make-ssl-client-stream + #+cl-ssl #:make-ssl-server-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-client-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-server-stream + #+lispworks #:socket-os-fd + ) + #-cormanlisp (:nicknames #-(or clisp allegro) socket #-allegro acl-socket)) + + +(defpackage acl-compat.system + (:nicknames :acl-compat.sys) + (:use :common-lisp) + (:export + #:command-line-arguments + #:command-line-argument + #:reap-os-subprocess + )) + + +; these are not all in the ccl package which causes an error +#+(and mcl (not openmcl)) +(shadowing-import '( + fundamental-binary-input-stream + fundamental-binary-output-stream + fundamental-character-input-stream + fundamental-character-output-stream + stream-element-type + stream-listen + stream-read-byte + stream-read-char + stream-peek-char + stream-write-byte + stream-write-char + stream-read-char-no-hang + stream-force-output + stream-finish-output + stream-clear-input + stream-clear-output + stream-line-column + stream-read-sequence + stream-unread-char + stream-read-line + stream-write-sequence + stream-write-string) + :ccl) + +#-cormanlisp +(defpackage :gray-stream + (:use #:common-lisp) + (:import-from #+lispworks :stream #+cmu :lisp #+clisp :gray #+cormanlisp :gray-streams + #+mcl :ccl #+allegro :excl #+sbcl :sb-gray + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-peek-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-(or clisp openmcl) #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-(or clisp openmcl) #:stream-write-sequence + #:stream-write-string + #+lispworks #:stream-write-buffer + #+lispworks #:stream-read-buffer + #+lispworks #:stream-fill-buffer + #+lispworks #:stream-flush-buffer + #+lispworks #:with-stream-input-buffer + #+lispworks #:with-stream-output-buffer) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-clisp #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-clisp #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) + +#+cormanlisp +(defpackage :gray-stream + (:use #:common-lisp :gray-streams) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) Added: vendor/portableaserve/acl-compat/sbcl/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/sbcl/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/sbcl/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/sbcl/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:02 2004// +/acl-excl.lisp/1.8/Sun Jan 22 13:01:22 2006// +/acl-mp.lisp/1.16/Sun Jan 22 13:01:22 2006// +/acl-socket.lisp/1.9/Tue Aug 31 20:36:22 2004// +/acl-sys.lisp/1.1/Wed Apr 30 12:59:00 2003// +D Added: vendor/portableaserve/acl-compat/sbcl/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/sbcl/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/sbcl Added: vendor/portableaserve/acl-compat/sbcl/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/sbcl/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/sbcl/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/sbcl/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,32 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name)))) + (cond + ((sb-posix:s-isreg mode) :file) + ((sb-posix:s-isdir mode) :directory) + (t nil)))) + +(defmacro atomically (&body forms) + `(acl-mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "unix-signal not implemented in acl-excl-sbcl.lisp")) + +(defun filesys-inode (path) + (sb-posix:stat-ino (sb-posix:lstat path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + Added: vendor/portableaserve/acl-compat/sbcl/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/sbcl/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,294 @@ +;; Threading for sbcl, or stub functions for single-threaded sbcl. +;; +;; Written by Rudi Schlatte, intended to be distributed along with the +;; acl-compat library, under the same license as the rest of it. + +;; Inspirations taken from Dan Barlow<dan(a)metacircles.com>'s work for +;; McCLIM; cut, pasted and mutilated with permission. + +(in-package :acl-compat.mp) + +(defstruct (process + (:constructor %make-process) + (:predicate processp)) + name + state + whostate + function ; function wot will be run + arguments ; arguments to the function + id ; pid of unix thread or nil + %lock ; lock for process structure mutators + run-reasons ; primitive mailbox for IPC + %queue ; queue for condition-wait + initial-bindings ; special variable bindings + property-list) + +(defparameter *current-process* + #-sb-thread + (%make-process) + #+sb-thread + ;; We don't fill in the process id, so the process compiling this + ;; (the REPL, in most cases) can't be killed by accident. (loop for + ;; p in (all-processes) do (kill-process p)), anyone? + (%make-process :name "initial process" :function nil)) + +(defparameter *all-processes-lock* + (sb-thread:make-mutex :name "all processes lock")) + +(defparameter *all-processes* + (list *current-process*)) + +#-sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (%make-process :name "the only process" + :run-reasons run-reasons + :initial-bindings initial-bindings)) + +#+sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (let ((p (%make-process + :name name + :run-reasons run-reasons + :initial-bindings initial-bindings + :%lock (sb-thread:make-mutex + :name (format nil "Internal lock for ~A" name)) + :%queue (sb-thread:make-waitqueue + :name (format nil "Blocking queue for ~A" name))))) + (sb-thread:with-mutex (*all-processes-lock*) + (push p *all-processes*)) + p)) + +(defmacro defun/sb-thread (name args &body body) + #-sb-thread (declare (ignore body)) + `(defun ,name ,args + #-sb-thread + (declare (ignore ,@(remove-if + (lambda (x) + (member x '(&optional &rest &key &allow-other-keys + &aux))) + (mapcar (lambda (x) (if (consp x) (car x) x)) + args)))) + #-sb-thread + (error + "~A: Calling a multiprocessing function on a single-threaded sbcl build" + ',name) + #+sb-thread + ,@body)) + +(defun/sb-thread process-interrupt (process function) + (sb-thread:interrupt-thread (process-id process) function)) + +;; TODO: why no such function was in +sb-thread part? +(defun/sb-thread process-wait-function (process) + (declare (ignore process))) + +(defun/sb-thread process-wait (reason predicate &rest arguments) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (apply predicate arguments))) + (when it (return it))) + (process-allow-schedule))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread process-allow-schedule (&optional process) + (declare (ignore process)) + (sleep .01)) + +(defun/sb-thread process-revoke-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (setf (process-run-reasons process) + (delete object (process-run-reasons process))) + (when (and (process-id process) (not (process-run-reasons process))) + (disable-process process))))) + +(defun/sb-thread process-add-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (push object (process-run-reasons process)) + (if (process-id process) + (enable-process process) + (restart-process process))))) + +(defun/sb-thread process-run-function (name-or-options preset-function + &rest preset-arguments) + (let* ((make-process-args (etypecase name-or-options + (list name-or-options) + (string (list :name name-or-options)))) + (process (apply #'make-process make-process-args))) + (apply #'process-preset process preset-function preset-arguments) + (setf (process-run-reasons process) :enable) + (restart-process process) + process)) + +(defun/sb-thread process-preset (process function &rest arguments) + (setf (process-function process) function + (process-arguments process) arguments) + (when (process-id process) (restart-process process))) + +(defun/sb-thread process-kill (process) + (when (process-id process) + (sb-thread:destroy-thread (process-id process)) + (setf (process-id process) nil)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*)))) + +#+sb-thread +(defun make-process-lock (&key name) + (sb-thread:make-mutex :name name)) +#-sb-thread +(defun make-process-lock (&key name) + (declare (ignore name)) + nil) + +(defun/sb-thread process-lock (lock &optional lock-value whostate timeout) + (declare (ignore whostate timeout)) + (sb-thread:get-mutex lock lock-value)) + +(defun/sb-thread process-unlock (lock &optional lock-value) + (declare (ignore lock-value)) + (sb-thread:release-mutex lock)) + +#-sb-thread +(defmacro with-process-lock ((lock &key norecursive timeout whostate) + &body forms) + (declare (ignore lock norecursive timeout whostate)) + `(progn ,@forms)) + +#+sb-thread +(defmacro with-process-lock ((place &key timeout whostate norecursive) + &body body) + (declare (ignore norecursive timeout)) + (let ((old-whostate (gensym "OLD-WHOSTATE"))) + `(sb-thread:with-recursive-lock (,place) + (let (,old-whostate) + (unwind-protect + (progn + (when ,whostate + (setf ,old-whostate (process-whostate *current-process*)) + (setf (process-whostate *current-process*) ,whostate)) + ,@body) + (setf (process-whostate *current-process*) ,old-whostate)))))) + + +#-sb-thread +(defmacro without-scheduling (&body forms) + `(progn ,@forms)) ; * + +;;; FIXME but, of course, we can't. Fix whoever wants to use it, +;;; instead +#+sb-thread +(defmacro without-scheduling (&body body) + `(progn ,@body)) + +;;; Same implementation for multi- and uni-thread +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (let ((c (gensym "TIMEOUT-"))) + `(handler-case + (sb-ext::with-timeout ,seconds (progn ,@body)) + (sb-ext::timeout (,c) (declare (ignore ,c)) ,@timeout-forms)))) + +(defun/sb-thread restart-process (process) + (labels ((boing () + (let ((*current-process* process) + (bindings (process-initial-bindings process)) + (function (process-function process)) + (arguments (process-arguments process))) + (declare (type function function)) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function arguments)) + (apply function arguments))))) + (when (process-id process) + (sb-thread:terminate-thread (process-id process))) + ;; XXX handle run-reasons in some way? Should a process continue + ;; running if all run reasons are taken away before + ;; restart-process is called? (process-revoke-run-reason handles + ;; this, so let's say (setf (process-run-reasons process) nil) is + ;; not guaranteed to do the Right Thing.) + (when (setf (process-id process) + (sb-thread:make-thread #'boing :name (process-name process))) + process))) + +(defun current-process () + *current-process*) + +(defun all-processes () + (copy-list *all-processes*)) + +(defun/sb-thread process-wait-with-timeout (reason timeout predicate) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*)) + (end-time (+ (get-universal-time) timeout))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (funcall predicate))) + (when (or (> (get-universal-time) end-time) it) + (return it))) + (sleep .01))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread disable-process (process) + ;; TODO: set process-whostate + ;; Can't figure out how to safely block a thread from a different one + ;; and handle all the locking nastiness. So punt for now. + (if (eq sb-thread:*current-thread* (process-id process)) + ;; Keep waiting until we have a reason to run. GC and other + ;; things can break a wait prematurely. Don't know if this is + ;; expected or not. + (do () + ((process-run-reasons process) nil) + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-wait (process-%queue process) + (process-%lock process)))) + (error "Can't safely disable-process from another thread"))) + +(defun/sb-thread enable-process (process) + ;; TODO: set process-whostate + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-notify (process-%queue process)))) + +;;; TODO: integrate with McCLIM / system-wide queue for such things +#+sb-thread +(defvar *atomic-spinlock* (sb-thread::make-spinlock)) + +#-sb-thread +(defmacro atomic-incf (place) + `(incf ,place)) + +#+sb-thread +(defmacro atomic-incf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (incf ,place))) + +#-sb-thread +(defmacro atomic-decf (place) + `(decf ,place)) + +#+sb-thread +(defmacro atomic-decf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (decf ,place))) + +(defun process-active-p (process) + (sb-thread:thread-alive-p (process-id process))) Added: vendor/portableaserve/acl-compat/sbcl/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/sbcl/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,283 @@ +;; This package is designed for sbcl. It implements the +;; ACL-style socket interface on top of sbcl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package #:acl-compat.socket) + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +(defclass datagram-socket (server-socket) + ()) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + +(defmethod print-object ((socket datagram-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "datagram socket listening on port ~d" (port socket)))) + +(defgeneric accept-connection (socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket)) + :input (if (numberp wait) wait nil)) + (let* ((socket (socket-accept (socket server-socket))) + (stream (socket-make-stream socket + :input t :output t + ; :buffering :none + :element-type + (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)) + nil)) + +(defmethod receive-from ((socket datagram-socket) size &key buffer extract) + (multiple-value-bind (rbuf len address port) + (socket-receive (socket socket) buffer size) + (declare (ignore port)) + (let ((buf + (if (not extract) + rbuf + (subseq rbuf 0 len)))) ;; FIXME: am I right? + (when buffer + (replace buffer buf :end2 len)) + (values + (if buffer buffer buf) + len + address)))) + +(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port) + (let* ((rhost (typecase remote-host + (string (lookup-hostname remote-host)) + (otherwise remote-host))) + (s (socket socket)) + (stream (progn + (socket-connect s rhost remote-port) + (socket-make-stream s :input t :output t :buffering :none)))) + (write-sequence buffer stream) + size)) + + + +(defun make-socket (&key + (type :stream) + (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte))) + (socket + (if (eq type :datagram) + (progn + (setf connect :passive-udp) + (make-instance 'inet-socket :type :datagram :protocol :udp)) + (make-instance 'inet-socket :type :stream :protocol :tcp)))) + (ecase connect + (:passive-udp + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (make-instance 'datagram-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:passive + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (socket-listen socket 10) ;Arbitrarily chosen backlog value + (make-instance 'server-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:active + (socket-connect socket (lookup-hostname remote-host) remote-port) + (let ((stream (socket-make-stream socket :input t :output t + :element-type element-type + ; :buffering :none + ))) + (if (eq :bivalent format) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-close (socket server))) + +#+ignore +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (or (values fixnum fixnum fixnum fixnum) + (values simple-string))) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + "Convert from 32-bit integer to dotted string." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun ipaddr-to-vector (ipaddr) + "Convert from 32-bit integer to a vector of octets." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (make-array 4 :initial-contents (list a b c d)))) + +(declaim (ftype (function (vector) + (values (unsigned-byte 32))) + vector-to-ipaddr)) +(defun vector-to-ipaddr (sensible-ipaddr) + "Convert from 4-integer vector to 32-bit integer." + (loop with result = 0 + for component across sensible-ipaddr + do (setf result (+ (ash result 8) component)) + finally (return result))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (or null (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + "Convert from dotted string to 32-bit integer." + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr)))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (host-ent-address (get-host-by-name host)) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setf socket (getf (stream-plist socket-stream) :socket))) + (vector-to-ipaddr (socket-peername socket)) + (progn (warn "Could not get remote host for ~S" socket-stream) + 0)))) + +(defun remote-port (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setq socket (getf (stream-plist socket-stream) :socket))) + (nth-value 1 (socket-peername socket)) + (progn (warn "Could not get remote port for ~S" socket-stream) + 0)))) + +(defun local-host (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (vector-to-ipaddr (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local host" thing) + 0)))) + (server-socket (vector-to-ipaddr #(127 0 0 1))) + (t (progn (warn "Could not get local host for ~S" thing) + 0)))) + +(defun local-port (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (nth-value 1 (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local port" thing) + 0)))) + (server-socket (port thing)) + (t (progn (warn "Could not get local port for ~S" thing) + 0)))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/sbcl/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/sbcl/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/sbcl/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,11 @@ +(in-package :acl-compat.system) + +(defun command-line-arguments () + sb-ext:*posix-argv*) + +(defun command-line-argument (n) + (nth n sb-ext:*posix-argv*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) Added: vendor/portableaserve/acl-compat/scl/.cvsignore =================================================================== --- vendor/portableaserve/acl-compat/scl/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/acl-compat/scl/CVS/Entries =================================================================== --- vendor/portableaserve/acl-compat/scl/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:02 2004// +/acl-excl.lisp/1.6/Tue Feb 8 09:55:43 2005// +/acl-mp.lisp/1.1/Wed Apr 30 12:58:59 2003// +/acl-socket.lisp/1.1/Wed Apr 30 12:58:59 2003// +/acl-sys.lisp/1.1/Wed Apr 30 12:58:58 2003// +D Added: vendor/portableaserve/acl-compat/scl/CVS/Repository =================================================================== --- vendor/portableaserve/acl-compat/scl/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/acl-compat/scl Added: vendor/portableaserve/acl-compat/scl/CVS/Root =================================================================== --- vendor/portableaserve/acl-compat/scl/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/acl-compat/scl/acl-excl.lisp =================================================================== --- vendor/portableaserve/acl-compat/scl/acl-excl.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/acl-excl.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,264 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(defpackage :acl-compat.excl + (:use #:common-lisp #:ext) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:string-to-octets + #:write-vector + + ;; TODO: find better place for bivalent stream classes + #:bivalent-input-stream + #:bivalent-output-stream + #:bivalent-stream + #:make-bivalent-input-stream + #:make-bivalent-output-stream + #:make-bivalent-stream + )) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +;;; Bivalent Gray streams + + +(defclass lisp-stream-mixin () + ;; For bivalent streams, lisp-stream must be a stream of type + ;; unsigned-byte + ((lisp-stream :initarg :lisp-stream + :accessor lisp-stream))) + +(defclass bivalent-input-stream (lisp-stream-mixin + fundamental-character-input-stream + fundamental-binary-input-stream)) + +(defclass bivalent-output-stream (lisp-stream-mixin + fundamental-character-output-stream + fundamental-binary-output-stream)) + +(defclass bivalent-stream (bivalent-input-stream bivalent-output-stream)) + + +(defun make-bivalent-input-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-input-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-output-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-output-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-stream :lisp-stream lisp-stream)) + + +(defmethod open-stream-p ((stream lisp-stream-mixin)) + (common-lisp::open-stream-p (lisp-stream stream))) + +(defmethod close ((stream lisp-stream-mixin) &key abort) + (close (lisp-stream stream) :abort abort)) + +(defmethod input-stream-p ((stream lisp-stream-mixin)) + (input-stream-p (lisp-stream stream))) + +(defmethod output-stream-p ((stream lisp-stream-mixin)) + (output-stream-p (lisp-stream stream))) + +(defmethod stream-element-type ((stream bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-read-char ((stream bivalent-input-stream)) + (code-char (read-byte (lisp-stream stream) nil :eof))) + +(defmethod stream-read-byte ((stream bivalent-input-stream)) + (read-byte (lisp-stream stream) nil :eof)) + +;; stream-unread-char + +(defmethod stream-read-char-no-hang ((stream bivalent-input-stream)) + (if (listen (lisp-stream stream)) + (code-char (read-byte (lisp-stream stream))) + nil)) + +;; stream-peek-char + +(defmethod stream-listen ((stream bivalent-input-stream)) + (listen (lisp-stream stream))) + +(defmethod stream-clear-input ((stream bivalent-input-stream)) + (clear-input (lisp-stream stream))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq vector) &optional start end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (assert (<= end (length seq))) + (if (subtypep (array-element-type seq) 'character) + (loop for count upfrom start + for i from start below end + do (setf (aref seq i) (code-char (read-byte stream))) + finally (return count)) + (read-sequence seq (lisp-stream stream) + :start start :end end))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq cons) &optional (start 0) end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (let ((seq (nthcdr start seq))) + (loop for count upfrom start + for head on seq + for i below (- end start) + while head + do (setf (car head) (read-byte stream)) + finally (return count)))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq null) &optional (start 0) end) + (declare (ignore end)) + start) + +(defmethod stream-element-type ((stream bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-write-char ((stream bivalent-output-stream) character) + (write-byte (char-code character) (lisp-stream stream))) + +(defmethod stream-write-byte ((stream bivalent-output-stream) byte) + (write-byte byte (lisp-stream stream))) + +(defmethod stream-line-column ((stream bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream bivalent-output-stream)) + (finish-output (lisp-stream stream))) + +(defmethod stream-force-output ((stream bivalent-output-stream)) + (force-output (lisp-stream stream))) + +(defmethod stream-clear-output ((stream bivalent-output-stream)) + (clear-output (lisp-stream stream))) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq vector) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (cond + ((subtypep (array-element-type seq) '(unsigned-byte 8)) + (write-sequence seq (lisp-stream stream) :start start :end end)) + ((subtypep (array-element-type seq) 'character) + (loop for i from start below end + do (stream-write-char stream (aref seq i)))) + ((subtypep (array-element-type seq) 'integer) + (loop for i from start below end + do (stream-write-byte stream (aref seq i))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq cons) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (let ((seq (nthcdr start seq))) + (loop for element in seq + for i below (- end start) + while seq + do (etypecase element + (character (stream-write-char stream element)) + (integer (stream-write-byte stream element))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq null) &optional (start 0) end) + (declare (ignore start end)) + seq) + +;;; End bivalent Gray streams + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: vendor/portableaserve/acl-compat/scl/acl-mp.lisp =================================================================== --- vendor/portableaserve/acl-compat/scl/acl-mp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/acl-mp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,155 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding)))) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defmacro with-process-lock ((lock &key norecursive) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock) ,@forms)) Added: vendor/portableaserve/acl-compat/scl/acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/scl/acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,196 @@ +;; This package is designed for scl. It implements the +;; ACL-style socket interface on top of scl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. +;; +;; This was modified for SCL by Kevin Rosenberg + +(defpackage acl-socket + (:use "MP" "COMMON-LISP") + #+cl-ssl (:import-from :ssl "MAKE-SSL-CLIENT-STREAM" "MAKE-SSL-SERVER-STREAM") + (:export #:socket #:make-socket #:accept-connection + #:ipaddr-to-dotted #:dotted-to-ipaddr #:ipaddr-to-hostname #:lookup-hostname + #:remote-host #:remote-port #:local-host #:local-port #:socket-control + #+cl-ssl #:make-ssl-client-stream #+cl-ssl #:make-ssl-server-stream) + (:nicknames socket)) + +(in-package socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (excl:make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (excl:make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream excl::lisp-stream-mixin)) + (system:fd-stream-fd (excl::lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in scl. Restart the server with chunking off."))) + + +(provide 'acl-socket) Added: vendor/portableaserve/acl-compat/scl/acl-sys.lisp =================================================================== --- vendor/portableaserve/acl-compat/scl/acl-sys.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/scl/acl-sys.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +(in-package :sys) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: vendor/portableaserve/acl-compat/test-acl-socket.lisp =================================================================== --- vendor/portableaserve/acl-compat/test-acl-socket.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/acl-compat/test-acl-socket.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,61 @@ +;;; Unit tests for the ACL-SOCKET compatibility package. + +(in-package cl-user) + +(require :acl-socket) + +(use-package '(acl-socket)) + +(defun test1 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test2 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :output-chunking t) + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test3 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :input-chunking t) + (prog1 + (read-line stream) + (close stream))))) + +(defun test4 () + (let ((stream (or (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500) + (error "Failed to connect.")))) + (socket-control stream :input-chunking t) + (format t "File number 1: ") + #1=(handler-case + (loop + for char = (read-char stream nil stream) + until (eq char stream) + do (write-char char)) + (excl::socket-chunking-end-of-file (e) (socket-control stream :input-chunking t))) + (format t "~%File number 2: ") + #1# + (terpri) + (values))) + + + + + + + Property changes on: vendor/portableaserve/acl-compat/test-acl-socket.lisp ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/aserve/.cvsignore =================================================================== --- vendor/portableaserve/aserve/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,25 @@ +/.cvsignore/1.7/Mon Feb 9 14:11:02 2004// +/ChangeLog/1.8/Fri Aug 5 09:52:37 2005// +/aserve-cmu.system/1.1/Sun Jun 9 11:35:01 2002// +/aserve-corman.lisp/1.1/Fri Jan 3 15:25:59 2003// +/aserve-mcl.system/1.1/Mon Apr 8 14:29:29 2002// +/aserve.asd/1.13/Sat Mar 13 17:19:17 2004// +/authorize.cl/1.8/Sun Feb 20 12:20:45 2005// +/cgi.cl/1.9/Sun Feb 20 12:20:45 2005// +/client.cl/1.18/Sun Feb 20 12:20:45 2005// +/decode.cl/1.10/Sun Feb 20 12:20:45 2005// +/defsys.cl/1.3/Thu Jun 20 06:39:44 2002// +/example.cl/1.12/Tue Jan 27 10:53:44 2004// +/headers.cl/1.7/Sun Feb 20 12:20:45 2005// +/license-allegroserve.txt/1.1.1.1/Mon Aug 6 03:42:20 2001// +/license-lgpl.txt/1.1.1.1/Mon Aug 6 03:42:32 2001// +/load.cl/1.5/Mon Apr 26 18:18:37 2004// +/loadonly.cl/1.1/Tue Dec 3 14:44:38 2002// +/log.cl/1.12/Sun Feb 20 12:20:45 2005// +/macs.cl/1.10/Sun Feb 20 12:20:45 2005// +/main.cl/1.45/Thu Oct 20 07:54:06 2005// +/packages.cl/1.6/Sun Feb 20 12:20:45 2005// +/parse.cl/1.12/Sun Feb 20 12:20:45 2005// +/proxy.cl/1.17/Sat Jan 21 16:51:44 2006// +/publish.cl/1.19/Fri Aug 5 09:26:39 2005// +D Added: vendor/portableaserve/aserve/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +A D/doc//// +A D/examples//// +A D/htmlgen//// +A D/test//// +A D/webactions//// Added: vendor/portableaserve/aserve/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve Added: vendor/portableaserve/aserve/CVS/Root =================================================================== --- vendor/portableaserve/aserve/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/ChangeLog =================================================================== --- vendor/portableaserve/aserve/ChangeLog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/ChangeLog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1082 @@ +2005-08-05 Gabor Melis <mega(a)hotpop.com> + + * main.cl (connection-reset-error): detect sigpipe and + "connection reset by peer" on sbcl + + * publish.cl: In http 1.1 keep alive is the default. + Client needs to send "Connection: close". In http 1.0 + non-persistent connection is the default, client + needs to send "Connection: keep-alive". + + * main.cl: fixed atomic-{incf,decf} for sbcl + +2004-01-09 John Foderaro <jkf(a)tiger.franz.com> +1.2.35 + * publish.cl, main.cl, test/t-aserve.cl: add a slot to + all entities holding + the extra headers to add to the response. Add a :headers + argument to all publish functions that allows one + to store a value in the new headers slot. + +2003-12-23 John Foderaro <jkf(a)tiger.franz.com> +1.2.34 + * fix typo in exports wserver-io-timeout + +2003-12-12 Kevin Layer <layer(a)relay.known.net> + + * makefile: set base version to 6.2 + * proxy.cl: fix typo in proxy-failure-response, include requested + uri, too + +2003-10-31 John Foderaro <jkf(a)tiger.franz.com> + + * cgi.cl - transfer data from script back to http client + immediately rather than buffering it up. + +2003-10-27 John Foderaro <jkf(a)tiger.franz.com> +1.2.33 + * webactions/ files - change headers to include lgpl copyright info + +2003-10-22 John Foderaro <jkf(a)tiger.franz.com> +1.2.32 + * add webactions subdirectory of code + +2003-09-22 John Foderaro <jkf(a)tiger.franz.com> +1.2.31 + + * authorize.cl: send back some text with failed response + * publish.cl: fix html sent back to with failed responses + + +2003-09-22 <jkf(a)main.verada.com> + + * decode.cl: fix multiline base64 decoding. + +2003-09-12 <layer@HOBART> +1.2.30 + + * load.cl: fix problem building on acl 7.0 on windows + +2003-09-10 Kevin Layer <layer@crikey> +1.2.29 + + * load.cl, + * examples/examples.cl, + * examples/urian.cl: use *load-pathname* instead of + *load-truename* since truename in ACL 7.0 goes through symbolic + links and this doesn't work in the way aserve is built at franz + (via symlinks to source code) + +2003-09-04 John Foderaro <jkf(a)tiger.franz.com> +1.2.28 + * non-standard http headers are again supported in all + functions, including proxying (where they are just passed on + or passed back as the case may be). + +2003-08-12 John Foderaro <jkf(a)tiger.franz.com> + + * move the require of :uri to before the first + reference to it in packages.cl + +2003-05-09 <jkf(a)main.verada.com> +1.2.27 + * added a hook argument to most publish functions. documented + as 'entity hook function' + * chat.cl - use cookies to get around security problem + * add compute-request-headers (an internal fucntion at the + moment, I may export it in the future) + + +2003-05-08 John Foderaro <jkf(a)tiger.franz.com> + + * doc/aserve.html - clarify that you can have a list of + authorization objects in an entity. + + * main.cl - make the uri-scheme of (request-uri req) correctly + reflect if this is an https or http request. + +2003-02-26 John Foderaro <jkf(a)tiger.franz.com> +1.2.26 + * doc/aserve.html - new get-request-body argument + +2003-02-24 Charles A. Cox <cox@ultra> + New file: examples/locale.cl. + + * load.cl: add locale example. + * main.cl: add external-format argument to + get-request-body for spr27296. + * examples/examples.cl: Minor home page cleanup for ics + examples. + * examples/urian.cl: Add extra smarts for determining a + page's charset. + * test/t-aserve.cl: Add spr27296 test. + +2003-02-06 John Foderaro <jkf(a)tiger.franz.com> + + * main.cl - added (setf request-query-value) + +2003-01-10 John Foderaro <jkf(a)tiger.franz.com> +1.2.25 + * publish.cl (get-cookie-values): handle case of a cookie parameter + not having value, i.e name2; Pretend it was name2=; + +2003-01-07 John Foderaro <jkf(a)tiger.franz.com> + + * client.cl - when sending character data obey external formats + * main.cl - initialize log stream to *initial-terminal-io* since + *standard-output* could be bound to something during the loading + process. + * [htmlgen changes, see it's ChangeLog] + +2002-09-06 John Foderaro <jkf(a)tiger.franz.com> + + * detect connection reset by peer on the AIX operating system + * [change made in htmlgen ChangeLog] + +2002-08-09 John Foderaro <jkf(a)tiger.franz.com> +1.2.24 + * change #\newline to #\linefeed in the source for portability + * fix :comment in htmlgen + * put aserve package definitions and exports in new file: + packages.cl + +2002-04-10 John Foderaro <jkf(a)tiger.franz.com> + + * main.cl - fix bug in get-multipart-sequence when used + in an International Lisp with multibyte character input. + In certain rare cases it could get stuck decoding the last + bits of a buffer. + + - add :ssl-password argument to net.aserve:start to + specify the password for decrypting the private key + in the file with the ssl certificate. [requires + acl feature introduced in acl 6.2]2 + + * client.cl - if the content passed to do-http-request + is a list of vectors, each vector in the list will + be sent to the server. + + +2002-02-28 John Foderaro <jkf(a)tiger.franz.com> +1.2.23 +>>> * incompatible change: + The path part of a uri can't contain certain characters + unless they are escaped like %xx. Even characters that + needn't be escaped *can* be escaped. Thus to canonicalize + the uri path and to allow it to be easily mapped to filenames + we now decode the uri path (convert %xx to the actual character) + before processing it (looking for matches in the published + entities). If you had published a path like "foo%20bar" + then you must change it to "foo bar". + * cgi.cl - add default for :script-name arg + * various - open socket in nodelay mode to maximize performance + + + +2002-02-13 John Foderaro <jkf(a)tiger.franz.com> +1.2.22 + * authorize.cl - add new authorizer: function-authorizer + + * cgi.cl - run-cgi-program takes a :env arguemnt to allow + additional environment variables to be specified. + +2002-01-15 John Foderaro <jkf(a)tiger.franz.com> +1.2.21 + * main.cl - fix bug where the value of + *default-aserve-external-format* was captured at macroexpansion + time rather than run time. All code using with-http-body + should be recompiled. + + * publish.cl - allow mime types to be specified for filenames that + don't have a type component (e.g. ReadMe files). + * publish.cl - set-cookie-header takes an encode-value argument + to control whether it does encoding of its argument. + +2002-01-07 John Foderaro <jkf(a)tiger.franz.com> + + * main.cl - fix problem of restarting aserve in non-ssl mode + after starting it is ssl mode. + +2002-01-06 John Foderaro <jkf(a)tiger.franz.com> + + * add :nofile return code to parse-multipart-header + +2002-01-04 John Foderaro <jkf(a)tiger.franz.com> +1.2.20 + * main.cl - add two higher level functions to aid retrieving + multipart data: parse-multipart-header and get-all-multipart-data. + The examples now show using both the low level and higher + level functions for retrieving multipart form data. + +2001-12-03 John Foderaro <jkf(a)tiger.franz.com> +1.2.19 + * main.cl: add ensure-stream-lock function to put a lock object + on a stream that the logging functions then can use. + +2001-11-30 <jkf@CROW> + + * doc/aserve.html - add documentation on using AllegroServe as + an NT service, and a description of how to write + web pages that handle international characters + * main.cl - add :external-format argument to request-query-value + +2001-11-28 John Foderaro <jkf(a)tiger.franz.com> + + * log.cl - use locking around writes to the log if the + stream has a lock on it's property list. + +2001-11-28 <jkf(a)main.verada.com> + + * add :binary type to publish-multi + * chat.cl - add the ability to upload pictures + +2001-11-26 John Foderaro <jkf(a)tiger.franz.com> +1.2.18 + * decode.cl - handle character set decoding inside uri queries + * publish.cl - access file caching + + +2001-11-15 John Foderaro <jkf(a)tiger.franz.com> +1.2.17 + * added new publish fcn: publish-prefix +>>> * incompatible changes: + redid the way access files are processed, see the + document for the latest spec. + notable changes: + :ignore is now :deny + :block is gone from :subdirectories but I've added + :allow and :deny for fine tuned blocking + :inherit now defaults to nil + you can have multiple forms of the same kind of + information in a single access file and they will + all be used. + +2001-11-06 John Foderaro <jkf(a)tiger.franz.com> + + * fix bug causing infinite loop when reading truncated form body + +2001-11-05 John Foderaro <jkf(a)tiger.franz.com> +1.2.16 + * failed request now identifies AllegroServe as the server + and gives its version number + * if AllegroServe isn't setup to proxy it will not match proxy + requests with local web pages. + +2001-11-05 <jkf(a)main.verada.com> + + * log.cl - write to log files under the protection of a process + lock found on the stream-property-list of the stream associated + with the :lock indicator. If no such lock is found, write + to the streame anyway. + * examples/chat.cl - improve the speed of deleting messages by + binary searching the existing messages. + +2001-10-31 John Foderaro <jkf(a)tiger.franz.com> +1.2.15 + * start now takes a host argument to allow you to bind the server + to a specific host + * publish-multi will not return 304 (not modified) unless the + request is a get or a head + * files published with publish-file will now obey a single + range specifier so they will be download accelerator friendly + +2001-10-26 John Foderaro <jkf(a)tiger.franz.com> + + * add entity-plist slot to entities and use it to link + file entities to their parent directory entities with + the :parent indicator + * add map-entities function + * print vhosts in a why that shows their host names + +2001-10-24 John Foderaro <jkf(a)tiger.franz.com> +1.2.14 + * added access files for publish-directory. These allow + .htaccess-like controlling of what publish-directory publishes. +>>> * incompatible change: added an extra argument to the + publish-directory filter function and publisher functions. + +2001-10-19 John Foderaro <jkf(a)tiger.franz.com> +1.2.13 + * added publish-multi + * while debugging (:notrap) we ignore connection reset by peer errors + by default since they are frequent and not errors in most + cases. You can have them recognized by setting + *debug-connection-reset-by-peer* to t. + + +2001-10-18 John Foderaro <jkf(a)tiger.franz.com> + + * The initial log stream (which is used then to initialize vhost + log streams) is now *initial-terminal-io* and not + *standard-output*. + * random messages (written by logmess) are now sent to the + vhost-error-stream of the default-vhost of the server. + This allows one to separate these random messages from the + the request logs + * logs of proxy activity is now sent to the vhost-error-stream + of the default-vhost of the server. we may rethink this later. + * support vhost specific request filters + +2001-10-17 John Foderaro <jkf(a)tiger.franz.com> + + * cgi.cl: redo cgi so that it doesn't buffer data... also + can now process standard error from scripts + +2001-10-16 John Foderaro <jkf(a)tiger.franz.com> +1.2.12 + +>>> * incompatible change: the format argument to with-http-body + has been moved to with-http-response. + The format argument to with-http-body was ignored, but on + with-http-response it will be obeyed and will override + the format specified in the entity. + + The internal generic function compute-strategy now takes + three arguments. This function isn't part of the + external interface to AllegroServe but some users have + specialized it. + +2001-10-15 John Foderaro <jkf(a)tiger.franz.com> + + * add timeout value to each entity object to serve as a default + that's checked before the wserver-response-timeout. + * add a timeout argument to publish functions to set this + entity timeout value. + * add a publisher argument to publish-directory so users can + control what kind of entity is created when the real file is + eventually found. + +2001-10-12 John Foderaro <jkf(a)tiger.franz.com> + + * using socket stream i/o timeouts in acl6.1 + * moved the *http-response-timeout* to a slot in the wserver + object so it can be server dependent. + * documented timeouts in aserve.html + * added timeout test to t-aserve.cl but disabled running them + by default since they take a long time. + +2001-10-10 John Foderaro <jkf(a)tiger.franz.com> +1.2.11 + * upgraded support for virtual hosts, introducting + an object to denote a virtual host so that each + virtual host can do its own logging. + See aserve.html for details on Virtual Hosts. + +2001-10-08 John Foderaro <jkf(a)tiger.franz.com> + + * publish.cl - publish-directory must pass on host info + to the publish-files that it does. + - unpublish takes a :server argument + +2001-09-29 John Foderaro <jkf(a)tiger.franz.com> + + * cgi.cl - fix bug where content-length was specified wrong + +2001-09-21 John Foderaro <jkf(a)tiger.franz.com> +1.2.10 + * added ability to run cgi programs + new file cgi.cl + +2001-09-20 John Foderaro <jkf(a)tiger.franz.com> + + * examples/examples.cl - add commentary to some of the links + to make them clearer + +2001-09-20 Kevin Layer <layer@crikey> + + * makefile: split `clean' into `clean' and `cleanall', the latter + which removes aserve-src. + * makefile (clean): add `r' to `rm' + +2001-09-18 Kevin Layer <layer@crikey> +1.2.9 + + * makefile: add build and srcdist rules; have make clean remove + aserve-src + * load.cl: parameterize make-src-distributions's directory name + +2001-09-12 John Foderaro <jkf(a)tiger.franz.com> +1.2.8 + * client.cl: add :skip-body to do-http-request. add test for this. + * decode.cl: fix form-urlencoded-to-query so that it can + handle a non simple string (which can be returned under + certain circumstances from get-request-body) + +2001-08-28 John Foderaro <jkf(a)tiger.franz.com> +1.2.7 + * take the default value for the external-format + argument from *default-aserve-external-format*. + net.aserve:start sets the value of *default-aserve-external-foramt* + in worker threads. + + * parse.cl (split-string): don't get confused by commas inside + a double quoted header parameter value. + +2001-08-24 John Foderaro <jkf(a)tiger.franz.com> + + * when an error occurs in the worker thread print the command line + for the request that got the error. + +2001-08-16 John Foderaro <jkf(a)tiger.franz.com> +1.2.6 + * main.cl - try harder to prevent debug output from multiple + threads from getting jumbled up on the console + * publish.cl - do a keep-alive connection if the data is a binary + stream as long as we know the content length. + Add a new internal entity type so that returns of + "304 - Not Modified" can do keep alives too. + +2001-08-15 John Foderaro <jkf(a)tiger.franz.com> +1.2.5 + * main.cl - incf version number for new release + +2001-08-09 John Foderaro <jkf(a)tiger.franz.com> + + * publish.cl - added :filter functionality to publish-directory + * test/t-aserve.cl - test filters in publish-directory + +2001-08-08 John Foderaro <jkf(a)tiger.franz.com> + + * publish.cl - allow list of index files to be specified in + for each directory-entity. + - specify a catch-all compute-response-stream method so + users adding new entity type don't have to do so. + +2001-08-08 jkf <jkf(a)main.verada.com> + + * publish.cl - fix for when no body is given with-http-body + and thus a string-output-stream is not created. + +2001-07-30 <jkf@DEEDEE> +1.2.4 + * main.cl: fix get-multipart-* to correspond to rfc2046 + and thus it will work with the Opera browser which + generates legal (but unusual) kinds of boundary markers + +2001-07-19 John Foderaro <jkf(a)tiger.franz.com> +1.2.3 + * publish.cl + - If publish-file file is changed then invalidate + the cached information on it. + - remove extraneous slots in classes. + + * test/t-aserve.cl + test cache invaldation in publish-file + +2001-07-18 <jkf@CROW> + + * doc/publish.html - update publish-file doc for preload and + cache-p args + * doc/htmlgen.html - make first example clearer + * doc/tutorial.html - add note to help Windows users + +2001-07-18 jkf <jkf(a)main.verada.com> + + * publish.cl - add cache-p argument to publish-file which will + cache the file contents on first use + * chat.cl - add support for removing selective private messages + after a certain amount of time. + * test/t-aserve.cl - test cache-p argument to publish-file + +2001-07-09 John Foderaro <jkf(a)tiger.franz.com> + + * example/chat.cl - add chat transcript feature + + +2001-06-27 jkf <jkf(a)main.verada.com> +1.2.2 + * added the ability to filter requests before they get + processed. see Request-Filters in aserve.html + +2001-06-26 John Foderaro <jkf(a)tiger.franz.com> +1.2.1 + * main.cl - don't get blocked on a force-output that will + never return due to the other side of the connection + going away. + * examples/chat.cl - support private chats amoung groups of + people. Support deleting messages. Support levels + of users. Support redirecting + people at certain IP addresses away from the chat if + they cause problems. + +2001-06-05 John Foderaro <jkf(a)tiger.franz.com> +1.2.0 + * main.cl - update version to 1.2.0 to mark acl 6.1 release. + +2001-04-04 John Foderaro <jkf(a)tiger.franz.com> + + * changed how publish-directory deals with urls that + point to directories and not files. It used to + pretend that you specified an index.html or index.htm + file in that directory. This was bad since relative urls + in the index file would not be processed correctly. with + the change it now redirects to the index.html or index.htm + file so that the browser knows what it's getting. + +2001-03-22 John Foderaro <jkf(a)tiger.franz.com> +1.1.41 + * add os-processes argument to net.aserve:start + which causes aserve to fork (on unix only) and create + multiple operating system processes listening on the + same port. + + +2001-02-08 John Foderaro <jkf(a)tiger.franz.com> +1.1.40 + * added the proxy-proxy argument to net.aserve:start that + permits you to specify that the allegroserve proxy should + sent its requests through another proxy. + +2001-02-06 John Foderaro <jkf(a)tiger.franz.com> +1.1.39 + * proxy and scanning fixes + +2001-01-22 John Foderaro <jkf(a)tiger.franz.com> +1.1.38 + * main.cl: incf version. Also hooks added for links scanning. + +2001-01-18 John Foderaro <jkf(a)tiger.franz.com> + + * examples/urian.cl - new international character set demo + (reachable from the main aserve examples page) + +2001-01-02 jkf <jkf(a)main.verada.com> +1.1.37 + * main.cl, proxy.cl - add the ability to save and restore + the whole state of the proxy cache. (see docs for start + and shutdown in the manual). + + * ensure that proxy cache threads are killed off when a shutdown + is done. + +>>> incompatible change: the net.aserve:shutdown function used to + take an optional argument. Now it takes keyword arguments. + +2000-12-27 John Foderaro <jkf(a)tiger.franz.com> +1.1.36 + * client.cl: handle illegal set-cookie headers sent by Netscape's + v3 web server. In a client request Split the single large + Cookie line into muliple Cookie lines so that Netscape's v3 + web server can understand them. + Add a redirect-methods argument to do-http-request to support + more user control of redirection. + * proxy.cl - many enhancements including connection caching + +2000-11-06 Kevin Layer <layer@ultra> +1.1.35 + * log.cl: make logmess a method, so I can define an after method + on it in my own code + * main.cl: maybe-universal-time-to-date and + universal-time-to-date: take time-zone optional argument, so my + redefined version of log-request can specify the local time zone + +2000-10-31 John Foderaro <jkf(a)tiger.franz.com> +1.1.34 + * add to the list of characters to escape in form-urlencoding + those that must be escaped so that the result can be put + in the query string of a uri + + * in proxy code write request and headers in one big block + to get around bug in IP redirectors (such as found in www.cbs.com) + +2000-10-25 jkf <jkf(a)main.verada.com> +1.1.33 + * hooks for link checking and experimenting with caching + +2000-10-19 John Foderaro <jkf(a)tiger.franz.com> +1.1.32 + * add ssl arguments to net.aserve.start and + net.aserve.client:do-http-request so that a secure server + can be started and secure http requests can be made. + Make the aserve test suite test run though the tests using ssl. + Note: the ssl module is only present in certain acl6 distributoins. + + * add examples/puzzle.cl - a demo featuring the use of international + characters in acl6. + +2000-10-15 John Foderaro <jkf(a)tiger.franz.com> +1.1.31 + * support caching requests with cookies + +2000-10-12 John Foderaro <jkf(a)tiger.franz.com> +1.1.30 + * proxy and cache facilty added. + +2000-09-22 Charles A. Cox <cox@pie> + + * decode.cl: Add :external-format to to uriencode-string. + * publish.cl: Add :external-format to set-cookie-header. + * test/t-aserve.cl: Add :external-format tests for + uri{en,de}code-string. + +2000-09-07 Charles A. Cox <cox@delta> +1.1.29 + +>>> Note: Many of the functions listed in this log entry have had + the :external-format argument added. Documentation has been + updated + + Note 2: All changes intended to be upward compatible. Allegro + specific changes are marked with #+(and allegro (version>= 6 0)). + + * client.cl: make-http-client-request: add/use external-format + argument. + * decode.cl: uridecode-string, query-to-form-urlencoded, + encode-form-urlencode, form-urlencoded-to-query: add/use + external-format argument. + * main.cl: with-http-body, request-query: add/use external-format + argument. + * publish.cl: get-cookie-values: add/use external-format + argument. + * examples/examples.cl: Add new international character examples. + * test/t-aserve.cl: Add tests for external-format additions. + + +2000-08-28 John Foderaro <jkf(a)tiger.franz.com> +1.1.28 + * client.cl - before doing a redirect close down the existing + connection. + +2000-08-25 John Foderaro <jkf(a)tiger.franz.com> + + * fix bug which caused file descriptors to remain open + forever if a "connection reset by peer" error occured. + Added the ability to track sockets opened by aserve to + ensure that they were closed before being gc'ed away. + +2000-08-24 John Foderaro <jkf(a)tiger.franz.com> +1.1.27 + * rewrote the get-multipart-xxx functions to use an + (unsigned-byte 8) buffer since character buffers have + issues with international code. This eliminates the + extra <cr><lf> at the end problem with get-multipart-sequence. + The file transfer should be faster, especially if you + pass get-multipart-sequence a 4096 byte (unsigned-byte 8) vector. + + !! Eliminte the raw argument from get-multipart-sequence. Now + transfers are all 'raw' + If a character array is passed to get-multipart-sequence then + we just copy into each character the code-char of the + item in the buffer (which corresponds to the latin1-base + external format). We will allow external-format select + soon. + + +2000-08-21 John Foderaro <jkf(a)tiger.franz.com> + + * add :proxy arg to net.aserve:start so you can enable the proxy + when you start the server. + * fix test suite to report only legit errors + +2000-08-20 jkf <jkf(a)main.verada.com> +1.1.26 + * Added a proxy capability. enable-proxy will turn it on. + Currently it acts an http/1.0 client and server since that + makes it easier to debug. However this does cause 12 test + set errors to be reported since it expects to see http/1.1 + responses. + +2000-08-17 jkf <jkf(a)main.verada.com> + + * implement generalized cons-free header parsing and use it + in both the client and server. + + * change the header info returned by do-http-request to + also use keywords to describe headers + !! non upward compatiable change !! + +2000-08-15 John Foderaro <jkf(a)tiger.franz.com> + + * fix bug where certain headers were sent twice + +2000-08-12 John Foderaro <jkf(a)tiger.franz.com> + + * name headers by keyword symbols rather than strings + !! this change is not upward compatible !! + + +2000-08-10 John Foderaro <jkf(a)tiger.franz.com> +1.1.25 + * decode.cl: request-query will now convert items in query + strings without values into ("keyname" . "") in the resulting + alist. + * doc/aserve.html - update doc of request-query and + request-query-value to reflect what happens with null valued + query elements + +2000-08-09 jkf <jkf(a)main.verada.com> + + * publish.cl: write the transfer encoding as all lowercase 'chunked' + since a bug in Mozilla M17 means it will only understand this form. + * htmlgen/htmlgen.cl - add the <caption> tag + +2000-08-04 jkf <jkf(a)main.verada.com> +1.1.24 + * examples/chat.cl - add user logins and private messages + between users. + +2000-07-31 jkf <jkf(a)main.verada.com> + + * main.cl: if a multipart-mixed body was being sent then + note that the request-body has been grabbed. + +2000-07-25 jkf <jkf(a)main.verada.com> + + * example/chat.cl - enhanced to support logging into the chat + +2000-07-17 John Foderaro <jkf(a)tiger.franz.com> +1.1.22 + + * main.cl: incf version + +2000-07-15 John Foderaro <jkf(a)tiger.franz.com> + + * examples/chat.cl - sample program that does web based chat + +2000-07-14 John Foderaro <jkf(a)tiger.franz.com> + + * client.cl - now do-http-request will always return a uri object + (previously it would return its uri arg unless a redirect + was done in which case it would return a uri object) + +2000-07-01 John Foderaro <jkf(a)tiger.franz.com> + + * client.cl - handle the "100 continue" response we seem to + get from IIS whenever we do a post. + +2000-06-25 jkf <jkf(a)main.verada.com> + + * keep track all of all ip addresses by which the server + is contacted (this is simpler than trying to figure them + out in advance). + * add function to find a response object given the code. + * keep track of the raw uri by which a request was made + (as distinguished from the uri in which we've added the + host and port values). This is necessary to distriguish + when we must proxy. + * in html-print assume that attribute values are already html escaped + +2000-06-12 John Foderaro <jkf(a)tiger.franz.com> + + * main.cl: add utility function request-query-value to + combine getting the query info via request query + and locating the particular value with assoc + +2000-06-08 John Foderaro <jkf(a)tiger.franz.com> +1.1.21 + * client.cl - do-http-request: + 1. give the redirect arg a numeric + value to prevent infinite redirect loops. + 2. handle two other redirect codes + 3. autoredirect only for get and head + 4. return the uri accessed as the fourth value + * main.cl - add more response codes + - handle calls to request-query specifying different + uri and post values. + * examples.cl - add redirect test + * t-aserve.cl - test redirection + * doc/aserve.html - update for changes above + * doc/tutorial.html - don't be so cookie centric + +2000-05-30 John Foderaro <jkf(a)tiger.franz.com> +1.1.20 + * macs.cl - add note about where to find the if* macro + * main.cl - cache result of get-request-body so that it can + safely be called more than once inside a response + function. Also be sure to call get-request-body + if the connection is keep-alive and there might + be a body following the headers. + * t-aserve.cl - test enhancment to get-request-body + * doc/aserve.html - fix do-http-request documentation to + reflect change made in 1.1.18 + + + +Fri May 26 22:42:12 PST 2000 Duane Rettig <duane@beta> +1.1.19 + * makefile: set SHELL variable + * main.cl: incf version + +2000-05-16 John Foderaro <jkf(a)tiger.franz.com> +1.1.18 + * ! Non upward-compatiable change ! - the function + do-http-request returns arguments in a different + order, it now returns the body value first, then the + response code and then the headers. + * fixed bug in publish-directory (sourceforge bug 105426) + * added query and content-type arguments to do-http-request + and make-http-client-request. These make it even easier + to send form data to web servers + + +2000-05-16 John Foderaro <jkf(a)tiger.franz.com> +1.1.17 + + + * in order to make portions of the LGPL license meaningful + for a Lisp program we've added a prequel to the license + agreement in the file license-allegroserve.txt. + +2000-05-16 jkf <jkf(a)main.verada.com> + + * client.cl + - increase header reading buffer size - but we should + make this growable. + - handle cookies with = signs embedded + * decode.cl + - in query-to-form-urlencoded all the values to + be non-strings and in that case use ~a format to stringify them + * parse.cl + - add arg to utility function + +2000-05-04 John Foderaro <jkf(a)tiger.franz.com> +1.1.16 + * request-query can now read from uri and/or post'ed body + see doc/aserve.html for details + +2000-04-26 John Foderaro <jkf(a)tiger.franz.com> +1.1.15 + * ! Non upward-compatible change ! -- the function + decode-form-urlencoded has been renamed + form-urlencoded-to-query so as to match its new inverse + function: query-to-form-urlencoded + + * added query-to-form-urlencoded to allow one to encode + query to strings for use by client code. + +2000-04-24 John Foderaro <jkf(a)tiger.franz.com> +1.1.14 + * verify that it works in acl501 trial (Linux) + +2000-04-24 <jkf@CROW> + + * load.cl: make aServe load in acl5.0.1 Lite (Windows) but + be advised that it doesn't work very well due to socket + problems that can be patched in the Lite version. + + * main.cl: the default timeout for a with-http-response + now comes from *http-response-timeout* and it + now defaults to 120 seconds rather than 60. + + * some documention updates + +2000-04-23 jkf <jkf(a)main.verada.com> + + * client.cl - added proxy argument so that client requests + can go through a proxy + * various doc fixes + +2000-04-17 John Foderaro <jkf(a)tiger.franz.com> +1.1.13 + * rename Allegro iServe to AllegroServe. + As a result where iserve was used before we now use aserve. + For example the package is now called net.aserve. + + +2000-04-17 John Foderaro <jkf(a)tiger.franz.com> +1.1.12 + + * add test/t-iserve.cl to the list of files in the ftp distribution + +2000-04-16 <jkf@DEEDEE> + + * debug-on and debug-off are no longer exported symbols. + They continue to exist but you have to use + net.iserve::debug-on and net.iserve::debug-off to reach them. + + * added two new response type symbols to aid in doing redirections: + *response-moved-permanently* + *response-temporary-redirect* + note that netscape 4 doesn't understand *response-temporary-redirect* + as that's a http/1.1 thing. + + * request-query takes a :handle-post keyword arguments. When true + (and that's the default) it will automatically read, + extract, parse and cache the query string from the entity body + when the request is a post request. + +2000-03-28 John Foderaro <jkf(a)tiger.franz.com> + + * move htmlgen.html from htmlgen/ to doc/ so that it's in + a consistent place regardless of distribution type. + +2000-04-08 <jkf@DEEDEE> +1.1.11 + * make the debugging output feature based rather than + numeric. see net.iserve:debug-on + * properly do client queries + * use setfable reply-header-slot-value to read and set + headers for the reply that will be sent + * always send back HTTP/1.1 as our protocol + + +2000-03-27 John Foderaro <jkf(a)tiger.franz.com> +1.1.10 + * add headers argument to do-http-request and make-http-client-request + to allow you to add headers + * fix client requests for :head so it doesn't wait for a body + to be returned + * fix debugging output when running inside emacs + * add client info to documentation. + +2000-03-27 John Foderaro <jkf(a)tiger.franz.com> +1.1.9 + + * mainly documentation fixes + +2000-03-22 John Foderaro <jkf(a)tiger.franz.com> +1.1.8 + * fix http/0.9 processing + + * make errors in http worker threads, if uncaught (see below) + and if the emacs-lisp interface is running, cause a new + emacs window to appear in which you can debug the problem + + * add net.iserve::*trap-errors* (default t). If set to + nil then errors in http processing by iserve will result + in error break loops. + + * fixed errors in publish-directory. Also prevent user from + passing ../ in urls to access above the published directory + +2000-03-22 John Foderaro <jkf(a)tiger.franz.com> +1.1.7 + * make initial lisp listerner of standalone version sleep + so that the process can be put in the background. + * add t-iserve.cl and begin to add automated tests + * add cookies and authorization to client module + * load client module into iserve + +2000-03-20 John Foderaro <jkf(a)tiger.franz.com> +1.1.6 + * convert references to neo to iserve + * minor fixups in tutorial + +2000-03-20 John Foderaro <jkf(a)tiger.franz.com> +1.1.5 + * include iservelogo.gif in the ftp distribution + * fix problem where the response to a file entity request + for a file that doesn't exist would cause browser to hang + until the socket was closed + +2000-03-17 John Foderaro <jkf(a)tiger.franz.com> +1.1.4 + * change source-readme.txt and load.cl so that + it will build on Windows without the unix tools + +******************************************************************************* +join from acl50 branch +- cvs command: cvs update -d -j acl50 +- next merge tag: acl50_merge2 +******************************************************************************* + +2000-03-15 John Foderaro <jkf(a)tiger.franz.com> +1.1.3 + * switch to lgpl license. + * add source-readme.txt to describe what to do with + the source + +2000-03-14 John Foderaro <jkf(a)tiger.franz.com> +1.1.2 + * add authorizer objects to support checking for valid + access to pages + +2000-03-07 John Foderaro <jkf(a)tiger.franz.com> +1.1.1 + * load.cl - lisp need not be in the directory containing this + file in order to load it (and iserve) + * main.cl - get-request-body will not get fooled by :get requests + * publish.cl - make virtual hosts work for prefix handlers + * doc/iserve.html - update to describe :remove arg to pubilsh + functions + * doc/tutorial.html - lots more added + * examples/tutorial.cl - add sample methods + +2000-03-02 jkf <jkf(a)main.verada.com> + + * added setuid, setgid args to start + * changed the names of the worker processes + * changed the names of the slots and accessors holding the + commonly used request header info + * allowed the :host arg to publish to be a list of host names + * for publish-file compute the content-type automatically if + not provided + +2000-02-25 John Foderaro <jkf(a)tiger.franz.com> + + * added code to the examples so that the pubished url + handlers will find the files they reference (if any) + no matter what the current directory is when the examples + file is loaded. + +2000-02-18 John Foderaro <jkf(a)tiger.franz.com> + + * moved examples and doc to their own directories + +2000-02-08 John Foderaro <jkf(a)tiger.franz.com> +1.1.0 + renamed neo to Allegro iServe + changed neo package to net.iserve + changed htmlgen package to net.html.generator + +2000-02-08 John Foderaro <jkf(a)tiger.franz.com> +1.0.9 + + * main.cl - added exports + * examples.cl - show how to publish a generated jpg file + * neo.html - more documentation + +2000-01-28 John Foderaro <jkf(a)tiger.franz.com> +1.0.8 + * renamed accessors + +2000-01-25 John Foderaro <jkf(a)tiger.franz.com> + + * partially added logging + +2000-01-25 jkf <jkf(a)main.verada.com> + + * use uri package + +2000-01-18 John Foderaro <jkf(a)tiger.franz.com> +1.0.7 + * changed :url to :path in the publish functions + * added a locator class to expose the search for a matching + entity + +2000-01-11 John Foderaro <jkf(a)tiger.franz.com> + + * document accessors. + get timedout-response working + +1999-12-15 John Foderaro <jkf(a)tiger.franz.com> +1.0.6 + * cookie support added and documented + +1999-12-14 jkf <jkf(a)main.verada.com> + + * added new file decode.cl to hold all decode/encode functions + +1999-12-11 John Foderaro <jkf(a)tiger.franz.com> +1.0.5 + * add shutdown command + +1999-12-02 John Foderaro <jkf(a)tiger.franz.com> +1.0.4 + * do case insensitive comparison of mime separation strings. + It may not be necessary but it seemed to be for IE. + +1999-11-02 John Foderaro <jkf(a)tiger.franz.com> +1.0.3 + * fixed chunking output calls so it works again + +1999-10-15 jkf <jkf(a)main.verada.com> +1.0.2 + + * added multipart info grabbing and updated the documentatoin + +1999-10-13 John Foderaro <jkf(a)tiger.franz.com> +1.0.1 + * start changelog + + Added: vendor/portableaserve/aserve/aserve-cmu.system =================================================================== --- vendor/portableaserve/aserve/aserve-cmu.system 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/aserve-cmu.system 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,65 @@ +;;; -*- mode: lisp -*- + +(in-package :cl-user) + +;; Stig: if clc is present, we're a debian-package +;; Rudi: Not if kludge-no-cclan is also present (see README.cmucl) +#+(and common-lisp-controller (not kludge-no-cclan)) +(setf (logical-pathname-translations "aserve") + '(("examples;**;*.*.*" "/usr/share/doc/cl-aserve/examples/") + ("**;*.*.*" "cl-library:;aserve;**;*.*.*") + )) + +(mk:defsystem "ASERVE" + :source-pathname + #-common-lisp-controller + (translate-logical-pathname "aserve:") + ;; Stig: somehow things screw up if we translate here + #+common-lisp-controller + "aserve:" + :source-extension "cl" + :components (;;#-common-lisp-controller + (:module "htmlgen" + :components ((:file "htmlgen"))) + ;;;; Stig: we might use above.. will check again later + ;;#+common-lisp-controller + ;;(:file "htmlgen") + + (:file "macs") + (:file "main" + :depends-on ("macs")) + (:file "headers" + :depends-on ("main")) + (:file "parse" + :depends-on ("main")) + (:file "decode" + :depends-on ("main")) + (:file "publish" + :depends-on ("main" "htmlgen")) + (:file "authorize" + :depends-on ("main" "publish")) + (:file "log" + :depends-on ("main")) + (:file "client" + :depends-on ("main")) + (:file "proxy" + :depends-on ("main"))) + + ;; Stig: if we're a debian-package we should automagically load acl-compat + #+(and common-lisp-controller) + :depends-on + #+(and common-lisp-controller) (acl-compat) + :finally-do + (progn + (pushnew :aserve *features*))) + +#+cmu +(defun init-aserve-cmu () + ;; this isn't strictly necessary, but scheduling feels very coarse + ;; without startup-idle-and-top-level-loops, leading to answer delays + ;; of about 1s per request. + (unless (find-if + #'(lambda (proc) (string= (mp:process-name proc) "Top Level Loop")) + (mp:all-processes)) + (mp::startup-idle-and-top-level-loops))) + Added: vendor/portableaserve/aserve/aserve-corman.lisp =================================================================== --- vendor/portableaserve/aserve/aserve-corman.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/aserve-corman.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,61 @@ +;;;; AllegroServe loader for Corman Lisp - Version 1.0 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris(a)double.co.nz +;;;; +;;;; 03/03/2000 - 1.0 +;;;; Initial release. +;;;; Change the *as-source-directory* constant to +;;;; point to the installation directory of +;;;; the AllegroServe install files. +;;;; +;;;; +(in-package :cl-user) + +(defconstant *as-source-directory* "d:/projects/lisp/portableaserve/") +(load (concatenate 'string *as-source-directory* "acl-compat/acl-compat-corman.lisp")) + +(defconstant *as-files* + (list + "aserve/htmlgen/htmlgen.cl" + "aserve/packages.cl" + "aserve/macs.cl" + "aserve/main.cl" + "aserve/headers.cl" + "aserve/parse.cl" + "aserve/decode.cl" + "aserve/publish.cl" + "aserve/authorize.cl" + "aserve/log.cl" + "aserve/client.cl" + "aserve/proxy.cl")) + +(loop for file in *as-files* do (load (concatenate 'string *as-source-directory* file))) + +(provide 'allegroserve) \ No newline at end of file Added: vendor/portableaserve/aserve/aserve-mcl.system =================================================================== --- vendor/portableaserve/aserve/aserve-mcl.system 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/aserve-mcl.system 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,46 @@ +;;; -*- mode: lisp -*- + +(in-package "CL-USER") + + +;There is a bug in OpenMCL where we can't create directories. +;So we only put the :binary-pathname if the bin/OpenMCL directory is there. + +(let* ((dir (make-pathname :directory (append (pathname-directory *load-truename*) + (list "bin" (lisp-implementation-type))))) + (bin-path (list :binary-pathname dir)) + (bin-extension nil)) + + #+openmcl (unless (probe-file dir) (setf bin-path nil)) + #+openmcl (setf bin-extension (list :binary-extension "dfsl")) + + (eval + + `(mk:defsystem "ASERVE" + :source-pathname (translate-logical-pathname "aserve:") + :source-extension "cl" + ,@bin-path + ,@bin-extension + :components ((:module "htmlgen" + :components ((:file "htmlgen"))) + (:file "macs") + (:file "main" + :depends-on ("macs")) + (:file "headers" + :depends-on ("main")) + (:file "parse" + :depends-on ("main")) + (:file "decode" + :depends-on ("main")) + (:file "publish" + :depends-on ("htmlgen")) + (:file "authorize" + :depends-on ("main")) + (:file "log" + :depends-on ("main")) + (:file "client" + :depends-on ("main")) + (:file "proxy" + :depends-on ("main")))) + + )) \ No newline at end of file Added: vendor/portableaserve/aserve/aserve.asd =================================================================== --- vendor/portableaserve/aserve/aserve.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/aserve.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,135 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; This as an ASDF system for ASERVE meant to replace +;;;; aserve-cmu.system, but could replace all other systems, too. +;;;; (hint, hint) + +(defpackage #:aserve-system + (:use #:cl #:asdf)) +(in-package #:aserve-system) + +(defclass acl-file (cl-source-file) ()) +(defmethod asdf:source-file-type ((c acl-file) (s module)) "cl") + +;;;; ignore warnings +;;;; +;;;; FIXME: should better fix warnings instead of ignoring them +;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code + +(defclass legacy-acl-source-file (acl-file) + () + (:documentation + "Common Lisp source code module with (non-style) warnings. +In contrast to CL-SOURCE-FILE, this class does not think that such warnings +indicate failure.")) + +(defmethod perform ((operation compile-op) (c legacy-acl-source-file)) + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c))) + (warnings-p nil) + (failure-p nil)) + (setf (asdf::component-property c 'last-compiled) nil) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (setq warnings-p t))) + ;; _not_ (or error (and warning (not style-warning))) + (error (lambda (c) + (declare (ignore c)) + (setq failure-p t)))) + (compile-file source-file + :output-file output-file)) + ;; rest of this method is as for CL-SOURCE-FILE + (setf (asdf::component-property c 'last-compiled) (file-write-date output-file)) + (when warnings-p + (case (asdf::operation-on-warnings operation) + (:warn (warn "COMPILE-FILE warned while performing ~A on ~A" + c operation)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (asdf::operation-on-failure operation) + (:warn (warn "COMPILE-FILE failed while performing ~A on ~A" + c operation)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))))) + +#+(or lispworks cmu sbcl mcl openmcl clisp) +(defsystem aserve + :name "AllegroServe (portable)" + :author "John K. Foderaro" + :version "1.2.35" + :licence "LLGPL" + :default-component-class acl-file + :components ((:file "packages") + (:file "macs" :depends-on ("packages")) + (:legacy-acl-source-file "main" :depends-on ("macs")) + (:file "headers" :depends-on ("main")) + (:legacy-acl-source-file "parse" :depends-on ("main")) + (:file "decode" :depends-on ("main")) + (:file "publish" :depends-on ("main")) + (:file "authorize" :depends-on ("main" "publish")) + (:file "log" :depends-on ("main")) + (:file "client" :depends-on ("main")) + (:file "proxy" :depends-on ("main" "headers"))) + :depends-on (htmlgen acl-compat) + :perform (load-op :after (op aserve) + (pushnew :aserve cl:*features*))) + +#+allegro +(defclass original-aserve (asdf:component) + ((loaded :initform nil :accessor loaded))) + +#+allegro +(defmethod asdf:perform ((op asdf:load-op) (c original-aserve)) + #+common-lisp-controller (c-l-c:original-require 'aserve) + #-common-lisp-controller (require 'aserve) + (setf (loaded c) t)) + +#+allegro +(defmethod asdf:operation-done-p ((op asdf:load-op) (c original-aserve)) + (loaded c)) + +#+allegro +(defmethod asdf:operation-done-p ((op asdf:compile-op) (c original-aserve)) + t) + +#+allegro +(defsystem aserve + :components ((:original-aserve "dummy"))) + +;;; Logical pathname is needed by AllegroServe examples +#+(or lispworks cmu mcl openmcl clisp sbcl) +(setf (logical-pathname-translations "ASERVE") + `( + #+ignore ; Don't need this with asdf + ("**;*.lisp.*" ;,(logical-pathname "**;*.cl.*") + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative "aserve" + :wild-inferiors) + :name :wild + :type "cl" + :version :wild) + *load-truename* + )) + ("**;*.*.*" + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative :wild-inferiors) + :name :wild + :type :wild + :version :wild + ;:case :common + ) + *load-truename*)))) +#+cmu +(defun cl-user::init-aserve-cmu () + ;; this isn't strictly necessary, but scheduling feels very coarse + ;; without startup-idle-and-top-level-loops, leading to answer delays + ;; of about 1s per request. + (unless (find-if + #'(lambda (proc) (string= (mp:process-name proc) "Top Level Loop")) + (mp:all-processes)) + (mp::startup-idle-and-top-level-loops))) + + Added: vendor/portableaserve/aserve/authorize.cl =================================================================== --- vendor/portableaserve/aserve/authorize.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/authorize.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,222 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; authorize.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; $Id: authorize.cl,v 1.8 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; classes and functions for authorizing access to entities + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +(in-package :net.aserve) + +(defclass authorizer () + ;; denotes information on authorizing access to an entity + ;; this is meant to be subclassed with the appropriate slots + ;; for the type of authorization to be done + ()) + + + +;; - password authorization. +;; +(defclass password-authorizer (authorizer) + ((allowed :accessor password-authorizer-allowed + ;; list of conses (name . password) + ;; which are valid name, password pairs for this entity + :initarg :allowed + :initform nil) + (realm :accessor password-authorizer-realm + :initarg :realm + :initform "AllegroServe") + )) + + + +(defmethod authorize ((auth password-authorizer) + (req http-request) + (ent entity)) + ;; check if this is valid request, return t if ok + ;; and :done if we've sent a request for a new name and password + ;; + (multiple-value-bind (name password) (get-basic-authorization req) + + (if* name + then (dolist (pair (password-authorizer-allowed auth)) + (if* (and (equal (car pair) name) + (equal (cdr pair) password)) + then (return-from authorize t)))) + + ;; valid name/password not given, ask for it + (with-http-response (req *dummy-computed-entity* + :response *response-unauthorized* + :format :text) + (set-basic-authorization req + (password-authorizer-realm auth)) + + ; this is done to preventing a chunking response which + ; confuse the proxy (for now).. + (if* (member ':use-socket-stream (request-reply-strategy req)) + then (setf (request-reply-strategy req) + '(:string-output-stream + :post-headers))) + + (with-http-body (req *dummy-computed-entity*) + (html (:html (:body (:h1 "Access is not authorized")))) + )) + :done)) + + + + + +;; location authorization +;; we allow access based on where the request is made from. +;; the pattern list is a list of items to match against the +;; ip address of the request. When the first match is made the +;; request is either accepted or denied. +;; +;; the possible items in the list of patterns +;; :accept accept immediately +;; :deny deny immediately +;; (:accept ipaddress [bits]) accept if left 'bits' of the +;; ipaddress match +;; (:deny ipaddress [bits]) deny if the left 'bits' of the +;; ipaddress match +;; +;; bits defaults to 32 +;; the ipaddress can be an +;; integer - the 32 bit ip address +;; string +;; "127.0.0.1" - the dotted notation for an ip address +;; "foo.bar.com" - the name of a machine +;; when the ipaddress is a string it is converted to an integer +;; the first time it is examined. +;; When the string is a machine name then the conversion may or +;; may not work due to the need to access a nameserver to do +;; the lookup. +;; +;; +;; + + +(defclass location-authorizer (authorizer) + ((patterns :accessor location-authorizer-patterns + ;; list of patterns to match + :initarg :patterns + :initform nil))) + + + + +(defmethod authorize ((auth location-authorizer) + (req http-request) + (ent entity)) + (let ((request-ipaddress (acl-compat.socket:remote-host (request-socket req)))) + (dolist (pattern (location-authorizer-patterns auth)) + (if* (atom pattern) + then (case pattern + (:accept (return-from authorize t)) + (:deny (return-from authorize nil)) + (t (warn "bogus authorization pattern: ~s" pattern) + (return-from authorize nil))) + else (let ((decision (car pattern)) + (ipaddress (cadr pattern)) + (bits (if* (cddr pattern) + then (caddr pattern) + else 32))) + (if* (not (member decision '(:accept :deny))) + then (warn "bogus authorization pattern: ~s" pattern) + (return-from authorize nil)) + + (if* (stringp ipaddress) + then ; check for dotted ip address first + (let ((newaddr (acl-compat.socket:dotted-to-ipaddr ipaddress + :errorp nil))) + (if* (null newaddr) + then ; success! + (ignore-errors + (setq newaddr (acl-compat.socket:lookup-hostname ipaddress)))) + + (if* newaddr + then (setf (cadr pattern) + (setq ipaddress newaddr)) + else ; can't compute the address + ; so we'll not accept and we will deny + ; just to be safe + (warn "can't resolve host name ~s" ipaddress) + (return-from authorize nil)))) + + + (if* (not (and (integerp bits) (<= 1 bits 32))) + then (warn "bogus authorization pattern: ~s" pattern) + (return-from authorize nil)) + + ; now we're finally ready to test things + (let ((mask (if* (eql bits 32) + then -1 + else (ash -1 (- 32 bits))))) + (if* (eql (logand request-ipaddress mask) + (logand ipaddress mask)) + then ; matched, + (case decision + (:accept (return-from authorize t)) + (:deny (return-from authorize nil)))))))) + + t ; the default is to accept + )) + + +;; - function authorization + +(defclass function-authorizer (authorizer) + ((function :accessor function-authorizer-function + :initarg :function + :initform nil))) + +(defmethod authorize ((auth function-authorizer) + (req http-request) + (ent entity)) + (let ((fun (function-authorizer-function auth))) + (if* fun + then (funcall fun req ent auth)))) + + + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/cgi.cl =================================================================== --- vendor/portableaserve/aserve/cgi.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/cgi.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,449 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; cgi.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: cgi.cl,v 1.9 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; common gateway interface (running external programs) + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +(in-package :net.aserve) + +(defun run-cgi-program (req ent program + &key + path-info + path-translated + (script-name (puri:uri-path (request-uri req))) + (query-string nil query-string-p) + auth-type + (timeout 200) + error-output + env + ) + ;; program is a string naming a external command to run. + ;; invoke the program after setting all of the environment variables + ;; according to the cgi specification. + ;; http://hoohoo.ncsa.uiuc.edu/cgi/interface.html + ;; + ;; error-output can be + ;; nil - inherit lisp's standard output + ;; pathname or string - write to file of a given name + ;; :output - mix in the error output with the output + ;; function - call function when input's available from the error + ;; stream + (let ((envs (list '("GATEWAY_INTERFACE" . "CGI/1.1") + `("SERVER_SOFTWARE" + . ,(format nil "AllegroServe/~a" + *aserve-version-string*)))) + (error-output-arg) + (error-fcn) + (body)) + + ; error check the error argument + (typecase error-output + ((or null pathname string) + (setq error-output-arg error-output)) + (symbol + (if* (eq error-output :output) + then (setq error-output-arg error-output) + else (setq error-output-arg :stream + error-fcn error-output))) + (function + (setq error-output-arg :stream + error-fcn error-output)) + (t (error "illegal value for error-output: ~s" error-output))) + + + (let ((our-ip (acl-compat.socket:local-host (request-socket req)))) + (let ((hostname (acl-compat.socket:ipaddr-to-hostname our-ip))) + (if* (null hostname) + then (setq hostname (acl-compat.socket:ipaddr-to-dotted our-ip))) + (push (cons "SERVER_NAME" hostname) envs))) + + (push (cons "SERVER_PROTOCOL" + (string-upcase (string (request-protocol req)))) + envs) + + (push (cons "SERVER_PORT" + (write-to-string (acl-compat.socket:local-port + (request-socket req)))) + envs) + + (push (cons "REQUEST_METHOD" + (string-upcase (string (request-method req)))) + envs) + + (if* path-info + then (push (cons "PATH_INFO" path-info) envs)) + + (if* path-translated + then (push (cons "PATH_INFO" path-translated) envs)) + + (if* script-name + then (push (cons "SCRIPT_NAME" script-name) envs)) + + (if* query-string-p + then (if* query-string + then (push (cons "QUERY_STRING" query-string) envs)) + else ; no query string arg given, see if the uri + ; for ths command has a query string + (let ((query (puri:uri-query + (request-uri req)))) + (if* query + then (push (cons "QUERY_STRING" query) envs)))) + + + (let ((their-ip (acl-compat.socket:remote-host (request-socket req)))) + (let ((hostname (acl-compat.socket:ipaddr-to-hostname their-ip))) + (if* hostname + then (push (cons "REMOTE_HOST" hostname) envs))) + + (push (cons "REMOTE_ADDR" (acl-compat.socket:ipaddr-to-dotted their-ip)) + envs)) + + (if* auth-type + then (push (cons "AUTH_TYPE" auth-type) envs)) + + (if* (member (request-method req) '(:put :post)) + then ; there is likely data coming along + (setq body (get-request-body req )) + (if* (equal body "") then (setq body nil)) ; trivial case + (let ((content-type (header-slot-value req :content-type))) + (if* content-type + then (push (cons "CONTENT_TYPE" + content-type) + envs)) + (push (cons "CONTENT_LENGTH" + (princ-to-string + (if* body then (length body) else 0))) + envs))) + + ; now do the rest of the headers. + + (dolist (head (listify-parsed-header-block (request-header-block req))) + (if* (and (not (member (car head) '(:content-type :content-length) + :test #'eq)) + (cdr head)) + then (push (cons (format nil "HTTP_~a" + (substitute #\_ #\- + (string-upcase + (string (car head))))) + (cdr head)) + envs))) + + (dolist (header env) + (if* (not (and (consp header) + (stringp (car header)) + (stringp (cdr header)))) + then (error "bad form for environment value: ~s" header)) + (let ((ent (assoc (car header) envs :test #'equal))) + (if* ent + then ; replace value with user specified value + (setf (cdr ent) (cdr header)) + else ; add new value + (push header envs)))) + + ;; now to invoke the program + ;; this requires acl6.1 on unix since this is the first version + ;; that can set the environment variables for the run-shell-command + ;; call + + (multiple-value-bind + (to-script-stream + from-script-stream + from-script-error-stream + pid) + (run-shell-command program + :input (if* body then :stream) + :output :stream + :error-output error-output-arg + :separate-streams t + :wait nil + :environment envs + :show-window :hide) + (declare (ignore ignore-this)) + + (unwind-protect + ; first send the body to the script + ; maybe we should interleave reading and writing + ; but that's a lot of work + (progn + (ignore-errors + (if* (and body to-script-stream) + then (write-sequence body to-script-stream))) + + (if* to-script-stream + then (ignore-errors (close to-script-stream)) + (setq to-script-stream nil)) + + ; read the output from the script + (read-script-data req ent + from-script-stream from-script-error-stream + error-fcn + timeout)) + + + ;; cleanup forms: + (if* to-script-stream + then (ignore-errors (close to-script-stream))) + (if* from-script-stream + then (ignore-errors (close from-script-stream))) + (if* from-script-error-stream + then (ignore-errors (close from-script-error-stream))) + (if* pid + then ;; it may be bad to wait here... + (acl-compat.mp:with-timeout (60) ; ok w-t + (acl-compat.sys:reap-os-subprocess :pid pid :wait t))))))) + + +(defun read-script-data (req ent stream error-stream error-fcn timeout) + ;; read from the stream and the error-stream (if given) + ;; do the cgi header processing and start sending output asap + ;; + ;; don't close the streams passed, they'll be closed by the caller + ;; + (let ((active-streams) + (buff) + (start 0)) + + (labels ((error-stream-handler () + ;; called when data available on error stream. + ;; calls user supplied handler function + (let ((retcode (funcall error-fcn req ent error-stream))) + (if* retcode + then ; signal to close off the error stream + (setq active-streams + (delete error-stream active-streams :key #'car))))) + + (data-stream-header-read () + ;; called when data available on standard output + ;; and we're still reading in search of a full header + ;; + (if* (>= start (length buff)) + then ; no more room to read, must be bogus header + (failed-script-response req ent) + (return-from read-script-data) + else (let ((len (read-vector buff stream + :start start))) + (if* (<= len start) + then ; eof, meaning no header + (failed-script-response req ent) + (return-from read-script-data) + else (setq start len) + (multiple-value-bind (resp headers bodystart) + (parse-cgi-script-data buff start) + (if* resp + then ; got the header, switch + ; to body + (data-stream-body-process + resp headers bodystart) + ; never returns + )))))) + + (data-stream-body-process (resp headers bodystart) + ;; called when it's time to start returning the body + (with-http-response (req ent :response resp + :format :binary) + (with-http-body (req ent :headers headers) + ; write out first block + + (write-all-vector buff + *html-stream* + :start bodystart + :end start) + + ; now loop and read rest + (setf (cdr (assoc stream active-streams :test #'eq)) + #'data-stream-body) + + (loop + (if* (null active-streams) + then (return)) + + (let ((active + (acl-compat.mp:wait-for-input-available + (mapcar #'car active-streams) + :timeout timeout))) + + (if* (null active) + then ; timeout, just shut down streams + (setq active-streams nil) + else ; run handlers + (mapc #'(lambda (x) + (funcall (cdr (assoc x active-streams + :test #'eq)))) + active) + + ))))) + (return-from read-script-data)) + + (data-stream-body () + ;; process data coming back from the body + (let ((len (read-vector buff stream))) + + (if* (<= len 0) + then ; end of file, remove this stream + (setq active-streams + (delete stream active-streams + :key #'car)) + else ; send data to output + (write-all-vector buff + *html-stream* + :start 0 + :end len) + (force-output *html-stream*))))) + + + (setq active-streams + (list (cons stream #'data-stream-header-read))) + + (if* error-stream + then (push (cons error-stream #'error-stream-handler) + active-streams)) + + (unwind-protect + (progn + (setq buff (get-header-block)) + + + + (loop + ; this loop is for searching for a valid header + + (let ((active + (acl-compat.mp:wait-for-input-available + (mapcar #'car active-streams) :timeout timeout))) + + (if* (null active) + then ; must have timed out + (failed-script-response req ent) + (return-from read-script-data)) + + ; run the handlers + (mapc #'(lambda (x) + (funcall (cdr (assoc x active-streams :test #'eq)))) + active)))) + ; cleanup + (free-header-block buff))))) + + + + + +(defun failed-script-response (req ent) + ;; send back a generic failed message + (with-http-response (req ent + :response *response-internal-server-error* + :content-type "text/html") + (with-http-body (req ent) + (html "The cgi script failed to run")))) + + + +(defun parse-cgi-script-data (buff end) + ;; if there's a valid header block in the buffer from 0 to end-1 + ;; then return + ;; 1. the response object denoting the response value to send back + ;; 2. a list of headers and values + ;; 3. the index in the buffer where the data begins after the header + ;; + ;; else return nil + (let* ((loc (search *crlf-crlf-usb8* buff + :end2 (min (length buff) end))) + (loclflf (and (null loc) + ;; maybe uses bogus lf-lf to end headers + (search *lf-lf-usb8* buff + :end2 (min (length buff) end)))) + (incr 2)) + + (if* loclflf + then (setq loc loclflf + incr 1)) + + (if* (null loc) + then ; hmm.. no headers..bogus return + ;(warn "no headers found") + (return-from parse-cgi-script-data nil)) + + (incf loc incr) ; after last header crlf (lf), before final crlf (lf) + (let ((headers (parse-and-listify-header-block + buff + loc)) + (resp *response-ok*)) + + + (incf loc incr) ; past the final crlf (lf) + + (if* (assoc :location headers :test #'eq) + then (setq resp *response-moved-permanently*)) + + + (let ((status (assoc :status headers :test #'eq)) + code + reason) + + (if* status + then (ignore-errors + (setq code (read-from-string (cdr status)))) + (if* (not (integerp code)) + then ; bogus status value, just return nil + ; eventually we'll get a failed response + (logmess + (format nil + "cgi script return bogus status value: ~s" + code)) + (return-from parse-cgi-script-data nil)) + (let ((space (position #\space (cdr status)))) + (if* space + then (setq reason + (subseq (cdr status) space)))) + (setq resp (make-resp code reason)) + + (setq headers (delete status headers)))) + (values resp headers loc)))) + + + + + + +(defun write-all-vector (sequence stream &key (start 0) + (end (length sequence))) + ;; write everything in the vector before returning + (loop + (if* (< start end) + then (setq start (write-vector sequence stream + :start start + :end end)) + else (return))) + + end) + + Added: vendor/portableaserve/aserve/client.cl =================================================================== --- vendor/portableaserve/aserve/client.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/client.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1056 @@ +;; -*- mode: common-lisp; package: net.aserve.client -*- +;; +;; client.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: client.cl,v 1.18 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; http client code. + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +;; this will evolve into the http client code but for now it's +;; just some simple stuff to allow us to test aserve +;; + + + + + + + +(in-package :net.aserve.client) + + + + +(defclass client-request () + ((uri ;; uri we're accessing + :initarg :uri + :accessor client-request-uri) + + (method ; :get, :put, etc + :initarg :method + :accessor client-request-method) + + (headers ; alist of ("headername" . "value") + :initform nil + :initarg :headers + :accessor client-request-headers) + (response-code ; response code (an integer) + :initform nil + :accessor client-request-response-code) + (socket ; the socket through which we'll talk to the server + :initarg :socket + :accessor client-request-socket) + (protocol + ; the protocol value returned by the web server + ; note, even if the request is for http/1.0, apache will return + ; http/1.1. I'm not sure this is kosher. + :accessor client-request-protocol) + (response-comment ;; comment passed back with the response + :accessor client-request-response-comment) + ; + (bytes-left ;; indicates how many bytes in response left + ; value is nil (no body) + ; integer (that many bytes left, not chunking) + ; :unknown - read until eof, not chunking + ; :chunking - read until chunking eof + :accessor client-request-bytes-left + :initform nil) + + (cookies ;; optionally a cookie jar for hold received and sent cookies + :accessor client-request-cookies + :initarg :cookies + :initform nil) + )) + + +(defvar crlf (make-array 2 :element-type 'character + :initial-contents '(#\return #\linefeed))) + +(defmacro with-better-scan-macros (&body body) + ;; define the macros for scanning characters in a string + `(macrolet ((collect-to (ch buffer i max &optional downcasep) + ;; return a string containing up to the given char + `(let ((start ,i)) + (loop + (if* (>= ,i ,max) then (fail)) + (if* (eql ,ch (schar ,buffer ,i)) + then (return (buf-substr start ,i ,buffer ,downcasep))) + (incf ,i) + ))) + + (collect-to-eol (buffer i max) + ;; return a string containing up to the given char + `(let ((start ,i)) + (loop + (if* (>= ,i ,max) + then (return (buf-substr start ,i ,buffer))) + (let ((thisch (schar ,buffer ,i))) + (if* (eq thisch #\return) + then (let ((ans (buf-substr start ,i ,buffer))) + (incf ,i) ; skip to linefeed + (return ans)) + elseif (eq thisch #\linefeed) + then (return (buf-substr start ,i ,buffer)))) + (incf ,i) + ))) + + (skip-to-not (ch buffer i max &optional (errorp t)) + ;; skip to first char not ch + `(loop + (if* (>= ,i ,max) + then ,(if* errorp + then `(fail) + else `(return))) + (if* (not (eq ,ch (schar ,buffer ,i))) + then (return)) + (incf ,i))) + + (buf-substr (from to buffer &optional downcasep) + ;; create a string containing [from to } + ;; + `(let ((res (make-string (- ,to ,from)))) + (do ((ii ,from (1+ ii)) + (ind 0 (1+ ind))) + ((>= ii ,to)) + (setf (schar res ind) + ,(if* downcasep + then `(char-downcase (schar ,buffer ii)) + else `(schar ,buffer ii)))) + res))) + + ,@body)) + + +(defun do-http-request (uri + &rest args + &key + (method :get) + (protocol :http/1.1) + (accept "*/*") + content + content-type + query + (format :text) ; or :binary + cookies ; nil or a cookie-jar + (redirect 5) ; auto redirect if needed + (redirect-methods '(:get :head)) + basic-authorization ; (name . password) + keep-alive ; if true, set con to keep alive + headers ; extra header lines, alist + proxy ; naming proxy server to access through + user-agent + (external-format *default-aserve-external-format*) + ssl ; do an ssl connection + skip-body ; fcn of request object + ) + + ;; send an http request and return the result as four values: + ;; the body, the response code, the headers and the uri + (let ((creq (make-http-client-request + uri + :method method + :protocol protocol + :accept accept + :content content + :content-type content-type + :query query + :cookies cookies + :basic-authorization basic-authorization + :keep-alive keep-alive + :headers headers + :proxy proxy + :user-agent user-agent + :external-format external-format + :ssl ssl + ))) + + (unwind-protect + (let (new-location) + + (loop + (read-client-response-headers creq) + ;; if it's a continue, then start the read again + (if* (not (eql 100 (client-request-response-code creq))) + then (return))) + + (if* (and (member (client-request-response-code creq) + '(#.(net.aserve::response-number *response-found*) + #.(net.aserve::response-number *response-moved-permanently*) + #.(net.aserve::response-number *response-temporary-redirect*) + #.(net.aserve::response-number *response-see-other*)) + :test #'eq) + redirect + (member method redirect-methods :test #'eq) + (if* (integerp redirect) + then (> redirect 0) + else t)) ; unrestricted depth + then + (setq new-location + (cdr (assoc :location (client-request-headers creq) + :test #'eq)))) + + (if* (and (null new-location) + ; not called when redirecting + (if* (functionp skip-body) + then (funcall skip-body creq) + else skip-body)) + then + (return-from do-http-request + (values + nil ; no body + (client-request-response-code creq) + (client-request-headers creq) + (client-request-uri creq)))) + + ;; read the body of the response + (let ( #+ignore (atype (if* (eq format :text) ; JSC: We do not need to set this all over and over + then 'character + else '(unsigned-byte 8))) + ans + res + (start 0) + (end nil) + body) + + (loop + (if* (null ans) + then (setq ans (make-array 1024 :element-type '(unsigned-byte 8)) ; was atype) + start 0)) + + (setq end (client-request-read-sequence ans creq :start start)) + (if* (zerop end) + then ; eof + (return)) + (if* (eql end 1024) + then ; filled up + (push ans res) + (setq ans nil) + else (setq start end))) + + ;; we're out with res containing full arrays and + ;; ans either nil or holding partial data up to but not including + ;; index start + + (if* res + then ; multiple items + (let* ((total-size (+ (* 1024 (length res)) start)) + (bigarr (make-array total-size :element-type '(unsigned-byte 8)) ; was atype) + )) + (let ((sstart 0)) + (dolist (arr (reverse res)) + (replace bigarr arr :start1 sstart) + (incf sstart (length arr))) + (if* ans + then ; final one + (replace bigarr ans :start1 sstart))) + + (setq body bigarr)) + else ; only one item + (if* (eql 0 start) + then ; nothing returned + (setq body "") + else (setq body (subseq ans 0 start)))) + + (if* new-location + then ; must do a redirect to get to the real site + (client-request-close creq) + (apply #'do-http-request + (puri:merge-uris new-location uri) + :redirect + (if* (integerp redirect) + then (1- redirect) + else redirect) + args) + else + (values + (if (eq format :text) + (let ((result (make-string (length body)))) + (map-into result #'code-char body) + result) + body) + (client-request-response-code creq) + (client-request-headers creq) + (client-request-uri creq))))) + + ;; protected form: + (client-request-close creq)))) + + + + + + + + + + + + + +(defun make-http-client-request (uri &key + (method :get) ; :get, :post, .... + (protocol :http/1.1) + keep-alive + (accept "*/*") + cookies ; nil or a cookie-jar + basic-authorization + content + content-length + content-type + query + headers + proxy + user-agent + (external-format + *default-aserve-external-format*) + ssl + ) + + + (let (host sock port fresh-uri scheme-default-port) + ;; start a request + + ; parse the uri we're accessing + (if* (not (typep uri 'puri:uri)) + then (setq uri (puri:parse-uri uri) + fresh-uri t)) + + ; make sure it's an http uri + (case (or (puri:uri-scheme uri) :http) + (:http nil) + (:https (setq ssl t)) + (t (error "Can only do client access of http or https uri's, not ~s" uri))) + + ; make sure that there's a host + (if* (null (setq host (puri:uri-host uri))) + then (error "need a host in the client request: ~s" uri)) + + (setq scheme-default-port + (case (or (puri:uri-scheme uri) (if* ssl + then :https + else :http)) + (:http 80) + (:https 443))) + + ; default the port to what's appropriate for http or https + (setq port (or (puri:uri-port uri) scheme-default-port)) + + (if* proxy + then ; sent request through a proxy server + (assert (stringp proxy) (proxy) + "proxy value ~s should be a string" proxy) + (multiple-value-bind (phost pport) + (net.aserve::get-host-port proxy) + (if* (null phost) + then (error "proxy arg should have form \"foo.com\" ~ +or \"foo.com:8000\", not ~s" proxy)) + + (setq sock (acl-compat.socket:make-socket :remote-host phost + :remote-port pport + :format :bivalent + :type net.aserve::*socket-stream-type* + :nodelay t + ))) + else (setq sock + (acl-compat.socket:make-socket :remote-host host + :remote-port port + :format :bivalent + :type + net.aserve::*socket-stream-type* + :nodelay t + + )) + (if* ssl + then (setq sock + (funcall 'acl-compat.socket::make-ssl-client-stream sock))) + ) + + #+(and allegro (version>= 6 0)) + (let ((ef (find-external-format external-format))) + #+(and allegro (version>= 6)) (net.aserve::warn-if-crlf ef) + (setf (stream-external-format sock) ef)) + + #+allegro + (if* net.aserve::*watch-for-open-sockets* + then (schedule-finalization + sock + #'net.aserve::check-for-open-socket-before-gc)) + + (if* query + then (case method + ((:get :put) ; add info the uri + ; must not blast a uri we were passed + (if* (not fresh-uri) + then (setq uri (puri:copy-uri uri))) + (setf (puri:uri-query uri) (query-to-form-urlencoded + query + :external-format + external-format))) + (:post ; make the content + (if* content + then (error "Can't specify both query ~s and content ~s" + query content)) + (setq content (query-to-form-urlencoded + query :external-format external-format) + content-type "application/x-www-form-urlencoded")))) + + + (net.aserve::format-dif :xmit sock "~a ~a ~a~a" + (string-upcase (string method)) + (if* proxy + then (puri:render-uri uri nil) + else (uri-path-etc uri)) + (string-upcase (string protocol)) + crlf) + + ; always send a Host header, required for http/1.1 and a good idea + ; for http/1.0 + (if* (not (eql scheme-default-port port)) + then (net.aserve::format-dif :xmit sock "Host: ~a:~a~a" host port crlf) + else (net.aserve::format-dif :xmit sock "Host: ~a~a" host crlf)) + + ; now the headers + (if* keep-alive + then (net.aserve::format-dif :xmit + sock "Connection: Keep-Alive~a" crlf)) + + (if* accept + then (net.aserve::format-dif :xmit + sock "Accept: ~a~a" accept crlf)) + + ; content can be a nil, a single vector or a list of vectors. + ; canonicalize.. + (if* (and content (atom content)) then (setq content (list content))) + + (if* content + then (let ((computed-length 0)) + (dolist (content-piece content) + (typecase content-piece + ;;added for paserve - in some lisps (e.g. mcl) + ;;strings are not character arrays + ((or (array character (*)) (array base-char (*))) + (if* (null content-length) + then (incf computed-length + #+allegro + (native-string-sizeof + content-piece + :external-format external-format) + #-allegro + (length content-piece)))) + + ((array (unsigned-byte 8) (*)) + (if* (null content-length) + then (incf computed-length (length content-piece)))) + (t (error "Illegal content array: ~s" content-piece)))) + + (if* (null content-length) + then (setq content-length computed-length)))) + + + + (if* content-length + then (net.aserve::format-dif :xmit + sock "Content-Length: ~s~a" content-length crlf)) + + + (if* cookies + then (let ((str (compute-cookie-string uri + cookies))) + (if* str + then (net.aserve::format-dif :xmit + sock "Cookie: ~a~a" str crlf)))) + + (if* basic-authorization + then (net.aserve::format-dif :xmit sock "Authorization: Basic ~a~a" + (base64-encode + (format nil "~a:~a" + (car basic-authorization) + (cdr basic-authorization))) + crlf)) + + (if* user-agent + then (if* (stringp user-agent) + thenret + elseif (eq :aserve user-agent) + then (setq user-agent net.aserve::*aserve-version-string*) + elseif (eq :netscape user-agent) + then (setq user-agent "Mozilla/4.7 [en] (WinNT; U)") + elseif (eq :ie user-agent) + then (setq user-agent "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)") + else (error "Illegal user-agent value: ~s" user-agent)) + (net.aserve::format-dif :xmit + sock "User-Agent: ~a~a" user-agent crlf)) + + (if* content-type + then (net.aserve::format-dif :xmit sock "Content-Type: ~a~a" + content-type + crlf)) + (if* headers + then (dolist (header headers) + (net.aserve::format-dif :xmit sock "~a: ~a~a" + (car header) (cdr header) crlf))) + + + (write-string crlf sock) ; final crlf + + ; send out the content if there is any. + ; this has to be done differently so that if it looks like we're + ; going to block doing the write we start another process do the + ; the write. + (if* content + then ; content can be a vector a list of vectors + (if* (atom content) then (setq content (list content))) + (dolist (cont content) + (net.aserve::if-debug-action + :xmit + (format net.aserve::*debug-stream* + "client sending content of ~d characters/bytes" + (length cont))) + (write-sequence cont sock))) + + + (force-output sock) + + (make-instance 'client-request + :uri uri + :socket sock + :cookies cookies + :method method + ))) + + +(defun uri-path-etc (uri) + ;; return the string form of the uri path, query and fragment + (let ((nuri (puri:copy-uri uri))) + (setf (puri:uri-scheme nuri) nil) + (setf (puri:uri-host nuri) nil) + (setf (puri:uri-port nuri) nil) + (if* (null (puri:uri-path nuri)) + then (setf (puri:uri-path nuri) "/")) + + (puri:render-uri nuri nil))) + + +(defmethod read-client-response-headers ((creq client-request)) + ;; read the response and the headers + (let ((buff (get-header-line-buffer)) + (buff2 (get-header-line-buffer)) + (pos 0) + len + (sock (client-request-socket creq)) + (headers) + protocol + response + comment + val + ) + (unwind-protect + (with-better-scan-macros + (if* (null (setq len (read-socket-line sock buff (length buff)))) + then ; eof getting response + (error "premature eof from server")) + (macrolet ((fail () + `(let ((i 0)) + (error "illegal response from web server: ~s" + (collect-to-eol buff i len))))) + (setq protocol (collect-to #\space buff pos len)) + (skip-to-not #\space buff pos len) + (setq response (collect-to #\space buff pos len)) + ; some servers don't return a comment, so handle that + (skip-to-not #\space buff pos len nil) + (setq comment (collect-to-eol buff pos len))) + + (if* (equalp protocol "HTTP/1.0") + then (setq protocol :http/1.0) + elseif (equalp protocol "HTTP/1.1") + then (setq protocol :http/1.1) + else (error "unknown protocol: ~s" protocol)) + + (setf (client-request-protocol creq) protocol) + + (setf (client-request-response-code creq) + (quick-convert-to-integer response)) + + (setf (client-request-response-comment creq) comment) + + + ; now read the header lines + (setq headers (net.aserve::compute-client-request-headers sock)) + + + (setf (client-request-headers creq) headers) + + ;; do cookie processing + (let ((jar (client-request-cookies creq))) + (if* jar + then ; do all set-cookie requests + (let (prev) + ; Netscape v3 web server bogusly splits set-cookies + ; over multiple set-cookie lines, so we look for + ; incomplete lines (those ending in #\;) and combine + ; them with the following set-cookie + (dolist (headval headers) + (if* (eq :set-cookie (car headval)) + then (if* prev + then (setq prev (concatenate 'string + prev (cdr headval))) + else (setq prev (cdr headval))) + + (if* (not (eq #\; (last-character prev))) + then (save-cookie (client-request-uri creq) + jar + prev) + + (setq prev nil))))))) + + + (if* (eq :head (client-request-method creq)) + then ; no data is returned for a head request + (setf (client-request-bytes-left creq) 0) + elseif (equalp "chunked" (client-response-header-value + creq :transfer-encoding)) + then ; data will come back in chunked style + (setf (client-request-bytes-left creq) :chunked) + (acl-compat.socket:socket-control (client-request-socket creq) + :input-chunking t) + elseif (setq val (client-response-header-value + creq :content-length)) + then ; we know how many bytes are left + (setf (client-request-bytes-left creq) + (quick-convert-to-integer val)) + elseif (not (equalp "keep-alive" + (client-response-header-value + creq :connection))) + then ; connection will close, let it indicate eof + (setf (client-request-bytes-left creq) :unknown) + else ; no data in the response + nil) + + + + creq ; return the client request object + ) + (progn (put-header-line-buffer buff2 buff))))) + + + +(defmethod client-request-read-sequence (buffer + (creq client-request) + &key + (start 0) + (end (length buffer))) + ;; read the next (end-start) bytes from the body of client request, handling + ;; turning on chunking if needed + ;; return index after last byte read. + ;; return 0 if eof + (let ((bytes-left (client-request-bytes-left creq)) + (socket (client-request-socket creq)) + (last start)) + (if* (integerp bytes-left) + then ; just a normal read-sequence + (if* (zerop bytes-left) + then 0 ; eof + else (let ((ans (net.aserve::rational-read-sequence buffer + socket :start start + :end (+ start + (min (- end start) + bytes-left))))) + (if* (eq ans start) + then 0 ; eof + else (net.aserve::if-debug-action :xmit + (write-sequence + buffer + net.aserve::*debug-stream* + :start start + :end + ans)) + (setf (client-request-bytes-left creq) + (- bytes-left (- ans start))) + ans))) + elseif (or (eq bytes-left :chunked) + (eq bytes-left :unknown)) + then (handler-case (do ((i start (1+ i)) + (stringp (stringp buffer)) + (debug-on (member :xmit + net.aserve::*debug-current* + :test #'eq))) + ((>= i end) (setq last end)) + (setq last i) + (let ((ch (if* stringp + then (read-char socket nil nil) + else (read-byte socket nil nil)))) + (if* (null ch) + then (return) + else (if* debug-on + then (write-char + (if* (characterp ch) + then ch + else (code-char ch)) + net.aserve::*debug-stream*)) + (setf (aref buffer i) ch)))) + (acl-compat.excl::socket-chunking-end-of-file + (cond) + (declare (ignore cond)) + ; remember that there is no more data left + (setf (client-request-bytes-left creq) :eof) + nil)) + ; we return zero on eof, regarless of the value of start + ; I think that this is ok, the spec isn't completely clear + (if* (eql last start) + then 0 + else last) + elseif (eq bytes-left :eof) + then 0 + else (error "socket not setup for read correctly") + ))) + + +(defmethod client-request-close ((creq client-request)) + (let ((sock (client-request-socket creq))) + (if* sock + then (setf (client-request-socket creq) nil) + (ignore-errors (force-output sock)) + (ignore-errors (close sock))))) + + +(defun quick-convert-to-integer (str) + ; take the simple string and convert it to an integer + ; it's assumed to be a positive number + ; no error checking is done. + (let ((res 0)) + (dotimes (i (length str)) + (let ((chn (- (char-code (schar str i)) #.(char-code #\0)))) + (if* (<= 0 chn 9) + then (setq res (+ (* 10 res) chn))))) + res)) + + +(defmethod client-response-header-value ((creq client-request) + name &key parse) + ;; return the value associated with the given name + ;; parse it too if requested + (if* (stringp name) + then (error "client-response headers are now named by symbols, not strings")) + + (let ((val (cdr (assoc name (client-request-headers creq) :test #'eq)))) + (if* (and parse val) + then (net.aserve::parse-header-value val) + else val))) + + + + + +(defun read-socket-line (socket buffer max) + ;; read the next line from the socket. + ;; the line may end with a linefeed or a return, linefeed, or eof + ;; in any case don't put that the end of line characters in the buffer + ;; return the number of characters in the buffer which will be zero + ;; for an empty line. + ;; on eof return nil + + ;; JSC Note: This function is only used for reading headers. Therefore we + ;; are safe in always doing CODE->CHAR conversions here. + + (let ((i 0)) + (loop + (let* ((ch (read-byte socket nil nil)) + (ch (and ch (code-char ch)))) + (if* (null ch) + then ; eof from socket + (if* (> i 0) + then ; actually read some stuff first + (return i) + else (return nil) ; eof + ) + elseif (eq ch #\return) + thenret ; ignore + elseif (eq ch #\linefeed) + then ; end of the line, + (return i) + elseif (< i max) + then ; ignore characters beyone line end + (setf (schar buffer i) ch) + (incf i)))))) + + + + +;; buffer pool for string buffers of the right size for a header +;; line + +(defvar *response-header-buffers* nil) + +(defun get-header-line-buffer () + ;; return the next header line buffer + (let (buff) + (acl-compat.excl::atomically + (acl-compat.excl::fast (setq buff (pop *response-header-buffers*)))) + (if* buff + thenret + else (make-array 400 :element-type 'character)))) + +(defun put-header-line-buffer (buff &optional buff2) + ;; put back up to two buffers + (acl-compat.mp:without-scheduling + (push buff *response-header-buffers*) + (if* buff2 then (push buff2 *response-header-buffers*)))) + + + + + +;;;;; cookies + +(defclass cookie-jar () + ;; holds all the cookies we've received + ;; items is a alist where each item has the following form: + ;; (hostname cookie-item ...) + ;; + ;; where hostname is a string that must be the suffix + ;; of the requesting host to match + ;; path is a string that must be the prefix of the requesting host + ;; to match + ;; + ;; + ((items :initform nil + :accessor cookie-jar-items))) + +(defmethod print-object ((jar cookie-jar) stream) + (print-unreadable-object (jar stream :type t :identity t) + (format stream "~d cookies" (length (cookie-jar-items jar))))) + +;* for a given hostname, there will be only one cookie with +; a given (path,name) pair +; +(defstruct cookie-item + path ; a string that must be the prefix of the requesting host to match + name ; the name of this cookie + value ; the value of this cookie + expires ; when this cookie expires + secure ; t if can only be sent over a secure server + ) + + +(defmethod save-cookie (uri (jar cookie-jar) cookie) + ;; we've made a request to the given host and gotten back + ;; a set-cookie header with cookie as the value + ;; jar is the cookie jar into which we want to store the cookie + + (let* ((pval (car (net.aserve::parse-header-value cookie t))) + namevalue + others + path + domain + ) + (if* (consp pval) + then ; (:param namevalue . etc) + (setq namevalue (cadr pval) + others (cddr pval)) + elseif (stringp pval) + then (setq namevalue pval) + else ; nothing here + (return-from save-cookie nil)) + + ;; namevalue has the form name=value + (setq namevalue (net.aserve::split-on-character namevalue #\= + :count 1)) + + ;; compute path + (setq path (cdr (net.aserve::assoc-paramval "path" others))) + (if* (null path) + then (setq path (or (puri:uri-path uri) "/")) + else ; make sure it's a prefix + (if* (not (net.aserve::match-head-p + path (or (puri:uri-path uri) "/"))) + then ; not a prefix, don't save + (return-from save-cookie nil))) + + ;; compute domain + (setq domain (cdr (net.aserve::assoc-paramval "domain" others))) + + (if* domain + then ; one is given, test to see if it's a substring + ; of the host we used + (if* (null (net.aserve::match-tail-p domain + (puri:uri-host uri))) + then (return-from save-cookie nil)) + else (setq domain (puri:uri-host uri))) + + + (let ((item (make-cookie-item + :path path + :name (car namevalue) + :value (or (cadr namevalue) "") + :secure (net.aserve::assoc-paramval "secure" others) + :expires (cdr (net.aserve::assoc-paramval "expires" others)) + ))) + ; now put in the cookie jar + (let ((domain-vals (assoc domain (cookie-jar-items jar) :test #'equal))) + (if* (null domain-vals) + then ; this it the first time for this host + (push (list domain item) (cookie-jar-items jar)) + else ; this isn't the first + ; check for matching path and name + (do* ((xx (cdr domain-vals) (cdr xx)) + (thisitem (car xx) (car xx))) + ((null xx) + ) + (if* (and (equal (cookie-item-path thisitem) + path) + (equal (cookie-item-name thisitem) + (car namevalue))) + then ; replace this one + (setf (car xx) item) + (return-from save-cookie nil))) + + ; no match, must insert based on the path length + (do* ((prev nil xx) + (xx (cdr domain-vals) (cdr xx)) + (thisitem (car xx) (car xx)) + (length (length path))) + ((null xx) + ; put at end + (if* (null prev) then (setq prev domain-vals)) + (setf (cdr prev) (cons item nil))) + (if* (>= (length (cookie-item-path thisitem)) length) + then ; can insert here + (if* prev + then (setf (cdr prev) + (cons item xx)) + + else ; at the beginning + (setf (cdr domain-vals) + (cons item (cdr domain-vals)))) + (return-from save-cookie nil)))))))) + + + +(defparameter cookie-separator + ;; useful for separating cookies, one per line + (make-array 10 :element-type 'character + :initial-contents '(#\return + #\linefeed + #\C + #\o + #\o + #\k + #\i + #\e + #\: + #\space))) + +(defmethod compute-cookie-string (uri (jar cookie-jar)) + ;; compute a string of the applicable cookies. + ;; + (let ((host (puri:uri-host uri)) + (path (or (puri:uri-path uri) "/")) + res + rres) + + (dolist (hostval (cookie-jar-items jar)) + (if* (net.aserve::match-tail-p (car hostval) + host) + then ; ok for this host + (dolist (item (cdr hostval)) + (if* (net.aserve::match-head-p (cookie-item-path item) + path) + then ; this one matches + (push item res))))) + + (if* res + then ; have some cookies to return + #+ignore (dolist (item res) + (push (cookie-item-value item) rres) + (push "=" rres) + (push (cookie-item-name item) rres) + (push semicrlf rres)) + + (dolist (item res) + (push (cookie-item-value item) rres) + (push "=" rres) + (push (cookie-item-name item) rres) + (push cookie-separator rres)) + + (pop rres) ; remove first seperator + (apply #'concatenate 'string rres)))) + +(defun last-character (string) + ;; return the last non blank character, or nil + (do ((i (1- (length string)) (1- i)) + (ch)) + ((< i 0) nil) + (setq ch (schar string i)) + (if* (eq #\space ch) + thenret + else (return ch)))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/decode.cl =================================================================== --- vendor/portableaserve/aserve/decode.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/decode.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,760 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; decode.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; +;; $Id: decode.cl,v 1.10 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; decode/encode code + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +(in-package :net.aserve) + +;---------------- urlencoding ---------------- +; there are two similar yet distinct encodings for character strings +; that are referred to as "url encodings". We'll refer to +; the first as uriencoding and the second as form-urlencoding +; +; 1. uri's. rfc2396 describes the format of uri's +; uris use only the printing characters. +; a url can be broken down into a set of a components using +; a regular expression matcher. +; Each component consists of a string of characters. Certain +; characters must be escaped with %xy in order to put them +; in the uri, and others need only be escaped in certain components +; where not escaping them would change the meaning. It's legal +; to over-escape though. +; Here are the characters that need never be escaped: +; lower case a-z +; upper case A-Z +; numbers 0-9 +; mark chars: - _ . ! ~ * ' ( ) +; +; anything else should be escaped. +; +; The encoding (converting characters to their %xy form) must be +; done on a component by component basis for a uri. +; You can't just give a function a complete uri and say "encode this" +; because if it's a uri then it's already encoded. You can +; give a function a filename to be put into a uri and +; say "encode this" and that function +; could look for reserved characters in the filename and convert them +; to %xy form. +; +; 2. x-www-form-urlencoded +; when the result of a form is to be sent to the web server +; it can be sent in one of two ways: +; 1. the "get" method where the form data is passed in the uri +; after a "?". +; 2 the "post" method where the data is stored in the body +; of the post with an application/x-www-form-urlencoded +; mime type. +; +; the form data is sent in this format +; name=value&name2=value2&name3=value3 +; where each of the name,value items is is encoded +; such that +; alphanumerics are unchanged +; space turns into "+" +; linefeed turns into "%0d%0a" +; The following characters don't have to be encoded: +; - _ . ! ~ * ' ( ) +; Everything else must be escaped. While the escaping +; isn't necessary to be stored as the body of a post form +; we want to use the same function to encode queries +; to be placed in uris, and there escaping is more necessary. + + +;--- uriencoding + +(defvar *uri-encode* + ;; maps 7 bit characters to t iff they have to be encoded + ;; all characters with the 8th bit set must be encoded + (let ((res (make-array 128 :initial-element t))) + + ; the alphanums + (dolist (range '((#\a #\z) + (#\A #\Z) + (#\0 #\9))) + (do ((i (char-code (car range)) (1+ i))) + ((> i (char-code (cadr range)))) + (setf (svref res i) nil))) + + ; the mark characters: + (dolist (ch '(#\- #\_ #\. #\! #\~ #\* #\' #$ #$)) + (setf (svref res (char-code ch)) nil)) + + res)) + +(defun uri-encode-p (code) + ;; return t iff the character must be encoded as %xy in a uri + (if* (>= code 128) + then t + else (svref *uri-encode* code))) + +#+allegro +(defun uriencode-string (str &key (external-format + *default-aserve-external-format*)) + ;; encode the given string using uri encoding. + ;; It may return the same string if no encoding need be done + ;; + (let ((len (native-string-sizeof str :external-format external-format)) + (count 0)) + (excl::with-dynamic-extent-usb8-array (mbvec len) + ;; We use string-to-mb for 5.0.1 compatibility. string-to-octets is + ;; generally prefered after 6.0. + (string-to-mb str :external-format external-format + :null-terminate nil + :mb-vector mbvec) + ;; count the number of encodings that must be done + (dotimes (i len) + (if* (uri-encode-p (aref mbvec i)) then (incf count))) + + (if* (zerop count) + then str ;; just return the string, no encoding done + else (excl::with-dynamic-extent-usb8-array (newmbvec + (+ len (* 2 count))) + (let ((j 0)) + (dotimes (i len) + (let ((code (aref mbvec i))) + (if* (uri-encode-p code) + then (setf (aref newmbvec j) #.(char-code #\%)) + (macrolet ((hexdig (code) + ;; return char code of hex digit + `(if* (< ,code 10) + then (+ ,code + #.(char-code #\0)) + else (+ (- ,code 10) + #.(char-code #\a))))) + (let* ((upcode (logand #xf (ash code -4))) + (downcode (logand #xf code))) + (setf (aref newmbvec (+ j 1)) + (hexdig upcode)) + (setf (aref newmbvec (+ j 2)) + (hexdig downcode)))) + (incf j 3) + else (setf (aref newmbvec j) code) + (incf j))))) + (values + ;; use values to suppress multiple values returned by + ;; octets-to-string. + ;; We use mb-to-string for 5.0.1 compatibility. + ;; octets-to-string is generally prefered after 6.0. + (mb-to-string newmbvec + :external-format :latin1-base + :end (+ len (* 2 count))))))))) + + +#-allegro +(defun uriencode-string (str &key (external-format + *default-aserve-external-format*)) + ;; encode the given string using uri encoding. + ;; It may return the same string if no encoding need be done + ;; + (declare (ignore external-format)) + (let ((len (length str)) + (count 0)) + (let ((byte-string (loop :with result = (make-array len :element-type '(unsigned-byte 8)) + :for i :from 0 :below len + :do (setf (aref result i) (char-code (aref str i))) + :finally (return result)))) + ;; count the number of encodings that must be done + (dotimes (i len) + (if* (uri-encode-p (aref byte-string i)) then (incf count))) + + (if (zerop count) + str ;; just return the string, no encoding done + (let* ((newstr (make-string (+ len (* 2 count)))) + (j 0)) + (dotimes (i len) + (let ((code (aref byte-string i))) + (if (uri-encode-p code) + (progn + (setf (aref newstr j) #\%) + (macrolet ((hexdig (code) + ;; return char code of hex digit + `(if* (< ,code 10) + then (code-char (+ ,code + #.(char-code #\0))) + else (code-char(+ (- ,code 10) + #.(char-code #\a)))))) + (let* ((upcode (logand #xf (ash code -4))) + (downcode (logand #xf code))) + (setf (aref newstr (+ j 1)) + (hexdig upcode)) + (setf (aref newstr (+ j 2)) + (hexdig downcode)))) + (incf j 3)) + (progn + (setf (aref newstr j) (code-char code)) + (incf j))))) + newstr))))) + + + +(defun uridecode-string (str &key (external-format + *default-aserve-external-format*)) + ;; decoded the uriencoded string, returning possibly the + ;; same string + ;; + (un-hex-escape str nil :external-format external-format) + ) + + + + + + + + +;---- form-urlencoding + +(defvar *url-form-encode* + ;; maps 7 bit characters to t iff they have to be encoded + ;; all characters with the 8th bit set must be encoded + ;; + ;; what's stored in the table is + ;; nil - no encoding needed + ;; N (integer) - how many extra characters are needed to encode this + ;; (i.e. one less than the total size encoded) + + (let ((res (make-array 128 :initial-element 2) ; assume all escaped + )) + + ; don't escape the alphanumerics + (dolist (range '((#\a #\z) + (#\A #\Z) + (#\0 #\9))) + (do ((i (char-code (car range)) (1+ i))) + ((> i (char-code (cadr range)))) + (setf (svref res i) nil))) + + + ; these 'mark' characters don't need escaping either + (dolist (ch '(#\- #\_ #\. #\! #\~ #\* #\' #$ #$)) + (setf (svref res (char-code ch)) nil)) + + ; note: character needing special handling are space and linefeed + (setf (svref res #.(char-code #\space)) 0) + (setf (svref res #.(char-code #\linefeed)) 5) + + + res)) + + +(defun query-to-form-urlencoded (query &key (external-format + *default-aserve-external-format*)) + ;; query is a list of conses, each of which has as its + ;; car the query name and as its cdr the value. A value of + ;; nil means we encode name= and nothing else + ;; encode into single string + (let (res) + (dolist (ent query) + (if* res + then (push "&" res) ; separator + ) + (push (encode-form-urlencoded (car ent) :external-format external-format) + res) + (push "=" res) + (if* (cdr ent) + then (push (encode-form-urlencoded (cdr ent) + :external-format external-format) + res))) + + (apply #'concatenate 'string (nreverse res)))) + + + +(defmacro with-tohex-cvt-buffer ((buffer-var str) &body body) + + #-(and allegro (version>= 6 0)) + ;; Not using a separate buffer + `(let ((,buffer-var ,str)) + (macrolet ((buf-elt (buf i) + `(char-code (char ,buf ,i)))) + ,@body)) + + #+(and allegro (version>= 6 0)) + `(let ((,buffer-var (string-to-octets ,str + :external-format external-format + :null-terminate nil))) + (macrolet ((buf-elt (buf i) + `(aref ,buf ,i))) + ,@body))) + +(defun encode-form-urlencoded (str &key (external-format + *default-aserve-external-format*)) + ;; encode the given string using form-urlencoding + + ;; a x-www-form-urlencoded string consists of a sequence + ;; of name=value items separated by &'s. + ;; Each of the names and values is separately encoded using this function. + + ;; to build a complete x-www-form-urlencoded string use + ;; query-to-form-urlencoded. + + ; first compute if encoding has to be done and what it will + ; cost in space + + (declare (ignorable external-format)) + + (if* (not (stringp str)) + then (setq str (format nil "~a" str))) + + (with-tohex-cvt-buffer (buf str) + (let (extra) + (dotimes (i (length buf)) + (let ((code (buf-elt buf i))) + (let ((this-extra (if* (< code 128) + then (svref *url-form-encode* code) + else 2 ; encode as %xy + ))) + (if* this-extra + then (setq extra (+ (or extra 0) this-extra)))))) + + (if* (null extra) + then ; great, no encoding necessary + str + else ; we have to encode + (let ((ret (make-string (+ (length buf) extra)))) + (do ((from 0 (1+ from)) + (end (length buf)) + (to 0)) + ((>= from end)) + (let* ((code (buf-elt buf from))) + (if* (eq code #.(char-code #\space)) + then ; space -> + + (setf (schar ret to) #\+) + (incf to) + elseif (eq code #.(char-code #\linefeed)) + then (dolist (nch '(#\% #\0 #\d #\% #\0 #\a)) + (setf (schar ret to) nch) + (incf to)) + elseif (or (>= code 128) + (svref *url-form-encode* code)) + then ; char -> %xx + (macrolet ((hex-digit-char (num) + ; number to hex char + `(let ((xnum ,num)) + (if* (> xnum 9) + then (code-char + (+ #.(char-code #\a) + (- xnum 10))) + else (code-char + (+ #.(char-code #\0) + xnum)))))) + (setf (schar ret to) #\%) + (setf (schar ret (+ to 1)) + (hex-digit-char (logand #xf (ash code -4)))) + (setf (schar ret (+ to 2)) + (hex-digit-char (logand #xf code)))) + (incf to 3) + else ; normal char + (setf (schar ret to) (code-char code)) + (incf to)))) + ret))))) + + + + + + + + +(defun form-urlencoded-to-query (str &key (external-format + *default-aserve-external-format*)) + ;; decode the x-www-form-urlencoded string returning a list + ;; of conses, the car being the name and the cdr the value, for + ;; each form element. This list is called a query list. + ;; + + (if* (not (typep str 'simple-array)) + then ; we need it to be a simple array for the code below to work + (setq str (copy-seq str))) + + (let ((res nil) + (max (length str))) + + (do ((i 0) + (start 0) + (name) + (max-minus-1 (1- max)) + (seenpct) + ;; The following is a flag which determines whether we should do + ;; external-format processing on the source string. + ;; Note that we are assuming the source string not to be in Unicode, + ;; but to contain one latin1 octet per element. This is the way + ;; a uri gets returned by parse-uri. + (seen-non-ascii nil) + (ch)) + ((>= i max)) + (setq ch (schar str i)) + + (let (obj) + (if* (or (eq ch #\=) + (eq ch #\&)) + then (setq obj (buffer-substr str start i)) + (setq start (1+ i)) + elseif (eql i max-minus-1) + then (setq obj (buffer-substr str start (1+ i))) + elseif (and (not seenpct) (or (eq ch #\%) + (eq ch #\+))) + then (setq seenpct t) + elseif (and (not seen-non-ascii) + (>= (char-code ch) #.(expt 2 7))) + then (setq seen-non-ascii t)) + + (if* obj + then (if* (or seenpct seen-non-ascii) + then (setq obj (un-hex-escape + obj t + :external-format external-format) + seenpct nil)) + + (if* name + then (push (cons name obj) res) + (setq name nil) + elseif (or (eq ch #\&) + (eq i max-minus-1)) + then ; a name with no value + (push (cons obj "") res) + else ; assert (eq ch #\=) + (setq name obj)))) + + (incf i)) + + (nreverse res))) + +(defmacro with-unhex-cvt-buffer ((buffer-var size) + &body body) + #-(and allegro (version>= 6 0)) + ;; Buffer is a string, which gets returned + `(let ((,buffer-var (make-string ,size))) + (macrolet ((cvt-buf-to-string (x &key external-format end) + (declare (ignore external-format end)) + x) + (set-buf-elt (buf i char) + `(setf (schar ,buf ,i) ,char)) + (buf-elt (buf i) + `(schar ,buf ,i))) + ,@body)) + + #+(and allegro (version>= 6 0)) + ;; Buffer is a static octet array, which gets converted to a string. + `(excl::with-dynamic-extent-usb8-array (,buffer-var ,size) + (macrolet ((cvt-buf-to-string (x &key external-format end) + `(values + (octets-to-string ,x :end ,end + :external-format ,external-format))) + (set-buf-elt (buf i char) + `(setf (aref ,buf ,i) (char-code ,char))) + (buf-elt (buf i) + `(code-char (aref ,buf ,i)))) + ,@body))) + +(defun un-hex-escape (given spacep + &key (external-format + *default-aserve-external-format*)) + ;; convert a string with %xx hex escapes into a string without + ;; if spacep it true then also convert +'s to spaces + ;; + (declare (ignorable external-format)) + (let ((count 0) + (seenplus nil) + ;; The following is a flag which determines whether we should do + ;; external-format processing on the source string. + ;; Note that we are assuming the source string not to be in Unicode, + ;; but to contain one latin1 octet per element. This is the way + ;; a uri gets returned by parse-uri. + (seen-non-ascii nil) + (len (length given))) + + ; compute the number of %'s (times 2) + (do ((i 0 (1+ i))) + ((>= i len)) + (let ((ch (schar given i))) + (if* (eq ch #\%) + then ; check for %0a%0d which is to be converted to #\linefeed + (if* (and (< (+ i 5) len) ; enough chars left + (do ((xi (+ i 1) (+ xi 1)) + (end (+ i 6)) + (pattern '(#\0 #\d #\% #\0 #\a) + (cdr pattern))) + ((>= xi end) t) + (if* (not (char-equal (schar given xi) + (car pattern))) + then (return nil)))) + then ; we are looking at crlf, turn into + ; lindfeed + (incf count 5) ; 5 char shrinkage + (incf i 5) + else (incf count 2) + (incf i 2)) + elseif (eq ch #\+) + then (setq seenplus t) + elseif (>= (char-code ch) #.(expt 2 7)) + then (setq seen-non-ascii t)))) + + (if* (and (null seenplus) + (null seen-non-ascii) + (eq 0 count)) + then ; move along, nothing to do here + (return-from un-hex-escape given)) + + (macrolet ((cvt-ch (ch) + ;; convert hex character to numeric equiv + `(let ((mych (char-code ,ch))) + (if* (<= mych #.(char-code #\9)) + then (- mych #.(char-code #\0)) + else (+ 9 (logand mych 7)))))) + + (with-unhex-cvt-buffer (str (- len count)) + (do ((to 0 (1+ to)) + (from 0 (1+ from))) + ((>= from len) + (cvt-buf-to-string str :end to :external-format external-format)) + (let ((ch (schar given from))) + (if* (eq ch #\%) + then (let ((newchar + (code-char (+ (ash (cvt-ch (schar given (1+ from))) + 4) + (cvt-ch (schar given (+ 2 from))))))) + (if* (and (eq newchar #\linefeed) + (> to 0) + (eq (buf-elt str (1- to)) #\return)) + then ; replace return by linefeed + (decf to)) + + (set-buf-elt str to newchar)) + + (incf from 2) + elseif (and spacep (eq ch #\+)) + then (set-buf-elt str to #\space) + else (set-buf-elt str to ch)))))))) + + + + + + + + + + +;----------------- base64 -------------------- + + +;;;; encoding algorithm: +;; each character is an 8 bit value. +;; three 8 bit values (24 bits) are turned into four 6-bit values (0-63) +;; which are then encoded as characters using the following mapping. +;; Zero values are added to the end of the string in order to get +;; a size divisible by 3 (these 0 values are represented by the = character +;; so that the resulting characters will be discarded on decode) +;; +;; encoding +;; 0-25 A-Z +;; 26-51 a-z +;; 52-61 0-9 +;; 62 + +;; 63 / +;; + + +(defvar *base64-decode* + ;; + ;; use in decoding to map characters to values + ;; + (let ((arr (make-array 128 + :element-type '(unsigned-byte 8) + :initial-element 0))) + (do ((i 0 (1+ i)) + (ch (char-code #\A) (1+ ch))) + ((> ch #.(char-code #\Z))) + (setf (aref arr ch) i)) + (do ((i 26 (1+ i)) + (ch (char-code #\a) (1+ ch))) + ((> ch #.(char-code #\z))) + (setf (aref arr ch) i)) + (do ((i 52 (1+ i)) + (ch (char-code #\0) (1+ ch))) + ((> ch #.(char-code #\9))) + (setf (aref arr ch) i)) + (setf (aref arr (char-code #\+)) 62) + (setf (aref arr (char-code #\/)) 63) + + arr)) + + +(defvar *base64-encode* + ;; + ;; used in encoding to map 6-bit values to characters + ;; + (let ((arr (make-array 64 :element-type 'character))) + (dotimes (i 26) + (setf (schar arr i) + (code-char (+ (char-code #\A) i)))) + (dotimes (i 26) + (setf (schar arr (+ 26 i)) + (code-char (+ (char-code #\a) i)))) + (dotimes (i 10) + (setf (schar arr (+ 52 i)) + (code-char (+ (char-code #\0) i)))) + (setf (schar arr 62) #\+) + (setf (schar arr 63) #\/) + arr)) + +;; note: 12/5/03 +;; beginning in acl 6.2 patch excl.003 there are more efficient built-in +;; functions for doing this conversion: +;; excl:string-to-base64-string [encode] +;; excl:base64-string-to-string [decode] +;; +;; At some future point we'll make use of these functions in AllegroServe +;; and drop the functions below. +;; + + +(defun base64-decode (string) + ;; + ;; given a base64 string, return it decoded. + ;; beware: the result will not be a simple string + ;; + (let ((res (make-array (length string) :element-type 'character + :fill-pointer 0 + :adjustable t)) + (arr *base64-decode*)) + (declare (type (simple-array (unsigned-byte 8) (128)) arr)) + (do ((i 0 (+ i 4)) + (cha) + (chb)) + ((>= i (length string))) + + ; for multiline decoding, ignore cr and lfs + (loop + (let ((ch (char string i))) + (if* (or (eq ch #\linefeed) (eq ch #\return)) + then (incf i) + (if* (>= i (length string)) + then (return-from base64-decode res)) + else (return)))) + + (let ((val (+ (ash (aref arr (char-code (char string i))) 18) + (ash (aref arr (char-code (char string (+ i 1)))) 12) + (ash (aref arr (char-code + (setq cha (char string (+ i 2))))) + 6) + (aref arr (char-code + (setq chb (char string (+ i 3)))))))) + (vector-push-extend (code-char (ash val -16)) res) + ;; when the original size wasn't a mult of 3 there may be + ;; non-characters left over + (if* (not (eq cha #\=)) + then (vector-push-extend (code-char (logand #xff (ash val -8))) res)) + (if* (not (eq chb #\=)) + then (vector-push-extend (code-char (logand #xff val)) res)))) + res)) + + +(defun base64-encode (str) + ;; + ;; take the given string and encode as a base64 string + ;; beware: the result will not be a simple string + ;; + (let ((output (make-array (ceiling (* 1.3 (length str))) + :element-type 'character + :fill-pointer 0 + :adjustable t)) + v1 v2 v3 eol + (from 0) + (max (length str)) + ) + + (loop + (if* (>= from max) + then (return)) + (setq v1 (char-code (schar str from))) + + (incf from) + + (if* (>= from max) + then (setq v2 0 + eol t) + else (setq v2 (char-code (schar str from)))) + + (incf from) + + ; put out first char of encoding + (vector-push-extend (schar *base64-encode* (logand #x3f + (ash v1 -2))) + output) + + ; put out second char of encoding + + (vector-push-extend (schar *base64-encode* + (+ (ash (logand 3 v1) 4) + (logand #xf (ash v2 -4)))) + + output) + + (if* eol + then ; two pads + (vector-push-extend #\= output) + (vector-push-extend #\= output) + (return)) + + (if* (>= from max) + then (setq v3 0 + eol t) + else (setq v3 (char-code (schar str from)))) + + (incf from) + + + ; put out third char of encoding + + (vector-push-extend (schar *base64-encode* + (+ (ash (logand #xf v2) 2) + (logand 3 (ash v3 -6)))) + + output) + + (if* eol + then (vector-push-extend #\= output) + (return)) + + ; put out fourth char of encoding + + (vector-push-extend (schar *base64-encode* (logand #x3f v3)) + output)) + + output)) + + Added: vendor/portableaserve/aserve/defsys.cl =================================================================== --- vendor/portableaserve/aserve/defsys.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/defsys.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,77 @@ +(in-package "CL-USER") + +(defsystem "ASERVE" + (:default-pathname "ASERVE:") + :members + ("./htmlgen/htmlgen" + "macs" + "main" + "headers" + "parse" + "decode" + "publish" + "authorize" + "log" + "client" + "proxy" + ) + :rules + ((:in-order-to :compile "macs" + (:caused-by (:compile "htmlgen")) + (:requires (:load "htmlgen"))) + (:in-order-to :load "macs" + (:requires (:load "htmlgen"))) + + (:in-order-to :compile "main" + (:caused-by (:compile "macs")) + (:requires (:load "macs"))) + (:in-order-to :load "main" + (:requires (:load "macs"))) + + (:in-order-to :compile "headers" + (:caused-by (:compile "main")) + (:requires (:load "main"))) + (:in-order-to :load "headers" + (:requires (:load "main"))) + + (:in-order-to :compile "parse" + (:caused-by (:compile "headers")) + (:requires (:load "headers"))) + (:in-order-to :load "parse" + (:requires (:load "headers"))) + + (:in-order-to :compile "decode" + (:caused-by (:compile "parse")) + (:requires (:load "parse"))) + (:in-order-to :load "decode" + (:requires (:load "parse"))) + + (:in-order-to :compile "publish" + (:caused-by (:compile "decode")) + (:requires (:load "decode"))) + (:in-order-to :load "publish" + (:requires (:load "decode"))) + + (:in-order-to :compile "authorize" + (:caused-by (:compile "publish")) + (:requires (:load "publish"))) + (:in-order-to :load "authorize" + (:requires (:load "publish"))) + + (:in-order-to :compile "log" + (:caused-by (:compile "authorize")) + (:requires (:load "authorize"))) + (:in-order-to :load "log" + (:requires (:load "authorize"))) + + (:in-order-to :compile "client" + (:caused-by (:compile "log")) + (:requires (:load "log"))) + (:in-order-to :load "client" + (:requires (:load "log"))) + + (:in-order-to :compile "proxy" + (:caused-by (:compile "client")) + (:requires (:load "client"))) + (:in-order-to :load "proxy" + (:requires (:load "client"))))) \ No newline at end of file Added: vendor/portableaserve/aserve/doc/.cvsignore =================================================================== --- vendor/portableaserve/aserve/doc/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +{arch} +.arch-ids Added: vendor/portableaserve/aserve/doc/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/doc/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,7 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:02 2004// +/aserve.html/1.4/Tue Dec 2 14:20:40 2003// +/cvs.html/1.1/Sun Jun 9 11:35:00 2002// +/htmlgen.html/1.3/Tue Dec 2 14:20:39 2003// +/rfc2396.txt/1.1.1.1/Mon Aug 6 03:42:39 2001// +/tutorial.html/1.3/Sun Jun 9 11:34:59 2002// +D Added: vendor/portableaserve/aserve/doc/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/doc/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/doc Added: vendor/portableaserve/aserve/doc/CVS/Root =================================================================== --- vendor/portableaserve/aserve/doc/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/doc/aserve.html =================================================================== --- vendor/portableaserve/aserve/doc/aserve.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/aserve.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3103 @@ +<html> + +<head> +<title>AllegroServe</title> +<meta name="GENERATOR" content="Microsoft FrontPage 3.0"> +</head> + +<body> + +<h1 align="center">AllegroServe - A Web Application Server +version 1.2.32</h1> + +copyright(c) 2000-2003. Franz Inc + +<h2 align="left">Table of Contents</h2> + +<a href="#introduction">Introduction</a> +<a href="#running-AllegroServe">Running AllegroServe</a> +<a href="#starting-the-server">Starting the Server</a> +  <a href="#f-start">start</a> +<a href="#shutting-down-the-server">Shutting Down the Server</a> +  <a href="#f-shutdown">shutdown</a> +<a href="#publishing-information">Publishing Information</a> +  <a href="#f-publish-file">publish-file</a> +    <a href="#entity-hook-function">Entity hook function</a> +  <a href="#f-publish-directory">publish-directory</a> +     <a href="#directory-access-files">Directory Access Files</a> +  <a href="#f-publish">publish</a> +     <a href="#f-publish-prefix">publish-prefix</a> +     <a href="#f-publish-multi">publish-multi</a> +<a href="#generating-a-computed-response">Generating a Computed Response</a> +  <a href="#f-with-http-response">with-http-response</a> +  <a href="#f-with-http-body">with-http-body</a> +  <a href="#f-get-request-body">get-request-body</a> +  <a href="#f-header-slot-value">header-slot-value</a> +  <a href="#f-reply-header-slot-value">reply-header-slot-value</a> +  <a href="#f-request-query">request-query</a> +     <a href="#f-request-query-value">request-query-value</a> +<a href="#request-object-readers">Request Object Readers and Accessors</a> +  <a href="#f-request-method">request-method</a> +  <a href="#f-request-uri">request-uri</a> +  <a href="#f-request-protocol">request-protocol</a> +  <a href="#f-request-socket">request-socket</a> +  <a href="#f-request-wserver">request-wserver</a> +  <a href="#f-request-raw-request">request-raw-request</a> +  <a href="#f-request-reply-code">request-reply-code</a> +  <a href="#f-request-reply-date">request-reply-date</a> +  <a href="#f-request-reply-headers">request-reply-headers</a> +  <a href="#f-request-reply-content-length">request-reply-content-length</a> +  <a href="#f-request-reply-plist">request-reply-plist</a> +  <a href="#f-request-reply-strategy">request-reply-strategy</a> +  <a href="#f-request-reply-stream">request-reply-stream</a> +<a href="#cgi-program">CGI Program Execution</a> +  <a href="#f-run-cgi-program">run-cgi-program</a> +<a href="#form-processing">Form Processing</a> +  <a href="#f-get-multipart-header">get-multipart-header</a> +  <a href="#f-parse-multipart-header">parse-multipart-header</a> +  <a href="#f-get-multipart-sequence">get-multipart-sequence</a> +     <a href="#f-get-all-multipart-data">get-all-multipart-data</a> +     <a href="#f-form-urlencoded-">form-urlencoded-to-query</a> +  <a href="#f-query-to">query-to-form-urlencoded</a> +<a href="#authorization">Authorization</a> +  <a href="#f-get-basic-authorization">get-basic-authorization</a> +  <a href="#f-set-basic-authorization">set-basic-authorization</a> +  <a href="#c-password-authorizer">password-authorizer</a> +  <a href="#c-location-authorizer">location-authorizer</a> +     <a href="#c-function-authorizer">function-authorizer</a> +<a href="#cookies">Cookies</a> +  <a href="#f-set-cookie-header">set-cookie-header</a> +  <a href="#f-get-cookie-values">get-cookie-values</a> +<a href="#varaibles">Variables</a> +     <a href="#v-aserve-version">*aserve-version*</a> +  <a href="#v-default-aserve-external-format">*default-aserve-external-format*</a> +  <a href="#v-http-response-timeout">*http-response-timeout*</a> +  <a href="#v-mime-types">*mime-types*</a> +<a href="#iseve-request-proc">AllegroServe Request Processing Protocol +</a>  <a href="#f-handle-request">handle-request</a> +  <a href="#f-standard-locator">standard-locator</a> +  <a href="#f-unpublish-locator">unpublish-locator</a> +  <a href="#f-authorize">authorize</a> +  <a href="#f-failed-request">failed-request</a> +  <a href="#f-denied-request">denied-request</a> +  <a href="#f-process-entity">process-entity</a> +<a href="#cliient-request">Client Functions</a> +  <a href="#f-do-http-request">do-http-request</a> +  <a href="#c-client-request">client-request</a> +  <a href="#c-cookie-jar">cookie-jar</a> +  <a href="#f-make-http-client-request">make-http-client-request</a> +  <a href="#f-read-client-response">read-client-response-headers</a> +  <a href="#f-client-request-read-sequence">client-request-read-sequence</a> +  <a href="#f-client-request-read-close">client-request-close</a> +  <a href="#f-uriencode-string">uriencode-string</a> +<a href="#proxy">Proxy</a> +<a href="#cache">Cache</a> +<a href="#filters">Request Filters</a> +<a href="#virtual_hosts">Virtual Hosts</a> +<a href="#timeouts">Timeouts</a> +  <a href="#f-wserver-io-timeout">wserver-io-timeout</a> +  <a href="#f-wserver-response-timeout">wserver-response-timeout</a> +<a href="#miscellaneous">Miscellaneous</a> +     <a href="#f-ensure-stream-lock">ensure-stream-lock</a> +     <a href="#f-map-entities">map-entities</a> +<a href="#asaservice">Running AllegroServe as a Service on Windows NT</a> +<a href="#international-chars-aserve">Using International Characters in AllegroServe</a> +<a href="#debugging">Debugging</a> +     <a href="#f-debug-on">net.aserve::debug-on</a> +  <a href="#f-debug-off">net.aserve::debug-off</a> + + + + +<h2 align="left">In<a name="introduction"></a>troduction</h2> + +AllegroServe is a webserver  written at <a +href="http://www.franz.com">Franz Inc</a>.  AllegroServe is designed to work +with the <a href="htmlgen.html">htmlgen</a> system for generating dynamic html, as one of +the big advantages of  a web server written in Common Lisp is the ability to generate +html dynamically.  In this document we'll consider the web server and dynamic html +generation to be parts of the same product. + +The design goals of AllegroServe are: + +<ul> + <li>a very small footprint.   It should be possible to make AllegroServe a part of + every application without being concerned about the impact of its size and processing + requirements.</li> + <li>simple configuration.  AllegroServe should start automatically with minimal input + from the user.  </li> + <li>easy to use.   The typical scenarios should be easy to program with just + knowledge of simple html.</li> + <li>usable in commercial applications .</li> + <li>support the latest http protocol (currently HTTP/1.1)</li> + <li>runnable in multiple configurations.    We want to support a program that + just wants to make some part of it visible or configurable by one user through a web + server.  We also want to support  a web site running on a multiprocessor taking + many hits per second.   Finally, we want to support levels in between those + scenarios.</li> +</ul> + +  + +<h2><a name="running-AllegroServe"></a>Running AllegroServe</h2> + +Running  AllegroServe requires that you + +<ul> + <li>load aserve.fasl into Lisp</li> + <li>publish zero or more urls</li> + <li>start the server</li> + <li>publish zero or more urls</li> +</ul> + +We mention publish twice to emphasize that you can publish urls before +and after you start the server. + +  + +<h2><a name="starting-the-server"></a>Starting the server</h2> + +The function net.aserve:start is used to start the +server running. + +<a name="f-start"></a>(start &key port host +listeners chunking keep-alive server setuid setgid +            debug proxy proxy-proxy +cache restore-cache accept-hook ssl ssl-password +            os-processes +external-format) + +If no arguments are given then start  starts a multi-threaded web +server on port 80, which is the standard web server port.    If you are +running this on Unix then you can only allocate port 80 if you are logged in as root or +have made Lisp a set-user-id root program. + +There are quite a few keyword arguments to start, but in practice you +only need be concerned with :port and :listeners. +    The arguments have the following meanings: + +<ul> + <li>port -- the port on which to open the web server.  80 is the default.</li> + <li>host -- the host on which to run the server.  If you don't specify this then the + server will listen on all TCP/IP network interfaces on the machine.   If you + specify "localhost" then the server willl only accept connections from the same + machine.   Other values for host can be used to run AllegroServe only a + particular network interface.  Host can be a name (like "foo.franz.com"), a + dotted ip address "192.168.0.1" or an integer IP address.</li> + <li>listeners -- the number of threads to process http requests.     If + a value isn't given for the :listeners argument then 5 is assumed.   + If  the value is nil or 0 then the server runs in simple + server mode in which the start function doesn't + return - instead it processes the requests itself, one at a time.  If a positive + number is given as the value of :listeners then the server runs in threaded + server mode.   In this mode separate lisp lightweight processes + are started to handle requests from clients, the number of request handing threads is + equal to the value of the :listeners keyword argument.  In this mode + the start function returns after starting the other threads.</li> + <li>chunking -- if true then the server will use the chunked transfer encoding when it's + possible to do so.  This is an optimization and should be left enabled unless you + suspect that it is the cause of some sort of error.   The default is true.</li> + <li>keep-alive -- if true then the server will keep connections alive if requested by the + web client, and if there are sufficient free threads to handle new requests coming in. +    This is an optimization and should be left on.   The default is + true.</li> + <li>server -- if this is a passed a value it must be a wserver object, + which denotes  a particular instance of a web server.   This is for support + of running multiple independent web servers in the same lisp image.  This will be + described in a later section (eventually).</li> + <li>setuid -- after opening the port, change the user id of this process to the given number + (only numbers are allowed, not names).  This will only have an effect on Unix and it + will only succeed if the current user id is root.   You would + want to use this argument if you plan on opening port 80 on Unix, as you + would have to start the server as root but then would want to change the + user id to an account with fewer privileges before allowing possibly malicious people to + connect to it.</li> + <li>setgid -- after opening the port, change the group  id of this process to the given + number (only numbers are allowed, not names).  This will only have an effect on Unix</li> + <li>debug -- if given a number this will print debugging messages whose associated codes are + this number or less.    This is really an internal switch and may be + removed in future versions.</li> + <li>proxy -- if true then this server will also act as a proxy server and will forward http + requests to other servers.</li> + <li>proxy-proxy -- if proxy is also given a true value, then this argument + determines where the proxy will forward  requests.  If proxy-proxy is nil then + the requests go directly to the server given in the request.  If proxy-proxy is + given  a value of a host and an optional port then the request is forwarded to the + proxy server at that address.   Valid values for proxy-proxy look like + "proxy.myfirm.com" and "localhost:8000".   If no port is not + specified, port 80 is assumed.</li> + <li>cache -- if true (and if proxy is true as well) cache locally the work done by the proxy + server.  The value of this variable specifies the size of the caches, both memory and + disk.  See the section on caches for more details on the format of the argument.</li> + <li>restore-cache - if given a value then this value should be the name of the file created + by net.aserve:shutdown when given the save-cache + argument.   The state of the cache is restored as of when it was saved. +    This will only succeed if the external cache files that were in use when the shutdown + was done are in exactly the same state they were when the shutdown was + done.   When the restore-cache argument is given, the value of + the cache argument is ignored.</li> + <li>accept-hook -- this should be a function of one argument, the socket which was created + when a http request was accepted by AllegroServe.  The function should return a + socket for AllegroServe to use.  This hook is normally used to turn a regular socket + into an SSL socket.</li> + <li>ssl - if true then it should be the name of PEM encoded file containing the server + certificate and the associated private key.  This causes the server to listen for SSL + connections only.  The default value of port is made 443 (rather + than 80).  This makes use of the accept-hook argument so if ssl + is specified then accept-hook should not be specified.   ssl is + supported only in certain versions of Allegro CL.</li> + <li>ssl-password - if the private key in the PEM encoded file referenced by the ssl + argument is encrypted, then this is the key to decrypt it.</li> + <li>os-processes - if given it should be an integer number of operating system processes in + which to run AllegroServe.  This is available on Unix only at the moment.  The + AllegroServes in different processes do not share a common Lisp heap.. +   </li> + <li>external-format - If given it should name the value to which + *default-aserve-external-format* should be bound to when requests are processed.  The + default value is :latin1-base</li> +</ul> + +  + +<h2><a name="shutting-down-the-server"></a>Shutting down the server</h2> + +<a name="f-shutdown"></a>(shutdown &key server +save-cache) + +This shuts down the web server given (or the most recently started web server if no +argument is passed for server).  If save-cache is +given then it should be the name of a file to which the current state of the proxy cache +will be written.   The save-cache file will only contain +in-memory information about the cache.  The cache usually consists of disk files as +well and in order to maintain the complete state of the cache these files must be saved by +the user as well.  The information in the save-cache file refers to +the disk cache files so those disk cache files must exist and be in the same state and +location should the user choose to restore the state of the cache. + +  + +<h2><a name="publishing-information"></a>Publishing information</h2> + +Once the server is started it will accept requests from http clients, typically web +browsers.   Each request is parsed and then AllegroServe searches for an object +to handle that request.   That object is called an entity.  +If an entity is found, it is passed the request and is responsible for generating and +sending a response to the client.  If an entity can't be found then AllegroServe +sends back a response saying that that request was invalid. + +Publishing is the process of creating entities and registering them in the +tables scanned by AllegroServe after a request is read. + +<h3>Components of a request</h3> + +A request from an http client contains a lot of information.  The two items that +determine which entity will handle the request are + +<ul> + <li>the path of the url.  This is the part of the url after the host + name and before the query string (if any).  For example in the url  http://bar.com:8030/files/foo?xx=3&yy=4 + the part we call the path  is just /files/foo. + If the path contains escaped characters (e.g. /foo%20bar) then we replace the %xx + in the path with the actual character before processing the request.  Thus if you're + publishing an entity to handle a uri such as http://www.machine.com/foo%20bar + you should publish the path "foo bar" and not "foo%20bar".</li> + <li>the host to which the request is directed.   This is not + necessarily the host that is receiving the request due to virtual hosts and proxy + servers.  This value comes from the Host: header line, if one is + given. </li> +</ul> + +  + +  + +A request contains other information and while that information isn't used to determine +which entity will handle the request it can be used by the entity handling the request in +any way it sees fit. + +  + +The following functions create entities and specify which requests they will handle. +   An entity is distinguished by the path and host +values passed to the particular publish function.   When a publish +is done for a path and host for which there is already +an entity assigned, the old entity is replaced by the new entity. + +  + +<a name="f-publish-file"></a>(publish-file &key +path host port  file content-type class preload cache-p remove +                   +authorizer server timeout plist hook) + +This creates an entity that will return the contents of a file on the disk in response +to a request.   The url and file  must be +given, the rest of the arguments are optional..  The arguments have these meanings: + +<ul> + <li>path -- a string that must match the name part of the url as described + above in Components of a Request</li> + <li>host -- normally nil.  If you wish to do virtual + hosting read <a href="#virtual_hosts">this section</a> describing how it's done.a</li> + <li>port -- this argument is currently unused and will likely be removed in + future versions.</li> + <li>file -- the name of the file to return when a request to this entity is + made.   The file doesn't have to exist until the request is made unless preload + is specified as true.</li> + <li>content-type -- A string describing the content of the file.  This + is often referred to as the MIME type of the file.  An example is + "text/html" to describe an html file.  If a content-type value is not + provided, then AllegroServe checks the pathname-type in the  *mime-types* hash table + to see if there is a content-type associated with this pathname-type.  If it fails to + find a content-type then it uses the type "application/octet-stream".  </li> + <li>class -- a Clos class name or class object to be used to hold this + entity.  The class must be a subclass of  file-entity. +    </li> + <li>preload --if true it instructs AllegroServe to read + the contents of the file in immediately and store it in a lisp object.  This will + speed up the response to this request.  If the file on disk is updated AllegroServe + will ignore the preloaded content and will access the content from disk.   If preload + is true then you most likely want to specify cache-p true as well.</li> + <li>cache-p -- if true then AllegroServe will cache the + last value read for this file.  When asked for this file AllegroServe + will check to see if the file has changed on disk (using the last modified time as a + measure).  If the file hasn't changed AllegroServe will returned the cached value, + otherwise AllegroServe will read in and cache the new contents of the + file and will return that as a response.</li> + <li>remove -- instead of adding an entity, remove the entities that match + the given path and host. This removes all entities, not + just file entities.  If a host value is not passed in an argument, + then this will remove all entities for this path, regardless of their host + values.</li> + <li>server -- if this entity should only be served by a particular server, + then this specifies which server.   See the section (to be written) on running + multiple servers in the same Lisp process.</li> + <li>timeout - specifies the number of seconds AllegroServe has to return + this file to the http client.  If AllegroServe is running in a lisp that supports + timeouts on each I/O operation (e.g. Acl 6.1 or newer) then the default value for this + argument is a huge number, meaning in effect that there will be no time limit on the + transfer.   If I/O timeouts are not supported then the default value of this + argument is nil meaning ignore this value and use the timeout value held + in the server object and retrieved with wserver-response-timeout..</li> + <li>plist - initial property list for this entity</li> + <li>hook - a function of three arguments: req,ent and extra.    + See <a href="#entity-hook-function">entity hook function</a>.</li> +</ul> + +The function that handles requests for files will respond correctly to If-Modified-Since +header lines and thus minimizes network traffic. + +Example: + +This will work on Unix where the password file is stored in /etc. + +<pre>(publish-file :path "/password" :file "/etc/passwd" :content-type "text/plain")</pre> + +<h3><a name="entity-hook-function"></a>Entity Hook Function</h3> + +AllegroServe supplies many subclasses of entity which automatically generate a +responses to requests.     There are times when user code needs to run +during the generation of  a response by one of the built-in entity classes. +   For example you may wish to add or modify the headers that will be sent back +with the publish-file's response.    The entity hook +function is called just before the with-http-body in the response +function.  At this point all the response headers have been specified but the hook +function is free to change them or add new headers. + +The entity hook function takes three arguments: req, ent +and extra.   Req and ent are +the familiar http-request and entity arguments.   Extra is +usually nil but will be one of the following symbols to tell  the +hook function if it's being called in a special context. + +<table border="1" width="100%"> + <tr> + <td width="21%">:illegal-range</td> + <td width="79%">request has asked for a range of bytes that is not present in the entity. +   As a result a "416 - Illegal Range Specified"  response is being + generated.</td> + </tr> + <tr> + <td width="21%">:in-range</td> + <td width="79%">request has asked for a range of bytes and that range is being returned.</td> + </tr> + <tr> + <td width="21%">:not-modified</td> + <td width="79%">request contains an "If Not Modified" header and AllegroServe is + returning a "304 - Not Modified" response.</td> + </tr> +</table> + +  + +  + +<a name="f-publish-directory"></a>(publish-directory +&key prefix host port destination remove authorizer server +                        +indexes filter timeout plist publisher access-file +                        +hook) + +publish-directory is used to publish a complete directory tree of +files.  This is similar to how web servers such as Apache publish files.   +AllegroServe publishes the files in  the directory tree in a lazy +manner.   As files in the tree are referenced by client requests entities are +created and published.  + +publish-directory creates a mapping from all urls whose name begins +with prefix to files stored in the directory specified by the destination.   +The host, port, remove, authorizer, plist, hook and server +arguments are as described above for publish-file. +     The timeout argument defaults as described in publish-file. + The hook argument specifies what hook function should be put in the +entities that publish-directory creates.   The access-file +argument names the <a href="#directory-access-files">access file</a> name which will be +used in this directory tree. When a request comes in for which there isn't an entity that +matches it exactly,  AllegroServe checks to see if a prefix of the request has been +registered.  If so, and if the resulting entity is a directory-entity +as created by this function, then it strips the prefix off the given request and appends +the remaining part of the request to the destination string.  It then publishes that +(normally using publish-file and computing the content-type from the file +type).    Next that file-entity is made to handle the request +in the normal manner. + +If a request comes that maps to a directory rather than a file then AllegroServe tries +to locate an index file for that directory.  The indexes argument +specifies a list of index files to search for.  By default the list consists of two +filenames "index.html" and "index.htm". + +The valueof the filter argument is a function of four values: req +ent  filename and info.  req +and ent are the request and entity objects that describe the current +client request.     filename is the name of a known file +on the current machine which  is being requested by the current request.  info +is the list of <a href="#directory-access-files">access information</a> for this file. + +If the filter returns nil then the normal operation  is done by +the directory-entity handler: the selected file is published and then the request to +access it processed (and subsequent access using that url will just return the file and +never go through the filter again). + +If the filter chooses to handle the request for the file itself  it must generate +a response to the request and then return a non-nil value.  To avoid subsequent calls +to the filter for this file the filter may choose to publish a handler for this url. +  If the filter wants to forbid access to this file a handy way to to call (failed-request req) and the standard "404 Not found" +will be sent back to the client. + +The publisher argument can be used to specify exactly what happens +when a request comes that's handled by the directory-entity and a file is +located on the disk that matches the incoming url.   Nomally a publish-file +is done to add that file.  You may want to publish some other kind of entity to +represent that file.  The publisher argument, if non-nil, must be a +function of  four arguments:  req ent filename info.  +The filename is a string naming the file that's been matched with the request.   +info is the list of <a href="#directory-access-files">access information</a> +for this file.  The publisher function must return an entity to be +processed to send back a response.   The publisher function may +wish to publish that entity but it need not do so. +<div align="center"><center> + +<table border="1" width="86%" cellpadding="5"> + <tr> + <td width="100%">Note:  publish-directory is a more general function + than its name implies.    It looks at each url path for a match for prefix + and if such a match is found the prefix is removed and replaced + with destination.   Thus is prefix is "/foo" + and destination is "/bar" then a url path of  "/foobaz/joe.html" + would be converted to "/barbaz/joe.html". +     This is rarely useful but it does show that you have to be careful + about the prefix and destination strings.  It's usually the case that if the prefix + string ends in "/" then the destination string should end in "/" + (and vice versa).  Thus a prefix of "/foo" would have a + destination of "/bar" and a prefix of "/foo/" + would have a destination of "/bar/".  </td> + </tr> +</table> +</center></div> + +  + +<h3><a name="directory-access-files"></a>Directory Access Files</h3> + +When files are accessed and automatically published you may wish to set some of the +parameters of the entity that is published. As mentioned above you can define a publisher +function that has complete control in publishing the entity.  A less powerful but +easier to use alternative is to place access files in the directory tree being +published.   An access file specifies information that you want passed to the +publisher function.  You can modify these access files while the directory tree is +published and their latest values will be used for publishing subsequent files. +   This is similar to they way Apache controls its publishing with .htaccess +files (except that in AllegroServe once a file is published the access files have no +effect on it). + +The name of an access file in AllegroServe is controlled by the :access-file +argument to publish-directory.   We'll assume the name chosen +is access.cl in this document.   If no :access-file +argument is given to publish-directory then no access file checking is +done.  When a file is about to be published all access files from the destination +directory all the way down to the directory containing the file to be published are read +and used.  For example if the destination in a publish-directory +was given as "/home/joe/html/" and an http request comes in which +references the file "/home/joe/html/pics/archive/foo.jpg"  then +AllegroServe will check for access files at all of these locations and in this +order + +<ul> + <li>/home/joe/html/access.cl</li> + <li>/home/joe/html/pics/access.cl</li> + <li>/home/joe/html/pics/archive/access.cl</li> +</ul> + +The information is collected as successive access files are read.  The new +information is placed before the existing information thus causing subdirectory   +access files to possibly shadow information in access files in directories above it.  +Also superdirectory access file information is automatically eliminated if it isn't marked +as being inherited.  + +The publisher function receives the collected information and can do +with it what it wishes.  We'll describe what the built-in publisher function does +with the information. + +When we speak of information in access files we are purposely +being vague.   We define what information must look like and what the standard +publisher function does with certain information but we allow users to define their own +kinds of information and use that in their own publisher function. + +Each access file consists of zero or more Lisp forms (and possibly lisp style +comments).  Each form is  a list beginning with a keyword symbol and then +followed by a property-list-like sequence of   keywords and values.   +Nothing in the form is evaluated.     The form cannot contain #. or #,. +macros. + +One  information form is used by AllegroServe's directory publisher code to decide +if it's permitted to descend another directory level: + +(:subdirectories  :allow allow-list :deny deny-list +:inherit inherit-value) + +As AllegroServe descends from the destination directory toward the +directory containing the file to be accessed it stops at each directory level accumlates +the access information and then tests to see if it can descend further based on the :subdirectories +information.   If it cannot descend into the next subdirectory it gives +up immediately and a 404 - Not Found response is returned.    +See the section Allow Deny processing below for a description of how it uses the :allow +and :deny values. + +These other information forms are used by the standard publisher function.    +Each takes an :inherit argument which defaults to false.   +Information not given with ::inherit t will be eliminated as AllegroServe +descends directory levels. + +<table border="1" width="100%"> + <tr> + <th width="15%">name</th> + <th width="17%">args</th> + <th width="68%">meaning</th> + </tr> + <tr> + <td width="15%">:ip</td> + <td width="17%">:patterns + :inherit</td> + <td width="68%">specifies a<a href="#c-location-authorizer"> location-authorizer</a> + restriction on which machines can see published files.  The value of the :patterns + argument has the same form as the :patterns slot of a + location-authorizer.</td> + </tr> + <tr> + <td width="15%">:password</td> + <td width="17%">:realm + :allowed + :inherit</td> + <td width="68%">specifies a <a href="#c-password-authorizer">password-authorizer</a> + restriction on access to published files.   See the password-authorizer documentation + for a description of the :realm and :allowed arguments</td> + </tr> + <tr> + <td width="15%">:files</td> + <td width="17%">:allow + :deny + :inherit</td> + <td width="68%">specifies which files are visible to be published.  To be visible a + file must be allowed and not denied.  What is tested is the filename only (that is + the part after the last directory separator in the files's complete name).  See below + for the rules on how allow and denied is used.</td> + </tr> + <tr> + <td width="15%">:mime</td> + <td width="17%">:types + :inherit</td> + <td width="68%">specifies which mime types are to be associated with which file types. +   This list takes precedence over the built-in list inside AllegroServe.  :types + is a list of mime specifiers.   A mime specifier is a list beginning with a + string giving the mime type followed by the files types that should map to that mime type. +   A file type in a list (e.g. ("ReadMe")) refers to the whole file name + rather than the type component.</td> + </tr> +</table> + +<h3>Allow and Deny Processing</h3> + +The :files and :subdirectories information are used +to determine if a file or subdirectory of a given name is accessible.  AllegroServe +will collect all the access file information for the directory containing the file or +subdirectory and for all directories above it up to the directory given as the destination +argument to publish-directory.  Information from superdirectories +will only be used :inherit t is given for that information.  + +The rules is it that a given name is accessible if it is allowed and not denied.   +That is the filename or directory name must match one of the allow clauses and none of the +deny clauses.  There may be multiple allow and deny clauses since there may be +multiple information forms of the type :files or :subdirectories. +   Each allow or deny argument can be a string or a list of strings or nil +(which is the same as that argument not being given).   The strings +are regular expressions (which are not exactly like unix shell wildcard filename +expressions).   In particular ".*" is +the regular expression that matches anything. + +The special cases are the following + +<ul> + <li>if :allow is given as nil or is not given at all then that is the same + as specifying ".*" the regular expression that + matches everything.</li> + <li>if :deny is given as nil or is not given then that is the same as + specifying a regular expression that matches nothing.</li> + <li>if AllegroServe is looking for :files information and there is none to + be found in the accumulated information, then access is allowed.   A similar + thing is true if AllegroServe is searching for :subdirectories + information and none is found.</li> +</ul> + +  + +. + +Here is a sample access file: + +; only connections to localhost will be able to access the +files +(:ip :patterns ((:accept "127.1") :deny) :inherit t)    +(:password :realm "mysite" +           :allowed (("joe" . +"mypassword") +                     +("sam" . "secret")) +           :inherit t) ;  applies +to subdirectories +; publish html and cgi files, but not those beginning with a period +(:files :allow ("\\.html$" "\\.cgi$") :deny ("^\\.")) +; specify mime type for non-standard file extensions.  Also +; specify that a file named exactly ChangeLog should be given +; mime type "text/plain" +(:mime :types (("text/jil" "jil" "jlc") +("text/plain" "cl" ("ChangeLog")))) + +  + +  + +<a name="f-publish"></a>(publish &key path host +port content-type function class format remove server authorizer timeout plist hook) + +This creates a mapping from a url to a computed-entity, that is an +entity that computes its response every time a request comes in.  The path, +host, port, remove, server , authorizer, +hook and class arguments are as in the other publish +functions.  The timeout argument defaults to nil always.   +The content-type sets a default value for the response to the request but +this can be overridden.  The format argument is either :text +(the default) or :binary and it specifies the kind of value that +will be sent back (after the response headers, which are always in text).   This +value is only important if the response is generated in a particular way (described +below).   The value of the hook argument is stored in the +entity created however the hook function will only be run if the function +supplied makes use of it. + +The function argument is  a function of two arguments: an object +of class http-request that holds a description of the request, and an +object of class entity that holds this entity which is handling the +request.   This function must generate a response to the http request, even if +the response is only that the request wasn't found. + +  + +<a name="f-publish"></a><a name="f-publish-prefix"></a>(publish-prefix +&key prefix host port content-type function class +                     +format remove server authorizer timeout plist hook) + +This is like publish except that it declares function +to be the handler for all urls that begin with the string prefix. +   Note however that prefix handlers have lower priority than exact handlers. +  Thus if you declare a prefix handler for "/foo" and also a specific +handler for "/foo/bar.html" then the specific handler will be chosen if +"/foo/bar.html" is found in an http request.   Typically a prefix +handler is used to make available a whole directory of files since their complete names +being with a common prefix (namely the directory in which the files are located). +   If you want to publish a whole directory then you probably want to use publish-directory +since it has a number of features to support file publishing.   The value of the +hook argument is stored in the entity created however the hook function will only +be run if the function supplied makes use of it. + +  + +<a name="f-publish-multi"></a>(publish-multi &key +path host port content-type items class remove server authorizer timeout hook) + +Some web pages are created from information from various sources.   publish-multi +allows you to specify a sequence of places that supply data for the combined web page. +  The data for each page is cached by publish-multi so that minimal +computation is required each time the page is requested.    + +The host, port, content-type, class, remove, server, authorizer, hook and +timeout arguments are the same as those of the other publish functions. +   The items argument is unique to publish-multi +and is a list of zero or more of the following objects + +<ul> + <li>string or pathname - this is a reference to a file on the server.  This item + contributes the contents of the file to the final web page.</li> + <li>symbol or function - this is a function of four arguments: req ent cached-time + cached-value.   It returns two values:  the new value and the last + modified time of the value.   The function may look at the cached-value or + cached-time and realize that nothing has changed since that time that would cause this + function to return a new value.  In that case it should return the cached-value and + cached-time that it received as arguments.   If a value must always be computed + each time the function is called it may return nil for the last modified + time.  This will result in no LastModified header being sent in the response. +    The value the function returns can either be a string or an array of + unsigned-byte 8 values.   It's preferred to return an array of unsigned-byte 8 + values.  If a string is returned then it will be converted to an + array of unsigned-byte 8 by using (string-to-octets string :null-terminate nil). +    The cached-value argument to the function will be nil + or an unsigned-byte 8 array.</li> + <li>(:string string) - this item supplies the given string + to the web page.</li> + <li>(:binary vector) - vector should be a one dimensional simple-array of + (unsigned-byte 8).  This vector of bytes is added to the web page.</li> +</ul> + +Here's an example where we create a page from a fixed header and trailer page with a +bit of dynamic content in the middle. + +<pre>(publish-multi :path "/thetime" + :items (list "header.html" + #'(lambda (req ent old-time old-val) + (declare (ignore req ent old-time old-val)) + (with-output-to-string (p) + (html-stream p + :br + "The time is " + (:princ (get-universal-time)) + (:b + "Lisp Universal Time") + :br))) + "footer.html")) + </pre> + +<h2><a name="generating-a-computed-response"></a>Generating a computed response </h2> + +There are a variety of ways that a response can be sent back to the http client +depending on whether keep-alive is being done, chunking is possible, whether the response +is text or binary, whether the client already has the most recent data, and whether the +size of the body of the response is known before the headers are sent.  AllegroServe +handles the complexity of determining the optimal response strategy and the user need only +use a few specific macros in the computation of the response in order to take advantage of +AllegroServe's strategy computation + +Here's a very simple computed response.  It just puts "Hello World!" in +the browser window: + +<pre>(publish :path "/hello" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "Hello World!"))))) + + + +</pre> + +This example works regardless of whether the request comes in from an old +HTTP/0.9 browser or a modern HTTP/1.1 browser.  It may or may not send the response +back with Chunked transfer encoding and it may or may not keep the connection alive after +sending back the response.   The user code doesn't have to deal with those +possibilities, it just uses with-http-response and with-http-body +and the rest is automatic.  The html macro is part of the htmlgen +package that accompanies AllegroServe.   In the case above we are being lazy and +not putting out the html directives that should be found on every page of html since most +browsers are accommodating.   Here's the function that generates the correct +html: +<div align="left"> + +<pre>(publish :path "/hello2" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:body "Hello World!")))))))</pre> +</div> + +  + +The function above generates: <html><body>Hello +World!</body></html>. + +  + +The macros and functions used in computing responses are these: + +<hr> + +<a name="f-with-http-response"></a>(with-http-response +(req ent &key timeout check-modified format response content-type) +                    +&rest body) + +This macro begins the process of generating a response to an http request +and then  runs the code in the body which will actually send out the +response.  req and ent are the request and entity +objects passed into the function designated to compute the response for the request. +    timeout sets a time limit for the computation of the +response.   If timeout is nil then the entity ent +is checked for a timeout value.  If that value is also nil then the timeout value is +retreived from the current wserver object using wserver-response-timeout. +  If check-modified is true (the default) then the last-modified +time stored in the entity object will be compared against the if-modified-since +time of the request and if that indicates that the client already has the latest +copy of this entity then a not-modified response will be automatically +returned to the client and the body of this macro will not be +run.   response is an object containing the code and +description of the http response we wish to return.    The default value is the +value of *response-ok* (which has a code of 200 and a string descriptor +"OK").   content-type is a string describing the MIME +type of the body (if any) sent after the headers.  It has a form like +"text/html".   If content-type isn't given here then +the content-type value in the entity (which is set in the call to publish) +will be used. + +The format argument specifies whether the code that +writes the body of the response will want to write :text (e.g. write-char) +or :binary (e.g. write-byte) when it writes the data of +the body of the response.      Based on the value of the format +argument, AllegroServe will create the correct kind of response stream.   If format +is not specified here it will default to the value specified when publish +was called to create the entity.  If not :format argument was passed +to publish then :binary format is assumed. +    If :binary is specified then you can write both text +and binary to the stream  since Allegro's binary streams also support text calls as +well.  If you specify :text then you may end up with a stream that +supports only text operations. + +An http response consists of a line describing the response code, followed +by headers (unless it's the HTTP/0.9 protocol in which case there are no headers), +   and then followed by the body (if any) of the response.   with-http-response +doesn't normally send anything to the client.  It only does so when it determines +that the if-modified-since predicate doesn't hold and that it must send +back a not-modified response.    Thus  is not enough +to just call with-http-response in your response function.  You must +always call with-http-body inside the call to with-http-response. + +  + +<hr> + +<a name="f-with-http-body"></a>(with-http-body +(req ent &key format headers external-format)  &rest body) + +This macro causes the whole http response to be sent out.  The macro +itself will send out everything except the body of the response.  That is the +responsibility of the code supplied as the body form of the macro. +    In cases where there is no body to the response being sent it is still +necessary to call with-http-body so that the other parts of the response +are sent out, e.g. at a minimum you should put (with-http-body (req ent)) in the body of a with-http-response. + +The body forms may not be executed! If the +request is an http head request then the browser wants only the headers +returned.   The with-http-body macro will not evaulate the body +forms.   You must be aware of this and should never put code in the body +form that absolutely must be executed when a request is given. + +The headers argument is a list of conses, where the car +is the header name (a keyword symbol) and the cdr is the header value.  These headers +are added to the headers sent as part of this response. + +Within the body forms the code calls (request-reply-stream +req) to obtain a stream to which it can write to supply the body of the response. +  The external-format of this stream is set to the value of the external-format +argument (which defaults to the value of *default-aserve-external-format*).   +The variable *html-stream* is bound to the value of (request-reply-stream +req) before the body is evaluated.   This makes it +easy  to use the html macro to generate html as part of the +response. + +Note: there used to be a :format argument to with-http-body. +That argument was never used by with-http-body.  The :format +argument has been moved to with-http-response so that it can now +have an effect on the stream created. + +<hr> + +<a name="f-get-request-body"></a>(get-request-body +request &key external-format) + +Return the body of the request as a string.  If there is no body the return value +will be an empty string.   The result is cached inside the request object, so +this function can be called more than once while processing a request.   The +typical reason for there to be a body to a request is when a web browser sends the result +of a form with  a POST method.   The octets that make up the body of the +request are converted to a string (and then cached) using the :octets +external format as this is the appropriate external format if the request body contains a +list of form values. + +If an external-format is specified the body is reconverted to a string +using the given external-format and then returned from this function.   This +reconversion does not affect the cached value. + +<hr> + +<a name="f-header-slot-value"></a>(header-slot-value +request header-name) + +Return the value given in the request for the given header-name (a keyword symbol). +     If the header wasn't present in this request then nil will +be returned.   header-slot-value is a macro that will expand +into a fast accessor if the header-name is a constant naming a known +header slot + +In older versions of aserve the header-name was a string.. + +  + +<hr> + +<a name="f-reply-header-slot-value"></a>(reply-header-slot-value +request header-name) + +Return the value associated with the header header-name in the reply +sent back to the client.  This function is setf'able and this is the preferred way to +specify headers and values to be sent with a reply. + +<hr> + +<a name="f-request-query"></a>(request-query request +&key uri post external-format) + +Decode and return an alist of the query values in the request.   Each item in +the alist is a cons where the car is a string giving the name of the argument and the cdr +is a string giving the value of the argument. + +The query string is in one or both of two places: + +<ul> + <li>it begins at the first question mark in the uri and continues until the end of the uri + or a sharp sign (#), whichever comes first.</li> + <li>it is in the body of a POST request from a web client.</li> +</ul> + +request-query will by default look in both locations for the query +string and concatenate the results of decoding both query strings.  If you would like +it to not check one or both of the locations you can use the :uri and :post +keyword arguments.   If uri is true (and true is the default +value) then the query string in the uri is checked.  If post is true +(and true is the default value) and if the request is a POST then the body of the post +form will be decoded for query values. + +The external-format is used in the conversion of bytes in the form to +characters.  It defaults to the value of *default-aserve-external-format*. + +A query is normally a set of names and values.  +http://foo.com/bar?a=3&b=4 yields a query alist (("a" +. "3") ("b" . "4")). +If a name doesn't have an associated value then the value in the alist is the empty +string.  +http://foo.com/bar?a&b=&c=4   yields a query alist (("a" +. "") ("b" . "") (c . "4")) + +.   + +<a name="f-request-query-value"></a>(request-query-value +key request &key uri post external-format test) + +This combines a call to request-query to retrieve the alist of query +keys and values, with a call to assoc to search for the specific key, and +finally with a call to cdr to return just the value from the assoc list +entry.  The test argument is the function to be used to test the +given key against the keys in the assoc list. It defaults to #'equal. + +If the given key is not present in the query nil is returned. +  If the given key is present in the query but doesn't have an associated +value then the empty string is returned. + +<hr> + +  + +<h2><a name="request-object-readers"></a>Request Object Reader and Accessors</h2> + +The request object contains information about the http request being processed and it +contains information about the response that is being computed and returned to the +requestor.   The following functions access slots of the request object.   +Those with names beginning with request-reply- are accessing the slots +which hold information about the response to the request.   When a function is +listed as an accessor that means that it can be setf'ed +as well as used to read the slot value. + +  + +<a name="f-request-method"></a>(request-method +request) - reader - a keyword symbol naming the kind of request, typically +:get, :put or :post. + +<a name="f-request-uri"></a>(request-uri request) +- reader - a uri object describing the request.   If the request contains a +"Host:" header line then the value of this header is placed in the uri-host and +uri-port slots of this uri object. + +<a name="f-request-protocol"></a>(request-protocol +request) - reader - a keyword symbol naming the http protocol +requested.  It is either :http/0.9, :http/1.0 or :http/1.1. + +<a name="f-request-protocol-string"></a>(request-protocol-string +request) - reader - a string naming the http protocol requested. It is +either "HTTP/0.9", "HTTP/1.0" or "HTTP/1.1". + +<a name="f-request-socket"></a>(request-socket +request) - reader - the socket object through which the request was made +and to which the response must be sent.    This object can be used to +determine the IP address of the requestor. + +<a name="f-request-wserver"></a>(request-wserver +request) - reader - the wserver object describing the web server taking +this request + +<a name="f-request-raw-request"></a>(request-raw-request +request) - reader -  a string holding the exact request made by the +client + +  + +<a name="f-request-reply-code"></a>(request-reply-code +request)      - accessor - the value describes the +response code and string we will return for this request.   See the value of the +argument response in with-http-response for more +information. + +<a name="f-request-reply-date"></a>(request-reply-date +request)      - accessor - the date the response will +be made (in Lisp's universal time format).  This defaults to the time when the +request arrived. + +<a name="f-request-reply-headers"></a>(request-reply-headers +request) - accessor - an alist of some of the headers to send out with the +reply (other headers values are stored in specific slots of the request object).  +Each entry in the alist is a cons where the car is a keyword symbol +holding the header name and the cdr is the value (it is printed using the +~a format directive).    Typically request-reply-headers +isn't used, instead the headers to be sent are passed as the :header +argument to with-http-body, or (setf reply-header-slot-value) +is called. + +<a name="f-request-reply-content-length"></a>(request-reply-content-length +request)     - accessor -  the value to send as the +Content-Length of this response.   This is computed automatically by +AllegroServe and thus a user program shouldn't have to set this slot under normal +circumstances. + +<a name="f-request-reply-plist"></a>(request-reply-plist +request)      - accessor -  this slot holds a +property list on which AllegroServe uses to store  less important information.  +The user program can use it as well. + +<a name="f-request-reply-strategy"></a>(request-reply-strategy +request)   - accessor - the strategy is a list of symbols which +describe how AllegroServe will build a response stream and will send back a +response.  More details will be given about the possible strategies at a future time. + +<a name="f-request-reply-stream"></a>(request-reply-stream +request)       - accessor -  This is the +stream to be used in user code to send back the body of the response.    +This stream must  be used instead of the value of request-socket. + +  + +<hr> + +<h2><a name="cgi-program"></a>CGI Program Execution</h2> + +The <a href="http://hoohoo.ncsa.uiuc.edu/cgi/interface.html">Common Gateway Interface</a> +(CGI) specification allows web servers to run programs in response to http requests and to +send the results of  the execution of those programs back the web client. +   The CGI programs finds information about the request in its environment +variables and, in the case of a put or post request, the +body of the request is sent to standard input of the program. + +CGI is a clumsy and slow protocol for extending the behavior or a web server and is +falling out of favor.  However there are legacy CGI applications you may need to call +from AllegroServe.   You invoke an external program using the CGI protocol with +the run-cgi-program function. + +<a name="f-run-cgi-program"></a>(run-cgi-program req +ent program &key path-info path-translated +                                      +script-name query-string +                                      +auth-type timeout error-output env) + +In response to an http request, this runs program which must be a +string naming an exectuable program or script followed optionally by command line +arguments to pass to that program.  Before the program is run the +environment variables are set according the the CGI protocol.  The timeout +argument is how long AllegroServe should wait for a response from the program before +giving up.   The default is 200 seconds.   The error-output argument +specifies what should be done with data the cgi program sends to its standard error. +  This is described in detail below.  The other keyword arguments allow the +caller to specify values for the CGI environment variables that can't be computed +automatically.  path-info specifies the PATH_INFO environment +variable, and similarly for path-translated, script-name, query-string +and auth-type.   If query-string is not +given and the uri that invoked this request contains a query part then +that query part is passed in the QUERY_STRING environment variable.   If script-name +is not given then its value defaults to the path of the uri of the request.   If +you wish to add or modify the environment variables set for the cgi process you can +specify a value for env.  The value of env should +be a list of conses, the car of each cons containing the environment variable name (a +string) and the cdr of each cons containing the environment variable value (a +string).   env is checked after all the standard environment +variables are computed and the value given in env will override the value +computed automatically. + +cgi programs send their result to standard output (file descriptor 1 on Unix).  If +they encounter problems they often send informative messages to standard error (file +descriptor 2 on Unix).    The error-output argument to +run-cgi-program allows the caller to specify what happens to data sent to standard error. +  The possibile values for error-output are: + +<table border="1" width="100%"> + <tr> + <td width="32%">nil</td> + <td width="68%">The cgi program's standard error is made the same as the Lisp process' + standard error.   This standard error may not be the same as the current binding + of *standard-error*.</td> + </tr> + <tr> + <td width="32%">pathname or string</td> + <td width="68%">A file with the given name is opened and standard error is directed to + that file.</td> + </tr> + <tr> + <td width="32%">:output</td> + <td width="68%">Standard error is directed to the same place as standard output thus the + error messages will be mixed into the result of running the cgi program.</td> + </tr> + <tr> + <td width="32%">symbol or function</td> + <td width="68%">The function is run whenever there is data available to be read from + standard error.  It must read that data.  It must return a true value if it + detected an end of file during the read and nil otherwise.    + The function takes arguments: req ent stream</td> + </tr> +</table> + +A typical way of publishing a CGI page is this: + +<pre>(publish :path "/cgi/myprog" + :function #'(lambda (req ent) + (run-cgi-program req ent "/server/cgi-bin/myprog")))</pre> + +If you're concerned about capturing the error output then here's an example where we +supply  a function to collect all the error output into a string. Once collected we +simply print it out here but in a real web server you would want to store it in a log +file. + +<pre>(defun cgierr (req ent) + (let ((error-buffer (make-array 10 + :element-type 'character + :adjustable t + :fill-pointer 0))) + (net.aserve:run-cgi-program + req ent + "aserve/examples/cgitest.sh 4" + :error-output + #'(lambda (req ent stream) + (declare (ignore req ent)) + (let (eof) + (loop + (let ((ch (read-char-no-hang stream nil :eof))) + + (if* (null ch) then (return)) + + (if* (eq :eof ch) + then (setq eof t) + (return)) + + (vector-push-extend ch error-buffer))) + eof + ))) + + (format t "error buffer is ~s~%" error-buffer) + ))</pre> + +  + +  + +Note: The ability to run CGI programs from AllegroServe was due to +features added in Allegro Common Lisp version 6.1.   This will not work in +earlier versions of Allegro CL. + +<hr> + +<h2><a name="form-processing"></a>Form Processing</h2> + +Forms are used on web pages in order to allow the user to send information to the web +server.   A form consists of a number of objects, such as text fields, file +fields, check boxes and radio buttons.   Each field has a name.   When +the user takes a certain action, the form data is encoded and sent to the web server. +    There are three ways that data can be sent to the web server.  The +method used is determined by the attributes of the <form> tag that +defines the form + +<ul> + <li><form method="get"> -  The data is made part of + the url that is sent to the web server and is separated from the url + itself by a question mark.  The AllegroServe url handler code uses (request-query + req) to retrieve the alist of form names and values.   This + method has a few disadvantages - the amount of data that can be sent is limited since the + size of urls is limited.  Also the data is visible to everyone seeing the url and + that may not be desirable.  </li> + <li><form method="post"> - The data is sent in the body of + the request.    The  AllegroServe url handler should call (request-query + req) to retrieve and decode the data posted.    In this + case  request-query calls (get-request-body req) to + retrieve the body from the web browser and then (form-urlencoded-to-query body) to + turn it into an alist that associates form field names with values.</li> + <li><form method="post" enctype="multipart/form-data"> - The + data is sent in the body of the request in MIME format, with each field in its own + separate MIME entity.    This method is only necessary when one of the + fields in the form is a <input type="file"> since that + causes the whole contents of a file to be sent from the browser to the web server.   + When sending a file you would like to include information such as the filename and + content-type of the file, and by sending it in MIME format there is room for this + information in the MIME header.   We describe how to retrieve data from such a + form next.</li> +</ul> + +<h3>Retrieving multipart/form-data information</h3> + +If you create a form with <form method="post" +enctype="multipart/form-data"> then your url handler must do the +following to retrieve the value of each field in the form: + +<ol> + <li>Call (get-multipart-header req) to return the MIME headers of the next + field.  If this returns nil then there are no more fields to retrieve.  You'll + likely want to call parse-multipart-header on the result of get-multipart-header + in order to extract the imporant information from the header.</li> + <li>Create a buffer and call (get-multipart-sequence req buffer) repeatedly + to return the next chunk of data.  When there is no more data to read for this field, + get-multipart-sequence will return nil.     If you're + willing to store the whole multipart data item in a lisp object in memory you can call get-all-multipart-data + instead to return the entire item in one Lisp object.</li> + <li>go back to step 1</li> +</ol> + +It's important to retrieve all of the data sent with the form, even if that data is +just ignored.  This is because there may be another http request following this one +and it's important to advance to the beginning of that request so that it is properly +recognized.   + +Details on the functions are given next. + +  + +<hr> + +<a name="f-get-multipart-header"></a>(get-multipart-header +request) + +This returns nil or  the MIME headers for the next form field in alist form. +    If nil is returned then there is no more form data.   See parse-multipart-header +for a simple way to extratacting information from the header. + +For an input field such as <input type="text" +name="textthing"> the value returned by get-multipart-header +would be + +<pre>((:content-disposition + (:param "form-data" ("name" . "textthing"))))</pre> + +For an input field such as <input type="file" +name="thefile"> the value returned by get-multipart-header +would be something like + +<pre>((:content-disposition + (:param "form-data" ("name" . "thefile") + ("filename" . "C://down//550mhz.gif"))) + (:content-type "image/gif"))</pre> + +Note that the filename is expressed in the syntax of the operating system on which the +web browser is running.  This syntax may or may not make sense to the Lisp pathname +functions of the AllegroServe web server as it may be running on a totally different +operating system. + +  + +<hr> + +<a name="f-parse-multipart-header"></a>(parse-multipart-header +header) + +This take the value of get-multipart-header and returns values that describe the +important information in the header. + +The first value returned is + +<ul> + <li>:eof  - this header says that there are no more multipart items. +   This value is returned when the value of header is nil.</li> + <li>:data - the next multipart item is a simple form value.  The + second value returned is a string naming the value.  You can retrieve the value + itself using repeated calls to get-multipart-sequence or one call to get-all-multipart-data. + </li> + <li>:file - the next multipart item is a file the user is uploading to the + server.    The second value returned in the name of the form item for which + this file was given.  The third value is the name of the file as specified by the + user to his browser.  The fourth value returned is the MIME Content-Type that the + browser is guessing applies to this contents of the file.   The contents of the + file can be retrieved using repeated calls to get-multipart-sequence or + one call to get-all-multipart-data. </li> + <li>:nofile - If a form contains a place for a filename but no filename was + entered before the form was submitted then this type of header is sent.  The values + returned are the same as those for :file. The third value (the filename) + will always be the empty string. </li> + <li>nil - This header has a form not recognized by parse-multipart-header. +     If you encounter this please let us know about it since we would like + enhance parse-multipart-header to understand this type of header. +    If you encounter this  type of header you still have to read the + contents of the data item that follows the header in order to read the next header. +    A call to (get-all-multipart-data req :limit 1000) will read + and throw away the following value so you can then read the next header.</li> +</ul> + +<hr> + +<a name="f-get-multipart-sequence"></a>(get-multipart-sequence +request buffer &key start end external-format) + +This retrieves the next chunk of data for the current form field and stores it in buffer. +   If start is given then it specifies the index in the buffer +at which to begin storing the data.  If end is given then it +specifies the index just after the last index in which to store data. + +The return value is nil if there is no more data to return, otherwise +it is the index one after the last  index filled with data in buffer. + +The buffer can be a one dimensional array of character or of (unsigned-byte +8).  For the most efficient transfer of data from the browser to +AllegroServe, the program should use a 4096 byte (unsigned-byte 8) array. + +If the buffer is  a character array then the data is converted from +get-multipart-sequence's (unsigned-byte 8) array to characters using the given +external-format (which defaults to the value of *default-aserve-external-format*). + +get-multipart-sequence may return before filling up the whole buffer, +so the program should be sure to make use of the index returned by get-multipart-sequence. + +  + +<hr> + +<a name="f-get-all-multipart-data"></a>(get-all-multipart-data +request &key  type size external-format limit) + +This retrieves the complete data object following the last multipart header. +   It returns it as a lisp object.   If type is +:text (the default) then the result is returned as a lisp string.   If type +is :binary then the result is returned as an array of  element-type +(unsigned-byte 8).    size (which defaults to 4096) is the +size of the internal buffers used by this function to retrieve the data.   You +usually won't need to specify a value for this but but if you know the values retrieved +are either very small or very large it may may the operation run faster to specify an +appropriate size.    external-format is +used when type is :text to convert  the octet +stream into characters.  It defaults to the value of *default-aserve-external-format*. +  limit can be given an integer value that specifies the maximum +size of data you're willing to retrieve.  By default there is no limit.  This +can be dangerous as a user may try to upload a huge data file which will take up so much +Lisp heap space that it takes down the server.   If a limit is +given and that limit is reached, get-all-multipart-data will continue to +read the data from the client until it reaches the end of the data, however it will not +save it and will return the symbol :limit to indicate that the data being +send to the sever exceeded the limit.  It will return a second value which is the +size of the data the client tried to upload to the server.    If your +application intends to handle very large amounts of data being uploaded to the server you +would be better off using get-multipart-sequence since with that you can +write the data buffer by buffer to the disk instead of storing it in the Lisp heap. + +<hr> + +  + +In AllegroServe the information sent to the web server as a result of filling out a +form  is called a query.  We store a query as a list of conses, +where the car of the cons is the name (a string) and the +cdr of the cons is the value (another string).    When a +query is transmitted by the web browser to AllegroServe it is sent as string using the +encoding application/x-www-form-urlencoded.  We provide the +following functions to convert between the encoding and the query list: + +  + +<a name="f-form-urlencoded-"></a>(form-urlencoded-to-query +string &key external-format) + +Decodes the string and returns the query list.   The default value for external-format +is the value of *default-aserve-external-format*. + +  + +<a name="f-query-to"></a>(query-to-form-urlencoded +query &key external-format) + +Encodes the query and returns a string.   The default value for external-format +is the value of *default-aserve-external-format*. + +  + +Examples: + +<pre>user(4): (query-to-form-urlencoded '(("first name" . "joe") + ("last name" . "smith"))) +"first+name=joe&last+name=smith" + +user(5): (form-urlencoded-to-query "first+name=joe&last+name=smith") +(("first name" . "joe") ("last name" . "smith")) + </pre> + +<pre>user(6): (query-to-form-urlencoded + `(("last name" . ,(coerce '(#\hiragana_letter_ta + #\hiragana_letter_na + #\hiragana_letter_ka) + 'string))) + :external-format :euc) + "last+name=%a4%bf%a4%ca%a4%ab"</pre> + +<pre>user(7): (query-to-form-urlencoded + `(("last name" . ,(coerce '(#\hiragana_letter_ta + #\hiragana_letter_na + #\hiragana_letter_ka) + 'string))) + :external-format :shiftjis) + "last+name=%82%bd%82%c8%82%a9" + +user(8): (coerce + (cdr + (assoc "last name" + (form-urlencoded-to-query "last+name=%82%bd%82%c8%82%a9" + :external-format :shiftjis) + :test #'equalp)) + 'list) + (#\hiragana_letter_ta #\hiragana_letter_na #\hiragana_letter_ka) +</pre> + +<hr> + +<h2><a name="authorization"></a>Authorization </h2> + +You may want to restrict certain entities to be accessible from only certain machines +or people.   You can put the test for authorization in the entity response +function using one of the following functions, or you can have the check done +automatically by storing a list of authorizer objects in the entity. + +  + +<h3>functions</h3> + +These two functions  invoke and process the Basic Authorization Method +  defined by the http specification.    The password-authorizer +class described below make use of these functions. + +<a name="f-get-basic-authorization"></a>(get-basic-authorization +request) + +This function retrieves the Basic authorization information associated with this +request, if any.    The two returned values are the name and password, both +strings.  If there is no Basic authorization information with this request, nil +is returned. + +  + +<a name="f-set-basic-authorization"></a>(set-basic-authorization +request realm) + +This adds a header line that requests Basic authorization in the given realm (a +string).    This should be called between with-http-response +and with-http-body and only for response of type 401 (i.e. *response-unauthorized*). +   The realm is an identifier, unique on this site, for the set of pages for +which access should be authorized by a certain name and password. + +  + +This example manually tests for basic authorization where the name is foo +and the password is bar. + +<pre>(publish :path "/secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (multiple-value-bind (name password) (get-basic-authorization req) + (if* (and (equal name "foo") (equal password "bar")) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))) + else ; this will cause browser to put up a name/password dialog + (with-http-response (req ent :response *response-unauthorized*) + (set-basic-authorization req "secretserver") + (with-http-body (req ent))))))) + +</pre> + +<h3>authorizer classes</h3> + +The authorizer slot of an entity object can contain a authorizer +object or a list of zero or more authorizer objects.  When a request +arrives for this entity the authorizer objects are consulted to see if +this request should be permitted.   In order for the request to be permitted, all +authorizer objects must permit the request.  AllegroServe supplies three   +interesting subclasses of authorizer and users are free to add their own +subclasses to support their own authorization needs.   + +The protocol followed during authorization is this: + +<ol> + <li>an entity object is selected that matches the request.  The value of the entity's + authorizer slot is retrieved from the entity object.</li> + <li>if the list of pending authorizer objects is nil then it is considered + authorized.</li> + <li>otherwise the authorize generic function is called on the first authorizer + object, passing authorize the authorizer object, the + http-request object and the entity object</li> + <li>the return value from authorize can be  + t - meaning this request is authorized to access this entity.  In + this case the first authorizer object is popped from the list of pending authorizer + objects and we go back to step 2. + nil - meaning that this request isn't authorized.  The response from + AllegroServe will be the standard "failed request" response so the user won't be + able to distinguish this response from one that would be received if the entity didn't + exist at all. + :deny - a denied request response will be returned.   It will not + use the 401 return code so this will not cause a password box to be displayed by the + browser. + :done - the request is denied, and a response has already been sent to + the requestor by the authorize function so no further response should be + made.</li> +</ol> + +  + +<a name="c-password-authorizer"></a>password-authorizer  [class] + +This subclass of authorizer is useful if you want to protect an entity +using the Basic authorization scheme that asks for a name and a password. +    When you create this class of object you should supply values for the +two slots: + +<table border="1" width="100%"> + <tr> + <td width="13%"><big>Slot Name</big></td> + <td width="11%"><big>initarg</big></td> + <td width="76%"><big>what</big></td> + </tr> + <tr> + <td width="13%">allowed</td> + <td width="11%">:allowed</td> + <td width="76%">list of conses, each cons having the form ("name" . + "password") where any of the listed name password pairs will allow + access to this page.</td> + </tr> + <tr> + <td width="13%">realm</td> + <td width="11%">:realm</td> + <td width="76%">A string which names the protection space for the given name and password. +   The realm will appear in the dialog box the browser displays when asking for a name + and password. </td> + </tr> +</table> + +An example of it's use is the following where we allow access only if the user enters a +name of joe and a password of eoj or a name of fred +and a password of derf. + +<pre> (publish :path "/foo" + :content-type "text/html" + :authorizer (make-instance 'password-authorizer + :allowed '(("joe" . "eoj") + ("fred" . "derf")) + :realm "SecretAuth") + + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page"))))))</pre> + +  + +<a name="c-location-authorizer"></a>location-authorizer [class] + +This authorizer class checks the IP address of the request to see if it is permitted +access to the entity.  The  authorizer can specify a sequence of  patterns +and for each pattern a command of :accept (permit the access) or :deny +(forbid the access).    The first pattern that matches determines if the +request is accepted or denied.  If the pattern list is empty or if no pattern +matches, then the request is accepted.  + +The single slot of an object of class location-authorizer is + +<table border="1" width="100%"> + <tr> + <td width="13%"><big>Slot Name</big></td> + <td width="11%"><big>initarg</big></td> + <td width="76%"><big>what</big></td> + </tr> + <tr> + <td width="13%">patterns</td> + <td width="11%">:patterns</td> + <td width="76%">a list of patterns and commands, where the syntax of a pattern-command is + described below.</td> + </tr> +</table> + +A pattern can be + +<ul> + <li>:accept -- this is a pattern that matches all IP addresses and causes + the access to be authorized</li> + <li>:deny -- this is a pattern that matches all IP addresses and causes the + access to be rejected</li> + <li>(:accept ipaddress [bits]) --  if the request's IP address matches + the most significant bits of ipaddress then this access + is accepted.   bits is optional and defaults to 32 (the whole + address).  The ipaddress can be an integer (the 32 bit IP address) or it can be a + string in either dotted form "123.23.43.12"  or a host name + "foo.bar.com".   In the case of a host name, a lookup must be done to + map the host name to an  IP address.   If this lookup fails then it is + assumed that the pattern doesn't match.   If ipaddress is a + string, then the first time it is examined during authorization it is converted to an + integer IP address and that value replaces the string in the pattern (thus caching the + result of the conversion to an IP address).</li> + <li>(:deny ipaddress [bits]) -- just like the case above except the request + is rejected if it matches the ipaddress.   One difference is + this: if the ipaddress is a host name and that host name cannot be + translated to an IP address, then it is assumed to match, and thus the request will be + denied.  </li> +</ul> + +The example of using a location-authorizer only permits connections +coming in via the loopback network (which occurs if you specify <a +href="http://localhost/whatever">http://localhost/whatever</a>) or if they come from one +particular machine (tiger.franz.com).  Note that we end the pattern list with :deny +so that anything not matching the preceding patterns will be denied. + +<pre>(publish :path "/local-secret-auth" + :content-type "text/html" + :authorizer (make-instance 'location-authorizer + :patterns '((:accept "127.0" 8) + (:accept "tiger.franz.com") + :deny)) + + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You made it to the secret page")))))) + +</pre> + +<a name="c-function-authorizer"></a>function-authorizer   [class] + +This authorizer contains a function provided by the user which is used to test if the +request is authorized.   The function take three arguments, the http-request +object, the entity and the authorizer object.   It must return one of the four +value that the authorize function returns, namely t, nil :deny +or :done. + +A function-authorizer is created as follows + +<pre>(make-instance 'function-authorizer + :function #'(lambda (req ent auth) + t ; always authorize + ))</pre> + +The function slot can be set using (setf function-authorizer-function) if you wish to +change it after the authorizer has been created. + +  + +<h2><a name="cookies"></a>Cookies</h2> + +Cookies are name value pairs that a web server can direct a web browser to save and +then pass back to the web server under certain circumstances.   Some users +configure their web browsers to reject cookies, thus you are advised against building a +site that depends on cookies to work. + +Each cookie has these components: + +<ol> + <li>name - a string.   Since you can get multiple cookies sent to + you by a web browser, using a unique name will allow you to distinguish the values.</li> + <li>value - a string</li> + <li>path - a string which must be the prefix of the request from the web + browser for this cookie to be sent.  The string "/" is the prefix of all + requests.</li> + <li>domain - a string which must be the suffix of the name of the machine + where the request is being sent in order for this cookie to be sent.</li> + <li>expiration - a time when this cookie expires. </li> + <li>secure - either true or false.  If true then this cookie will only + be sent if the connection is through a secure socket</li> +</ol> + +  + +<a name="f-set-cookie-header"></a>(set-cookie-header +request &key name value expires domain path secure encode-value external-format) + +This function should be called between the calls to with-http-response and +with-http-body.   It can be called more than once.  Each +call will cause one Set-Cookie directive to be sent to the web browser.     +The name and value arguments should be given (and they +should be strings).  They will be automatically encoded using the same encoding used +in urls (we call it uriencoding). The purpose of this encoding is to convert +characters that are either unprintable or those that have a special meaning into a +printable string.    The web browser doesn't care about the name +and value, it just stores them and sends them back to the web server. +    If you use the get-cookie-values function to retrieve +the cookie name and value pairs, then it will +automatically decode the uriencoding. + +You can disable the encoding of the value by specifying a nil value to +encode-value.    This should only be necessary if you are +working with buggy http client applications. + +If the path argument isn't given, it will default to "/" which +will allow this cookie to match all requests. +If the domain argument isn't given then it will default to the host to +which this request was sent.  If you wish to specify this you are only allowed to +specify a subsequence of the host to which this request was sent (i.e the name of the +machine running the webserver).   The domain should have at +least two periods in it (i.e.  ".foo.com"). +expires can be a lisp universal time or it can be the symbol :never +meaning this should never expire.  If expires isn't given or is nil +then this cookie will expire when the user quits their web browser. +secure should be true or false.  Any non-nil value is interpreted as +true. The default value is false. +The external-format is used to convert bytes to characters.   It +defaults to the value of *default-aserve-external-format*. + +  + +<a name="f-get-cookie-values"></a>(get-cookie-values +request &key external-format) + +Return the cookie name and value pairs from the +header of the request.   Each name value pair +will be in a cons whose car is the name and whose cdr +is the value.   The names and values will be decoded (in other +words the decoding done by set-cookie-header will be undone). +   The external-format is used to convert bytes to characters. +  It defaults to the value of *default-aserve-external-format*. + +  + +<hr> + +<h2><a name="varaibles"></a>Variables</h2> + +These special variables contain  information about AllegroServe or help control +AllegroServe: + +<a name="v-aserve-version"></a>*aserve-version* +- a list of three values: (major-version minor-version sub-minor-version) which is usually +printed with periods separating the values (i.e. X.Y.Z). + +<a name="v-default-aserve-external-format"></a>*default-aserve-external-format* +- a symbol or external format object which is the default value for those AllegroServe +functions that take an external-format argument.   http requests are normally +run in separate lisp threads and those threads bind *default-aserve-external-format* to +the value of the external-format argument to the start function.   Thus changing +the value of *default-aserve-external-format* in one thread will not affect its value in +other threads.   You should decide the default external format before you start +AllegroServe running. + +<a name="v-http-response-timeout"></a>*http-response-timeout* +- the default value for the timeout argument to with-http-response.   [in future +versions of AllegroServe we'll treat this value like *default-aserve-external-format* and +bind it in each worker thread] + +<a name="v-mime-types"></a>*mime-types* +- a hash table where the keys are the file types (e.g. "jpg") and the values are +the MIME types (e.g. "image/jpeg"). + +  + +<hr> + +<h2><a name="iseve-request-proc"></a>AllegroServe request processing protocol</h2> + +We'll describe here the steps AllegroServe goes through from the time it receives a +request until a response to that request has been sent back to the +browser.    We want the protocol to be open so that users can extend +AllegroServe's behavior to suit their needs.  However given that AllegroServe is a +new program and will be undergoing extensive review from its users, we expect that the +protocol will change.   It shouldn't lose any of its current extensibility but +the names and argument lists of generic functions may change.  + +When a client connects to the port on which AllegroServe is listening, AllegroServe +passes that connected socket to a free worker thread which then wakes up and calls the +internal function net.aserve::process-connection.   If there +are no free worker threads then AllegroServe waits for one to be available. + +In each worker thread the variable *wserver* is bound to the wserver +object that holds all the information about the webserver on which the connection was made +(remember that one AllegroServe process can be running more than one +webserver).   process-connection reads the request from the +socket (but doesn't read past the header lines).     If the request can't +be read within *read-request-timeout* seconds (currently 20) then the +request is rejected.    The request is stored in an object of class http-request.    +Next process-connection calls handle-request to do all +the work of the request and then log-request to log the action of the +request.  Finally if the response to the request indicated that the connection was to +be kept open rather than being closed after the response, then process-connection +loops back to the top to read the next request. + +  + +<a name="f-handle-request"></a>(handle-request (req +http-request))    [generic function] + +This generic function must locate the entity to handle this request and then cause it +to respond to the request.   If there is no matching entity then handle-request +must send a response back to the client itself.  handle-request uses +locators to find the entity (more on this below), and then if an entity is found and that +entity has an authorizer, it calls authorize to see if this request is +allowed to access the selected entity.  If the entity passes the authorization then process-entity +is called to cause the entity to respond to the request.  process-entity +returns true if it processed the entity, and nil if did not in which case the search +continues for an entity.  If there is no entity to respond then failed-request +is called to send back a failure message. + +A locator is an object used to map requests into entities. +   The value of (wserver-locators *wserver*) is a list of +locator objects.   handle-request calls + +<a name="f-standard-locator"></a>(standard-locator +(req http-request) (loc locator)) [generic function] + +on each successive locator in that list until one returns an entity object. +    AllegroServe has two built-in locator classes, locator-exact +and locator-prefix, that are subclasses of locator.   When +you call publish or publish-file you are adding the +entity to locator of class locator-exact found in the wserver-locators +list.   When you call publish-directory you are adding +to the locator of class locator-prefix.    Users are free +to define new locator classes.    Locators should define the standard-locator +method as well as + +<a name="f-unpublish-locator"></a>(unpublish-locator +(loc locator))    [generic  function] + +which if called should remove all published entities from the locator. + +  + +Let's return to handle-request.  It has called standard-locator +and found an entity.   Next it checks to see if the entity has an authorizer +value and if so calls + +<a name="f-authorize"></a>(authorize (auth authorizer) +(req http-request) (ent entity))   [generic function] + +The return value will be one of + +<ul> + <li>t -- The request is authorized,  call process-entity + to make the entity respond.</li> + <li>nil -- The request is not authorized, call failed-request to + send back a response.</li> + <li>:deny -- The request is denied and we want the user to know that it was + denied rather than sending a generic failed message, call denied-request + to send back a response.</li> + <li>:done -- The authorize function has sent back a + response, there is nothing more for handle-request to do for this + request.</li> +</ul> + +If there is no authorizer for this entity then we just call process-entity. +   If there is no entity, then we call failed-request. + +  + +<a name="f-failed-request"></a>(failed-request (req +http-request))    [generic function] + +send back a response to the effect that the url request doesn't exist on this server. + +  + +<a name="f-denied-request"></a>(denied-request (req +http-request))   [generic function] + +send back a response to the effect that access to the requested url was denied. + +  + +<a name="f-process-entity"></a>(process-entity  +(req http-request) (ent entity))    [generic function] + +Send back a response appropriate to the given entity.     The +macros with-http-response and with-http-body should be used in the code that sends the +response. + +  + +  + +<hr> + +<h2><a name="cliient-request"></a>Client functions</h2> + +AllegroServe has a set of functions that perform http client-side actions.   +These functions are useful in generating computed pages that reflect the contents of other +pages.  We also use the client-side http functions to test AllegroServe. + +The client-side functions described in this section are exported from the net.aserve.client package. + +The function do-http-request sends a request and retrieves the whole +response.    This is the most convenient function to use to retrieve a web +page. + +If you need more control over the process you can use the functions: make-http-request, +read-client-response-headers and client-request-read-sequence. + +  + +<a name="f-do-http-request"></a>(do-http-request uri +&key method protocol accept +                          +content content-type query format cookies +                          +redirect redirect-methods basic-authorization +                          +keep-alive headers proxy user-agent external-format ssl +                          +skip-body) + +Sends a request to uri and returns four values: + +<ol> + <li>The body of the response.  If there is no body the empty string is returned.</li> + <li>the response code (for example, 200, meaning that the request succeeded)</li> + <li>an alist of headers where the car of each entry is a lowercase string + with the header name and the cdr is a string with the value of that + header item.</li> + <li>the uri object denoting the page accessed.  This is normally computed from the uri + value passed in but if redirection was done then this reflects the target of the + redirection.  If you plan to interpret relative html links in the body + returned then you must do so with respect to this uri value </li> +</ol> + +The uri can be a uri object or a string.   The scheme of the +uri must be nil or "http".   The keyword arguments to +do-http-request are + +<table border="1" width="100%"> + <tr> + <th width="22%">Name</th> + <th width="16%">default</th> + <th width="62%">description</th> + </tr> + <tr> + <td width="22%">method</td> + <td width="16%">:get</td> + <td width="62%">The type of request to make.  Other possible values are :put, + :post and :head.  :head is useful + if you just want to see if the link works without downloading the data.</td> + </tr> + <tr> + <td width="22%">protocol</td> + <td width="16%">:http/1.1</td> + <td width="62%">The other possible value is :http/1.0.  Modern web + servers will return the response body in chunks if told to use the :http/1.1 + protocol.  Buggy web servers may do chunking incorrectly (even Apache has bugs in + this regard but we've worked around them).  If you have trouble talking to a web + server you should try specifying the :http/1.0 protocol to see if that + works.</td> + </tr> + <tr> + <td width="22%">accept</td> + <td width="16%">"*/*"</td> + <td width="62%">A string listing of MIME types that are acceptable as a response to this + request.  The type listed can be simple such as "text/html" or more complex + like "text/html, audio/*"  The default is to accept anything which is + expressed "*/*".</td> + </tr> + <tr> + <td width="22%">content</td> + <td width="16%">nil</td> + <td width="62%">If the method is :put or :post then the + request should include something to be sent to the web server.   The value of + this argument is either a string or a vector of type (unsigned-byte 8) which will be sent + to the web server.   It may also be a list of strings or vectors. See the query + argument for a more convenient way to :post data to a form.</td> + </tr> + <tr> + <td width="22%">content-type</td> + <td width="16%">nil</td> + <td width="62%">A string which is to be the value of the Content-Type header field, + describing the format of the value of the content argument.    + This is only needed for :put and :post requests.</td> + </tr> + <tr> + <td width="22%">query</td> + <td width="16%">nil</td> + <td width="62%">This is a query alist of the form suitable for query-to-form-urlencoded. +   If the method is a :get then the value of  this argument is urlencoded + and made the query string of the uri being accessed.  If the method is :post + then the query string is urlencoded and made the content + of the request.  Also the content-type is set to application/x-www-form-urlencoded. + </td> + </tr> + <tr> + <td width="22%">format</td> + <td width="16%">:text</td> + <td width="62%">The body of the response is returned as a string if the value is + :text or as an array of type (unsigned-byte 8) if the value is :binary. +    When the body is a string the external-format argument is important.</td> + </tr> + <tr> + <td width="22%">cookies</td> + <td width="16%">nil</td> + <td width="62%">If you wish the request to include applicable cookies and for returned + cookies to be saved, then a cookie-jar object should be passed as the + value of this argument.</td> + </tr> + <tr> + <td width="22%">redirect</td> + <td width="16%">5</td> + <td width="62%">If the response is a redirect (code 301, 302, 303), and the method is one + given by the value of redirect-methods then if this argument is true + (and, if an integer, positive), do-http-request will call itself to + access the page to which the redirection is pointed.  If redirect is + an integer then in the recursive call the value passed for redirect will + be one less than the current value.  This prevents infinite recursion due to + redirection loops.</td> + </tr> + <tr> + <td width="22%">redirect-methods</td> + <td width="16%">(:get :head)</td> + <td width="62%">List of http methods which will be redirected if redirect + is true.</td> + </tr> + <tr> + <td width="22%">basic-authorization</td> + <td width="16%">nil</td> + <td width="62%">If given, it is a cons whose car is the name and whose cdr + is the password to be used to get authorization to access this page.</td> + </tr> + <tr> + <td width="22%">keep-alive</td> + <td width="16%">nil</td> + <td width="62%">If true then the web server will be told to keep the connection alive. +    Since do-http-request closes the connection after the + request this option currently does no more than allow us to experiment with how a web + server responds to a keep-alive request.</td> + </tr> + <tr> + <td width="22%">headers</td> + <td width="16%">nil</td> + <td width="62%">an alist of conses ("header-name" . + "header-value") for additional headers to send with the request.</td> + </tr> + <tr> + <td width="22%">proxy</td> + <td width="16%">nil</td> + <td width="62%">the name and optionally the port number of a proxying web server through + which this request should be made.   The form is of the argument is <a + href="http://www.machine.com">"www.machine.com"</a> or <a + href="http://www.machine.com:8000">"www.machine.com:8000"</a> if the web server + is listening on port 8000 rather than 80.   Proxying web servers are often used + when clients are behind firewalls that prevent direct access to the internet.   + Another use is to centralize the page cache for a group of clients.</td> + </tr> + <tr> + <td width="22%">user-agent</td> + <td width="16%">nil</td> + <td width="62%">If given it specifies the value of the User-Agent header to be sent with + the request.  Some sites respond differently based on the user-agent they believe has + made the request.  The lack of a User-Agent header may cause a server to ignore a + request since it believes that it is being probed by a robot.  The value of + user-agent can be a string or one of the keywords :aserve, :netscape + or :ie in which case an appropriate user agent string is sent.</td> + </tr> + <tr> + <td width="22%">external-format</td> + <td width="16%">the value of *default-aserve-external-format*</td> + <td width="62%">This determines the socket stream's external format.</td> + </tr> + <tr> + <td width="22%">ssl</td> + <td width="16%">nil</td> + <td width="62%">If true then the connection is made using the Secure Sockets Layer + protocol.    If the uri uses the https scheme then ssl + is assumed to be true and the ssl argument need not be specified.</td> + </tr> + <tr> + <td width="22%">skip-body</td> + <td width="16%">nil</td> + <td width="62%">If the value is a fucntion (satisifies functionp) then + the value is funcalled passing the client-request object as an argument. +   At this point the client-request object contains the information on the headers of + the response.   The function should return true if the body of the response + should be skipped and nil returned as the first value from + do-http-request.  If skip-body is not a function then if its value is true then + reading the body is skipped and nil returned in its place.</td> + </tr> +</table> + +  + +For example: + +<pre>user(5): (do-http-request "http://www.franz.com") +</pre> + +<pre>"<HTML> + <HEAD> + <TITLE>Franz Inc: Allegro Common Lisp and Common Lisp Products</TITLE> + <BASE FONTFACE=\"helvetica, arial\" FONTSIZE=\"1\"> +.....</pre> + +<pre>" +200 +(("content-type" . "text/html") ("transfer-encoding" . "chunked") +("server" . "Apache/1.3.9 (Unix) PHP/3.0.14") +("date" . "Mon, 24 Apr 2000 11:00:51 GMT")) +</pre> + +  + +It's easy to use do-http-request to fill in form objects on a page. +  If the form has input elements named  width and height +then you can send a request that specifies that information in this way: + +<pre>(do-http-request <a href="http://www.foo.com/myform.html">"http://www.foo.com/myform.html"</a> + :query '(("width" . 23) ("height" . 45)))</pre> + +The above assumes that the method on the form is "GET".   If the +method is "POST" then a similar call will work: + +<pre>(do-http-request <a href="http://www.foo.com/myform.html">"http://www.foo.com/myform.html"</a> :method :post + :query '(("width" . 23) ("height" . 45)))</pre> + + +        + +  + +Before we describe the lower level client request functions we will describe two +classes of objects used in that interface. + +<h2><a name="c-client-request"></a>client-request</h2> + +A client-request object includes the information about the request and +the response. + +The public fields of a client-request that are filled in after a call +to make-http-client-request are: + +<table border="1" width="100%"> + <tr> + <th width="31%">Accessor</th> + <th width="69%">Description</th> + </tr> + <tr> + <td width="31%">client-request-uri</td> + <td width="69%">uri object corresponding to this request</td> + </tr> + <tr> + <td width="31%">client-request-socket</td> + <td width="69%">socket object open to the web server denoted by the uri</td> + </tr> + <tr> + <td width="31%">client-request-cookies</td> + <td width="69%">the cookie-jar object (if any) passed in with this request.</td> + </tr> +</table> + +  + +After read-client-response-headers is called, the following fields of +the client-request objects are set: + +<table border="1" width="100%"> + <tr> + <th width="39%">Accessor</th> + <th width="61%">Description</th> + </tr> + <tr> + <td width="39%">client-request-response-code</td> + <td width="61%">the integer that is the response code for this request.  The most + common codes are 200 for Success and 404 for Not Found.</td> + </tr> + <tr> + <td width="39%">client-request-headers</td> + <td width="61%">an alist of header values in the response.  Each entry is a cons of + the form ("header-name" . "header-value"). +   The header names are all lower case.</td> + </tr> + <tr> + <td width="39%">client-request-protocol</td> + <td width="61%">A keyword symbol naming the protocol  that the web server returned + (which may be different that the protocol given in the request).   A typical + return value is :http/1.1</td> + </tr> + <tr> + <td width="39%">client-request-response-comment</td> + <td width="61%">A string giving a textual version of the response code.   The + string is arbitrary and you should not depend on all web servers returning the same string + for any given response code.</td> + </tr> +</table> + +  + +<h2><a name="c-cookie-jar"></a>cookie-jar</h2> + +A cookie-jar is a respository for cookies.  Cookies are stored in +a jar when a response from a client request includes Set-Cookie +headers.   Cookies from a jar are sent along with a request when they are +applicable to the given request.   We won't describe the rules for cookie +applicability here, you need only know that if you use our client functions  to +access a site that uses cookies to implement persistence, then you should create a cookie-jar +object and pass that same object in with each request.   More information on +cookies can be found <a +href="http://developer.netscape.com:80/docs/manuals/js/client/jsref/cookies.htm">here</a>. + +A cookie-jar is created with (make-instance +'cookie-jar). + +  + +(cookie-jar-items  cookie-jar) + +returns an alist of the cookies in the jar where each item has the form: + +(hostname cookie-item ...) + +The hostname is a string which is matched against the suffix of the +name of the host in the request (that is, a hostname of  ".foo.com" +matches "a.foo.com" and "b.foo.com". +).    The hostname should have at least two periods in it. +    The following cookie-item objects in the list all +apply to that hostname.    A cookie-item is a defstruct object +and has these fields + +<table border="1" width="100%"> + <tr> + <th width="29%">Accessor</th> + <th width="71%">Description</th> + </tr> + <tr> + <td width="29%">cookie-item-path</td> + <td width="71%">A string that must be the prefix of the path of the request for it to + match.  The prefix "/" matches all paths.</td> + </tr> + <tr> + <td width="29%">cookie-item-name</td> + <td width="71%">The name of the cookie.  A string.</td> + </tr> + <tr> + <td width="29%">cookie-item-value</td> + <td width="71%">The value of the cookie.  A string.</td> + </tr> + <tr> + <td width="29%">cookie-item-expires</td> + <td width="71%">A string holding the time the cookie expires [in a future release we may + make this a universal time]</td> + </tr> + <tr> + <td width="29%">cookie-item-secure</td> + <td width="71%">true if this cookie should only be sent over a secure connection.</td> + </tr> +</table> + +  + +  + +<a name="f-make-http-client-request"></a>(make-http-client-request +uri &key method protocol keep-alive +                                   +accept cookies headers proxy +                                   +basic-authorization query +                                   +content content-type content-length +                                   +user-agent external-format ssl) + +This function connects to the web server indicated by the uri and +sends the request.   The arguments are the same as those for do-http-request +and are documented there.   There is one additional argument: content-length. +   This argument can be used to set the content-length header +value in the request.  After setting the content-length the caller of make-http-client-request +would then be responsible for sending that many bytes of data to the socket to serve as +the body of the request.   If content-length is given, then a +value for content should not be given. + +If  make-http-client-request succeeds in contacting the web +server and sending a request, a client-request object is returned. +   If make-http-client-request fails, then an error is +signalled. + +The returned client-request object contains an open socket to a web +server, thus you must ensure that client-request object isn't discarded before client-request-close +is called on it to close the socket and reclaim that resource. + +After calling make-http-client-request the program will send the body +of the request (if any), and then it will call read-client-response-headers +to partially read the web server's response to the request. + +The default value for external-format is the value of *default-aserve-external-format* + +  + +  + +<a name="f-read-client-response"></a>(read-client-response-headers +client-request) + +This function reads the response code and response headers from the web server. +    After the function returns the program can use the client-request +accessors noted above to read the web server's response.  The body of the +response (if any) has not been read at this point.    You should use client-request-read-sequence +to read the body of the response + +  + +  + +<a name="f-client-request-read-sequence"></a>(client-request-read-sequence +buffer client-request +                              +&key start end) + +This fills the buffer with the body of the response from the web +server.   The buffer should either be a character array or an array of +(unsigned-byte 8).    If given, start specifies the index +of the first element in the buffer in which to store, and end is +one plus the index of the last element in which to store.  + +The return value is one plus the last index in the buffer filled by this function. The +caller of the function must be prepared for having the buffer only partially filled. +  If the return value is zero then it indicates an End of File condition. + +  + +<a name="f-client-request-read-close"></a>(client-request-close +client-request) + +The client-request object returned by make-http-request is closed.   This +returns the resources used by this connection to the operating system.  + +  + +<a name="f-uriencode-string"></a>(uriencode-string  +string &key external-format) + +Convert the string into a format that would be safe to use as a component of a url. +    In this conversion most printing characters are not changed +   All non printing characters and printing characters that could be confused +with characters that separate fields in a url are encoded a %xy where xy is the +hexadecimal representation of the char-code of the character.   +external-format defaults to the value of *default-aserve-external-format*. + +<hr> + +<h2><a name="proxy"></a>Proxy</h2> + +AllegroServe can serve as an http proxy.   What this means is that web +clients can ask AllegroServe to fetch a URL for them.   The two primary uses for +a proxy server are + +<ol> + <li>you have web clients on a local network and you would prefer that the web clients don't + send messages out to the internet.   You run AllegroServe on a machine that has + access both to the internal network and to the internet.  You then configure the web + clients to proxy through AllegroServe (directions for doing this are given below).</li> + <li>You wish to use AllegroServe's caching facility to store copies of pages locally to + improve responsiveness.  In this case you must start AllegroServe as a proxy server + for the web clients who will use the cache.</li> +</ol> + +In order to run AllegroServe as a proxy server you should specify :proxy t +in the arguments to the net.aserve:start function.   With this +specified AllegroServe will still act as a web server for pages on the machine on which +AllegroServe is running.  AllegroServe will act as a proxy for requests to other +machines. + +Each web browser has it's own way of specifying which proxy server it should use. +  For Netscape version 4 select the Edit menu, then Preferences... +and then click on the plus sign to the left of Advanced. +  Then select Proxies and click on  Manual Proxy +Configuration and the click on View and specify the name of the +machine running AllegroServe and the port number on which AllegroServe is listening. +  Then click OK on all the dialog boxes. + +For Internet Explorer 5 select the Tools menu, and then Internet +Options.. and then the Connections tab, and then LAN +Settings.   Click on Use a Proxy Server and then click +on Advanced and specify the machine name and port number for +AllegroServe.  Then click on OK to dismiss the dialog windows. + +  + +<hr> + +<h2><a name="cache"></a>Cache</h2> + +The AllegroServe cache is a facilty in development.  We'll describe here the +current status of the code. + +The cache consists of a memory cache and a set of zero or more disk caches. +     Items initially live in the memory cache and are moved to the +disk caches when the memory cache fills up.   Items enter the memory cache due +to a page being accessed via the proxy server.   Items in the disk cache move +back to the memory cache if the data portion must be sent back to the requesting client +(some requests can be answered without sending back the contents of the page and for these +the item stays in the disk cache). + +You specify the sizes of each cache.   The disk caches will never grow beyond +the size you specified but the memory cache can exceed the specified size for a short +time.  A background thread moves items from the memory cache to the disk caches and +we will allow you to control how often that thread wakes up and ensures that the memory +cache is within the desired constraints. + +When net.aserve:start is called you specify if you want caching and if +so what size caches you want.   A sample argument pair passed to net.aserve:start +is + +<pre>:cache '(:memory 10000000 :disk ("/tmp/mycache" 30000000) :disk (nil 20000000))</pre> + +This says that the memory cache should be 10,000,000 bytes and that there should be two +disk caches.   One disk cache is the file "/tmp/mycache" and can grow +to 30,000,000 bytes and the other cache will have a name chosen by AllegroServe and it can +grow to 20,000,000 bytes.   We should note here that one thing that +distinguishes the AllegroServe caching facilty from that found in many other http +proxy-caches is that AllegroServe uses a few  large cache files rather than storing +each cached item in a separate file in the filesystem.   + +A few other ways of specifying caching at startup is: + +<pre>:cache t</pre> + +This will create a memory case of the default size (currently 10 megabytes) and it will +create no disk caches. + +<pre>:cache 20000000</pre> + +This will create a memory cache of 20,000,000 byte and no disk caches. + +  + +When caching is enabled we publish two links to pages showing cache information. +   This is useful during debugging and is likely to change in the future.   +The two pages are  /cache-stats  and  /cache-entries. + +  + +<hr> + +<h2><a name="filters"></a>Request Filters</h2> + +After AllegroServe reads a request and before it checks the locators to find an entity +to handle the request, AllegroServe runs the request through a set of filters. + +<blockquote> + A filter is a function of one argument: the http-request object. The filter examines + and possibily alters the request object. The idea is that filters can do large scale and + simple url rewriting, such as changing all requests for one machine to another machine. + The filtering occurs before the test to see if this is a proxy request so a filter can + change a proxy request to a non proxy request or vice versa. + The currently active filters are found in two places.  First the vhost-filters + function of the applicable vhost returns a set of vhost + specific filters.   Next the wserver-filters function on the + current wserver object returns a set of server global filters. +     Both of these functions are setf'able to change the + set of filters. +</blockquote> + +  + +A filter function returns :done if no more filters should be run after +this one. If the filter returns anything else then subsequent filters in the list are run +as well.   If a filters in the vhost list returns :done +then the server global filters are not even checked. + +When a filter function runs it's most likely going to be looking at two slots in the +request object, which are accessed via these functions: + +<ul> + <li>request-raw-uri - the actual uri given in the http command </li> + <li>request-uri - a constructed uri starting with the raw uri and adding + information from the Host header field. This value is used to find the entity to run thus + it has all the information about the request. </li> +</ul> + +Also the value of (header-slot-value request :host) is +important to check and possibly change. + +If the browser is setup to access the internet directly then a request from the user +for +    http://foo.bar.com:23/whatever + +will cause the request to be sent to the server at foo.bar.com port 23 +and the request will have: + +<ol> + <li>the request-raw-uri is /whatever </li> + <li>the request-uri is http://foo.bar.com:23/whatever </li> + <li>the Host header value is "foo.bar.com:23" </li> +</ol> + + + + +If the browser is setup to send all requests through a proxy at proxy.blop.com +then a request for +http://foo.bar.com:23/whatever +will come to proxy.blop.com and will have a different raw uri: + +<ol> + <li>the request-raw-uri is now http://foo.bar.com:23/whatever </li> + <li>the request-uri is still http://foo.bar.com:23/whatever </li> + <li>the Host header value is still "foo.bar.com:23" </li> +</ol> + +If the filter wants to alter the destination of request it should ensure that the three +values mentioned above are set appropriately for the destination. If the new destination +is not served by the current allegroserve wserver, then the filter will have to make sure +to turn it into a proxy request (and this will only work if this AllegroServe was started +with proxying enabled). + +  + +<hr> + +<h2><a name="virtual_hosts"></a>Virtual Hosts</h2> + +It is possible for a single web sever to act like two or more indepenent web servers. +  This is known as virtual hosting.  AllegroServe supports the ability +to run any number of virtual hosts in a single instance of AllegroServe. + +AllegroServe runs on a single machine and listens for requests on one port on one or +more more IP addresses.   When a request arrives there is usually a header line +labelled Host whose value is the specific hostname typed +into the browser by the user.   Thus if hostnames www.foo.com +and www.bar.com both point to the same machine then it's +possible for the webserver on that machine to distinguish a request for http://www.foo.com from a request for http://www.bar.com +by looking at the Host header. + +In order to make AllegroServe easy to use you can ignore the virtual hosting facility +until you plan to use it.   As long as you don't specify a :host +argument to any of the publish functions when adding content to your site, everything you +publish will be visible from your web server no matter which hostname the web browser uses +to access your site.  If you decide you want to make use of virtual hosting, then +read on. + +<h3>vhost class</h3> + +In AllegroServe a virtual host is denoted by a instance of class vhost. +   The contents of a vhost object are: + +<table border="1" width="83%"> + <tr> + <th width="26%">Accessor Function</th> + <th width="57%">What</th> + <th width="17%">initarg</th> + </tr> + <tr> + <td width="26%">vhost-log-stream</td> + <td width="57%">Stream to which to write logging information on requests to this virtual + host</td> + <td width="17%">:log-stream</td> + </tr> + <tr> + <td width="26%">vhost-error-stream</td> + <td width="57%">Stream to which AllegroServe sends informational and error messages that + are generated during request processing.</td> + <td width="17%">:error-stream</td> + </tr> + <tr> + <td width="26%">vhost-names</td> + <td width="57%">A list of all the names for this virtual host.  </td> + <td width="17%">:names</td> + </tr> + <tr> + <td width="26%">vhost-filters</td> + <td width="57%">list of <a href="#filters">filter functions</a> </td> + <td width="17%">:filters</td> + </tr> +</table> + +The defaults values for the two streams in a vhost object is the wserver-log-stream +from the server object. + +Every instance of AllegroServe has a default vhost object that can be retrieved from +the wserver object via the function wserver-default-vhost. +   If a request comes in for a virtual host that's not known, then it's +assumed to be for the default virtual host. + +There are two ways to create virtual hosts in AllegroServe: implicitly or explicitly. +   If a publish function is called with a :host value that +names a host not known to be a virtual host then a vhost instance will be +created automatically and stored in the wserver's hash table that maps +names to vhost objects.  This is implicit virtual host creation. + +If you know ahead of time the virtual hosts you'll be serving then it's better to setup +all the virtual hosts explicitly.   You create a vhost instance +with make-instance and you register each virtual host in the wserver-vhosts +table using gethash.     Following is an example of +setting up a server to have two virtual hosts, one that responds to three names and one +that responds to two names.   Since we are using the default vhost to represent +the first virtual host, this virtual host will also receive requests for names we haven't +mentioned explicitly. + +  + +<pre>(defun setup-virtual-hosts (server) + (let ((vhost-table (wserver-vhosts server)) + (foo-names '("localhost" "www.foo.com" "foo.com")) + (bar-names '("www.bar.com" "store.bar.com"))) + + (let ((default-vhost (wserver-default-vhost server))) + (setf (vhost-names default-vhost) foo-names) + (dolist (name foo-names) + (setf (gethash name vhost-table) default-vhost))) + + (let ((bar-vhost (make-instance 'vhost :names bar-names))) + (dolist (name bar-names) + (setf (gethash name vhost-table) bar-vhost))))) + +</pre> + +When a request comes in, AllegroServe will determine which vhost is the intended target +and if none is found it will select the default vhost as the intended target.  The +vhost so determined will be stored in the http-request object in the slot +accessed by request-vhost function. + +<h3><a name="host_arg"></a>host argument to publish functions</h3> + +We now are in a position to describe what values the :host argument to +the publish functions can take on.   The :host argument can be nil +or one of: + +<ol> + <li>a string naming a virtual host.  If there is no virtual host with this name a new + virtual host object is created. </li> + <li>a vhost object</li> + <li>the symbol :wild</li> + <li>a list of items of the above items</li> +</ol> + +If the value of the :host argument is nil, then its +value is assumed to be :wild. + +The value of the :host argument is converted into a list of one or +more vhost objects and/or the symbol :wild.    The meaning +of a vhost is clear: it means that this entity will be visible on this virtual host. +  The meaning of :wild is that this entity will be visible on all +virtual hosts, except it can be shadowed by a entity specified for a particular virtual +host.  Thus you could publish an entity for :path "/" and :host +:wild and it will be used for all virtual hosts that don't specify a entity for :path +"/".  Note that when a request comes in and the search is done for +an entity to match the request every step of the way we look first for a vhost specific +handler and then a :wild handler   It is not the case +that we first do a complete search for a vhost specific handler and then restart the +search this time looking for a :wild handler. + +  + +<hr> + +<h2><a name="timeouts"></a>Timeouts</h2> + +A web server is a program that provides resources to client program connecting over the +network.  The resources a web server has to offer is limited and it's important that +network problems or buggy clients don't cause those resources to be unavailable to new +clients.   AllegroServe uses timeouts to ensure that no client can hold a web +server resource for more than a certain amount of time. + +Three common ways for a resource to be held are + +<ol> + <li>A client stops sending a request in the middle of the request.   This can + happen if the client machine crashes or  if the client's machine loses network + connectivity with the  machine running AllegroServe.</li> + <li>A client stops reading the response to its request.    The networking + code will automatically stop the sender from writing new data if the receiver has a lot of + existing data to read. </li> + <li>The response function to an http request can take a very long time, or may even be in an + infinite loop.   This could be due to a bug in a http response function or + something unexpected, like a database query taking a long time to finish.</li> +</ol> + +  + +<h3>Acl 6.0 or older</h3> + +For AllegroServe running in Acl 6.0 or older timeouts are done this way: + +net.aserve::*read-request-timeout*  - number of seconds +AllegroServe allows for the request line (the first line) and all following header lines. +  The default is 20 seconds. + +net.aserve::*read-request-body-timeout* - number of seconds +AllegroServe allows for the body of the request (if any) to be read.   The +default is 60 seconds. + +(wserver-response-timeout wserver) - the number of seconds +AllegroServe allows for an http request  function to be run and finished sending back +its response.  The initial value for this slot of the wserver object is found in *http-response-timeout* +which defaults to 120 seconds.  You can alter this timeout value with the :timeout +argument to with-http-response or by specifying a :timeout +when publishing the entity. + +<h3>Acl 6.1 or newer</h3> + +In Acl 6.1 we added the capability of having each I/O operation to a socket stream time +out.   This means that we don't have to predict how long it should take to get a +request or send a response.  As long as we're making progress reading or writing we +know that the client on the other end of the network connection is alive and well. +   We still need a timeout to handle case (3) above but we can allow a lot more +time for the http response since we aren't using this timer to catch dead clients as well. +   Thus we have these timeout values: + +<a name="f-wserver-io-timeout"></a>(wserver-io-timeout wserver) - the +number of seconds that AllegroServe will wait for any read or write operation to the +socket to finish.   The value is initialized to the value of *http-io-timeout* +  which defaults to 60 seconds. + +<a name="f-wserver-response-timeout"></a>(wserver-response-timeout wserver) +-  the number of seconds AllegroServe allows for an http request function to be run +and finished sending back its response. The initial value for this slot of the wserver +object is found in *http-response-timeout* which defaults to 300 seconds. +You can alter this timeout value with the :timeout argument to with-http-response +or by specifying a :timeout argument to the publish function creating the +entity. + +publish-directory and publish-file default their timeout +argument in a way that makes sense based on whether the Lisp supports I/O timeouts. +   If I/O timeouts are supported then there is no reason to do a global timeout +for the whole response if you're just sending back a file.   Thus in this case +the timeout argument defaults to a huge number. + +  + +<hr> + +<h2><a name="miscellaneous"></a>Miscellaneous</h2> + +<a name="f-ensure-stream-lock"></a>(ensure-stream-lock +stream) + +The function adds a <a +href="http://www.franz.com/support/documentation/6.1/doc/multiprocessing.htm#proc…">process +lock</a> to stream's property list (under the indicator :lock) +if no such lock is present.   Then it returns the object stream. + +The AllegroServe logging functions make use of the stream's lock to ensure that only +one thread at a time write log information to the stream.   If the logging +functions find that a a log stream doesn't have a lock associated with it then the log +information will still be written to the stream but under heavy load the log information +from multiple threads will become intermixed. + +  + +<a name="f-map-entities"></a>(map-entities function +locator) + +When one of the publish functions is called enties +are placed in locator objects.   The locator objects +are then checked when http requests come in to find the appropriate entity.  map-entities +will apply the given function of one argument to all the entities in the +given locator.   One common use of map-entities +is to find entities that you no longer wish to be published.  For that reason map-entities +will remove the entity the passed to the function if the function +returns the keyword symbol :remove as its value. + +  + +<hr> + +<h2><a name="asaservice"></a>Running AllegroServe as a Service on Windows NT</h2> + +On Windows NT (and Windows 2000 and Windows XP) when you log off all the programs you +are running are terminated.   If you want to run AllegroServe on your machine +after you log out you have to start it as a Windows Service.  This +is easy to do thanks to code contributed by Ahmon Dancy.   + +The first step is to download the <a href="http://opensource.franz.com/ntservice">ntservice +code and documentation</a> from the Franz <a href="http://opensource.franz.com">opensource +site</a>.  Read the documentation carefully especially as regards the different +capabilities of the accounts under which you may choose to run AllegroServe.   + +You'll probably want to build an AllegroServe application that can run either normally +or as a service,.  You can run it normally to debug it and then start it as a service +when you're satisifed that it works. + +Following is an example of how this can be done.   I've decided that if the /service argument is given on the command line when I start my +application then I'll start my application as a service, otherwise I start it normally. +     Here is the restart-init-function (to generate-application) +that I define: + +<pre>(defun start-aserve-application () + (flet ((start-application () + (net.aserve:start :port 8020) + (loop (sleep 100000)))) + (if* (member "/service" (sys:command-line-arguments) :test #'equalp) + then ; start as a service + (ntservice:start-service #'start-application) + else ; start as a normal app + (start-application)))))</pre> + +  + +I use (loop (sleep 100000)) to ensure that the restart-init-function +never returns. + +  + +In order to register my application as a service to the operating system I call ntservice:create-service +like this: + +<pre>(ntservice:create-service "aservetest" "Aserve Test Service" + "c:\\acl61\\testservice\\testapp\\testapp.exe -- /service")</pre> + +Note that I use "--" before the "/service".  This is very important. +   The "--" separates the arguments +used to start up the program from the arguments passed to the program itself.    +The call to ntservice:create-service is done only once and need not be +done from within your application.  + +Once an application is registered as a service you can start it by going to the Control +Panel, selecting Administrative Tools and then Services.   Locate the service +you just added, right click on it and select start.   You can +stop the service with a a right click as well. + +  + +<hr> + +<h2><a name="international-chars-aserve"></a>Using International Characters in +AllegroServe</h2> + +A character set is a collection of characters and a rule to encode them as a +sequence of octets.   The default character set for web protocols is Latin1 +(also known as ISO 8859-1).   The Latin1 character set represents nearly every +character and punctuation needed for western European languages (which includes English). +   + +If you want to work with characters outside the Latin1 set you'll want to use the <a +href="http://www.franz.com/support/documentation/6.1/doc/iacl.htm">International version +of Allegro CL</a> which represents characters internally by their 16-bit <a +href="http://www.unicode.org">Unicode</a> value.    In this section we'll +assume that you're using International Allegro CL. + +What the web protocols refer to as charset (character set) Allegro CL +refers to as an external-format.  Allegro CL uses a different term +since it always uses 16-bit Unicode to represent characters internally.  16 bit +unicode can represent nearly all characters on the planet.  It's only when those +characters are read from or written to devices outside of Lisp that the actual encoding of +those characters into octets matters.    Thus the external-format +specifies how characters are encoded and specifies which Unicode characters are part of +the character set that the external-format defines.  Attempts to write a Unicode +character that's not part of the character set results in a question mark being written. + +External-formats are also used in Allegro CL to do certain character to character +transformations.  In particular on the Windows platform external formats are used to +convert the lisp end of line (a single #\newline character) to the #\return #\linefeed +character that is standard on Windows.   Thus an external format such as :utf-8 +  has a different effect on Windows than on Unix, and this is not desireable for web +applications.   The function call (crlf-base-ef :utf-8) +returns an external format on Windows and on Unix that simply does the character encoding +part of the external format, and thus this is the external format you would want to use in +a web application. + +<h3>server to client (browser) character transfer</h3> + +When a web server returns a response to a client it sends back a response line, a +header and optionally a body.   The response line and header are always sent +using a subset of the Latin1 character set (the subset corresponding the the US ASCII +character set).   The body is sent using the full Latin1 character set, unless +otherwise specified.  To specify the character set of the body you add an extra +parameter to the Content-Type header.   Instead of specifying a content type of +"text/html" you might specify "text/html; charset=iso-8859-2". +   This alerts the http client that it must interpret the octets comprising the +body of the response according to the iso-8859-2 character set.   This however +is not enough to make AllegroServe encode the Unicode characters +it's sending to the client using the approrpriate external format.  You would have to +do this: + +<pre>(with-http-response (req ent) + (with-http-body (req ent :external-format (crlf-base-ef :iso8859-2)) + ... generate and write page here.. +))</pre> + +Note that the charset names and external format name are similar but not identical. +  Check <a href="http://www.iana.org/assignments/character-sets">here</a> for the +charset names and check <a +href="http://www.franz.com/support/documentation/6.1/doc/iacl.htm#external-format…">here</a> +for the Allegro CL external format names. + +In order to make it easier to specify external formats in AllegroServe you can specify +a default external format when you start the server (with the :external-format +argument to the start function).   The variable *default-aserve-external-format* +will then be bound to this external format in each of the threads that processes +http requests.   It's the value of *default-aserve-external-format* +that is used as the default argument to the :external-format argument to with-http-body. + +The default value of the :external-format argument to the start +function, and thus the default value of *default-aserve-external-format*, +is (crlf-base-ef :latin1-base).   This means that regardless of +the locale in which you run AllegroServe, AllegroServe will by default using the Latin1 +character set, which is what is expected by web clients.. + +A very useful character set is utf-8 which is the whole Unicode +character set and thus comprises all of the characters you can store inside Lisp. +   The corresponding Allegro CL external format is the value of (crlf-base-ef :utf-8).   Specifying +this character set allows you to write web pages that can characters from nearly every +language in the world (whether the web browser can find the glyphs to display all those +characters is another matter). + +<h3>client (browser) to server character transfer</h3> + +The brower sends characters to the web server when the user enters data into a form and +submits the form.   The important thing to remember is that the browser will +encode characters using the character set that was specified for the web page containing +the form.  If you fail to specify a charset when the page was given +to the web browser then the web browser will decide on its own how to encode characters +that aren't part of the default character set ( which is of course Latin1).    +The browser will not tell you which encoding it chose.   Therefore if you +ever plan on allowing  non-Latin1 characters to be specified in your forms you'll +want to specify a charset for the page containing the form. + +You can specify the charset in the Content-Type field of the header that's sent with +the page (as we described above) or you can put it in the page itself using a meta tag: + +<pre><meta http-equiv="Content-Type" content="text/html; charset=utf-8"></pre> + +Retrieving form data in AllegroServe is done with the request-query +function and that function takes an :external-format argument so you can +specify how the form data can be decoded.   If your form sends multipart data +then you can use the :external-format argument to get-multipart-sequence +to retrieve the form data and decode the data. + +<h3>examples</h3> + +The AllegroServe test page has links to a few pages that show how international +characters work with AllegroServe.  One of these is the the International Character +Display page.  This page  shows what happens when the charset +and external-format are set to different values and a page containing +international characters is displayed.  It demonstrates how it important is is that +those two character set specifications be kept in sync, and it shows that utf-8 +is most likely the best choice for a character set for your web pages. + +  + +<hr> + +<h2><a name="debugging"></a>Debugging</h2> + +Debugging entity handler functions is difficult since these are usually run on a +separate lisp thread.  Also AllegroServe catches errors in entity handler functions, +thus preventing you from interactively diagnosing the problem. + +You can put AllegroServe in a mode that makes debugging easier with the net.aserve::debug-on function.   Note that this is not +an exported function to emphasize the fact that you are working with the internals of +AllegroServe. + +  + +<a name="f-debug-on"></a>(net.aserve::debug-on +&rest debugging-features-to-enable) + +We've classified the debugging features and given each a keyword symbol name. +   This function turns on those named features.  If no arguments are given, +then debug-on prints the list of debugging features and whether each is +enabled. + +  + +<a name="f-debug-off"></a>(net.aserve::debug-off +&rest debugging-features-to-disable) + +This function turns off the given list of features. + +  + +The list of debug features are: + +<table border="1" width="100%"> + <tr> + <td width="18%">:info</td> + <td width="82%">AllegroServe prints information at certain places while doing its + processing.   </td> + </tr> + <tr> + <td width="18%">:xmit</td> + <td width="82%">AllegroServe prints what it receives from and sends to the client.  + In some cases the body of a request or response will not be printed.</td> + </tr> + <tr> + <td width="18%">:notrap</td> + <td width="82%">When enabled, this prevents AllegroServe from catching errors in entity + handler functions.  If an error occurs and you're running in an evironment where + background processes automatically create new windows (such as the emacs-lisp interface) + then you'll be given a chance to :zoom the stack and diagnose the problem.  Note that + if a timeout has been established to limit the amount of time that a certain step is + allowed (and this is done by default) then the interactive debugging session will be + aborted when the timeout is reached.</td> + </tr> +</table> + +  + +Two pseudo debug features are :all and :log..   +Specifying :all to debug-on or debug-off +  is the same as listing all of the debug features.   Specifying :log +is the same as specifying all features except :notrap. + +  +</body> +</html> Property changes on: vendor/portableaserve/aserve/doc/aserve.html ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/aserve/doc/cvs.html =================================================================== --- vendor/portableaserve/aserve/doc/cvs.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/cvs.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,144 @@ +<html> + +<head> +<title>cvs</title> +<meta name="GENERATOR" content="Microsoft FrontPage 3.0"> +</head> + +<body> + +Cvs allows you to automatically merge in the changes we make to +Allegro aserve to a copy of the source you may have modified.   This is much +easier and less error prone than trying to see what we've changed by comparing source +distributions and then merging in the changes yourself.   A copy of the cvs +document in pdf format is <a href="ftp://ftp.franz.com/pub/misc/cvs.pdf">here</a>.  +On our server we are using 1.10.7 of cvs, so you'll want to make sure +your cvs client is compatible with that version. + +To access our repository via cvs here are the parameters you'll need: + +<table border="0" width="58%" style="border: medium none" bgcolor="#FFFF00"> + <tr> + <td width="22%">CVSROOT</td> + <td width="87%">:pserver:cvspublic@cvspublic.franz.com:/cvs-public</td> + </tr> + <tr> + <td width="22%">password</td> + <td width="87%">cvspublic</td> + </tr> +</table> + +If you use the -d parameter as shown below you won't need to set the CVSROOT +environment variable.  + +Here is a sample session where you check out aserve for the first time.    +First you have to save the password for the account on your machine, and you do that using +the cvs login command: + +<pre>% cvs -d :pserver:cvspublic@cvspublic.franz.com:/cvs-public login +(Logging in to cvspublic(a)cvspublic.franz.com) +CVS password: cvspublic +</pre> + +Next you check out the source code: + +<pre> +% cvs -d :pserver:cvspublic@cvspublic.franz.com:/cvs-public checkout aserve +cvs server: Updating aserve +U aserve/ChangeLog +U aserve/authorize.cl +U aserve/client.cl +U aserve/decode.cl +U aserve/license-lgpl.txt +U aserve/load.cl +U aserve/loadonly.cl +U aserve/log.cl +U aserve/macs.cl +U aserve/main.cl +U aserve/parse.cl +U aserve/publish.cl +U aserve/readme.txt +U aserve/source-readme.txt +cvs server: Updating aserve/doc +U aserve/doc/aserve.html +U aserve/doc/notes-neo.n +U aserve/doc/rfc2396.txt +U aserve/doc/tutorial.html +cvs server: Updating aserve/examples +U aserve/examples/examples.cl +U aserve/examples/foo.txt +U aserve/examples/fresh.jpg +U aserve/examples/aservelogo.gif +U aserve/examples/prfile9.jpg +U aserve/examples/tutorial.cl +cvs server: Updating aserve/htmlgen +U aserve/htmlgen/htmlgen.cl +U aserve/htmlgen/htmlgen.html +U aserve/htmlgen/test.cl +% + +</pre> + +Now you can read aserve/source-readme.txt and learn how +to build aserve.   + +To see how cvs can help you, suppose you edit aserve/examples/examples.cl +and add a new page to be published.  You can ask cvs to tell you +what you've changed since you last retrieved the source from our repository:  + +<pre>% cd aserve + +% cvs diff +cvs server: Diffing . +cvs server: Diffing doc +cvs server: Diffing examples +Index: examples/examples.cl +=================================================================== +RCS file: /cvs-public/aserve/examples/examples.cl,v +retrieving revision 1.2 +diff -r1.2 examples.cl +369a370,378 +> +> (publish :path "/hiworld" +> : content-type "text/html" +> :function +> #'(lambda (req ent) +> (with-http-response (req ent) +> (with-http-body (req ent) +> "hi world")))) +> +cvs server: Diffing htmlgen +% + +</pre> + +You would now like to retrieve the latest version of the source from our repository and +merge our changes into your changes.   This is done with one command: executed +from the aserve directory created in the cvs checkout command: + +<pre>% cvs update -d +cvs server: Updating . +P client.cl +cvs server: Updating doc +cvs server: Updating examples +M examples/examples.cl +cvs server: Updating htmlgen +%</pre> + +The response from the command is terse.  In this case the P before +client.cl says that there were changes to that file in the +repository that have now been patched into your copy of the source.  The M +before examples/examples.cl says that you have local +modifications to this file.  If you see a file name preceded by U (as +they were in the cvs update command earlier), it means that this a new +file that was downloaded in full.  What you must look for is the response C +which said that the updating process found conflicts that it couldn't resolve because both +we and you modified the same lines in the file.   In this case you must edit the +file and look for the lines surrounded by <<<<<<<<<<, +========= and >>>>>>>>>> and remove the markers and resolve +the conflict + +We've just mentioned a few of the features of cvs, you are advised to +read the cvs manual to get the maximum benefit from it. +</body> +</html> Added: vendor/portableaserve/aserve/doc/htmlgen.html =================================================================== --- vendor/portableaserve/aserve/doc/htmlgen.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/htmlgen.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,559 @@ +<html> + +<head> +<title>HTML Generation Facility</title> +<meta name="GENERATOR" content="Microsoft FrontPage 3.0"> +</head> + +<body> + +<h1 align="center">HTML Generation Facility</h1> + +This document copyright (c) 2000-2003 Franz Inc. + +<h2>Introduction</h2> + +We've defined a pair of macros which enable  a program to generate html +in a concise and readable  manner.   These macros are quite a bit different +than those found in other html generation systems and thus we'll briefly +describe the justification for this design. + +html is a concise markup language. There is a tendency in language +design to assume that one's users won't be as smart as one's self and thus one tends to +dumb things down.  For example, html uses +to start a  paragraph.  The language designer says to himself: "while I +know that p means paragraph, my users won't so I'll spell it out as with-paragraph." +   A similar thing is done for all the other html commands and soon a program to +generate html contains so many long markup commands that it's hard to see the text of the +document from the markup commands.  A second problem is that as a user you're not +sure exactly what html will be generated by some high level with-xxx +forms.   If you're trying to generate a particular sequence of html +you're left experimenting with the high level forms and hoping that by luck you get the +output you want.    A third problem is that with the high level forms +you're forced to learn yet another markup language.  There are plenty of books and +reference guides to html itself and it's an easy language to master. +   Learning  a particular high-level mapping of html is an +added burden. + +With our html generation macros you write the actual html and +we just eliminate some of the tedious parts, such as closing off markup commands.   +The result is that the structure of the document is visible and you can use any book on html +as a reference. + +<h2>Example</h2> + +The following example of generated web page will be useful to refer to in the +discussion below of the syntax of the html macro. + +<pre>(defvar *my-counter* 0) ; initialize counter variable.</pre> + +<pre>(html (:html + (:head (:title "My Document")) + (:body (:h1 "My Document") + "Hello AllegroServe, the time is " + (:prin1 (get-universal-time)) + + (incf *my-counter*) ; evaluated but not printed +)))</pre> + +  + +This particular example generates a complete web page, but it's possible to use the +  html macro to generate partial pages as well.   In this +example, the generated page is surrounded by <html> and </html> +due to the :html form.    The page contains a header and a +body surrounded by their respective html markers.  The body of the document contains +a level 1 header followed by the text beginning "Hello, AllegroServe". +   Following that is printed the universal time at the time that the page is +generated (i.e now rather than when the macro was first processed by lisp).    +The following incf expression is evaluated but the result is not +printed.   In this case we're keeping a private count of the number of times +this page has been accessed. + +<h2>html macro</h2> + +Now that you have a sense of how the html macro works, we will +describe the syntax in detail. + +  + +(html form1 form2 ... formn)                     +[Macro] + +The forms are processed from left to right.  The most  likely effect is that +html output is generated.  The output is sent to the stream net.html.generator:*html-stream*. +  The html macro is designed to run inside AllegroServe's with-http-body +macro which binds *html-stream* to the correct stream.   Also +the html-stream macro described below binds *html-stream* before +calling html.  The action taken by html depends on +what the form looks like at macro-expansion time.    The possibilities are: + +<ul> + <li>string -  A string is simply written (using princ) to the output + stream.   Thus the string could contain embedded html commands.</li> + <li>keyword symbol -  The keyword must name a known html operator.   The + result is that the associated html markup command is sent to the output stream.  The + mapping of keyword to html command is trivial -- the print name of the keyword is the html + command.  So :p  emits .</li> + <li>list beginning with a keyword symbol - This names an html operator that + may or may not have an associated inverse operator beginning with "/".  The + typical result of this form is to emit the associated html markup command, then process + the items in the list in the same way as the forms are processed, and then emit the + inverse markup command.  Thus (:i "foo") emits foo. +      There is a special case when a single element list is given + (see below for details).  Also there are some special keywords that are commands to + the html macro rather than markup commands.  They are described + below.</li> + <li>list beginning with a list beginning with a keyword symbol - This is used to specify + markup commands that have parameters.  For example + ((:a href "/foo/bar.html") "the link") turns into <a + href="/foo/bar.html">the link</a>.    The + arguments are in plist form: a sequence of names and values.  The names are not + evaluated, they should be symbols or strings.   We often use keyword symbols for + the names since that looks more lisp-like and reduces the number of symbols we create. +   The values are evaluated and printed with a function that escapes + characters with special meaning in html : <, >, &, ".   If the + value is a symbol with a zero length print name, then something special is done:  The + name alone is printed without a following equal sign.  For example: ((:option + :size 4 :selected '||) "foo") generates <option + size="4" selected>foo</option>.    This form of + valueless argument is illegal html but in some older browsers it's the required syntax.</li> + <li>anything else  - everything else is simply evaluated in the normal lisp way and the + value thrown away.</li> +</ul> + +Special cases: + +<ul> + <li>(:princ arg1 arg2 .. argn) causes the result of + evaluating each of the args to be printed to the html stream using the princ + function (which prints without inserting escape characters needed by the lisp reader to + read the result).</li> + <li>(:prin1 arg1 arg2 ... argn) causes the result of + evaluating each of the args to be printed to the html stream using the prin1 function + (which prints by inserting escape characters needed by the lisp reader to read the + result).</li> + <li>(:princ-safe arg1 arg2 .. argn) acts like the :princ + case except that the output is scanned for characters that could be considered html markup + commands, and if found, these characters are escaped to prevent them from being treated as + html markup commands.</li> + <li>(:prin1-safe arg1 arg2 .. argn) acts like the :prin1 + case except that the output is scanned for characters that could be considered html markup + commands, and if found, these characters are escaped to prevent them from being treated as + html markup commands.</li> + <li>:newline simply inserts a newline into the html output stream. +    This will not have an effect on the result as viewed by a web browser (unless + it is emitted while inside an html markup command that specifies preformatted input). +   The main use for this is to make the resulting html file easier to read by a human.</li> + <li>You can conditionally specify arguments to a markup command using an argument name of +   :if*. Following the :if* is a lisp expression + which if true at runtime will cause the following argument value pair to be included in + the argument tag.  For example ((:td :if* (frob) :bgcolor + "#00ff00") "xx") will only put bgcolor="#00ff00" + in the argument if the expression (frob) returns true at runtime.</li> +</ul> + +  + +  + +(html-stream stream  form1 form2 ... +formn) +                    +[Macro] + +This binds net.html.generator:*html-stream* to the value of the stream +argument and then evaluates the form arguments just like the html +macro. + +  + +<h2>Examples</h2> + +We will show how to build a page containing a table using successively more runtime +customization of the table.  First we show how to build a table of squares. + +<pre>defun simple-table-a () + (with-open-file (p "test.html" + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body + (:table + (:tr (:td "0") (:td "0")) + (:tr (:td "1") (:td "1")) + (:tr (:td "2") (:td "4")) + (:tr (:td "3") (:td "9")) + (:tr (:td "4") (:td "16")) + (:tr (:td "5") (:td "25"))))))))</pre> + +The function simple-table-a builds a page containing this table: + +<table> + <tr> + <td>0</td> + <td>0</td> + </tr> + <tr> + <td>1</td> + <td>1</td> + </tr> + <tr> + <td>2</td> + <td>4</td> + </tr> + <tr> + <td>3</td> + <td>9</td> + </tr> + <tr> + <td>4</td> + <td>16</td> + </tr> + <tr> + <td>5</td> + <td>25</td> + </tr> +</table> + +It isn't very pretty but it's easy to see the correspondence between the html +macro and the resulting table.  Note that if we had done, for example, (:td +1) instead of (:td "1") then nothing would have been +emitted.   Only constant strings are printed, not constant integers.  To +use an integer here we would have had to do (:td (:princ 1)). + +We can use the ability to pass arguments to html markup commands to specify a border +around the elements of the table as shown here: + +<pre>(defun simple-table-b () + (with-open-file (p "test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body + ((:table border 2) + (:tr (:td "0") (:td "0")) + (:tr (:td "1") (:td "1")) + (:tr (:td "2") (:td "4")) + (:tr (:td "3") (:td "9")) + (:tr (:td "4") (:td "16")) + (:tr (:td "5") (:td "25")))))))) +</pre> + +The resulting table is: + +<table border="2"> + <tr> + <td>0</td> + <td>0</td> + </tr> + <tr> + <td>1</td> + <td>1</td> + </tr> + <tr> + <td>2</td> + <td>4</td> + </tr> + <tr> + <td>3</td> + <td>9</td> + </tr> + <tr> + <td>4</td> + <td>16</td> + </tr> + <tr> + <td>5</td> + <td>25</td> + </tr> +</table> + + +Suppose we wanted to make the table include the squares of numbers from zero to 100. +  That would take a lot of typing.  Instead, let's modify the table generation +function to compute a table of any size: + +<pre>(defun simple-table-c (count) + (with-open-file (p "test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body + ((:table border 2) + (dotimes (i count) + (html (:tr (:td (:princ i)) + (:td (:princ (* i i))))))))))))</pre> + +  + +Note that we can freely imbed calls to the html macro within another +call.   The dotimes call inside the :body +expression is simply evaluated and its value ignored.  However the side effect of the +dotimes is to generate more html and to send it to the stream bound in +the html-stream call.  The result of (simple-table-c +8) is + +<table border="2"> + <tr> + <td>0</td> + <td>0</td> + </tr> + <tr> + <td>1</td> + <td>1</td> + </tr> + <tr> + <td>2</td> + <td>4</td> + </tr> + <tr> + <td>3</td> + <td>9</td> + </tr> + <tr> + <td>4</td> + <td>16</td> + </tr> + <tr> + <td>5</td> + <td>25</td> + </tr> + <tr> + <td>6</td> + <td>36</td> + </tr> + <tr> + <td>7</td> + <td>49</td> + </tr> +</table> + +  + +We can specify at runtime values for the arguments to html markup forms.  This +function allows us to specify parameters of the table being built: + +<pre>(defun simple-table-d (count border-width backg-color border-color) + (with-open-file (p "test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body + ((:table border border-width + bordercolor border-color + bgcolor backg-color + cellpadding 3) + (:tr ((:td bgcolor "blue") + ((:font :color "white" :size "+1") + "Value")) + ((:td bgcolor "blue") + ((:font :color "white" :size "+1") + "Square")) + ) + (dotimes (i count) + (html (:tr (:td (:princ i)) + (:td (:princ (* i i)))))))))))) + </pre> + +This demonstrates that in an html markup command argument list the keywords aren't +evaluated but the values are.   If we evaluate this expression: + +<pre>(simple-table-d 10 3 "silver" "blue")</pre> + +then we generate this table: + +<table border="3" bordercolor="blue" bgcolor="silver" cellpadding="3"> + <tr> + <td bgcolor="blue">Value</td> + <td bgcolor="blue">Square</td> + </tr> + <tr> + <td>0</td> + <td>0</td> + </tr> + <tr> + <td>1</td> + <td>1</td> + </tr> + <tr> + <td>2</td> + <td>4</td> + </tr> + <tr> + <td>3</td> + <td>9</td> + </tr> + <tr> + <td>4</td> + <td>16</td> + </tr> + <tr> + <td>5</td> + <td>25</td> + </tr> + <tr> + <td>6</td> + <td>36</td> + </tr> + <tr> + <td>7</td> + <td>49</td> + </tr> + <tr> + <td>8</td> + <td>64</td> + </tr> + <tr> + <td>9</td> + <td>81</td> + </tr> +</table> + +  + +  + +An example of conditional arguments to a markup command is this: + +<pre>(defun simple-table-e (count) + (with-open-file (p "test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body + ((:table border 2) + (dotimes (i count) + (html (:tr + (dotimes (j count) + (html ((:td :if* (evenp j) :bgcolor "red" + :if* (not (evenp j)):bgcolor "green") + (:princ (* i j)))))))))))))) +</pre> + +This sets the color of the columns to alternately red and green:  Here is (simple-table-e 6) + +<table border="2"> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">0</td> + <td bgcolor="red">0</td> + <td bgcolor="green">0</td> + <td bgcolor="red">0</td> + <td bgcolor="green">0</td> + </tr> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">1</td> + <td bgcolor="red">2</td> + <td bgcolor="green">3</td> + <td bgcolor="red">4</td> + <td bgcolor="green">5</td> + </tr> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">2</td> + <td bgcolor="red">4</td> + <td bgcolor="green">6</td> + <td bgcolor="red">8</td> + <td bgcolor="green">10</td> + </tr> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">3</td> + <td bgcolor="red">6</td> + <td bgcolor="green">9</td> + <td bgcolor="red">12</td> + <td bgcolor="green">15</td> + </tr> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">4</td> + <td bgcolor="red">8</td> + <td bgcolor="green">12</td> + <td bgcolor="red">16</td> + <td bgcolor="green">20</td> + </tr> + <tr> + <td bgcolor="red">0</td> + <td bgcolor="green">5</td> + <td bgcolor="red">10</td> + <td bgcolor="green">15</td> + <td bgcolor="red">20</td> + <td bgcolor="green">25</td> + </tr> +</table> + +  + +  + +  + +<h2>HTML generation functions</h2> + +It's possible to express HTML using Lisp data structures.   The form is based +on how HTML is written using the html macro above.  + +Lisp HTML (lhtml) is defined as one of the following + +<ul> + <li>a string, which is rendered as HTML by simply printing it.  Thus the string can + contain embedded HTML commands.</li> + <li>a list beginning with a valid lhtml keyword and containing lhtml + forms.   The valid keywords are those corresponding to the HTML entity tags, + plus the special tags :princ, :princ-safe, :prin1, :prin1-safe, :newline + and :comment.   These act just as they do in the html + macro.   This form is rendered as an opening tag, then the rendering of the + body, and a closing HTML tag if one exists.</li> + <li>a list beginning with a list beginning with an lhtml keyword.   + This is the form used when attributes are to be supplied with the opening entity + tag.  </li> +</ul> + +Examples of valid lhtml: + +<ul> + <li>"foobarbaz"</li> + <li>(:i "foo")</li> + <li>((:body :bgcolor "#xffffff") "the body")</li> +</ul> + +  + +(html-print lhtml stream) + +Print the Lisp HTML expression lhtml to the stream. + +  + +(html-print-list lhtml-list stream) + +Print the list of lhtml forms to the stream.   This +is equivalent to calling html-print on every element of lhtml-list. + + +  + +  + +  +</body> +</html> Added: vendor/portableaserve/aserve/doc/rfc2396.txt =================================================================== --- vendor/portableaserve/aserve/doc/rfc2396.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/rfc2396.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2243 @@ + + + + + + +Network Working Group T. Berners-Lee +Request for Comments: 2396 MIT/LCS +Updates: 1808, 1738 R. Fielding +Category: Standards Track U.C. Irvine + L. Masinter + Xerox Corporation + August 1998 + + + Uniform Resource Identifiers (URI): Generic Syntax + +Status of this Memo + + This document specifies an Internet standards track protocol for the + Internet community, and requests discussion and suggestions for + improvements. Please refer to the current edition of the "Internet + Official Protocol Standards" (STD 1) for the standardization state + and status of this protocol. Distribution of this memo is unlimited. + +Copyright Notice + + Copyright (C) The Internet Society (1998). All Rights Reserved. + +IESG Note + + This paper describes a "superset" of operations that can be applied + to URI. It consists of both a grammar and a description of basic + functionality for URI. To understand what is a valid URI, both the + grammar and the associated description have to be studied. Some of + the functionality described is not applicable to all URI schemes, and + some operations are only possible when certain media types are + retrieved using the URI, regardless of the scheme used. + +Abstract + + A Uniform Resource Identifier (URI) is a compact string of characters + for identifying an abstract or physical resource. This document + defines the generic syntax of URI, including both absolute and + relative forms, and guidelines for their use; it revises and replaces + the generic definitions in RFC 1738 and RFC 1808. + + This document defines a grammar that is a superset of all valid URI, + such that an implementation can parse the common components of a URI + reference without knowing the scheme-specific requirements of every + possible identifier type. This document does not define a generative + grammar for URI; that task will be performed by the individual + specifications of each URI scheme. + + + + +Berners-Lee, et. al. Standards Track [Page 1] + +RFC 2396 URI Generic Syntax August 1998 + + +1. Introduction + + Uniform Resource Identifiers (URI) provide a simple and extensible + means for identifying a resource. This specification of URI syntax + and semantics is derived from concepts introduced by the World Wide + Web global information initiative, whose use of such objects dates + from 1990 and is described in "Universal Resource Identifiers in WWW" + [RFC1630]. The specification of URI is designed to meet the + recommendations laid out in "Functional Recommendations for Internet + Resource Locators" [RFC1736] and "Functional Requirements for Uniform + Resource Names" [RFC1737]. + + This document updates and merges "Uniform Resource Locators" + [RFC1738] and "Relative Uniform Resource Locators" [RFC1808] in order + to define a single, generic syntax for all URI. It excludes those + portions of RFC 1738 that defined the specific syntax of individual + URL schemes; those portions will be updated as separate documents, as + will the process for registration of new URI schemes. This document + does not discuss the issues and recommendation for dealing with + characters outside of the US-ASCII character set [ASCII]; those + recommendations are discussed in a separate document. + + All significant changes from the prior RFCs are noted in Appendix G. + +1.1 Overview of URI + + URI are characterized by the following definitions: + + Uniform + Uniformity provides several benefits: it allows different types + of resource identifiers to be used in the same context, even + when the mechanisms used to access those resources may differ; + it allows uniform semantic interpretation of common syntactic + conventions across different types of resource identifiers; it + allows introduction of new types of resource identifiers + without interfering with the way that existing identifiers are + used; and, it allows the identifiers to be reused in many + different contexts, thus permitting new applications or + protocols to leverage a pre-existing, large, and widely-used + set of resource identifiers. + + Resource + A resource can be anything that has identity. Familiar + examples include an electronic document, an image, a service + (e.g., "today's weather report for Los Angeles"), and a + collection of other resources. Not all resources are network + "retrievable"; e.g., human beings, corporations, and bound + books in a library can also be considered resources. + + + +Berners-Lee, et. al. Standards Track [Page 2] + +RFC 2396 URI Generic Syntax August 1998 + + + The resource is the conceptual mapping to an entity or set of + entities, not necessarily the entity which corresponds to that + mapping at any particular instance in time. Thus, a resource + can remain constant even when its content---the entities to + which it currently corresponds---changes over time, provided + that the conceptual mapping is not changed in the process. + + Identifier + An identifier is an object that can act as a reference to + something that has identity. In the case of URI, the object is + a sequence of characters with a restricted syntax. + + Having identified a resource, a system may perform a variety of + operations on the resource, as might be characterized by such words + as `access', `update', `replace', or `find attributes'. + +1.2. URI, URL, and URN + + A URI can be further classified as a locator, a name, or both. The + term "Uniform Resource Locator" (URL) refers to the subset of URI + that identify resources via a representation of their primary access + mechanism (e.g., their network "location"), rather than identifying + the resource by name or by some other attribute(s) of that resource. + The term "Uniform Resource Name" (URN) refers to the subset of URI + that are required to remain globally unique and persistent even when + the resource ceases to exist or becomes unavailable. + + The URI scheme (Section 3.1) defines the namespace of the URI, and + thus may further restrict the syntax and semantics of identifiers + using that scheme. This specification defines those elements of the + URI syntax that are either required of all URI schemes or are common + to many URI schemes. It thus defines the syntax and semantics that + are needed to implement a scheme-independent parsing mechanism for + URI references, such that the scheme-dependent handling of a URI can + be postponed until the scheme-dependent semantics are needed. We use + the term URL below when describing syntax or semantics that only + apply to locators. + + Although many URL schemes are named after protocols, this does not + imply that the only way to access the URL's resource is via the named + protocol. Gateways, proxies, caches, and name resolution services + might be used to access some resources, independent of the protocol + of their origin, and the resolution of some URL may require the use + of more than one protocol (e.g., both DNS and HTTP are typically used + to access an "http" URL's resource when it can't be found in a local + cache). + + + + + +Berners-Lee, et. al. Standards Track [Page 3] + +RFC 2396 URI Generic Syntax August 1998 + + + A URN differs from a URL in that it's primary purpose is persistent + labeling of a resource with an identifier. That identifier is drawn + from one of a set of defined namespaces, each of which has its own + set name structure and assignment procedures. The "urn" scheme has + been reserved to establish the requirements for a standardized URN + namespace, as defined in "URN Syntax" [RFC2141] and its related + specifications. + + Most of the examples in this specification demonstrate URL, since + they allow the most varied use of the syntax and often have a + hierarchical namespace. A parser of the URI syntax is capable of + parsing both URL and URN references as a generic URI; once the scheme + is determined, the scheme-specific parsing can be performed on the + generic URI components. In other words, the URI syntax is a superset + of the syntax of all URI schemes. + +1.3. Example URI + + The following examples illustrate URI that are in common use. + + ftp://ftp.is.co.za/rfc/rfc1808.txt + -- ftp scheme for File Transfer Protocol services + + gopher://spinaltap.micro.umn.edu/00/Weather/California/Los%20Angeles + -- gopher scheme for Gopher and Gopher+ Protocol services + + http://www.math.uio.no/faq/compression-faq/part1.html + -- http scheme for Hypertext Transfer Protocol services + + mailto:mduerst@ifi.unizh.ch + -- mailto scheme for electronic mail addresses + + news:comp.infosystems.www.servers.unix + -- news scheme for USENET news groups and articles + + telnet://melvyl.ucop.edu/ + -- telnet scheme for interactive services via the TELNET Protocol + +1.4. Hierarchical URI and Relative Forms + + An absolute identifier refers to a resource independent of the + context in which the identifier is used. In contrast, a relative + identifier refers to a resource by describing the difference within a + hierarchical namespace between the current context and an absolute + identifier of the resource. + + + + + + +Berners-Lee, et. al. Standards Track [Page 4] + +RFC 2396 URI Generic Syntax August 1998 + + + Some URI schemes support a hierarchical naming system, where the + hierarchy of the name is denoted by a "/" delimiter separating the + components in the scheme. This document defines a scheme-independent + `relative' form of URI reference that can be used in conjunction with + a `base' URI (of a hierarchical scheme) to produce another URI. The + syntax of hierarchical URI is described in Section 3; the relative + URI calculation is described in Section 5. + +1.5. URI Transcribability + + The URI syntax was designed with global transcribability as one of + its main concerns. A URI is a sequence of characters from a very + limited set, i.e. the letters of the basic Latin alphabet, digits, + and a few special characters. A URI may be represented in a variety + of ways: e.g., ink on paper, pixels on a screen, or a sequence of + octets in a coded character set. The interpretation of a URI depends + only on the characters used and not how those characters are + represented in a network protocol. + + The goal of transcribability can be described by a simple scenario. + Imagine two colleagues, Sam and Kim, sitting in a pub at an + international conference and exchanging research ideas. Sam asks Kim + for a location to get more information, so Kim writes the URI for the + research site on a napkin. Upon returning home, Sam takes out the + napkin and types the URI into a computer, which then retrieves the + information to which Kim referred. + + There are several design concerns revealed by the scenario: + + o A URI is a sequence of characters, which is not always + represented as a sequence of octets. + + o A URI may be transcribed from a non-network source, and thus + should consist of characters that are most likely to be able to + be typed into a computer, within the constraints imposed by + keyboards (and related input devices) across languages and + locales. + + o A URI often needs to be remembered by people, and it is easier + for people to remember a URI when it consists of meaningful + components. + + These design concerns are not always in alignment. For example, it + is often the case that the most meaningful name for a URI component + would require characters that cannot be typed into some systems. The + ability to transcribe the resource identifier from one medium to + another was considered more important than having its URI consist of + the most meaningful of components. In local and regional contexts + + + +Berners-Lee, et. al. Standards Track [Page 5] + +RFC 2396 URI Generic Syntax August 1998 + + + and with improving technology, users might benefit from being able to + use a wider range of characters; such use is not defined in this + document. + +1.6. Syntax Notation and Common Elements + + This document uses two conventions to describe and define the syntax + for URI. The first, called the layout form, is a general description + of the order of components and component separators, as in + + <first>/<second>;<third>?<fourth> + + The component names are enclosed in angle-brackets and any characters + outside angle-brackets are literal separators. Whitespace should be + ignored. These descriptions are used informally and do not define + the syntax requirements. + + The second convention is a BNF-like grammar, used to define the + formal URI syntax. The grammar is that of [RFC822], except that "|" + is used to designate alternatives. Briefly, rules are separated from + definitions by an equal "=", indentation is used to continue a rule + definition over more than one line, literals are quoted with "", + parentheses "(" and ")" are used to group elements, optional elements + are enclosed in "[" and "]" brackets, and elements may be preceded + with <n>* to designate n or more repetitions of the following + element; n defaults to 0. + + Unlike many specifications that use a BNF-like grammar to define the + bytes (octets) allowed by a protocol, the URI grammar is defined in + terms of characters. Each literal in the grammar corresponds to the + character it represents, rather than to the octet encoding of that + character in any particular coded character set. How a URI is + represented in terms of bits and bytes on the wire is dependent upon + the character encoding of the protocol used to transport it, or the + charset of the document which contains it. + + The following definitions are common to many elements: + + alpha = lowalpha | upalpha + + lowalpha = "a" | "b" | "c" | "d" | "e" | "f" | "g" | "h" | "i" | + "j" | "k" | "l" | "m" | "n" | "o" | "p" | "q" | "r" | + "s" | "t" | "u" | "v" | "w" | "x" | "y" | "z" + + upalpha = "A" | "B" | "C" | "D" | "E" | "F" | "G" | "H" | "I" | + "J" | "K" | "L" | "M" | "N" | "O" | "P" | "Q" | "R" | + "S" | "T" | "U" | "V" | "W" | "X" | "Y" | "Z" + + + + +Berners-Lee, et. al. Standards Track [Page 6] + +RFC 2396 URI Generic Syntax August 1998 + + + digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | + "8" | "9" + + alphanum = alpha | digit + + The complete URI syntax is collected in Appendix A. + +2. URI Characters and Escape Sequences + + URI consist of a restricted set of characters, primarily chosen to + aid transcribability and usability both in computer systems and in + non-computer communications. Characters used conventionally as + delimiters around URI were excluded. The restricted set of + characters consists of digits, letters, and a few graphic symbols + were chosen from those common to most of the character encodings and + input facilities available to Internet users. + + uric = reserved | unreserved | escaped + + Within a URI, characters are either used as delimiters, or to + represent strings of data (octets) within the delimited portions. + Octets are either represented directly by a character (using the US- + ASCII character for that octet [ASCII]) or by an escape encoding. + This representation is elaborated below. + +2.1 URI and non-ASCII characters + + The relationship between URI and characters has been a source of + confusion for characters that are not part of US-ASCII. To describe + the relationship, it is useful to distinguish between a "character" + (as a distinguishable semantic entity) and an "octet" (an 8-bit + byte). There are two mappings, one from URI characters to octets, and + a second from octets to original characters: + + URI character sequence->octet sequence->original character sequence + + A URI is represented as a sequence of characters, not as a sequence + of octets. That is because URI might be "transported" by means that + are not through a computer network, e.g., printed on paper, read over + the radio, etc. + + A URI scheme may define a mapping from URI characters to octets; + whether this is done depends on the scheme. Commonly, within a + delimited component of a URI, a sequence of characters may be used to + represent a sequence of octets. For example, the character "a" + represents the octet 97 (decimal), while the character sequence "%", + "0", "a" represents the octet 10 (decimal). + + + + +Berners-Lee, et. al. Standards Track [Page 7] + +RFC 2396 URI Generic Syntax August 1998 + + + There is a second translation for some resources: the sequence of + octets defined by a component of the URI is subsequently used to + represent a sequence of characters. A 'charset' defines this mapping. + There are many charsets in use in Internet protocols. For example, + UTF-8 [UTF-8] defines a mapping from sequences of octets to sequences + of characters in the repertoire of ISO 10646. + + In the simplest case, the original character sequence contains only + characters that are defined in US-ASCII, and the two levels of + mapping are simple and easily invertible: each 'original character' + is represented as the octet for the US-ASCII code for it, which is, + in turn, represented as either the US-ASCII character, or else the + "%" escape sequence for that octet. + + For original character sequences that contain non-ASCII characters, + however, the situation is more difficult. Internet protocols that + transmit octet sequences intended to represent character sequences + are expected to provide some way of identifying the charset used, if + there might be more than one [RFC2277]. However, there is currently + no provision within the generic URI syntax to accomplish this + identification. An individual URI scheme may require a single + charset, define a default charset, or provide a way to indicate the + charset used. + + It is expected that a systematic treatment of character encoding + within URI will be developed as a future modification of this + specification. + +2.2. Reserved Characters + + Many URI include components consisting of or delimited by, certain + special characters. These characters are called "reserved", since + their usage within the URI component is limited to their reserved + purpose. If the data for a URI component would conflict with the + reserved purpose, then the conflicting data must be escaped before + forming the URI. + + reserved = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | + "$" | "," + + The "reserved" syntax class above refers to those characters that are + allowed within a URI, but which may not be allowed within a + particular component of the generic URI syntax; they are used as + delimiters of the components described in Section 3. + + + + + + + +Berners-Lee, et. al. Standards Track [Page 8] + +RFC 2396 URI Generic Syntax August 1998 + + + Characters in the "reserved" set are not reserved in all contexts. + The set of characters actually reserved within any given URI + component is defined by that component. In general, a character is + reserved if the semantics of the URI changes if the character is + replaced with its escaped US-ASCII encoding. + +2.3. Unreserved Characters + + Data characters that are allowed in a URI but do not have a reserved + purpose are called unreserved. These include upper and lower case + letters, decimal digits, and a limited set of punctuation marks and + symbols. + + unreserved = alphanum | mark + + mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")" + + Unreserved characters can be escaped without changing the semantics + of the URI, but this should not be done unless the URI is being used + in a context that does not allow the unescaped character to appear. + +2.4. Escape Sequences + + Data must be escaped if it does not have a representation using an + unreserved character; this includes data that does not correspond to + a printable character of the US-ASCII coded character set, or that + corresponds to any US-ASCII character that is disallowed, as + explained below. + +2.4.1. Escaped Encoding + + An escaped octet is encoded as a character triplet, consisting of the + percent character "%" followed by the two hexadecimal digits + representing the octet code. For example, "%20" is the escaped + encoding for the US-ASCII space character. + + escaped = "%" hex hex + hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | + "a" | "b" | "c" | "d" | "e" | "f" + +2.4.2. When to Escape and Unescape + + A URI is always in an "escaped" form, since escaping or unescaping a + completed URI might change its semantics. Normally, the only time + escape encodings can safely be made is when the URI is being created + from its component parts; each component may have its own set of + characters that are reserved, so only the mechanism responsible for + generating or interpreting that component can determine whether or + + + +Berners-Lee, et. al. Standards Track [Page 9] + +RFC 2396 URI Generic Syntax August 1998 + + + not escaping a character will change its semantics. Likewise, a URI + must be separated into its components before the escaped characters + within those components can be safely decoded. + + In some cases, data that could be represented by an unreserved + character may appear escaped; for example, some of the unreserved + "mark" characters are automatically escaped by some systems. If the + given URI scheme defines a canonicalization algorithm, then + unreserved characters may be unescaped according to that algorithm. + For example, "%7e" is sometimes used instead of "~" in an http URL + path, but the two are equivalent for an http URL. + + Because the percent "%" character always has the reserved purpose of + being the escape indicator, it must be escaped as "%25" in order to + be used as data within a URI. Implementers should be careful not to + escape or unescape the same string more than once, since unescaping + an already unescaped string might lead to misinterpreting a percent + data character as another escaped character, or vice versa in the + case of escaping an already escaped string. + +2.4.3. Excluded US-ASCII Characters + + Although they are disallowed within the URI syntax, we include here a + description of those US-ASCII characters that have been excluded and + the reasons for their exclusion. + + The control characters in the US-ASCII coded character set are not + used within a URI, both because they are non-printable and because + they are likely to be misinterpreted by some control mechanisms. + + control = <US-ASCII coded characters 00-1F and 7F hexadecimal> + + The space character is excluded because significant spaces may + disappear and insignificant spaces may be introduced when URI are + transcribed or typeset or subjected to the treatment of word- + processing programs. Whitespace is also used to delimit URI in many + contexts. + + space = <US-ASCII coded character 20 hexadecimal> + + The angle-bracket "<" and ">" and double-quote (") characters are + excluded because they are often used as the delimiters around URI in + text documents and protocol fields. The character "#" is excluded + because it is used to delimit a URI from a fragment identifier in URI + references (Section 4). The percent character "%" is excluded because + it is used for the encoding of escaped characters. + + delims = "<" | ">" | "#" | "%" | <"> + + + +Berners-Lee, et. al. Standards Track [Page 10] + +RFC 2396 URI Generic Syntax August 1998 + + + Other characters are excluded because gateways and other transport + agents are known to sometimes modify such characters, or they are + used as delimiters. + + unwise = "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" + + Data corresponding to excluded characters must be escaped in order to + be properly represented within a URI. + +3. URI Syntactic Components + + The URI syntax is dependent upon the scheme. In general, absolute + URI are written as follows: + + <scheme>:<scheme-specific-part> + + An absolute URI contains the name of the scheme being used (<scheme>) + followed by a colon (":") and then a string (the <scheme-specific- + part>) whose interpretation depends on the scheme. + + The URI syntax does not require that the scheme-specific-part have + any general structure or set of semantics which is common among all + URI. However, a subset of URI do share a common syntax for + representing hierarchical relationships within the namespace. This + "generic URI" syntax consists of a sequence of four main components: + + <scheme>://<authority><path>?<query> + + each of which, except <scheme>, may be absent from a particular URI. + For example, some URI schemes do not allow an <authority> component, + and others do not use a <query> component. + + absoluteURI = scheme ":" ( hier_part | opaque_part ) + + URI that are hierarchical in nature use the slash "/" character for + separating hierarchical components. For some file systems, a "/" + character (used to denote the hierarchical structure of a URI) is the + delimiter used to construct a file name hierarchy, and thus the URI + path will look similar to a file pathname. This does NOT imply that + the resource is a file or that the URI maps to an actual filesystem + pathname. + + hier_part = ( net_path | abs_path ) [ "?" query ] + + net_path = "//" authority [ abs_path ] + + abs_path = "/" path_segments + + + + +Berners-Lee, et. al. Standards Track [Page 11] + +RFC 2396 URI Generic Syntax August 1998 + + + URI that do not make use of the slash "/" character for separating + hierarchical components are considered opaque by the generic URI + parser. + + opaque_part = uric_no_slash *uric + + uric_no_slash = unreserved | escaped | ";" | "?" | ":" | "@" | + "&" | "=" | "+" | "$" | "," + + We use the term <path> to refer to both the <abs_path> and + <opaque_part> constructs, since they are mutually exclusive for any + given URI and can be parsed as a single component. + +3.1. Scheme Component + + Just as there are many different methods of access to resources, + there are a variety of schemes for identifying such resources. The + URI syntax consists of a sequence of components separated by reserved + characters, with the first component defining the semantics for the + remainder of the URI string. + + Scheme names consist of a sequence of characters beginning with a + lower case letter and followed by any combination of lower case + letters, digits, plus ("+"), period ("."), or hyphen ("-"). For + resiliency, programs interpreting URI should treat upper case letters + as equivalent to lower case in scheme names (e.g., allow "HTTP" as + well as "http"). + + scheme = alpha *( alpha | digit | "+" | "-" | "." ) + + Relative URI references are distinguished from absolute URI in that + they do not begin with a scheme name. Instead, the scheme is + inherited from the base URI, as described in Section 5.2. + +3.2. Authority Component + + Many URI schemes include a top hierarchical element for a naming + authority, such that the namespace defined by the remainder of the + URI is governed by that authority. This authority component is + typically defined by an Internet-based server or a scheme-specific + registry of naming authorities. + + authority = server | reg_name + + The authority component is preceded by a double slash "//" and is + terminated by the next slash "/", question-mark "?", or by the end of + the URI. Within the authority component, the characters ";", ":", + "@", "?", and "/" are reserved. + + + +Berners-Lee, et. al. Standards Track [Page 12] + +RFC 2396 URI Generic Syntax August 1998 + + + An authority component is not required for a URI scheme to make use + of relative references. A base URI without an authority component + implies that any relative reference will also be without an authority + component. + +3.2.1. Registry-based Naming Authority + + The structure of a registry-based naming authority is specific to the + URI scheme, but constrained to the allowed characters for an + authority component. + + reg_name = 1*( unreserved | escaped | "$" | "," | + ";" | ":" | "@" | "&" | "=" | "+" ) + +3.2.2. Server-based Naming Authority + + URL schemes that involve the direct use of an IP-based protocol to a + specified server on the Internet use a common syntax for the server + component of the URI's scheme-specific data: + + <userinfo>@<host>:<port> + + where <userinfo> may consist of a user name and, optionally, scheme- + specific information about how to gain authorization to access the + server. The parts "<userinfo>@" and ":<port>" may be omitted. + + server = [ [ userinfo "@" ] hostport ] + + The user information, if present, is followed by a commercial at-sign + "@". + + userinfo = *( unreserved | escaped | + ";" | ":" | "&" | "=" | "+" | "$" | "," ) + + Some URL schemes use the format "user:password" in the userinfo + field. This practice is NOT RECOMMENDED, because the passing of + authentication information in clear text (such as URI) has proven to + be a security risk in almost every case where it has been used. + + The host is a domain name of a network host, or its IPv4 address as a + set of four decimal digit groups separated by ".". Literal IPv6 + addresses are not supported. + + hostport = host [ ":" port ] + host = hostname | IPv4address + hostname = *( domainlabel "." ) toplabel [ "." ] + domainlabel = alphanum | alphanum *( alphanum | "-" ) alphanum + toplabel = alpha | alpha *( alphanum | "-" ) alphanum + + + +Berners-Lee, et. al. Standards Track [Page 13] + +RFC 2396 URI Generic Syntax August 1998 + + + IPv4address = 1*digit "." 1*digit "." 1*digit "." 1*digit + port = *digit + + Hostnames take the form described in Section 3 of [RFC1034] and + Section 2.1 of [RFC1123]: a sequence of domain labels separated by + ".", each domain label starting and ending with an alphanumeric + character and possibly also containing "-" characters. The rightmost + domain label of a fully qualified domain name will never start with a + digit, thus syntactically distinguishing domain names from IPv4 + addresses, and may be followed by a single "." if it is necessary to + distinguish between the complete domain name and any local domain. + To actually be "Uniform" as a resource locator, a URL hostname should + be a fully qualified domain name. In practice, however, the host + component may be a local domain literal. + + Note: A suitable representation for including a literal IPv6 + address as the host part of a URL is desired, but has not yet been + determined or implemented in practice. + + The port is the network port number for the server. Most schemes + designate protocols that have a default port number. Another port + number may optionally be supplied, in decimal, separated from the + host by a colon. If the port is omitted, the default port number is + assumed. + +3.3. Path Component + + The path component contains data, specific to the authority (or the + scheme if there is no authority component), identifying the resource + within the scope of that scheme and authority. + + path = [ abs_path | opaque_part ] + + path_segments = segment *( "/" segment ) + segment = *pchar *( ";" param ) + param = *pchar + + pchar = unreserved | escaped | + ":" | "@" | "&" | "=" | "+" | "$" | "," + + The path may consist of a sequence of path segments separated by a + single slash "/" character. Within a path segment, the characters + "/", ";", "=", and "?" are reserved. Each path segment may include a + sequence of parameters, indicated by the semicolon ";" character. + The parameters are not significant to the parsing of relative + references. + + + + + +Berners-Lee, et. al. Standards Track [Page 14] + +RFC 2396 URI Generic Syntax August 1998 + + +3.4. Query Component + + The query component is a string of information to be interpreted by + the resource. + + query = *uric + + Within a query component, the characters ";", "/", "?", ":", "@", + "&", "=", "+", ",", and "$" are reserved. + +4. URI References + + The term "URI-reference" is used here to denote the common usage of a + resource identifier. A URI reference may be absolute or relative, + and may have additional information attached in the form of a + fragment identifier. However, "the URI" that results from such a + reference includes only the absolute URI after the fragment + identifier (if any) is removed and after any relative URI is resolved + to its absolute form. Although it is possible to limit the + discussion of URI syntax and semantics to that of the absolute + result, most usage of URI is within general URI references, and it is + impossible to obtain the URI from such a reference without also + parsing the fragment and resolving the relative form. + + URI-reference = [ absoluteURI | relativeURI ] [ "#" fragment ] + + The syntax for relative URI is a shortened form of that for absolute + URI, where some prefix of the URI is missing and certain path + components ("." and "..") have a special meaning when, and only when, + interpreting a relative path. The relative URI syntax is defined in + Section 5. + +4.1. Fragment Identifier + + When a URI reference is used to perform a retrieval action on the + identified resource, the optional fragment identifier, separated from + the URI by a crosshatch ("#") character, consists of additional + reference information to be interpreted by the user agent after the + retrieval action has been successfully completed. As such, it is not + part of a URI, but is often used in conjunction with a URI. + + fragment = *uric + + The semantics of a fragment identifier is a property of the data + resulting from a retrieval action, regardless of the type of URI used + in the reference. Therefore, the format and interpretation of + fragment identifiers is dependent on the media type [RFC2046] of the + retrieval result. The character restrictions described in Section 2 + + + +Berners-Lee, et. al. Standards Track [Page 15] + +RFC 2396 URI Generic Syntax August 1998 + + + for URI also apply to the fragment in a URI-reference. Individual + media types may define additional restrictions or structure within + the fragment for specifying different types of "partial views" that + can be identified within that media type. + + A fragment identifier is only meaningful when a URI reference is + intended for retrieval and the result of that retrieval is a document + for which the identified fragment is consistently defined. + +4.2. Same-document References + + A URI reference that does not contain a URI is a reference to the + current document. In other words, an empty URI reference within a + document is interpreted as a reference to the start of that document, + and a reference containing only a fragment identifier is a reference + to the identified fragment of that document. Traversal of such a + reference should not result in an additional retrieval action. + However, if the URI reference occurs in a context that is always + intended to result in a new request, as in the case of HTML's FORM + element, then an empty URI reference represents the base URI of the + current document and should be replaced by that URI when transformed + into a request. + +4.3. Parsing a URI Reference + + A URI reference is typically parsed according to the four main + components and fragment identifier in order to determine what + components are present and whether the reference is relative or + absolute. The individual components are then parsed for their + subparts and, if not opaque, to verify their validity. + + Although the BNF defines what is allowed in each component, it is + ambiguous in terms of differentiating between an authority component + and a path component that begins with two slash characters. The + greedy algorithm is used for disambiguation: the left-most matching + rule soaks up as much of the URI reference string as it is capable of + matching. In other words, the authority component wins. + + Readers familiar with regular expressions should see Appendix B for a + concrete parsing example and test oracle. + +5. Relative URI References + + It is often the case that a group or "tree" of documents has been + constructed to serve a common purpose; the vast majority of URI in + these documents point to resources within the tree rather than + + + + + +Berners-Lee, et. al. Standards Track [Page 16] + +RFC 2396 URI Generic Syntax August 1998 + + + outside of it. Similarly, documents located at a particular site are + much more likely to refer to other resources at that site than to + resources at remote sites. + + Relative addressing of URI allows document trees to be partially + independent of their location and access scheme. For instance, it is + possible for a single set of hypertext documents to be simultaneously + accessible and traversable via each of the "file", "http", and "ftp" + schemes if the documents refer to each other using relative URI. + Furthermore, such document trees can be moved, as a whole, without + changing any of the relative references. Experience within the WWW + has demonstrated that the ability to perform relative referencing is + necessary for the long-term usability of embedded URI. + + The syntax for relative URI takes advantage of the <hier_part> syntax + of <absoluteURI> (Section 3) in order to express a reference that is + relative to the namespace of another hierarchical URI. + + relativeURI = ( net_path | abs_path | rel_path ) [ "?" query ] + + A relative reference beginning with two slash characters is termed a + network-path reference, as defined by <net_path> in Section 3. Such + references are rarely used. + + A relative reference beginning with a single slash character is + termed an absolute-path reference, as defined by <abs_path> in + Section 3. + + A relative reference that does not begin with a scheme name or a + slash character is termed a relative-path reference. + + rel_path = rel_segment [ abs_path ] + + rel_segment = 1*( unreserved | escaped | + ";" | "@" | "&" | "=" | "+" | "$" | "," ) + + Within a relative-path reference, the complete path segments "." and + ".." have special meanings: "the current hierarchy level" and "the + level above this hierarchy level", respectively. Although this is + very similar to their use within Unix-based filesystems to indicate + directory levels, these path components are only considered special + when resolving a relative-path reference to its absolute form + (Section 5.2). + + Authors should be aware that a path segment which contains a colon + character cannot be used as the first segment of a relative URI path + (e.g., "this:that"), because it would be mistaken for a scheme name. + + + + +Berners-Lee, et. al. Standards Track [Page 17] + +RFC 2396 URI Generic Syntax August 1998 + + + It is therefore necessary to precede such segments with other + segments (e.g., "./this:that") in order for them to be referenced as + a relative path. + + It is not necessary for all URI within a given scheme to be + restricted to the <hier_part> syntax, since the hierarchical + properties of that syntax are only necessary when relative URI are + used within a particular document. Documents can only make use of + relative URI when their base URI fits within the <hier_part> syntax. + It is assumed that any document which contains a relative reference + will also have a base URI that obeys the syntax. In other words, + relative URI cannot be used within a document that has an unsuitable + base URI. + + Some URI schemes do not allow a hierarchical syntax matching the + <hier_part> syntax, and thus cannot use relative references. + +5.1. Establishing a Base URI + + The term "relative URI" implies that there exists some absolute "base + URI" against which the relative reference is applied. Indeed, the + base URI is necessary to define the semantics of any relative URI + reference; without it, a relative reference is meaningless. In order + for relative URI to be usable within a document, the base URI of that + document must be known to the parser. + + The base URI of a document can be established in one of four ways, + listed below in order of precedence. The order of precedence can be + thought of in terms of layers, where the innermost defined base URI + has the highest precedence. This can be visualized graphically as: + + .----------------------------------------------------------. + | .----------------------------------------------------. | + | | .----------------------------------------------. | | + | | | .----------------------------------------. | | | + | | | | .----------------------------------. | | | | + | | | | | <relative_reference> | | | | | + | | | | `----------------------------------' | | | | + | | | | (5.1.1) Base URI embedded in the | | | | + | | | | document's content | | | | + | | | `----------------------------------------' | | | + | | | (5.1.2) Base URI of the encapsulating entity | | | + | | | (message, document, or none). | | | + | | `----------------------------------------------' | | + | | (5.1.3) URI used to retrieve the entity | | + | `----------------------------------------------------' | + | (5.1.4) Default Base URI is application-dependent | + `----------------------------------------------------------' + + + +Berners-Lee, et. al. Standards Track [Page 18] + +RFC 2396 URI Generic Syntax August 1998 + + +5.1.1. Base URI within Document Content + + Within certain document media types, the base URI of the document can + be embedded within the content itself such that it can be readily + obtained by a parser. This can be useful for descriptive documents, + such as tables of content, which may be transmitted to others through + protocols other than their usual retrieval context (e.g., E-Mail or + USENET news). + + It is beyond the scope of this document to specify how, for each + media type, the base URI can be embedded. It is assumed that user + agents manipulating such media types will be able to obtain the + appropriate syntax from that media type's specification. An example + of how the base URI can be embedded in the Hypertext Markup Language + (HTML) [RFC1866] is provided in Appendix D. + + A mechanism for embedding the base URI within MIME container types + (e.g., the message and multipart types) is defined by MHTML + [RFC2110]. Protocols that do not use the MIME message header syntax, + but which do allow some form of tagged metainformation to be included + within messages, may define their own syntax for defining the base + URI as part of a message. + +5.1.2. Base URI from the Encapsulating Entity + + If no base URI is embedded, the base URI of a document is defined by + the document's retrieval context. For a document that is enclosed + within another entity (such as a message or another document), the + retrieval context is that entity; thus, the default base URI of the + document is the base URI of the entity in which the document is + encapsulated. + +5.1.3. Base URI from the Retrieval URI + + If no base URI is embedded and the document is not encapsulated + within some other entity (e.g., the top level of a composite entity), + then, if a URI was used to retrieve the base document, that URI shall + be considered the base URI. Note that if the retrieval was the + result of a redirected request, the last URI used (i.e., that which + resulted in the actual retrieval of the document) is the base URI. + +5.1.4. Default Base URI + + If none of the conditions described in Sections 5.1.1--5.1.3 apply, + then the base URI is defined by the context of the application. + Since this definition is necessarily application-dependent, failing + + + + + +Berners-Lee, et. al. Standards Track [Page 19] + +RFC 2396 URI Generic Syntax August 1998 + + + to define the base URI using one of the other methods may result in + the same content being interpreted differently by different types of + application. + + It is the responsibility of the distributor(s) of a document + containing relative URI to ensure that the base URI for that document + can be established. It must be emphasized that relative URI cannot + be used reliably in situations where the document's base URI is not + well-defined. + +5.2. Resolving Relative References to Absolute Form + + This section describes an example algorithm for resolving URI + references that might be relative to a given base URI. + + The base URI is established according to the rules of Section 5.1 and + parsed into the four main components as described in Section 3. Note + that only the scheme component is required to be present in the base + URI; the other components may be empty or undefined. A component is + undefined if its preceding separator does not appear in the URI + reference; the path component is never undefined, though it may be + empty. The base URI's query component is not used by the resolution + algorithm and may be discarded. + + For each URI reference, the following steps are performed in order: + + 1) The URI reference is parsed into the potential four components and + fragment identifier, as described in Section 4.3. + + 2) If the path component is empty and the scheme, authority, and + query components are undefined, then it is a reference to the + current document and we are done. Otherwise, the reference URI's + query and fragment components are defined as found (or not found) + within the URI reference and not inherited from the base URI. + + 3) If the scheme component is defined, indicating that the reference + starts with a scheme name, then the reference is interpreted as an + absolute URI and we are done. Otherwise, the reference URI's + scheme is inherited from the base URI's scheme component. + + Due to a loophole in prior specifications [RFC1630], some parsers + allow the scheme name to be present in a relative URI if it is the + same as the base URI scheme. Unfortunately, this can conflict + with the correct parsing of non-hierarchical URI. For backwards + compatibility, an implementation may work around such references + by removing the scheme if it matches that of the base URI and the + scheme is known to always use the <hier_part> syntax. The parser + + + + +Berners-Lee, et. al. Standards Track [Page 20] + +RFC 2396 URI Generic Syntax August 1998 + + + can then continue with the steps below for the remainder of the + reference components. Validating parsers should mark such a + misformed relative reference as an error. + + 4) If the authority component is defined, then the reference is a + network-path and we skip to step 7. Otherwise, the reference + URI's authority is inherited from the base URI's authority + component, which will also be undefined if the URI scheme does not + use an authority component. + + 5) If the path component begins with a slash character ("/"), then + the reference is an absolute-path and we skip to step 7. + + 6) If this step is reached, then we are resolving a relative-path + reference. The relative path needs to be merged with the base + URI's path. Although there are many ways to do this, we will + describe a simple method using a separate string buffer. + + a) All but the last segment of the base URI's path component is + copied to the buffer. In other words, any characters after the + last (right-most) slash character, if any, are excluded. + + b) The reference's path component is appended to the buffer + string. + + c) All occurrences of "./", where "." is a complete path segment, + are removed from the buffer string. + + d) If the buffer string ends with "." as a complete path segment, + that "." is removed. + + e) All occurrences of "<segment>/../", where <segment> is a + complete path segment not equal to "..", are removed from the + buffer string. Removal of these path segments is performed + iteratively, removing the leftmost matching pattern on each + iteration, until no matching pattern remains. + + f) If the buffer string ends with "<segment>/..", where <segment> + is a complete path segment not equal to "..", that + "<segment>/.." is removed. + + g) If the resulting buffer string still begins with one or more + complete path segments of "..", then the reference is + considered to be in error. Implementations may handle this + error by retaining these components in the resolved path (i.e., + treating them as part of the final URI), by removing them from + the resolved path (i.e., discarding relative levels above the + root), or by avoiding traversal of the reference. + + + +Berners-Lee, et. al. Standards Track [Page 21] + +RFC 2396 URI Generic Syntax August 1998 + + + h) The remaining buffer string is the reference URI's new path + component. + + 7) The resulting URI components, including any inherited from the + base URI, are recombined to give the absolute form of the URI + reference. Using pseudocode, this would be + + result = "" + + if scheme is defined then + append scheme to result + append ":" to result + + if authority is defined then + append "//" to result + append authority to result + + append path to result + + if query is defined then + append "?" to result + append query to result + + if fragment is defined then + append "#" to result + append fragment to result + + return result + + Note that we must be careful to preserve the distinction between a + component that is undefined, meaning that its separator was not + present in the reference, and a component that is empty, meaning + that the separator was present and was immediately followed by the + next component separator or the end of the reference. + + The above algorithm is intended to provide an example by which the + output of implementations can be tested -- implementation of the + algorithm itself is not required. For example, some systems may find + it more efficient to implement step 6 as a pair of segment stacks + being merged, rather than as a series of string pattern replacements. + + Note: Some WWW client applications will fail to separate the + reference's query component from its path component before merging + the base and reference paths in step 6 above. This may result in + a loss of information if the query component contains the strings + "/../" or "/./". + + Resolution examples are provided in Appendix C. + + + +Berners-Lee, et. al. Standards Track [Page 22] + +RFC 2396 URI Generic Syntax August 1998 + + +6. URI Normalization and Equivalence + + In many cases, different URI strings may actually identify the + identical resource. For example, the host names used in URL are + actually case insensitive, and the URL <http://www.XEROX.com> is + equivalent to <http://www.xerox.com>. In general, the rules for + equivalence and definition of a normal form, if any, are scheme + dependent. When a scheme uses elements of the common syntax, it will + also use the common syntax equivalence rules, namely that the scheme + and hostname are case insensitive and a URL with an explicit ":port", + where the port is the default for the scheme, is equivalent to one + where the port is elided. + +7. Security Considerations + + A URI does not in itself pose a security threat. Users should beware + that there is no general guarantee that a URL, which at one time + located a given resource, will continue to do so. Nor is there any + guarantee that a URL will not locate a different resource at some + later point in time, due to the lack of any constraint on how a given + authority apportions its namespace. Such a guarantee can only be + obtained from the person(s) controlling that namespace and the + resource in question. A specific URI scheme may include additional + semantics, such as name persistence, if those semantics are required + of all naming authorities for that scheme. + + It is sometimes possible to construct a URL such that an attempt to + perform a seemingly harmless, idempotent operation, such as the + retrieval of an entity associated with the resource, will in fact + cause a possibly damaging remote operation to occur. The unsafe URL + is typically constructed by specifying a port number other than that + reserved for the network protocol in question. The client + unwittingly contacts a site that is in fact running a different + protocol. The content of the URL contains instructions that, when + interpreted according to this other protocol, cause an unexpected + operation. An example has been the use of a gopher URL to cause an + unintended or impersonating message to be sent via a SMTP server. + + Caution should be used when using any URL that specifies a port + number other than the default for the protocol, especially when it is + a number within the reserved space. + + Care should be taken when a URL contains escaped delimiters for a + given protocol (for example, CR and LF characters for telnet + protocols) that these are not unescaped before transmission. This + might violate the protocol, but avoids the potential for such + + + + + +Berners-Lee, et. al. Standards Track [Page 23] + +RFC 2396 URI Generic Syntax August 1998 + + + characters to be used to simulate an extra operation or parameter in + that protocol, which might lead to an unexpected and possibly harmful + remote operation to be performed. + + It is clearly unwise to use a URL that contains a password which is + intended to be secret. In particular, the use of a password within + the 'userinfo' component of a URL is strongly disrecommended except + in those rare cases where the 'password' parameter is intended to be + public. + +8. Acknowledgements + + This document was derived from RFC 1738 [RFC1738] and RFC 1808 + [RFC1808]; the acknowledgements in those specifications still apply. + In addition, contributions by Gisle Aas, Martin Beet, Martin Duerst, + Jim Gettys, Martijn Koster, Dave Kristol, Daniel LaLiberte, Foteos + Macrides, James Marshall, Ryan Moats, Keith Moore, and Lauren Wood + are gratefully acknowledged. + +9. References + + [RFC2277] Alvestrand, H., "IETF Policy on Character Sets and + Languages", BCP 18, RFC 2277, January 1998. + + [RFC1630] Berners-Lee, T., "Universal Resource Identifiers in WWW: A + Unifying Syntax for the Expression of Names and Addresses + of Objects on the Network as used in the World-Wide Web", + RFC 1630, June 1994. + + [RFC1738] Berners-Lee, T., Masinter, L., and M. McCahill, Editors, + "Uniform Resource Locators (URL)", RFC 1738, December 1994. + + [RFC1866] Berners-Lee T., and D. Connolly, "HyperText Markup Language + Specification -- 2.0", RFC 1866, November 1995. + + [RFC1123] Braden, R., Editor, "Requirements for Internet Hosts -- + Application and Support", STD 3, RFC 1123, October 1989. + + [RFC822] Crocker, D., "Standard for the Format of ARPA Internet Text + Messages", STD 11, RFC 822, August 1982. + + [RFC1808] Fielding, R., "Relative Uniform Resource Locators", RFC + 1808, June 1995. + + [RFC2046] Freed, N., and N. Borenstein, "Multipurpose Internet Mail + Extensions (MIME) Part Two: Media Types", RFC 2046, + November 1996. + + + + +Berners-Lee, et. al. Standards Track [Page 24] + +RFC 2396 URI Generic Syntax August 1998 + + + [RFC1736] Kunze, J., "Functional Recommendations for Internet + Resource Locators", RFC 1736, February 1995. + + [RFC2141] Moats, R., "URN Syntax", RFC 2141, May 1997. + + [RFC1034] Mockapetris, P., "Domain Names - Concepts and Facilities", + STD 13, RFC 1034, November 1987. + + [RFC2110] Palme, J., and A. Hopmann, "MIME E-mail Encapsulation of + Aggregate Documents, such as HTML (MHTML)", RFC 2110, March + 1997. + + [RFC1737] Sollins, K., and L. Masinter, "Functional Requirements for + Uniform Resource Names", RFC 1737, December 1994. + + [ASCII] US-ASCII. "Coded Character Set -- 7-bit American Standard + Code for Information Interchange", ANSI X3.4-1986. + + [UTF-8] Yergeau, F., "UTF-8, a transformation format of ISO 10646", + RFC 2279, January 1998. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 25] + +RFC 2396 URI Generic Syntax August 1998 + + +10. Authors' Addresses + + Tim Berners-Lee + World Wide Web Consortium + MIT Laboratory for Computer Science, NE43-356 + 545 Technology Square + Cambridge, MA 02139 + + Fax: +1(617)258-8682 + EMail: timbl(a)w3.org + + + Roy T. Fielding + Department of Information and Computer Science + University of California, Irvine + Irvine, CA 92697-3425 + + Fax: +1(949)824-1715 + EMail: fielding(a)ics.uci.edu + + + Larry Masinter + Xerox PARC + 3333 Coyote Hill Road + Palo Alto, CA 94034 + + Fax: +1(415)812-4333 + EMail: masinter(a)parc.xerox.com + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 26] + +RFC 2396 URI Generic Syntax August 1998 + + +A. Collected BNF for URI + + URI-reference = [ absoluteURI | relativeURI ] [ "#" fragment ] + absoluteURI = scheme ":" ( hier_part | opaque_part ) + relativeURI = ( net_path | abs_path | rel_path ) [ "?" query ] + + hier_part = ( net_path | abs_path ) [ "?" query ] + opaque_part = uric_no_slash *uric + + uric_no_slash = unreserved | escaped | ";" | "?" | ":" | "@" | + "&" | "=" | "+" | "$" | "," + + net_path = "//" authority [ abs_path ] + abs_path = "/" path_segments + rel_path = rel_segment [ abs_path ] + + rel_segment = 1*( unreserved | escaped | + ";" | "@" | "&" | "=" | "+" | "$" | "," ) + + scheme = alpha *( alpha | digit | "+" | "-" | "." ) + + authority = server | reg_name + + reg_name = 1*( unreserved | escaped | "$" | "," | + ";" | ":" | "@" | "&" | "=" | "+" ) + + server = [ [ userinfo "@" ] hostport ] + userinfo = *( unreserved | escaped | + ";" | ":" | "&" | "=" | "+" | "$" | "," ) + + hostport = host [ ":" port ] + host = hostname | IPv4address + hostname = *( domainlabel "." ) toplabel [ "." ] + domainlabel = alphanum | alphanum *( alphanum | "-" ) alphanum + toplabel = alpha | alpha *( alphanum | "-" ) alphanum + IPv4address = 1*digit "." 1*digit "." 1*digit "." 1*digit + port = *digit + + path = [ abs_path | opaque_part ] + path_segments = segment *( "/" segment ) + segment = *pchar *( ";" param ) + param = *pchar + pchar = unreserved | escaped | + ":" | "@" | "&" | "=" | "+" | "$" | "," + + query = *uric + + fragment = *uric + + + +Berners-Lee, et. al. Standards Track [Page 27] + +RFC 2396 URI Generic Syntax August 1998 + + + uric = reserved | unreserved | escaped + reserved = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | + "$" | "," + unreserved = alphanum | mark + mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | + "(" | ")" + + escaped = "%" hex hex + hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | + "a" | "b" | "c" | "d" | "e" | "f" + + alphanum = alpha | digit + alpha = lowalpha | upalpha + + lowalpha = "a" | "b" | "c" | "d" | "e" | "f" | "g" | "h" | "i" | + "j" | "k" | "l" | "m" | "n" | "o" | "p" | "q" | "r" | + "s" | "t" | "u" | "v" | "w" | "x" | "y" | "z" + upalpha = "A" | "B" | "C" | "D" | "E" | "F" | "G" | "H" | "I" | + "J" | "K" | "L" | "M" | "N" | "O" | "P" | "Q" | "R" | + "S" | "T" | "U" | "V" | "W" | "X" | "Y" | "Z" + digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | + "8" | "9" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 28] + +RFC 2396 URI Generic Syntax August 1998 + + +B. Parsing a URI Reference with a Regular Expression + + As described in Section 4.3, the generic URI syntax is not sufficient + to disambiguate the components of some forms of URI. Since the + "greedy algorithm" described in that section is identical to the + disambiguation method used by POSIX regular expressions, it is + natural and commonplace to use a regular expression for parsing the + potential four components and fragment identifier of a URI reference. + + The following line is the regular expression for breaking-down a URI + reference into its components. + + ^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))? + 12 3 4 5 6 7 8 9 + + The numbers in the second line above are only to assist readability; + they indicate the reference points for each subexpression (i.e., each + paired parenthesis). We refer to the value matched for subexpression + <n> as $<n>. For example, matching the above expression to + + http://www.ics.uci.edu/pub/ietf/uri/#Related + + results in the following subexpression matches: + + $1 = http: + $2 = http + $3 = //www.ics.uci.edu + $4 = www.ics.uci.edu + $5 = /pub/ietf/uri/ + $6 = <undefined> + $7 = <undefined> + $8 = #Related + $9 = Related + + where <undefined> indicates that the component is not present, as is + the case for the query component in the above example. Therefore, we + can determine the value of the four components and fragment as + + scheme = $2 + authority = $4 + path = $5 + query = $7 + fragment = $9 + + and, going in the opposite direction, we can recreate a URI reference + from its components using the algorithm in step 7 of Section 5.2. + + + + + +Berners-Lee, et. al. Standards Track [Page 29] + +RFC 2396 URI Generic Syntax August 1998 + + +C. Examples of Resolving Relative URI References + + Within an object with a well-defined base URI of + + http://a/b/c/d;p?q + + the relative URI would be resolved as follows: + +C.1. Normal Examples + + g:h = g:h + g = http://a/b/c/g + ./g = http://a/b/c/g + g/ = http://a/b/c/g/ + /g = http://a/g + //g = http://g + ?y = http://a/b/c/?y + g?y = http://a/b/c/g?y + #s = (current document)#s + g#s = http://a/b/c/g#s + g?y#s = http://a/b/c/g?y#s + ;x = http://a/b/c/;x + g;x = http://a/b/c/g;x + g;x?y#s = http://a/b/c/g;x?y#s + . = http://a/b/c/ + ./ = http://a/b/c/ + .. = http://a/b/ + ../ = http://a/b/ + ../g = http://a/b/g + ../.. = http://a/ + ../../ = http://a/ + ../../g = http://a/g + +C.2. Abnormal Examples + + Although the following abnormal examples are unlikely to occur in + normal practice, all URI parsers should be capable of resolving them + consistently. Each example uses the same base as above. + + An empty reference refers to the start of the current document. + + <> = (current document) + + Parsers must be careful in handling the case where there are more + relative path ".." segments than there are hierarchical levels in the + base URI's path. Note that the ".." syntax cannot be used to change + the authority component of a URI. + + + + +Berners-Lee, et. al. Standards Track [Page 30] + +RFC 2396 URI Generic Syntax August 1998 + + + ../../../g = http://a/../g + ../../../../g = http://a/../../g + + In practice, some implementations strip leading relative symbolic + elements (".", "..") after applying a relative URI calculation, based + on the theory that compensating for obvious author errors is better + than allowing the request to fail. Thus, the above two references + will be interpreted as "http://a/g" by some implementations. + + Similarly, parsers must avoid treating "." and ".." as special when + they are not complete components of a relative path. + + /./g = http://a/./g + /../g = http://a/../g + g. = http://a/b/c/g. + .g = http://a/b/c/.g + g.. = http://a/b/c/g.. + ..g = http://a/b/c/..g + + Less likely are cases where the relative URI uses unnecessary or + nonsensical forms of the "." and ".." complete path segments. + + ./../g = http://a/b/g + ./g/. = http://a/b/c/g/ + g/./h = http://a/b/c/g/h + g/../h = http://a/b/c/h + g;x=1/./y = http://a/b/c/g;x=1/y + g;x=1/../y = http://a/b/c/y + + All client applications remove the query component from the base URI + before resolving relative URI. However, some applications fail to + separate the reference's query and/or fragment components from a + relative path before merging it with the base path. This error is + rarely noticed, since typical usage of a fragment never includes the + hierarchy ("/") character, and the query component is not normally + used within relative references. + + g?y/./x = http://a/b/c/g?y/./x + g?y/../x = http://a/b/c/g?y/../x + g#s/./x = http://a/b/c/g#s/./x + g#s/../x = http://a/b/c/g#s/../x + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 31] + +RFC 2396 URI Generic Syntax August 1998 + + + Some parsers allow the scheme name to be present in a relative URI if + it is the same as the base URI scheme. This is considered to be a + loophole in prior specifications of partial URI [RFC1630]. Its use + should be avoided. + + http:g = http:g ; for validating parsers + | http://a/b/c/g ; for backwards compatibility + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 32] + +RFC 2396 URI Generic Syntax August 1998 + + +D. Embedding the Base URI in HTML documents + + It is useful to consider an example of how the base URI of a document + can be embedded within the document's content. In this appendix, we + describe how documents written in the Hypertext Markup Language + (HTML) [RFC1866] can include an embedded base URI. This appendix + does not form a part of the URI specification and should not be + considered as anything more than a descriptive example. + + HTML defines a special element "BASE" which, when present in the + "HEAD" portion of a document, signals that the parser should use the + BASE element's "HREF" attribute as the base URI for resolving any + relative URI. The "HREF" attribute must be an absolute URI. Note + that, in HTML, element and attribute names are case-insensitive. For + example: + + <!doctype html public "-//IETF//DTD HTML//EN"> + <HTML><HEAD> + <TITLE>An example HTML document</TITLE> + <BASE href="http://www.ics.uci.edu/Test/a/b/c"> + </HEAD><BODY> + ... <A href="../x">a hypertext anchor</A> ... + </BODY></HTML> + + A parser reading the example document should interpret the given + relative URI "../x" as representing the absolute URI + + <http://www.ics.uci.edu/Test/a/x> + + regardless of the context in which the example document was obtained. + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 33] + +RFC 2396 URI Generic Syntax August 1998 + + +E. Recommendations for Delimiting URI in Context + + URI are often transmitted through formats that do not provide a clear + context for their interpretation. For example, there are many + occasions when URI are included in plain text; examples include text + sent in electronic mail, USENET news messages, and, most importantly, + printed on paper. In such cases, it is important to be able to + delimit the URI from the rest of the text, and in particular from + punctuation marks that might be mistaken for part of the URI. + + In practice, URI are delimited in a variety of ways, but usually + within double-quotes "http://test.com/", angle brackets + <http://test.com/>, or just using whitespace + + http://test.com/ + + These wrappers do not form part of the URI. + + In the case where a fragment identifier is associated with a URI + reference, the fragment would be placed within the brackets as well + (separated from the URI with a "#" character). + + In some cases, extra whitespace (spaces, linebreaks, tabs, etc.) may + need to be added to break long URI across lines. The whitespace + should be ignored when extracting the URI. + + No whitespace should be introduced after a hyphen ("-") character. + Because some typesetters and printers may (erroneously) introduce a + hyphen at the end of line when breaking a line, the interpreter of a + URI containing a line break immediately after a hyphen should ignore + all unescaped whitespace around the line break, and should be aware + that the hyphen may or may not actually be part of the URI. + + Using <> angle brackets around each URI is especially recommended as + a delimiting style for URI that contain whitespace. + + The prefix "URL:" (with or without a trailing space) was recommended + as a way to used to help distinguish a URL from other bracketed + designators, although this is not common in practice. + + For robustness, software that accepts user-typed URI should attempt + to recognize and strip both delimiters and embedded whitespace. + + For example, the text: + + + + + + + +Berners-Lee, et. al. Standards Track [Page 34] + +RFC 2396 URI Generic Syntax August 1998 + + + Yes, Jim, I found it under "http://www.w3.org/Addressing/", + but you can probably pick it up from <ftp://ds.internic. + net/rfc/>. Note the warning in <http://www.ics.uci.edu/pub/ + ietf/uri/historical.html#WARNING>. + + contains the URI references + + http://www.w3.org/Addressing/ + ftp://ds.internic.net/rfc/ + http://www.ics.uci.edu/pub/ietf/uri/historical.html#WARNING + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 35] + +RFC 2396 URI Generic Syntax August 1998 + + +F. Abbreviated URLs + + The URL syntax was designed for unambiguous reference to network + resources and extensibility via the URL scheme. However, as URL + identification and usage have become commonplace, traditional media + (television, radio, newspapers, billboards, etc.) have increasingly + used abbreviated URL references. That is, a reference consisting of + only the authority and path portions of the identified resource, such + as + + www.w3.org/Addressing/ + + or simply the DNS hostname on its own. Such references are primarily + intended for human interpretation rather than machine, with the + assumption that context-based heuristics are sufficient to complete + the URL (e.g., most hostnames beginning with "www" are likely to have + a URL prefix of "http://"). Although there is no standard set of + heuristics for disambiguating abbreviated URL references, many client + implementations allow them to be entered by the user and + heuristically resolved. It should be noted that such heuristics may + change over time, particularly when new URL schemes are introduced. + + Since an abbreviated URL has the same syntax as a relative URL path, + abbreviated URL references cannot be used in contexts where relative + URLs are expected. This limits the use of abbreviated URLs to places + where there is no defined base URL, such as dialog boxes and off-line + advertisements. + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 36] + +RFC 2396 URI Generic Syntax August 1998 + + +G. Summary of Non-editorial Changes + +G.1. Additions + + Section 4 (URI References) was added to stem the confusion regarding + "what is a URI" and how to describe fragment identifiers given that + they are not part of the URI, but are part of the URI syntax and + parsing concerns. In addition, it provides a reference definition + for use by other IETF specifications (HTML, HTTP, etc.) that have + previously attempted to redefine the URI syntax in order to account + for the presence of fragment identifiers in URI references. + + Section 2.4 was rewritten to clarify a number of misinterpretations + and to leave room for fully internationalized URI. + + Appendix F on abbreviated URLs was added to describe the shortened + references often seen on television and magazine advertisements and + explain why they are not used in other contexts. + +G.2. Modifications from both RFC 1738 and RFC 1808 + + Changed to URI syntax instead of just URL. + + Confusion regarding the terms "character encoding", the URI + "character set", and the escaping of characters with %<hex><hex> + equivalents has (hopefully) been reduced. Many of the BNF rule names + regarding the character sets have been changed to more accurately + describe their purpose and to encompass all "characters" rather than + just US-ASCII octets. Unless otherwise noted here, these + modifications do not affect the URI syntax. + + Both RFC 1738 and RFC 1808 refer to the "reserved" set of characters + as if URI-interpreting software were limited to a single set of + characters with a reserved purpose (i.e., as meaning something other + than the data to which the characters correspond), and that this set + was fixed by the URI scheme. However, this has not been true in + practice; any character that is interpreted differently when it is + escaped is, in effect, reserved. Furthermore, the interpreting + engine on a HTTP server is often dependent on the resource, not just + the URI scheme. The description of reserved characters has been + changed accordingly. + + The plus "+", dollar "$", and comma "," characters have been added to + those in the "reserved" set, since they are treated as reserved + within the query component. + + + + + + +Berners-Lee, et. al. Standards Track [Page 37] + +RFC 2396 URI Generic Syntax August 1998 + + + The tilde "~" character was added to those in the "unreserved" set, + since it is extensively used on the Internet in spite of the + difficulty to transcribe it with some keyboards. + + The syntax for URI scheme has been changed to require that all + schemes begin with an alpha character. + + The "user:password" form in the previous BNF was changed to a + "userinfo" token, and the possibility that it might be + "user:password" made scheme specific. In particular, the use of + passwords in the clear is not even suggested by the syntax. + + The question-mark "?" character was removed from the set of allowed + characters for the userinfo in the authority component, since testing + showed that many applications treat it as reserved for separating the + query component from the rest of the URI. + + The semicolon ";" character was added to those stated as being + reserved within the authority component, since several new schemes + are using it as a separator within userinfo to indicate the type of + user authentication. + + RFC 1738 specified that the path was separated from the authority + portion of a URI by a slash. RFC 1808 followed suit, but with a + fudge of carrying around the separator as a "prefix" in order to + describe the parsing algorithm. RFC 1630 never had this problem, + since it considered the slash to be part of the path. In writing + this specification, it was found to be impossible to accurately + describe and retain the difference between the two URI + <foo:/bar> and <foo:bar> + without either considering the slash to be part of the path (as + corresponds to actual practice) or creating a separate component just + to hold that slash. We chose the former. + +G.3. Modifications from RFC 1738 + + The definition of specific URL schemes and their scheme-specific + syntax and semantics has been moved to separate documents. + + The URL host was defined as a fully-qualified domain name. However, + many URLs are used without fully-qualified domain names (in contexts + for which the full qualification is not necessary), without any host + (as in some file URLs), or with a host of "localhost". + + The URL port is now *digit instead of 1*digit, since systems are + expected to handle the case where the ":" separator between host and + port is supplied without a port. + + + + +Berners-Lee, et. al. Standards Track [Page 38] + +RFC 2396 URI Generic Syntax August 1998 + + + The recommendations for delimiting URI in context (Appendix E) have + been adjusted to reflect current practice. + +G.4. Modifications from RFC 1808 + + RFC 1808 (Section 4) defined an empty URL reference (a reference + containing nothing aside from the fragment identifier) as being a + reference to the base URL. Unfortunately, that definition could be + interpreted, upon selection of such a reference, as a new retrieval + action on that resource. Since the normal intent of such references + is for the user agent to change its view of the current document to + the beginning of the specified fragment within that document, not to + make an additional request of the resource, a description of how to + correctly interpret an empty reference has been added in Section 4. + + The description of the mythical Base header field has been replaced + with a reference to the Content-Location header field defined by + MHTML [RFC2110]. + + RFC 1808 described various schemes as either having or not having the + properties of the generic URI syntax. However, the only requirement + is that the particular document containing the relative references + have a base URI that abides by the generic URI syntax, regardless of + the URI scheme, so the associated description has been updated to + reflect that. + + The BNF term <net_loc> has been replaced with <authority>, since the + latter more accurately describes its use and purpose. Likewise, the + authority is no longer restricted to the IP server syntax. + + Extensive testing of current client applications demonstrated that + the majority of deployed systems do not use the ";" character to + indicate trailing parameter information, and that the presence of a + semicolon in a path segment does not affect the relative parsing of + that segment. Therefore, parameters have been removed as a separate + component and may now appear in any path segment. Their influence + has been removed from the algorithm for resolving a relative URI + reference. The resolution examples in Appendix C have been modified + to reflect this change. + + Implementations are now allowed to work around misformed relative + references that are prefixed by the same scheme as the base URI, but + only for schemes known to use the <hier_part> syntax. + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 39] + +RFC 2396 URI Generic Syntax August 1998 + + +H. Full Copyright Statement + + Copyright (C) The Internet Society (1998). All Rights Reserved. + + This document and translations of it may be copied and furnished to + others, and derivative works that comment on or otherwise explain it + or assist in its implementation may be prepared, copied, published + and distributed, in whole or in part, without restriction of any + kind, provided that the above copyright notice and this paragraph are + included on all such copies and derivative works. However, this + document itself may not be modified in any way, such as by removing + the copyright notice or references to the Internet Society or other + Internet organizations, except as needed for the purpose of + developing Internet standards in which case the procedures for + copyrights defined in the Internet Standards process must be + followed, or as required to translate it into languages other than + English. + + The limited permissions granted above are perpetual and will not be + revoked by the Internet Society or its successors or assigns. + + This document and the information contained herein is provided on an + "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING + TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING + BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION + HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF + MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + + + + + + + + + + + + + + + + + + + + + + + + +Berners-Lee, et. al. Standards Track [Page 40] + Added: vendor/portableaserve/aserve/doc/tutorial.html =================================================================== --- vendor/portableaserve/aserve/doc/tutorial.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/doc/tutorial.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,577 @@ +<html> + +<head> +<title>AllegroServe Tutorial</title> +<meta name="GENERATOR" content="Microsoft FrontPage 3.0"> +</head> + +<body> + +<h1 align="center">AllegroServe Tutorial</h1> + +copyright (c) 2000-2001 Franz Inc + +This document is a companion to the AllegroServe reference manual.   Here we +will take you through various examples and demonstrate how to use the facilities of the +AllegroServe web server.   Refer to the reference manual for more details on the +functions we mention here. + +<h1>Loading AllegroServe</h1> + +AllegroServe is distributed as a single fasl file: AllegroServe.fasl.    +If the file is installed where require can find it then you need only +type + +<pre>(require :aserve)</pre> + +to ensure that it's loaded.  Otherwise you'll have to call the load +function.   In the subsequent steps we've assumed that you've loaded +AllegroServe into Lisp. + +<h1>Package setup</h1> + +AllegroServe consists of two components: a web server and an html generator.  +These are located in two Lisp packages: net.aserve and net.html.generator. +   These are long package names to type so the first thing to do is to create a +package that uses these packages as well as the normal Lisp packages.  Let's +create a package called tutorial and make that the current package: + +<pre>(defpackage :tutorial + (:use :common-lisp :excl :net.aserve :net.html.generator)) + +(in-package :tutorial) +</pre> + +<h1>Starting AllegroServe</h1> + +Normally you would publish all the pages for your site and then start the web server. +  That way everyone would see a consistent view of your site.  However, for this +tutorial we'll start the server first so that we can immediately see the pages we're +publishing. + +Web servers normally listen on port 80.  On Unix port 80 can +only be allocated by the the superuser (called root).     +On Windows any user can open port 80 as long as it's not yet +allocated.    In order to make this tutorial work on both Unix and Windows +(and not require that you run as root on Unix), we'll put our web server +on port 8000. + +<pre>tutorial(4): (start :port 8000) +#<wserver @ #x206929aa> +tutorial(5): </pre> + +Now the web server is up and running.   Let's assume that we're running +AllegroServe on a machine named test.franz.com.  If you now go to a +web browser and ask for http://test.franz.com  +you will contact this AllegroServe server and it will respond that whatever you asked for +wasn't found on the server (since we haven't published any pages).  You can also try http://test and get the same result +(although the response message will be slightly different).  If you are running the +web browser on test.franz.com as well you can ask for http://localhost +and get a similar "not found" response.    This demonstrates that +web servers are known by many names.  If you choose to take advantage of that +(creating what are known as Virtual Hosts) then AllegroServe will support +you .  However if you want to create web pages that are served by whatever name can +be used to reach the server, then AllegroServe will allow you to do that as well. + +Type :proc to Lisp and look at which Lisp lightweight processes are +running: + +<pre>tutorial(6): :proc +P Dis Sec dSec Priority State Process Name, Whostate, Arrest +* 8 3 3.2 0 runnable Initial Lisp Listener +* 2 0 0.0 0 waiting Connect to Emacs daemon, waiting for input +* 1 0 0.0 0 inactive Run Bar Process +* 1 0 0.0 0 waiting Editor Server, waiting for input +* 1 0 0.0 0 waiting AllegroServe-accept-6, waiting for input +* 0 0 0.0 0 inactive 1-aserve-worker +* 0 0 0.0 0 inactive 2-aserve-worker +* 0 0 0.0 0 inactive 3-aserve-worker +* 0 0 0.0 0 inactive 4-aserve-worker +* 0 0 0.0 0 inactive 5-aserve-worker +tutorial(7): </pre> + +We've emboldened the threads that are part of AllegroServe.    The +thread named aserve-accept-6 is waiting for an http request.  When +one arrives it passes it off to one of the aserve-worker threads and then +loops back to wait for the next request.  The number of  worker threads is +determined by the :listeners argument to the start +function. + +<h1>Publishing a file</h1> + +The simplest way to publish something is to publish files stored on the disk. +   Create  a file (here we called it /tmp/sample.txt) and +put some words in it, and then + +<pre>tutorial(30): (publish-file :path "/foo" :file "/tmp/sample.txt") +#<net.aserve::file-entity @ #x2076e0c2> +tutorial(31):</pre> + +If you are running on Windows then the file will have a name like +c:\tmp\sample.txt   When this file name is written in a Lisp string it would be +"c:\\tmp\\sample.txt" due to the special nature of the backslash character. + +Now if we ask a web browser for http://test.franz.com:8000/foo +we'll see the contents of the file in the web browser.  Since we didn't specify a +content-type in the call to publish-file the content-type will be +determined by the "txt" file type, which is associated with the +"text/plain" content-type. + +Because we didn't specify a :host argument to publish-file AllegroServe +will return this page to any browser regardless of the host name used to name the machine. +  So AllegroServe will respond to requests for http://test.franz.com:8000/foo +and http://test:8000/foo and http://localhost:8000/foo.    + +If we do + +<pre>tutorial(30): (publish-file :path "/foo" :file "/tmp/sample.txt" + :host "test.franz.com") +#<net.aserve::file-entity @ #x2076e0c2> +tutorial(31):</pre> + +Then AllegroServe will only respond to requests for http://test.franz.com:8000/foo. +  If we do + +<pre>tutorial(30): (publish-file :path "/foo" :file "/tmp/sample.txt" + :host ("test" "test.franz.com")) +#<net.aserve::file-entity @ #x2076e0c2> +tutorial(31):</pre> + +Then AllegroServe will only respond to http://test.franz.com:8000/foo +and http://test:8000/foo.    +This type of restriction is useful if you want to create the illusion that a single +machine is really a set of machines, each with its own set of web pages.   +Suppose that the machine test.franz.com also had the name sales.franz.com.  +You could publish two different ways to respond to the "/foo" +url, depending on the host name specified in the request + +<pre>tutorial(30): (publish-file :path "/foo" :file "/tmp/test-sample.txt" + :host "test.franz.com") +#<net.aserve::file-entity @ #x2076e0c2> +tutorial(31): (publish-file :path "/foo" :file "/tmp/sales-sample.txt" + :host "sales.franz.com") +#<net.aserve::file-entity @ #x2076e324></pre> + +Now you will get different results if you ask for  +http://test.franz.com:8000/foo and http://sales.franz.com:8000/foo. + + +<h1>Publishing a computed page</h1> + +The most important reason for using the AllegroServe web server is that you can compute +a web page when a request comes in.   This allows your program to display the +most up-to-date information on the page or tailor the page to each browser. +      Using the publish function, a lisp +function called a response function is associated with a url.  When +a request comes in that matches that url, the response function is run and it must +generate the correct response which is sent back to the browser.    The +simplest response function is published here: + +<pre>(publish :path "/hello" + :content-type "text/plain" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (princ "Hello World!" *html-stream*))))) + </pre> + +  + +Response functions take two arguments:  a request object and an entity object. +    The request object contains all of the information about the request +(such as the machine from which the request was made, and the headers passed along with +the request).  The request object is also used to store information about the +response that is made to the request.   The entity object contains the +information passed to the publish function.  One important item in +the entity is the content-type which serves as the default content-type +for the response (it can be overridden by an argument to with-http-response). + +A response function must use the with-http-response and with-http-body +macros and then send any additional data to the stream *html-stream*. +    Despite the name of the stream, the data need not always be html. +    The purpose of with-http-response is to allow +AllegroServe to determine how it will setup streams to respond to the +request.    AllegroServe will also check to see if the browser already has +an up-to-date copy of this page cached in which case it will not even run the code in the +body of the with-http-response macro.   with-http-body +is responsible for sending back the response code and headers,  and the body of with-http-body +is where lisp code can send data which will be the body of the response.  + +The preceding example sends a very simple plain text string, specifying the +content-type to be "text/plain".  Typically you'll want to return an html +page.  AllegroServe has a very concise macro for creating html.  Here's a +response function that sends html: + +<pre>(publish :path "/hello2" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html (:head (:title "Hello World Test")) + (:body + ((:font :color "red") "Hello ") + ((:font :color "blue") "World!")))))))) +</pre> + +While both of the preceding response functions generate their response at request time, +they both send back the exact same response every time.   That's not a very good +demonstration of dynamic web pages.   The following page shows how you can +implement a simple counter for the number of accesses: + +<pre>(publish :path "/hello-count" + :content-type "text/html" + :function + (let ((count 0)) + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "Hello Counter")) + (:body + ((:font :color (nth (random 5) + '("red" "blue" + "green" "purple" + "black"))) + "Hello World had been called " + (:princ (incf count)) + " times"))))))))) +</pre> + +This page counts the number of accesses and also displays the text in a color it +selects randomly.  + +  + +<h1>Publishing a form</h1> + +A form displays information, has places for the user to enter information, and has one +or more ways for the user to signal that he is done entering information and the the form +should be processed.   There may be more than one form on a web page but the +forms can't be nested or overlap. + +When the user clicks on the "Submit" (or equivalent) button and the form data +is sent by the browser to the web server, the web server has to process that data and +return a web page to display on the browser screen.  This is an important situation +where using Lisp to process the form data is significantly easier than the alternatives +(such as the shell, or perl or some other primitive scripting language). + +There are three ways that form data is sent to the web browser + +<ol> + <li>query string -- the form data is appended to the url, with a question mark separating + the path of the url from the form data.    This is the default way that + form data is returned.  It's fine for small amounts of data, and it allows the user + to bookmark the result of filling out a form. </li> + <li>encoded in the body of the request --  If the form specifies the POST method + is to be used to return the data, then the data is encoded and placed in the body of the + request after the headers.   This allows the form data to be huge.</li> + <li>multipart body -- in this scheme, the data from the web browser looks like a multipart + MIME message.  This is commonly used when the form data consists of complete files, + since in this case you want to pass along the name of the file (which is in the MIME + header) and you don't want to pay the cost of encoding the contents of the file.</li> +</ol> + +The three attributes of a :form tag that determine how data is sent to +the server are: + +<ol> + <li>:method  -- this is either "GET" (the default) or + "POST".     When "GET" is used the data will be + sent as a query string.</li> + <li>:enctype -- this is either + "application/x-www-form-urlencoded" (the default)  or is + "multipart/form-data" if you want the data sent as a multipart body.  The + value of this attribute only matters if the :method is set to + "POST".</li> + <li>:action -- this is the url to which the request with the data is sent. +    With AllegroServe it's often convenient to make this url the same as the url + of the entity that created the form, and have the entity handling function determine + whether it is being called to display the form or to handle the results of filling out the + form.</li> +</ol> + +Let's examine in detail each of the methods for sending form data: + +<h2>form data in a query string</h2> + +In a url like http://www.machine.com/foo/bar?name=gen&age=28 +the characters after the question mark are the query-string.    +The query string is not used by AllegroServe to determine the entity to +handle the request.  When the entity begins processing the request it can ask for the +request-query of the request object.    request-query +will return an assoc list where the car   of each entry is +a string (e.g. "name" in the example) and the cdr is also a +string (e.g. "gen" in the example).    You can ask for the request-query +of any request object and if there is no query string for the request, request-query +will return nil.    + +This is a typical entity handler that generates a form and handles the result of +filling out the form: + +<pre>(publish :path "/queryform" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((name (cdr (assoc "name" (request-query req) + :test #'equal)))) + (with-http-response (req ent) + (with-http-body (req ent) + (if* name + then ; form was filled out, just say name + (html (:html + (:head (:title "Hi to " (:princ-safe name))) + (:body "Your name is " + (:b (:princ-safe name))))) + else ; put up the form + (html (:html + (:head (:title "Tell me your name")) + (:body + ((:form :action "queryform") + "Your name is " + ((:input :type "text" + :name "name" + :maxlength "20"))))))))))))</pre> + +In the function above we first check to see what value is associated wtih the tag +"name" in the query string.   If there is a name then we know that +we've been called after the form was filled out, so we process the form data, which in +this case means just printing out the name.   Note that we use :princ-safe +to display the name in html.   It's important to use :princ-safe +instead of :princ in situations like this where we are printing a string +that may contain characters special to html.      In the :action +attribute for the :form we specified "queryform" instead of +"/queryform" since it's best to keep all urls relative rather than absolute in +order to make it possible to access the pages through a proxy server that might prepend a +string to the root of the url.   We could have separated the functionality in +the above example so that one entity handler put up the form  and another one +processed the form.    For simple forms it just seems simpler  to do +it all with one url and one entity function. + +  + +<h2>form data encoded in the request body</h2> + +When the data from the form is very large or it's important to hide it from view in the +url, the typical method to accomplish this is to specify the "POST" method for +the form.   In this case the data for the form appears in the body of the +request.  There are two supported encodings of the form data in the body.  In +this section we'll describe how to handle  the default encoding, called: +"application/x-www-form-urlencoded".  First you must call get-request-body +to read and return the body of the request.   Second you must call form-urlencoded-to-query +to convert the encoded body into an assoc list, where every entry is a cons consisting of +a string naming the value and then the string containing the value. + +The following sample shows a single entity handler function that can put up a form and +can process data from the form.   It isn't necessary to use the same handler for +putting up and processing the data from a form.    In this example we +create a form with a big box for entering text.   We invite the user to enter +text in the box and click on a button when he is finished.    At that point +the entity handler gets and decodes the body of the request,  and finds the data from +the text box.  It then generates a table showing how often the characters a +through z are found in the text selection. + +<pre>(publish :path "/charcount" + :content-type "text/html" + :function + #'(lambda (req ent) + (let* ((body (get-request-body req)) + (text (if* body + then (cdr (assoc "quotation" + (form-urlencoded-to-query body) + :test #'equal))))) + (with-http-response (req ent) + (with-http-body (req ent) + (if* text + then ; got the quotation, analyze it + (html + (:html + (:head (:title "Character Counts") + (:body + (:table + (do ((i #.(char-code #\a) (1+ i))) + ((> i #.(char-code #\z))) + (html (:tr + (:td (:princ (code-char i))) + (:td (:princ + (count (code-char i) + text))))))))))) + else ; ask for quotation + (html + (:html + (:head (:title "quote character counter") + (:body + ((:form :action "charcount" + :method "POST") + "Enter your favorite quote " + :br + ((:textarea + :name "quotation" + :rows 30 + :cols 50)) + :br + ((:input :type "submit" + :name "submit" + :value "count it")))))))))))))</pre> + +In this example we ask for the body of the request and then the value of the field +named "quotation".  If that isn't found then we assume that we are being +called to display the form.   We could have checked the value of (request-method +req) which will be :get when we should put up the form and :post +when we should analyze data from the form. + +  + +<h2>form data encoded as a multipart body</h2> + +The final method of sending form data is as a multipart message.   This +occurs when you specify a :method of "POST" and an :enctype +of "multipart/form-data".    The handler for this must detect +when it is being called from a :post request and must call a sequence of +functions to retrieve each item from the message body.  First it calls get-multipart-header +to get the next header (or nil if there are no more headers). +    The header data is an assoc list where the values have different +formats as described in the AllegroServe manual.  After reading the header  the +handler must call get-multipart-sequence to read successive chunks of +data associated with this header. + +An example demonstrating this is too large to include here but can be found in the +AllegroServe examples.cl file (search in that file for  "getfile-got") + +<h1>Authorizing a request</h1> + +You don't necessarily want to allow everyone to access every page you publish. +   We will describe common ways to check whether someone has permission to +access a page.   There are two ways to do the authorization checks.  You +can write the tests yourself in the entity function, or you can create an authorizer +object and attach it to the entity.    Below we'll show you how to +write the code to do the checks manually.   The Allegro AllegroServe manual +describes the authorizer objects. + +<h2>password</h2> + +One way to control access to a page is to request that the person at the browser enter +a name and password.   You can create a form and have the user enter the +information and then click on a button to submit it.   Another way is to return +a 401 (response unauthorized) code to the request made to access your page.    +When given that response, the web browser will pop up a window requesting a name and +password, and after that's entered, the browser resends the request but includes the name +and password in the header. + +The method you choose for asking for the name and password may depend on how secure you +want the response to be.  Using a form the name and password are sent to the web +server without any encoding at all (other than the simple urlencoding which only affects +unusual characters).   If your form uses the "GET" method then the +name and password appear in the url which makes them very easy to spot, so you at least +want to use the "POST" method if you use a form.    If on the +other hand you use the 401 response code, then the name and password are sent in a more +encrypted form (using an encoding called base64) however anyone +sufficiently motivated can decrypt this without a lot of trouble.   AllegroServe +does not yet support md5 authentication which is the most secure way to +do authentication in the HTTP/1.1 protocol. + +One advantage of using the 401 response to cause the user to enter a name and password +is that most web browsers will continue to send the entered name and password along with +future requests to the server until the web browser is restarted.   Thus you can +simultaneously unlock a whole group of pages.  If you choose to handle the +authentication in a form you may want to use a cookie to make a record that this web +browser is now qualified to access a certain group of pages.  Cookies aren't hard to +store, but some users turn off cookie saving thus you will  make your site +inaccessible to these people.  Another authorization mechanism is to insert hidden +fields in forms with values that tell the server that this access is authorized for a +certain amount of time. + +This is an example of using the 401 response to do user authorization.   + +<pre>(publish :path "/secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (multiple-value-bind (name password) (get-basic-authorization req) + (if* (and (equal name "foo") (equal password "bar")) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))) + else ; cause browser to ask name and password + (with-http-response (req ent :response + *response-unauthorized*) + (set-basic-authorization req "secretserver") + (with-http-body (req ent)))))))</pre> + +  + +<h2>source address</h2> + +You can determine the address from which a request was made and restrict access based +on that address.    If the request came through a proxy server then you are +really determining the address of the proxy server.  The following code only serves +the 'secret' page if the request came from a browser running on the same machine as the +server, and which is made over the loopback network on the machine.   The +loopback network is a network that exists entirely inside the operating system of the +machine.  The convention is that a loopback network address has 127 in the most +significant byte, and that is what we test for in the following example: + +<pre>(publish :path "/local-secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((net-address (ash (socket:remote-host + (request-socket req)) + -24))) + (if* (equal net-address 127) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You are on the local network")))) + else + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html (:head (:title "Unauthorized")) + (:body + "You cannot access this page " + "from your location"))))))))) +</pre> + +To see how this example works differently depending on whether the access is through +the loopback network or the regular network, try accessing it via http://localhost:8000/local-secret +and http://test.franz.com:8000/local-secret +  (where we are assuming that you are running on test-franz.com). + +<h1>Multiple servers</h1> + +AllegroServe can run multiple independent web servers.  Each web server listens +for requests on a different port.  Because each web server can appear to be serving +pages for different hosts (using the virtual host facility already described in the +discussion of the publish functions), it is usually not necessary to use +the multiple server facility we describe here.  + +All of the information about a web server, including the entities it serves, are stored +in a wserver object.     The current wserver +object is stored in the variable *wserver*.    The publish +functions use the value of *wserver* as the default server into which +they publish entities. + +  + +<h1>Debugging a computed response handler</h1> + +We will describe this in detail when the tutorial is updated.  For now read the +documentation on net.aserve::debug-on in the AllegroServe manual. + +  + +  + +  + +  +</body> +</html> Added: vendor/portableaserve/aserve/example.cl =================================================================== --- vendor/portableaserve/aserve/example.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/example.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,528 @@ +;;;; AllegroServe Example + +(defpackage "ASERVE-EXAMPLE" + (:use + #:COMMON-LISP + #:ACL-COMPAT.EXCL + #:NET.HTML.GENERATOR + #:NET.ASERVE) + (:export + #:start-server + #:stop-server + #:start-simple-server)) + +(in-package :aserve-example) + +(defparameter *hit-counter* 0) + +(publish :path "/" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:head (:title "Welcome to Portable AllegroServe on " (:princ (lisp-implementation-type)))) + (:body (:center ((:img :src "aservelogo.gif"))) + (:h1 "Welcome to Portable AllegroServe on " (:princ (lisp-implementation-type))) + (:p "These links show off some of Portable AllegroServe's capabilities. ") + (:i "This server's host name is " + (:princ-safe (header-slot-value req :host))) + #+unix + (:i ", running on process " (:princ (net.aserve::getpid))) + :br + (:princ (incf *hit-counter*)) " hits" + :p + (:b "Sample pages") :br + ((:a :href "apropos") "Apropos") :br + ((:a :href "pic") "Sample jpeg") :br + ((:a :href "pic-redirect") "Redirect to previous picture") :br + ((:a :href "pic-gen") "generated jpeg") "- hit reload to switch images" :br + ((:a :href "cookietest") "test cookies") :br + ((:a :href "secret") "Test manual authorization") + " (name: " (:b "foo") ", password: " (:b "bar") ")" + :br + ((:a :href "secret-auth") "Test automatic authorization") + " (name: " + (:b "foo2") + " password: " + (:b "bar2") ")" + :br + ((:a :href "local-secret") "Test source based authorization") + " This will only work if you can use " + "http:://localhost ... to reach this page" ;: + :br + ((:a :href "local-secret-auth") + "Like the preceding but uses authorizer objects") + :br + ((:a :href "timeout") "Test timeout") + :br + ((:a :href "getfile") "Client to server file transfer") + :br + ((:a :href "missing-link") "Missing Link") + " should get an error when clicked" + ) + + ))))) + +;; a very simple page. This is so simple it doesn't put out the required +;; tags (like <html>) yet I suspect that most browsers will display it +;; correctly regardless. +(publish :path "/hello" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "Hello World!"))))) + +;; this is the "/hello" example above modified to put out the correct +;; html tags around the page. +(publish :path "/hello2" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:body "Hello World!"))))))) + +;; display a picture from a file. +(publish-file :path "/pic" :file "ASERVE:examples;prfile9.jpg" + :content-type "image/jpeg") + +(publish-file :path "/aservelogo.gif" :file "ASERVE:examples;aservelogo.gif" + :content-type "image/gif") + +(publish :path "/pic-gen" + :content-type "image/jpeg" + :function + (let ((selector 0)) ; chose one of two pictures + #'(lambda (req ent) + (with-http-response (req ent :format :binary) + (with-http-body (req ent) + ; here is where you would generate the picture. + ; we're just reading it from a file in this example + (let ((stream (request-reply-stream req))) + (with-open-file (p (nth selector + `("ASERVE:examples;prfile9.jpg" + "ASERVE:examples;fresh.jpg")) + :element-type '(unsigned-byte 8)) + (setq selector (mod (1+ selector) 2)) + (loop for val = (read-byte p nil nil) + while val do (write-byte val stream))))))))) + +(publish :path "/pic-redirect" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent + :response *response-moved-permanently*) + (setf (reply-header-slot-value req :location) "pic") + (with-http-body (req ent) + ;; this is optional and most likely unnecessary since most + ;; browsers understand the redirect response + (html + (:html + (:head (:title "Object Moved")) + (:body + (:h1 "Object Moved") + "The picture you're looking for is now at " + ((:a :href "pic") "This location")))))))) + +(publish :path "/tform" + :content-type "text/html" + :function + (let ((name "unknown")) + #'(lambda (req ent) + (let ((body (get-request-body req))) + (format t "got body ~s~%" body) + (let ((gotname (assoc "username" + (form-urlencoded-to-query body) + :test #'equal))) + (when gotname + (setq name (cdr gotname))))) + + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "test form")) + (:body "Hello " (:princ-safe name) ", " + "Enter your name: " + ((:form :action "/tform" + :method "post") + ((:input :type "text" + :maxlength 10 + :size 10 + :name "username")))))))))) + + +;; example of a form that uses that 'get' method +;; +(publish :path "/apropos" + :content-type "text/html" + :function + #'(lambda (req ent) + + (let ((lookup (assoc "symbol" (request-query req) :test #'equal))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Allegro Apropos")) + ((:body :background "aserveweb/fresh.jpg") + "New Apropos of " + ((:form :action "apropos" + :method "get") + ((:input :type "text" + :maxlength 40 + :size 20 + :name "symbol"))) + :p + (if lookup + (let ((ans (apropos-list (cdr lookup)))) + (html :hr (:b "Apropos") " of " + (:princ-safe (cdr lookup)) + :br + :br) + (if (null ans) + (html "No Match Found") + (macrolet ((my-td (str) + `(html ((:td + :bgcolor "blue") + ((:font :color "white" + :size "+1") + (:b ,str)))))) + (html ((:table + :bgcolor "silver" + :bordercolor "blue" + :border 3 + :cellpadding 3) + (:tr + (my-td "Symbol") + (my-td "boundp") + (my-td "fboundp")) + (dolist (val ans) + (html (:tr + (:td (:prin1-safe val)) + (:td (:prin1 (and (boundp val) t))) + (:td (:prin1 (and (fboundp val) t)))) + :newline))))))) + (html "Enter name and type enter"))) + :newline)))))) + +;; a preloaded picture file +(publish-file :path "/aserveweb/fresh.jpg" + :file "ASERVE:examples;fresh.jpg" + :content-type "image/jpeg" + :preload t) + +;; a preloaded text file +(publish-file :path "/foo" + :file "ASERVE:examples;foo.txt" + :content-type "text/plain" + :preload t) + +(publish-file :path "/foo.txt" + :file "ASERVE:examples;foo.txt" + :content-type "text/plain" + :preload nil) + +;; some entries for benchmarking +(publish-file :path "/file2000" + :file "ASERVE:examples;file2000.txt" + :content-type "text/plain" + :preload nil) + +(publish-file :path "/file2000-preload" + :file "ASERVE:examples;file2000.txt" + :content-type "text/plain" + :preload t) + + +(publish :path "/dynamic-page" + :content-type "text/plain" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "This is a dynamic page"))))) + +;; an example which causes the web browser to put up the +;; name/password box and if you enter the name "foo" and password "bar" +;; then you get access to the secret info. +(publish :path "/secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (multiple-value-bind (name password) (get-basic-authorization req) + (if (and (string= name "foo") (string= password "bar")) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))) + (with-http-response (req ent + :response *response-unauthorized*) + (set-basic-authorization req "secretserver") + (with-http-body (req ent))))))) + +(publish :path "/local-secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((net-address (ash (acl-socket:remote-host + (request-socket req)) + -24))) + (if (equal net-address 127) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You are on the local network")))) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html (:head (:title "Unauthorized")) + (:body + "You cannot access this page " + "from your location"))))))))) + + +(publish :path "/local-secret-auth" + :content-type "text/html" + :authorizer (make-instance 'location-authorizer + :patterns '((:accept "127.0.0.0" 8) + (:accept "tiger.franz.com") + :deny)) + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You made it to the secret page")))))) + +;; these two urls show how to transfer a user-selected file from +;; the client browser to the server. +;; +;; We use two urls (/getfile to put up the form and /getfile-post to +;; handle the post action of the form). We could have done it all +;; with one url but since there's a lot of code it helps in the +;; presentation to separate the two. +;; +(publish :path "/getfile" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head "get file") + (:body + ((:form :enctype "multipart/form-data" + :method "post" + :action "getfile-got") + "Let me know what file to grab" + :br + ((:input :type "file" + :name "thefile" + :value "*.txt")) + :br + ((:input :type "text" :name "textthing")) + "Enter some text" + :br + ((:input :type "checkbox" :name "checkone")) + "check box one" + :br + ((:input :type "checkbox" :name "checktwo")) + "check box two" + :br + ((:input :type "submit"))))))))) + + +(publish :path "/secret-auth" + :content-type "text/html" + :authorizer (make-instance 'password-authorizer + :allowed '(("foo2" . "bar2") + ("foo3" . "bar3") + ) + :realm "SecretAuth") + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))))) + + +;; this called with the file from +(publish :path "/getfile-got" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (let (files-written + text-strings) + (loop for h = (get-multipart-header req) + while h + ;; we can get the filename from the header if + ;; it was an <input type="file"> item. If there is + ;; no filename, we just create one. + do (let ((cd (assoc :content-disposition h :test #'eq)) + (filename) + (sep)) + (when (and cd (consp (cadr cd))) + (setq filename (cdr (assoc "filename" + (cddr (cadr cd)) + :test #'equalp))) + (when filename + ;; locate the part of the filename after + ;; the last directory separator. the + ;; common lisp pathname functions are no + ;; help since the filename syntax may be + ;; foreign to the OS on which the server + ;; is running. + (setq sep + (max (or (position #\/ filename + :from-end t) -1) + (or (position #\\ filename + :from-end t) -1))) + (setq filename + (subseq filename (1+ sep) + (length filename))))) + (if filename + (progn + (push filename files-written) + (with-open-file (pp filename :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (format t "writing file ~s~%" filename) + (let ((buffer (make-array 4096 + :element-type + '(unsigned-byte 8)))) + ;; note: we could also use + ;; get-all-multipart-data here + (loop for count = (get-multipart-sequence + req buffer) + while count + do (write-sequence buffer pp :end count))))) + ;; no filename, just grab as a text string + (let ((buffer (make-string 1024))) + (loop for count = (get-multipart-sequence + req buffer + :external-format :utf8-base) + while count + do (push (subseq buffer 0 count) text-strings)))))) + ;; now send back a response for the browser + (with-http-body (req ent :external-format :utf8-base) + (html (:html (:head (:title "form example")) + (:body "-- processed the form, files written --" + (dolist (file (nreverse files-written)) + (html :br "file: " + (:b (:prin1-safe file)))) + :br + "-- Non-file items Returned: -- " :br + (dolist (ts (reverse text-strings)) + (html (:princ-safe ts) :br)))))))))) + + +(publish :path "/cookietest" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (set-cookie-header req + :name "froba" + :value "vala" + :path "/" + :expires :never) + (set-cookie-header req + :name "frob2" + :value "val2" + :path "/" + :expires :never) + (set-cookie-header req + :name "frob3-loooooooooooooong" + :value "val3-loooooooooooooong" + :path "/" + :expires :never) + (set-cookie-header req + :name "the time" + :value (net.aserve::universal-time-to-date + (get-universal-time)) + :path "/cookieverify" + :expires (+ (get-universal-time) + (* 20 60) ; 20 mins + ) + ) + + (with-http-body (req ent) + (html (:head (:title "Cookie Test")) + (:body "you should have a cookie now." + " Go " + ((:a :href "cookieverify") "here") + " to see if they were saved")))))) + +(publish :path "/cookieverify" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((cookie-info (get-cookie-values req))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Cookie results")) + (:body + "The following cookies were returned: " + (:prin1-safe cookie-info)))))))) + +(publish :path "/timeout" + :content-type "text/html" + :function + #'(lambda (req ent) + ;; do nothing interesting so that the timeout will + ;; occur + (with-http-response (req ent :timeout 15) + (loop (sleep 5))))) + +(publish :path "/long-slow" + :content-type "text/plain" + :function + #'(lambda (req ent) + ;; chew up cpu time in a look that blocks + ;; the scheduler from running so this aserve + ;; won't accept any more connections and we can + ;; demo the multiple process version + ; takes 50 secs on a 1.2ghz Athlon + (locally (declare (optimize (speed 3) (safety 0))) + (dotimes (aa 500) + (declare (fixnum aa)) + (dotimes (j 300) + (declare (fixnum j)) + (dotimes (i 10000) + (declare (fixnum i)) + (let ((k (+ i j))) + (declare (fixnum k)) + (setf k (- i j)) + (setf k (+ i j k)) + (setf k (- i j k))))))) + + (with-http-response (req ent) + (with-http-body (req ent) + (html "done"))))) + + +(defun start-server (&rest args &key (port 2001) &allow-other-keys) + (apply #'net.aserve:start :port port args)) + +(defun stop-server () + (net.aserve:shutdown)) + +(defun start-simple-server (&key (port 2001)) + (net.aserve:start :port port :chunking nil :keep-alive nil :listeners 0)) + + + +#| +(in-package :aserve-example) +(use-package :net.aserve.client) + +(setq cookies (make-instance 'cookie-jar)) +(do-http-request "http://www.dataheaven.de/" + :cookies cookies + :protocol :http/1.0) +(net.aserve.client::cookie-jar-items cookies) +|# Added: vendor/portableaserve/aserve/examples/.cvsignore =================================================================== --- vendor/portableaserve/aserve/examples/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/examples/.pics/.cvsignore =================================================================== --- vendor/portableaserve/aserve/examples/.pics/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +{arch} +.arch-ids Added: vendor/portableaserve/aserve/examples/.pics/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/examples/.pics/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:02 2004// +D Added: vendor/portableaserve/aserve/examples/.pics/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/examples/.pics/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +A D/med//// Added: vendor/portableaserve/aserve/examples/.pics/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/examples/.pics/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/examples/.pics Added: vendor/portableaserve/aserve/examples/.pics/CVS/Root =================================================================== --- vendor/portableaserve/aserve/examples/.pics/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/examples/.pics/med/.cvsignore =================================================================== --- vendor/portableaserve/aserve/examples/.pics/med/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/med/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +{arch} +.arch-ids Added: vendor/portableaserve/aserve/examples/.pics/med/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/examples/.pics/med/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/med/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:02 2004// +/Marble01.jpg/1.1.1.1/Mon Aug 6 03:42:59 2001// +/aservelogo.gif/1.1.1.1/Mon Aug 6 03:42:58 2001// +/fresh.jpg/1.1.1.1/Mon Aug 6 03:42:58 2001// +/prfile9.jpg/1.1.1.1/Mon Aug 6 03:42:58 2001// +D Added: vendor/portableaserve/aserve/examples/.pics/med/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/examples/.pics/med/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/med/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/examples/.pics/med Added: vendor/portableaserve/aserve/examples/.pics/med/CVS/Root =================================================================== --- vendor/portableaserve/aserve/examples/.pics/med/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.pics/med/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/examples/.pics/med/Marble01.jpg =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/.pics/med/Marble01.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/.pics/med/aservelogo.gif =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/.pics/med/aservelogo.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/.pics/med/fresh.jpg =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/.pics/med/fresh.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/.pics/med/prfile9.jpg =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/.pics/med/prfile9.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/.xvpics/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/examples/.xvpics/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.xvpics/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/aservelogo.gif/1.1.1.1/Mon Aug 6 03:42:59 2001// +D Added: vendor/portableaserve/aserve/examples/.xvpics/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/examples/.xvpics/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.xvpics/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/examples/.xvpics Added: vendor/portableaserve/aserve/examples/.xvpics/CVS/Root =================================================================== --- vendor/portableaserve/aserve/examples/.xvpics/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/.xvpics/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/examples/.xvpics/aservelogo.gif =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/.xvpics/aservelogo.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/examples/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,14 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:02 2004// +/aservelogo.gif/1.1.1.1/Mon Aug 6 03:42:49 2001// +/aservepowered.gif/1.1/Tue Dec 3 16:34:11 2002// +/cgitest.sh/1.1/Sun Jun 9 11:34:59 2002// +/chat.cl/1.5/Sun Feb 8 15:41:06 2004// +/examples.cl/1.7/Tue Jan 27 10:53:44 2004// +/file2000.txt/1.1.1.1/Mon Aug 6 03:42:46 2001// +/foo.txt/1.1.1.1/Mon Aug 6 03:42:49 2001// +/fresh.jpg/1.2/Sun Jun 9 11:34:59 2002// +/prfile9.jpg/1.2/Sun Jun 9 11:34:59 2002// +/puzzle.cl/1.3/Thu Dec 26 19:55:44 2002// +/tutorial.cl/1.3/Thu Dec 26 19:55:44 2002// +/urian.cl/1.3/Tue Dec 2 14:20:39 2003// +D Added: vendor/portableaserve/aserve/examples/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/examples/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +A D/.pics//// +A D/.xvpics//// Added: vendor/portableaserve/aserve/examples/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/examples/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/examples Added: vendor/portableaserve/aserve/examples/CVS/Root =================================================================== --- vendor/portableaserve/aserve/examples/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/examples/aservelogo.gif =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/aservelogo.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/aservepowered.gif =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/aservepowered.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/cgitest.sh =================================================================== --- vendor/portableaserve/aserve/examples/cgitest.sh 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/cgitest.sh 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,44 @@ +#! /bin/sh +# +# return various cgi responses based on the first argument +# +case $1 in + + 1) # bogus but common lf headers + echo 'Content-Type: text/plain' + echo + echo "The environment vars are " + env + echo "==== end ====" + ;; + + 2) # redirect to franz.com, send some headers + echo 'Location: http://www.franz.com' + echo 'etag: 123hellomac' + echo + echo -n 'go to franz' + ;; + + 3) # send back unauthorized request + echo 'Status: 401 unauthorized request' + echo + echo 'this request unauthorized' + ;; + + 4) # send back an ok response and something on the error stream + echo 'Content-Type: text/plain ' + echo ' ' + echo "okay" + echo stuff-on-error-stream 1>&2 + ;; + + *) # normal crlf headers + echo 'Content-Type: text/plain ' + echo ' ' + echo "The environment vars are " + env + echo "==== end ====" + ;; +esac + + Added: vendor/portableaserve/aserve/examples/chat.cl =================================================================== --- vendor/portableaserve/aserve/examples/chat.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/chat.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3366 @@ +;; +;; chat.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: chat.cl,v 1.5 2004/02/08 15:41:06 rudi Exp $ + +;; Description: +;; aserve chat program + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + +(defpackage :user (:use :net.aserve :excl :common-lisp :puri + :net.aserve.client + :net.html.generator)) +(in-package :user) + +(defvar *chat-home-package* :user) ; :user for now while debugging +(defvar *chat-home*) ; home dir for chat info +(defvar *chat-home-pics*) ; home dir for chat pics +(defvar *chat-picname* 0) +(defvar *default-count* 10) +(defvar *default-secs* 10) + +; secret path to get back to admin control +(defvar *quick-return-path* "/xyzz") + +(defvar *idle-timeout* (* 30 60)) ; 30 minutes + +(defvar *do-dnscheck* nil) ; translate ip to dns names + +(defvar *chat-hook* nil) ; invoked when the chat page is accessed + +(defvar *offer-transcript* nil) ; offer a chat transcript + +(defparameter *initial-msg-size* 100) ; size of initial message array +(defparameter *msg-increment* 200) ; how much to grow array each time + +;; parameters +; +; one set of of paraamter is the page style of the top frame +; call (set-style xxx) where xxx is one of the *xxx-style* values +; (set-style *normal-style*) +; (set-style *white-style*) +; +; setting *background-image* to an image url will put that url on +; the background of the top window +; e.g. +; (setq *background-image* "http://www.franz.com/~jkf/aserveback4.gif") +; (setq *background-image* nil) +; set *recent-first* to true to make the newest messages show first +; +; set *show-style* to 1 for normal, 2 for tables +; (setq *show-style* 1) +; (setq *show-style* 2) +; + + + +(defparameter *bottom-frames-bgcolor* "#dddddd") ; gray +(defparameter *bottom-frames-private* "#ff5555") ; for private messaging + +(defparameter *private-font-color* "#ff4444") ; red +(defparameter *public-font-color* "#ffcc66") ; gold + +(defstruct color-style + bgcolor + font-color + vlink-color + link-color + alink-color) + +(defparameter *normal-style* + (make-color-style + :bgcolor "#000000" ; black + :font-color "#ffcc66" ; gold + :vlink-color "#ffaaaa" ; red + :link-color "#aaffaa" ; green + :alink-color "#aaaaff" ; blue + )) + +(defparameter *white-style* + (make-color-style + :bgcolor "#ffffff" ; white + :font-color "#000000" ; black + :vlink-color "#ff0000" ; red + :link-color "#0000ff" ; blue + :alink-color "#00aa00" ; green + )) + + + +(defvar *top-frame-bgcolor* ) +(defvar *top-frame-font-color*) +(defvar *top-frame-vlink-color*) +(defvar *top-frame-link-color*) +(defvar *top-frame-alink-color*) + +(defvar *background-image* nil) + +(defvar *message-id-hook* nil) ; if true it can contribute to the messsage line + +(defvar *max-active-time* #.(* 2 60)) ; after 2 minutes no longer active + + +(defvar *recent-first* t) ; if true show most recent messages first + +(defvar *show-style* 1) ; 1 = tables, 2 = just entries + +; true if we wish to restrict messaging at all based on logged in +; and level +(defvar *restrict-messages* nil) + +; true if we show the machine name of chatters to everyone instead +; of just the owner +(defvar *show-machine-name-to-all* t) + +; force it to be loaded +;(defparameter *ensure-ef* (find-external-format :utf-8)) + +;; sample building command to create a standalone chat serve +#| +(generate-application "allegrochat" + "allegrochat/" + '(:sock :process :seq2 :acldns + "aserve/aserve.fasl" + "aserve/examples/chat.fasl" + ) + :restart-init-function + 'start-chat-standalone + :include-compiler nil + :read-init-files nil + :include-debugger t + :ignore-command-line-arguments t) + +|# + + + +; +; query attribute usage: +; u = controller ustring +; c = chat ustring +; s = secret key (specific to the object being accessed) +; x = user uid +; pp = uid of person sending message to, * means all +; purl = picture url +; z = lurk +; y = delete message +; b = upgrade user + + +(defclass master-chat-controller () + ((controllers :initform nil + ; list of chat-controller instances + :initarg :controllers + :accessor controllers) + (ustrings :initform nil + :initarg :ustrings + :accessor ustrings) + (master-lock :initform (mp:make-process-lock :name "chat master") + ;; used when doing serious altering to chat info + :reader master-lock) + (secret-key :initarg :secret-key + ;; to unlock the setup-chat + :initform (make-unique-string) + :reader secret-key) + (users :initform nil + :initarg :users + ;; list of user objects + :accessor users) + )) + + +(defvar *master-controller* nil) ; the master-controller instance + + + +(defclass chat-controller () + ;; describes a whole set of chats + + ((chats :initform nil + ; list of chat instances + :initarg :chats + :accessor chats) + (owner-name :initarg :owner-name + :reader owner-name) + (controller-name :initarg :controller-name + :reader controller-name) + (ustring :initarg :ustring :accessor ustring) ; un + (ustrings :initform nil + ;; ustrings of all the chats + :initarg :ustrings + :accessor ustrings) + (secret-key :initarg :secret-key + ;; knowing this key gives you access to + ;; changing the parameters of the chat + :accessor secret-key) + (controller-uri :initarg :controller-uri + ;; uri to reach this controller page + :accessor controller-uri) + (controller-query-string :initarg :controller-query-string + ; u=xxxxx&s=xxxxx specify this controller and + ; the secret key for this controller + :reader controller-query-string) + )) + + + +(defclass chat () + ((name :initarg :name + :reader chat-name + ) + + (state :initform :open + ; :open or :closed + :initarg :state + :accessor chat-state) + + (ustring :initarg :ustring + :accessor ustring) + + (filename :initarg :filename + ;; name of file holding chat info. + ;; should be just a name, no directory stuff, so + ;; it can be relative to the chat home + :accessor chat-filename) + + (secret-key :initarg :secret-key + ;; to do admin things to this chat + :initform (make-unique-string) + :reader secret-key) + + (chat-query-string :initarg :chat-query-string + ;; u=xxxx&c=yyyyyy indentifies chat + :reader chat-query-string) + (chat-owner-query-string :initarg :chat-owner-query-string + ;; u=xxxx&c=yyyyyy&s=xxxx indentifies chat + :reader chat-owner-query-string) + + + (messages :initform (make-array *initial-msg-size*) + :accessor chat-messages) + (message-next :initform 0 + ;; index in the messages array of place + ;; to store next message + :accessor chat-message-next) + (message-number :initform 0 + :initarg :message-number + ;; message number of the next message + :accessor chat-message-number) + (message-archive :initform 0 + :initarg :message-archive + ;; 1+ last message number archived so far + :accessor chat-message-archive) + ; used by experimental code to delete private messages + ; message number to scan next + (message-prvcheck :initform 0 + :accessor chat-message-prvcheck) + + ; list of deleted message numbers since the last archive + (messages-deleted :initform nil + :initarg :messages-deleted + :accessor chat-messages-deleted) + + + (message-lock :initform (mp:make-process-lock :name "chat-message") + ; grab this before changing the above + :accessor chat-message-lock) + + + ;; list of people monitoring this chat + (viewers :initform (make-viewers) + :accessor chat-viewers) + + ; used as index value in the redirect struct + (redirect-counter :initform 0 + :initarg :redirect-counter + :accessor redirect-counter) + + ; list of redirect structures + (redirects :initform nil + :initarg :redirects + :accessor chat-redirects) + )) + +(defstruct user + handle ; official handle of the user + password ; password string + ustring ; unique string of this user + pstring ; unique string, this one denotes user as a send target + cookie ; cookie stored under achat name + level ; nil - novice, 1 - higher privs + (time 0) ; time of last user activity + to-users ; string holding comma sep list of users to send to (nil=all) + ) + + +(defstruct viewers + (lock (mp:make-process-lock :name "viewers-lock")) + list ; list of viewent + ) + +(defstruct viewent + time ; time of last read, nil to make this one unused + user ; if user access, then user object + ipaddr ; if random access then ipaddr + hostname ; string if we've figured it out + ) + + + +(defstruct message + number ; is unique for each chat + ipaddr ; integer ip address of the source + dns ; dns name corresponding to the ip address + handle ; from handle (for unlogged in user) + real ; true if this is a real handle of a logged in user + to ; if non nil then a list of handles who are the target of this message + ; if nil then this goes to no-one + ; if t then this goes to everyone + time ; string - message time in a pretty format + (ut 0) ; universal time of message + body) + + + +(defstruct redirect + index ; unique name for each redirect + + ;; structure describing the redirection of a group of ip addresses + ipaddr ; bits not under the mask are ignored + maskbits ; bits from 0 to 32 + mask ; the actual mask + + to ; where to send the redirect + before ; true if we check before seeing if they are logged in + info ; string describing this redirect + (use 0) ; use count + active ; true if active + ) + + + +;; roles +; master-controller - can create controllers. has a secret key (s) +; controller - can create chats, each has a public key (u) and +; a private key (s). +; chat - is a collection of posted messages. has a public key (c) +; and a controller public key (u) and a secret key (s) +; Most access the chat using u and c. If you also know s then +; you have owner priviledges to the chat +; + + +;; pages +; +; url set what +; +; setup-chat - if no chat setup yet, bring up first page +; with link to first controller page page +; setup-chat s s has master control key, bring up page of +; existing chat controllers and form for +; craeting new one. This is the master controller +; page. +; new-controller s,name,controllername +; posted from setup-chat +; s is the master controller secret key +; name and controllername are used to build +; new controller object. +; controller u,s u has controller public string, s has +; controller private string, show chats by +; this controller and offer to create a new one +; create-chat u,s,name,filename create a new chat under the controller +; denoted by u. s has the controller private +; string (secret key) +; chat u,c,[s] build frameset for the given chat. +; s is the chat secret key [if given.] +; chattop u,c,[s],count,secs,y,z,b display count message and refresh in secs +; chaviewers u,c,[s] list who is watching the chat +; chatenter u,c,[s],pp,purl box into which to enter a message +; chatcontrol u,c,[s] specify message count and refresh seconds +; chatlogin u,c,x,[s] login to a existing user or create a new user +; +; chatloginnew u,c,[s],handle,password,password2 +; define new user +; +; chatlogincurrent u,c,[s],handle,password +; login as an existing user +; +; chatmaster u,c,s control elements of the chat. +; +; + + +; top level published urls + + + + +; functions +(defun start-chat (&key port home restart (listeners 10)) + ;; start the chat system going + (declare (special socket::*dns-configured*)) + + ;(unpublish :all t) ; useful during debugging, remove afterwards + + (if* (not (stringp home)) + then (error "must specify :home value as a string naming a directory (no trailing slash)")) + + (setq *chat-home* home) + + (ignore-errors + (excl::mkdir (setq *chat-home-pics* + (concatenate 'string *chat-home* "/pics")) #o755)) + + (setq *chat-picname* + (logand #xffffff (* 8 (get-universal-time)))) + + (publish-directory :prefix "/chatpics" + :destination *chat-home-pics* + ) + + (setq *master-controller* nil) + + (if* (not restart) + then (load-existing-chat *chat-home*) + (let (did-fixup) + ;; temp to add cookies to old chat + (dolist (user (users *master-controller*)) + (if* (null (user-cookie user)) + then (setf (user-cookie user) (make-unique-string)) + (setq did-fixup t))) + (if* did-fixup then (dump-existing-chat *chat-home*)))) + + (if* *master-controller* + then ; we have an existing chat setup + (publish-chat-links) + (start-chat-archiver *master-controller*) + ) + + (publish :path "/setup-chat" :function 'setup-chat + ; :content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + ; setup for reverse dns lookups. don't do reverse lookups if we + ; have to use the C library + #+(and allegro (version>= 6 0)) + (if* (and (boundp 'socket::*dns-configured*) + socket::*dns-configured*) + thenret + else (socket:configure-dns :auto t) + (setq *do-dnscheck* socket::*dns-configured* + socket::*dns-mode* :acldns)) + + + (if* port then (net.aserve:start :port port :listeners listeners + ; :external-format (crlf-base-ef :utf-8) + ) + ) + ) + + +(defun start-chat-standalone () + ;; useful function for starting chat standalone where the + ;; port and home arguments are required + + (if* (not (eql 5 (length (acl-compat.system:command-line-arguments)))) + then (format t "use: ~s port home~%" (acl-compat.system:command-line-argument 0)) + (exit 1)) + + (let ((port (read-from-string (nth 3 (acl-compat.system:command-line-arguments)))) + (home (nth 4 (sys:command-line-arguments)))) + (start-chat :port port :home home) + (loop (sleep 9999999)))) + +(defun shutdown-chat () + ;; stop the chat + (net.aserve:shutdown) + (setq *master-controller* nil) + (sleep 10) + (exit 0 :quiet t)) + + +(defun publish-chat-links () + + ; debugging only. builds link to the master controller page + (publish :path *quick-return-path* :function 'quick-return-master + ; :content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + + ; post'ed from form in setup-chat + (publish :path "/new-controller" :function 'new-controller + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/controller" :function 'existing-controller + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + ; get'ed from the controller page when user asks to create a chat + (publish :path "/create-chat" :function 'create-chat + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + + (publish :path "/chat" :function 'chat + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + (publish :path "/chattop" :function 'chattop + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatenter" :function 'chatenter + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatenter-pic" :function 'chatenter-pic + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatcontrol" :function 'chatcontrol + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatlogin" :function 'chatlogin + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatloginnew" :function 'chatloginnew + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatlogincurrent" + :function 'chat-login-current + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatviewers" :function 'chatviewers + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chatmaster" :function 'chatmaster + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + + (publish :path "/chattranscript" :function 'chattranscript + ;:content-type "text/html; charset=utf-8" + :content-type "text/html" + ) + ) + + +(defun load-existing-chat (home) + ;; read in and build the chat information + (declare (special user::value1)) + + (let ((master-file (concatenate 'string home "/cmaster.cl"))) + (if* (probe-file master-file) + then (with-standard-io-syntax + (load master-file) + (if* (boundp 'user::value1) + then (setq *master-controller* user::value1) + ; ensure users have cookies + ) + + ;; now read in chat data + (dolist (controller (controllers *master-controller*)) + (dolist (chat (chats controller)) + (and (archive-filename chat) + (probe-file (archive-filename chat)) + (let (did-delete) + (with-open-file (p (archive-filename chat) + :direction :input + :external-format :octets) + (do ((message (read p nil :eof) (read p nil :eof))) + ((eq message :eof) + ; use everything is archived we've read + (setf (chat-message-archive chat) + (chat-message-number chat)) + ; remove those put back on redundantly + ; by delete-chat-message + (setf (chat-messages-deleted chat) nil)) + (if* message + then (if* (and (consp message) + (eq :delete (car message))) + then (mapcar #'(lambda (num) + (delete-chat-message + chat num t nil)) + (cdr message)) + (setq did-delete t) + else (add-chat-message chat message))))) + + (if* did-delete + then ; write out archive again this time + ; without the deleted messages + (format t "Rewriting ~s~%" (archive-filename chat)) + (let ((messages (chat-messages chat))) + (with-open-file (p (archive-filename chat) + :direction :output + :if-exists :supersede + ;:external-format :utf-8 + ) + (dotimes (i (chat-message-next chat)) + (let ((message (svref messages i))) + (if* (message-to message) + then (pprint (svref messages i) p))))))))))))))) + +(defun dump-existing-chat (home) + (mp:with-process-lock ((master-lock *master-controller*)) + (labels ((dump-master-chat-controller (masterc) + `(make-instance 'master-chat-controller + :ustrings ',(ustrings masterc) + :secret-key ',(secret-key masterc) + :controllers + (list ,@(mapcar #'dump-chat-controller + (controllers masterc))) + :users ',(users masterc) + )) + + (dump-chat-controller (controller) + `(make-instance 'chat-controller + :chats + (list ,@(mapcar #'dump-chat (chats controller))) + :owner-name ',(owner-name controller) + :controller-name ',(controller-name controller) + :ustring ',(ustring controller) + :ustrings ',(ustrings controller) + :secret-key ',(secret-key controller) + :controller-uri ',(controller-uri controller) + :controller-query-string + ',(controller-query-string controller))) + + (dump-chat (chat) + `(make-instance 'chat + :name ',(chat-name chat) + :state ',(chat-state chat) + :ustring ',(ustring chat) + :filename ',(chat-filename chat) + :secret-key ',(secret-key chat) + :chat-query-string ',(chat-query-string chat) + :chat-owner-query-string ',(chat-owner-query-string chat) + :redirect-counter ',(redirect-counter chat) + :redirects ',(chat-redirects chat) + )) + + ) + + + (let ((new-master-file (concatenate 'string home "/ncmaster.cl")) + (master-file (concatenate 'string home "/cmaster.cl")) + (value)) + + (setq value + `(setq user::value1 + ,(dump-master-chat-controller *master-controller*))) + + (with-open-file (p new-master-file + :direction :output + :if-exists :supersede + ;:external-format :utf-8 + ) + (with-standard-io-syntax + (let ((*package* (find-package *chat-home-package*))) + (format p ";;Automatically generated, do not edit~%") + (print `(in-package ,*chat-home-package*) p) + (pprint value p) + (terpri p)))) + + ; success, so make it the official one + (ignore-errors (delete-file master-file)) + + #-(and allegro (version>= 6 2 :pre-beta 11)) + (rename-file new-master-file master-file) + + #+(and allegro (version>= 6 2 :pre-beta 11)) + (rename-file-raw new-master-file master-file) + )))) + + + + + + + + + +(defun quick-return-master (req ent) + ;; quick hack to get us to the master controller while debugging + (if* (null *master-controller*) + then (ancient-link-error req ent) + else (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:body "The master controllers is " + ((:a href + (format nil "setup-chat?s=~a" + (secret-key *master-controller*))) + "here")))))))) + +(defun illegal-access (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "illegal access")) + (:body "You are attempting to gain illegal access to this " + "chat control. Stop doing this.")))))) + +(defun setup-chat (req ent) + ;; this is the first function called to start a whole chat + ;; system going (building a master controller) and is also + ;; the function used by the master controller to specify new + ;; controllers. + (if* (null *master-controller*) + then (setq *master-controller* (make-instance 'master-chat-controller)) + (dump-existing-chat *chat-home*) + (do-first-setup-page req ent) + (start-chat-archiver *master-controller*) + elseif (not (equal (secret-key *master-controller*) + (request-query-value "s" req))) + then (illegal-access req ent) + + else (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Chat Setup")) + (:body (:h1 "Chat Setup") + + (if* (controllers *master-controller*) + then (html (:h2 "Existing Chat Controllers") + (display-chat-controllers + (controllers *master-controller*)))) + + (:h2 "New Chat Controller") + " This page is used to create a chat controller which " + "then can be use to create chats." + " Just fill out the form below and click on submit " + " and you'll be taken to a new controller page. " + ((:form :action "new-controller" + :method "POST") + ((:input :type "hidden" + :name "s" + :value (secret-key *master-controller*))) + ((:input :type "text" + :name "name" + :size 30 + :maxlength 30)) + "Your Name" + :br + + ((:input :type "text" + :name "controllername" + :size 30 + :maxlength 30)) + "Name for this collection of chats" + :br + + + ((:input :type "submit"))))))))) + + +(defun display-chat-controllers (controllers) + ;; display a table of chat controllers + (html + ((:table :border "1" :cellspacing 1 :cellpadding 3) + ((:tr :bgcolor "#9999ff") + (:th "Owner Name") + (:th "Collection Name") + (:th "Link")) + (dolist (controller controllers) + (html (:tr (:td (:princ-safe (owner-name controller))) + (:td (:princ-safe (controller-name controller))) + (:td ((:a :href (format nil "controller?~a" + (controller-query-string + controller))) + "Go To Page")))))))) + +(defun do-first-setup-page (req ent) + ;; called when setup-chat is done for the first time + ;; gives the special url that can be used by the chat superadmin + ;; to give chat controllers to others + + (publish-chat-links) + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "First Setup")) + (:body (:h1 "First Setup") + "This is the first access to this chat setup and you " + "are now the chat super-adminstrator." + " This " + ((:a href + (format nil "setup-chat?s=~a" + (secret-key *master-controller*))) + "link") + " will take you to a page where you can create chat" + "controller who then can create chats" + " Once you follow the link to the page be sure to bookmark " + " the page since this will be the only way to " + " exert your superadminstrator powers."))))) + + ) + + + + +(defun new-controller (req ent) + + (if* (or (not (eq (request-method req) :post)) + (not (equal (secret-key *master-controller*) + (request-query-value "s" req)))) + then ; someone's playing around + (return-from new-controller + (ancient-link-error req ent))) + + (with-http-response (req ent) + (let ((query (request-query req))) + (let ((controller + (new-chat-controller + :owner-name (cdr (assoc "name" query :test #'equalp)) + :controller-name (cdr (assoc "controllername" query + :test #'equalp)) + :secret-key (make-unique-string)))) + (mp:with-process-lock ((master-lock *master-controller*)) + (push controller (controllers *master-controller*))) + + (dump-existing-chat *chat-home*) + (with-http-body (req ent) + (html + (:html + (:head (:title "Created New Controller")) + (:body + "A new controller page has been created, go to " + ((:a :href (format nil "controller?~a" + (controller-query-string + controller))) + "here") + " to see the page")))))))) + +(defun existing-controller (req ent) + ;; when an owner visits his control page + (let ((controller (controller-from-req req))) + (if* (or (null controller) + (not (equal (secret-key controller) + (cdr (assoc "s" (request-query req) + :test #'equalp))))) + then (ancient-link-error req ent) + else (with-http-response (req ent) + (with-http-body (req ent) + (display-controller-page controller)))))) + + + +(defun display-controller-page (controller) + ;; display the html for the controller page + (html + (:html + (:head (:title "Controller for " + (:princ-safe (controller-name controller)))) + (:body + (:h1 "Controller for " + (:princ-safe (controller-name controller))) + (:h2 "Owner is " (:princ-safe + (owner-name controller))) + (if* (null (chats controller)) + then (html (:h2 "There are no chats defined yet")) + else (display-chat-list (chats controller) t)) + + ((:form :action + (concatenate 'string + "create-chat?" + (controller-query-string controller)) + + :method "POST") + :hr + (:h2 "Create New Chat") + ((:input :type "text" + :name "name" + :size 30) + " Enter Name for Chat") + :br + ((:input :type "text" + :name "filename" + :value (format nil "chat-~a.txt" (make-unique-string)) + :size 30)) + " File where messages are stored" + :br + ((:input :type "submit" + :value "Create Chat"))))))) + + + + + +(defun display-chat-list (chats owner-p) + ;; display the characteristics of the chats in a table + (html ((:table :border "1" :cellspacing 1 :cellpadding 3) + ((:tr :bgcolor "#9999ff") + (:th "Chat name") + (:th "State") + (:th "Link") + (if* owner-p + then (html (:th "Owner Link"))) + ) + (dolist (chat chats) + (html (:tr + (:td (:princ-safe (chat-name chat))) + (:td (:princ-safe (chat-state chat))) + (:td + ((:a :href (concatenate 'string + "chat?" + (chat-query-string chat))) + "Go to Chat")) + (if* owner-p + then (html (:td + ((:a :href (concatenate 'string + "chat?" + (chat-owner-query-string chat))) + "Go to Chat as owner")))))))))) + +(defun new-chat-controller (&key owner-name controller-name secret-key) + ;; create a new chat controller object + (let (ustring) + + ; create a unique string to indentify this controller + (loop + (setq ustring (make-unique-string)) + (mp:without-scheduling + (if* (not (member ustring + (ustrings *master-controller*) + :test #'equal)) + then (push ustring (ustrings *master-controller*)) + (return)))) + + (let ((controller (make-instance 'chat-controller + :owner-name owner-name + :controller-name controller-name + :secret-key secret-key + :ustring ustring + :controller-uri (compute-controller-uri ustring) + :controller-query-string + (format nil "u=~a&s=~a" + ustring + secret-key)))) + controller))) + + + +(defun compute-controller-uri (ustring) + (format nil "controller?u=~a" ustring)) + + +(defun make-unique-string () + ;; make a unique string that's not one of the other strings + ;; want it to around five characters long + + (let ((time (get-universal-time))) + ; randomize things + (dotimes (i (logand time #xf)) (random 10)) + (dotimes (i (logand time #x1f)) (random 10)) + (setq time (logxor time (random 4342211881376))) + (setq time (logxor time (random + (load-time-value + (get-universal-time))))) + ; make sure it's at least 8 digits base 26 + (if* (< time #.(expt 26 8)) + then (incf time #.(expt 26 8))) + ; + (string-downcase (format nil "~26r" time)))) + + + +(defun create-chat (req ent) + ;; create a new chat for the given controller + (let ((controller (controller-from-req req))) + (if* (or (null controller) + (not (equal (secret-key controller) + (request-query-value "s" req)))) + then (ancient-link-error req ent) + else (let (ustring) + (loop + (setq ustring (make-unique-string)) + (mp:without-scheduling + (if* (not (member ustring (ustrings controller) + :test #'equal)) + then (push ustring (ustrings controller)) + (return)))) + + (let ((chat (make-new-chat controller + :name (request-query-value "name" req) + :filename + (request-query-value "filename" req) + :ustring ustring))) + (mp:without-scheduling + (push chat (chats controller))) + (dump-existing-chat *chat-home*) + (with-http-response (req ent) + (with-http-body (req ent) + (display-controller-page controller)))))))) + +(defun ancient-link-error (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "This link is ancient and won't work any more")))) + + +(defun controller-from-req (req) + ;; locate controller named by request + (let ((ustring (request-query-value "u" req))) + (if* ustring + then (dolist (controller (controllers *master-controller*)) + (if* (equal ustring (ustring controller)) + then (return controller)))))) + +(defun chat-from-req (req) + ;; find the chat object given the req + (let ((controller (controller-from-req req))) + (if* controller + then (let ((chat-ustring (cdr (assoc "c" (request-query req) + :test #'equalp)))) + (if* chat-ustring + then (dolist (chat (chats controller)) + (if* (equal chat-ustring (ustring chat)) + then (return chat)))))))) + +(defun user-from-req (req) + ;; find the user object from this request + (let ((val (request-query-value "x" req))) + (if* val + then (let ((user (user-from-ustring val))) + (if* (and user (equal (user-cookie user) + (get-chat-cookie req))) + then user))))) + + + + +(defun user-from-ustring (ustring) + ;; find user object based on unique string + (find ustring (users *master-controller*) + :key #'user-ustring :test #'equal)) + +(defun user-from-pstring (ustring) + ;; find user object based on unique string + (find ustring (users *master-controller*) + :key #'user-pstring :test #'equal)) + +(defun users-from-ustring (ustring) + ;; ustring may be a comma separated value + (let (res) + (dolist (usr (net.aserve::split-on-character ustring #\,)) + (let ((u (user-from-ustring usr))) + (if* u then (pushnew u res :test #'eq)))) + (nreverse res))) + + +(defun users-from-pstring (ustring) + ;; ustring may be a comma separated value + (let (res) + (dolist (usr (net.aserve::split-on-character ustring #\,)) + (let ((u (user-from-pstring usr))) + (if* u then (pushnew u res :test #'eq)))) + (nreverse res))) + +(defun user-from-handle (handle) + ;; locate the user object given the handle + (find handle (users *master-controller*) + :key #'user-handle :test #'equal)) + +(defun make-new-chat (controller &key name filename ustring) + ;; make a new chat object + (let ((secret-key (make-unique-string))) + (make-instance 'chat + :name name + :ustring ustring + :filename filename + :secret-key secret-key + :chat-query-string (format nil "u=~a&c=~a" + (ustring controller) + ustring) + :chat-owner-query-string + (format nil "u=~a&c=~a&s=~a" + (ustring controller) + ustring + secret-key) + :secret-key secret-key))) + + + + +(defun get-chat-cookie (req) + (cdr (assoc "aschat" (get-cookie-values req) :test #'equal))) + +(defun set-chat-cookie (req cookie) + (set-cookie-header req :name "aschat" + :value cookie + :expires :never)) + + +; chat frames: +; +; chattop +; chatviewers chatenter chatcontrol + +(defun chat (req ent) + ;; generate the chat frames + (format t "start chat~%") (force-output) + (let ((chat (chat-from-req req)) + (user (user-from-req req)) + (qstring)) + + (if* user then (setf (user-time user) (get-universal-time))) + + ; do redirect check + (if* (null user) + then ; do not logged in check + (if* (redir-check req ent chat t) + then (return-from chat))) + + ; now the logged in or not logged in check + (if* (redir-check req ent chat nil) + then (return-from chat)) + + + + + + + (if* *chat-hook* + then (if* (funcall *chat-hook* req ent) + then (return-from chat))) + + + (if* (null chat) + then (ancient-link-error req ent) + else (setq qstring + (add-lurk + req + (add-secret req + (add-user req (chat-query-string chat))))) + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "chat - " + (:princ-safe (chat-name chat))) + ) + + ((:frameset :rows "*,160") + ((:frame :src + (format nil "chattop?~a&count=~d&secs=~d&hitbut=did" + qstring + *default-count* + *default-secs*) + :name "chattop") + ((:frameset :cols + (if* user + then "15%,*,20%" + else "*,20%")) + (if* user + then (html ((:frame :src + (concatenate 'string + "chatviewers?" + qstring))))) + ((:frame :src + (concatenate 'string + "chatenter?" + qstring) + :name "chatenter")) + ((:frame :src + (concatenate 'string + "chatcontrol?" + qstring)))) + (:noframes + "This chat program requires a browser that supports frames" + )))))))))) + + + + + + + +(defun add-user (req current-string) + ;; if a user has been specified in the chat + ;; the add it's x string to the current string + (let ((val (request-query-value "x" req))) + (if* val + then (format nil "~a&x=~a" current-string val) + else current-string))) + +(defun add-secret (req current-string) + ;; if a secret string has been defined then add it onto the + ;; current string + (let ((val (request-query-value "s" req))) + (if* val + then (format nil "~a&s=~a" current-string val) + else current-string))) + +(defun add-reverse (req current-string) + ;; if a reverse value has been defined then add it onto the + ;; current string + (let ((val (request-query-value "rv" req))) + (if* val + then (format nil "~a&rv=~a" current-string val) + else current-string))) + +(defun add-lurk (req current-string) + ;; if a lurk has been defined then add it onto the + ;; current string + (let ((val (request-query-value "z" req))) + (if* val + then (format nil "~a&z=~a" current-string val) + else current-string))) + +(defun chattop (req ent) + ;; put out the top part of the chat + (let* ((chat (chat-from-req req)) + (user (user-from-req req)) + (is-owner + (equal (and chat (secret-key chat)) + (request-query-value "s" req))) + (qstring)) + + (if* (null chat) + + then (return-from chattop (ancient-link-error req ent))) + + ; do redirect check + (if* (null user) + then ; do not logged in check + (if* (redir-check req ent chat t) + then (return-from chattop))) + + ; now the logged in or not logged in check + (if* (redir-check req ent chat nil) + then (return-from chattop)) + + + (let ((delete (request-query-value "y" req))) + (if* delete + then (delete-chat-message chat + (compute-integer-value delete) + is-owner + (and user + (user-handle user)) + ))) + + (let ((upgrade (request-query-value "b" req))) + (if* upgrade + then (let ((user (user-from-ustring upgrade))) + (if* user + then (setf (user-level user) 1) + (dump-existing-chat *chat-home*))))) + + (let* ((count (or (compute-integer-value + (request-query-value "count" req)) + 10)) + (secs (or (compute-integer-value + (request-query-value "secs" req)) + 0))) + + (if* (not (equal "385" (request-query-value "z" req))) + then (track-viewer chat user req)) + + (if* user + then + (if* (zerop (user-time user)) + then (setf (user-time user) (get-universal-time))) + + + (if* (equal (request-query-value "hitbut" req) "did") + then ; user hit button in the chatcontrol frame + (setf (user-time user) (get-universal-time)) + else ; test to see if time has expired + (if* (> (- (get-universal-time) (user-time user)) + *idle-timeout*) + then (do-idle-timedout req ent + (format nil + "chat?~a" + (add-lurk + req + (add-secret + req + (add-user + req + (chat-query-string chat)))))) + (return-from chattop)))) + + (with-http-response (req ent :timeout 500) + (setq qstring + (format nil "~a&count=~d&secs=~d" + (add-lurk + req + (add-reverse + req + (add-secret + req + (add-user + req + (chat-query-string chat))))) + count + secs)) + (with-http-body (req ent) + (html + (:html + (:head + (:title "chat frame") + (if* (and secs (> secs 0)) + then ; setup for auto refresh + (html ((:meta :http-equiv "Refresh" + :content + (format nil "~d;url=chattop?~a" + secs + qstring))))) + + ((:body :if* *background-image* + :background *background-image* + :if* (not *background-image*) + :bgcolor *top-frame-bgcolor* + :text *top-frame-font-color* + :link *top-frame-link-color* + :vlink *top-frame-vlink-color* + :alink *top-frame-alink-color* + ) + (if* (or (null secs) (zerop secs)) + then ; indicate frozen + (html (:center (:b ((:font :color "green") + "--*-- Frozen --*--"))) + :br)) + + (show-chat-info chat count + (not (equal "1" (request-query-value + "rv" + req))) + (if* user then (user-handle user)) + (if* is-owner then qstring) + (format nil "~a&count=~d&secs=~d" + (add-lurk + req + (add-reverse + req + (add-user + req + (chat-query-string chat)))) + count + secs))))))))))) + + +(defun chatenter (req ent) + ;; + ;; this is the window where you enter the post and your handle. + ;; + (let* ((chat (chat-from-req req)) + (user (user-from-req req)) + (pp (or (request-query-value "pp" req) "*")) ; who to send to + (ppp (request-query-value "ppp" req)) ; add a user to the dest + (purl (request-query-value "purl" req)) + (kind :multiline) + (to-users (users-from-pstring pp)) + (qstring)) + (if* (null chat) + then (return-from chatenter + (ancient-link-error req ent))) + + (let* ((body (request-query-value "body" req)) + (handle (request-query-value "handle" req))) + + (setq qstring + (add-secret req + (add-user req + (chat-query-string chat)))) + + + (if* user + then (setf (user-time user) (get-universal-time)) + + (if* ppp + then ; add this user + + (setq pp (setf (user-to-users user) + (concatenate 'string + (or (user-to-users user) "") + "," + ppp))) + (setq to-users (users-from-pstring pp)) + elseif (equal pp "*") + then (setf (user-to-users user) nil) + else (setf (user-to-users user) pp))) + + ; do redirect check + (if* (null user) + then ; do not logged in check + (if* (redir-check req ent chat t) + then (return-from chatenter))) + + ; now the logged in or not logged in check + (if* (redir-check req ent chat nil) + then (return-from chatenter)) + + + (if* (and body (not (equal "" body))) + then ; user added content to the chat + (add-chat-data chat req handle body user to-users purl nil)) + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head + :newline + "<script> + +</script> +" + :newline + ) + ((:body :onload "sf()" + :bgcolor + (if* to-users + then *bottom-frames-private* + else *bottom-frames-bgcolor*)) + ((:form :action (concatenate 'string + "chatenter?" + qstring) + :method "POST" + :name "f" + ) + (:center + (if* (eq kind :multiline) + then (html + (:table + (:tr + (:td + (:center + ((:input :name "send" + :value "Send" + :type "submit")) + " " + (if* user + then (html + (if* to-users + then (html + "Private msg from: ") + else (html "From: ")) + (:b + (:princ-safe + (user-handle user))) + " to " + (:b + (if* to-users + then (dolist (to-user to-users) + (html + (:princ-safe + (user-handle + to-user)) + " " + )) + else (html "all")))) + + else (html + "Your Name" + ((:input :name "handle" + :type "text" + :tabindex 3 + :size 20 + :value (if* handle then handle else ""))))) + " -- " + ((:a :href (format nil "chatlogin?~a" qstring) + :target "_top") + "Login") + " --    " + + ((:input :name "send" + :tabindex 2 + :value "Send" + :type "submit")) + (if* user + then (html " " + ((:a :href (format nil "chatenter-pic?~a&pp=~a" + qstring pp)) + "upload picture"))) + ))) + (:tr + (:td + ((:textarea :name "body" + :tabindex 1 + :cols 50 + :rows 5)) + ((:input :type "hidden" + :name "pp" + :value pp)))) + (:tr + (:td + (:center + ((:input :type "text" + :size 40 + :maxlength 100 + :value (or purl "") + :name "purl")) + " Picture Url"))))) + else ; single line + (html + (:table + (:tr + ((:td :colspan 1) + (:center + "Your Name" + ((:input :name "handle" + :type "text" + :size 20 + :value (if* handle then handle else ""))) + ((:input :name "send" + :value "Post Message" + :type "submit"))))) + (:tr + (:td + ((:input :type "text" + :name "body" + :size 60 + :maxsize 10000))))))))) + + )))))))) + +(defun chatenter-pic (req ent) + ;; + ;; this is the window where you enter the post and your handle. + ;; this version is for when you post a picture + ; + (let* ((chat (chat-from-req req)) + (user (user-from-req req)) + (pp (or (request-query-value "pp" req) "*")) ; who to send to + (ppp (request-query-value "ppp" req)) ; add a user to the dest + (to-users (users-from-pstring pp)) + (qstring)) + (if* (or (null chat) (null user)) + then (return-from chatenter-pic + (ancient-link-error req ent))) + + (if* (eq (request-method req) :post) + then (process-incoming-file chat req user to-users) + (setf (request-method req) :get) + (return-from chatenter-pic (chatenter req ent))) + + (let* () + + (setq qstring + (add-secret req + (add-user req + (chat-query-string chat)))) + + + ;; user must be true + (setf (user-time user) (get-universal-time)) + + (if* ppp + then ; add this user + + (setq pp (setf (user-to-users user) + (concatenate 'string + (or (user-to-users user) "") + "," + ppp))) + (setq to-users (users-from-pstring pp)) + elseif (equal pp "*") + then (setf (user-to-users user) nil) + else (setf (user-to-users user) pp)) + + + ; now the logged in or not logged in check + (if* (redir-check req ent chat nil) + then (return-from chatenter-pic)) + + + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + ((:body :bgcolor + (if* to-users + then *bottom-frames-private* + else *bottom-frames-bgcolor*)) + ((:form :action (concatenate 'string + "chatenter-pic?" + (format nil "~a&pp=~a" qstring pp)) + :method "POST" + :enctype "multipart/form-data" + ) + (:center + + (html + (:table + (:tr + (:td + (:center + ((:input :name "send" + :value "Send" + :type "submit")) + " " + + (html + (if* to-users + then (html + "Private msg from: ") + else (html "From: ")) + (:b + (:princ-safe + (user-handle user))) + " to " + (:b + (if* to-users + then (dolist (to-user to-users) + (html + (:princ-safe + (user-handle + to-user)) + " " + )) + else (html "all")))) + " -- " + ((:a :href (format nil "chatlogin?~a" qstring) + :target "_top") + "Login") + " --    " + + ((:input :name "send" + :tabindex 2 + :value "Send" + :type "submit"))))) + (:tr + (:td + "The picture file to upload (click Browse):" :br + ((:input :type "file" + :name "thefile" + :size 40 + :value "*.jpg"))) + (:tr + (:td + "Add commments about your picture" :br + ((:textarea :name "comments" + :tabindex 1 + :cols 50 + :rows 3))))))))))))))))) + + + +(defparameter *pic-counter* 0) + +(defun process-incoming-file (chat req user to-users) + (let ((comment "") type upload-pic) + (loop + (multiple-value-bind (kind name filename content-type) + (parse-multipart-header + (get-multipart-header req)) + (case kind + (:eof (return)) + (:data ; must be contents + (if* (equal name "comments") + then (setq comment (get-all-multipart-data req)))) + (:file + (let ((contents (get-all-multipart-data req :type :binary + :limit 2000000))) + ; see if it ends in .jpg or .gif + (if* (member content-type '("image/jpeg" + "image/pjpeg" + "image/jpg") + :test #'equal) + then (setq type "jpg") + elseif (equal content-type "image/gif") + then (setq type "gif") + else (format t "uploaded type of ~s is ~s~%" + filename content-type)) + (if* type + then (let ((filename (concatenate 'string + (format nil "~x" (incf *chat-picname* 23)) + "." + type))) + (with-open-file (p (concatenate 'string + *chat-home-pics* + "/" + filename) + :direction :output + :if-exists :supersede) + (write-sequence contents p)) + (setq upload-pic + `(:span :br ((:img :src ,(format nil "/chatpics/~a" filename))) :br)))))) + (t (get-all-multipart-data req :limit 1000))))) + + (if* (or (and comment (> (length comment) 0)) + upload-pic) + then (add-chat-data chat req nil comment user to-users nil + upload-pic)))) + + + + + + +#+ignore +(defun process-incoming-file (chat req user to-users) + ;; read the multipart file, publish it + ;; create the message referencing it, and then add that to the chat. + (let (file content-type comment upload-pic) + (loop (let ((h (get-multipart-header req))) + (if* (null h) then (return)) + (pprint h)(force-output) + (let ((name (cdr + (assoc "name" + (cddr (assoc :param + (cdr (assoc :content-disposition h :test #'eq)) + :test #'eq)) + :test #'equal)))) + (if* (equal name "thefile") + then ; the file we're uploading + (setq content-type (cadr (assoc :content-type h :test #'eq))) + (setq file (read-multipart-guts req)) + + elseif (equal name "comments") + then ; read the comments + (setq comment (octets-to-string (read-multipart-guts req))) + else (read-multipart-guts req))))) + + ;; now we may have a picture + (if* (and file content-type) + then ; we have guts + (let ((picname (format nil "/chatpix/~d~d" + (get-universal-time) (incf *pic-counter*)))) + (publish-multi :path picname + :content-type content-type + :items (list (list :binary file))) + + (setq upload-pic + `(:span :br ((:img :src ,picname)) :br)) + + (setq comment (or comment "")))) + + (if* (and comment (> (length comment) 0)) + then (add-chat-data chat req nil comment user to-users nil + upload-pic)) + + + )) + + + +(defun read-multipart-guts (req) + (let ((buffer (make-array 40000 :element-type '(unsigned-byte 8))) + (buffs) + (total-size 0)) + (loop (let ((count (get-multipart-sequence req buffer))) + (if* count + then (incf total-size count) + (push (subseq buffer 0 count) buffs) + else (return)))) + + (setq buffer (make-array total-size :element-type '(unsigned-byte 8))) + (let ((count 0)) + (dolist (buf (nreverse buffs)) + (replace buffer buf :start1 count) + (incf count (length buf)))) + buffer)) + + + + + + + + + +(defun do-idle-timedout (req ent goback) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "timed out")) + (:body "due to inactivity you have been timed out" + :br + (if* goback + then (html "To return to the chat click " + ((:a :href goback + :target "_top") + "here")))))))) + + +(defun chatcontrol (req ent) + ; control the updating + (let ((chat (chat-from-req req)) + (qstring)) + + (if* (null chat) + then (return-from chatcontrol (ancient-link-error req ent))) + + (let* ((count (or (request-query-value "count" req) *default-count*)) + (secs (or (request-query-value "secs" req) *default-secs*))) + + (setq qstring + (add-lurk + req + (add-secret req + (add-user req (chat-query-string chat))))) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + ((:body :bgcolor *bottom-frames-bgcolor*) + ((:form :action + (concatenate 'string + "chattop?" + qstring + ) + :target "chattop" + :method "POST") + ((:input :type "text" + :name "secs" + :size 3 + :value secs) + "Seconds") + :br + ((:input :type "text" + :name "count" + :size 4 + :value count)) + "messages" + :br + ((:input :type "checkbox" + :name "rv" + :value "1")) + " Reversed" + :br + + ; use to distinguish a call to chattop from + ; a user button click from a refresh one + + ((:input :type "hidden" + :name "hitbut" + :value "did")) + + ((:input :type "submit" + :name "submit" + :value "Update Messages")) + + + ; optional chat transcript link + (if* *offer-transcript* + then (html + :br :hr + ((:a :href (format nil "chattranscript?~a" qstring) + :target "_blank") + "View transcript."))) + ))))))))) + + +(defun compute-integer-value (string) + ;; compute the string to a number + ;; if there's any junk return nil if we haven't seen good stuff yet + (and (stringp string) + (let ((ans 0)) + (do ((i 0 (1+ i)) + (end (length string)) + (seen-digit) + ) + ((>= i end) + (if* seen-digit + then ans + else nil)) + (let ((digit (- (char-code (schar string i)) #.(char-code #\0)))) + (if* (<= 0 digit 9) + then (setq ans (+ (* ans 10) digit)) + (setq seen-digit t) + else (if* seen-digit + then (return ans) + else (return nil)))))))) + + + +(defun add-chat-data (chat req handle body user to-users purl upload-pic) + ;; chat is chat object + ;; req is http request object + ;; handle is handle typed by user (only matters if user not logged in) + ;; body is the string that's the posting + ;; user is the user object if user is logged in + ;; to-user is nil or the string naming the private message receipient + ;; purl is picture url value + (multiple-value-bind (prefix link) + (if* (and (stringp purl) (not (equal "" purl))) + then (scan-for-http purl)) + (declare (ignore prefix)) + + + + (if* (stringp to-users) + then ; just one user, turn it into a list + (setq to-users (list to-users))) + + (if* link + then (if* (and (consp link) + (consp (car link)) + (eq :img (caar link))) + thenret ; valid image url + else (setq link nil))) + + (if* (null link) + then (setq link upload-pic)) + + (let* ((cvted-body (html-chk-string-to-lhtml body)) + (ipaddr (socket:remote-host + (request-socket req))) + (dns (or #+ignore (socket:ipaddr-to-hostname ipaddr) + (socket:ipaddr-to-dotted ipaddr))) + (ut (get-universal-time)) + + (message + (make-message + :number (chat-message-number chat) + :ipaddr ipaddr + :dns dns + :handle (if* user then (user-handle user) else handle) + :to (if* to-users + then (mapcar #'user-handle to-users) + else t) + :real (if* user then t else nil) + :time (let ((time (compute-chat-date ut))) + (if* *message-id-hook* + then (funcall *message-id-hook* time) + else time)) + :ut ut + :body (if* link + then (cons link cvted-body) + else cvted-body)))) + + (mp:with-process-lock ((chat-message-lock chat)) + (add-chat-message chat message))))) + +(defun compute-chat-date (ut) + ; return string to use as time for this message + ; quick hack - hardwire in pdt + (multiple-value-bind (sec min hour day month) + (decode-universal-time ut) + (format nil "~d:~2,'0d:~2,'0d Pacific Time, ~a ~d" hour min sec + (month-name month) day + ))) + +(defun month-name (month) + (svref '#("" "Jan" "Feb" "Mar" "Apr" "May" "June" "July" + "Aug" "Sep" "Oct" "Nov" "Dec") + month)) + +(defun add-chat-message (chat message) + ;; add the message to the messages of the chat. + ;; assume that we've got the lock to do this. + (let ((messages (chat-messages chat)) + (message-next (chat-message-next chat))) + + (if* (>= message-next (length messages)) + then ; must grow messages + (let ((nmessages (make-array (+ (length messages) + *msg-increment*)))) + ;; copy only non-deleted messages + (let ((to 0)) + (dotimes (i (length messages)) + (let ((message (svref messages i))) + (if* (message-to message) + then (setf (svref nmessages to) message) + (incf to)))) + (setq message-next to) + (setf (chat-messages chat) nmessages) + (setq messages nmessages)))) + (setf (svref messages message-next) message) + (setf (chat-message-next chat) (1+ message-next)) + (setf (chat-message-number chat) + (1+ (message-number message))))) + + + +(defun delete-chat-message (chat messagenum is-owner handle) + ;; remove the message numbered messagenumy setting the to field to nil + (mp:with-process-lock ((chat-message-lock chat)) + (let ((message (find-chat-message chat messagenum))) + (if* (and message + (or is-owner ; owner can remove all + (and handle + (equal handle (message-handle message))))) + then (setf (message-to message) nil) + (push messagenum (chat-messages-deleted chat)))))) + +(defun delete-chat-message-by-message (chat message) + ;; remove the given message by setting the to field to nil + (mp:with-process-lock ((chat-message-lock chat)) + (if* message + then (setf (message-to message) nil) + (push (message-number message) + (chat-messages-deleted chat))))) + +(defun find-chat-message (chat number) + ;; find the message with the given number + (let* ((messages (chat-messages chat)) + (len (and messages (chat-message-next chat))) + (bottom 0) + (top (and len (1- len))) + ) + (if* messages + then ; find first message + ; do binary search + #+ignore (format t "Want message ~s~%" number) + (loop + (if* (> bottom top) + then (return nil) ; no message found + else (let ((try (truncate (+ top bottom) 2))) + #+ignore (format t "try ~d (~d -> ~d)~%" + try bottom top) + (let ((message (svref messages try))) + (if* message + then #+ignore (format t "try msg num is ~s~%" + (message-number message)) + (if* (eql (message-number message) number) + then #+ignore (format t "**found~%") + (return message) + elseif (< (message-number message) + number) + then ; in top quadrant + (setq bottom + (max (1+ bottom) try)) + else (setq top + (min (1- top) try))) + else (warn "Null chat message at ~d" + try) + (return nil))))))))) + + +(defun show-message-p (message handle) + ;; return true if this message should be shown to someone with + ;; the handle 'handle' + ;; + ;; handle is non-nil iff this person is logged in. + ;; + ;; message-to is nil if this is a deleted message in which case + ;; no one should see it. + ;; + (or + ; show everyone + (eq t (message-to message)) + + ; message specifically to handle + (and handle (member handle (message-to message) :test #'equal)) + + ; message from 'handle' and to at least one person + (and (equal (message-handle message) handle) + (message-to message)))) + + +(defun find-nth-message (messages start handle count) + ;; count down from start to find the index of the counth + ;; message visible to handle. return that index + + (assert (> count 0)) + + (loop + (if* (<= start 0) then (return 0)) + (let ((message (svref messages start))) + (if* (show-message-p message handle) + then (if* (<= (decf count) 0) then (return start))) + (decf start)))) + + +(defun compute-chat-statistics (chat) + ;; compute information about this chat + (mp::with-process-lock ((chat-message-lock chat)) + (let ((messages (chat-messages chat)) + (message-next (chat-message-next chat))) + (let ((total-messages 0) + (private-messages 0)) + (dotimes (i message-next) + (let ((message (svref messages i))) + (if* message + then (if* (message-to message) + then (incf total-messages) + (if* (not (eq t (message-to message))) + then (incf private-messages)))))) + + (values total-messages private-messages))))) + + + +(defun set-saved-chat-messages (chat count) + ;; set to save approx 'count' messages + (mp::with-process-lock ((chat-message-lock chat)) + (let ((messages (chat-messages chat)) + (message-next (chat-message-next chat))) + ; count backwards until we've passed 'count' messages + (do ((i (1- message-next) (1- i))) + ((< i 0) + ; no messages to remove + nil) + + (let ((message (svref messages i))) + (if* message + then (if* (<= count 0) + then ; remove all messages at this point + (delete-chat-message-by-message chat message) + else (if* (message-to message) + then (decf count))))))))) + + + + + + + + + + +(defun show-chat-info (chat count recent-first handle ownerp qstring) + ;; show the messages for all and those private ones for handle + ;; handle is only non-nil if this is a legit logged in handle + (let ((message-next (chat-message-next chat)) + (messages (chat-messages chat)) + (first-message) + (last-message) + (nth-message) + (message-increment) + ) + + ;; if the person is not logged in then minimize the count + (if* *restrict-messages* + then (if* (null handle) + then (setq count (min 5 count)) + else (let ((user (user-from-handle handle))) + (if* (and user (null (user-level user))) + then (setq count (min 10 count)))))) + + + (if* (zerop message-next) + then (html (:b "There are no messages in this chat")) + elseif (<= count 0) + thenret ; nothing to show + else ; starting at the end find the counth message + (setq nth-message + (find-nth-message messages (1- message-next) handle count)) + + (if* recent-first + then (setq first-message (1- message-next) + last-message nth-message + message-increment -1) + else (setq last-message (1- message-next) + first-message nth-message + message-increment 1)) + + (if* recent-first + then ; tag most recent message + (html ((:div :id "recent")))) + + (do ((i first-message (+ i message-increment))) + (nil) + + (let ((message (svref messages i))) + (if* (null message) + then (warn "null message at index ~d" i) + elseif (if* (or (eq t (message-to message)) + (member handle (message-to message) + :test #'equal)) + then ;; to everyone or us + nil ; don't skip + elseif (and (equal (message-handle message) + handle) + (message-to message)) + then ;; from us to someone, anyone + nil ; don't skip + else t ; skip + ) + thenret ; skip this message + elseif (eq *show-style* 1) + then + (html :newline + ((:font :color + (if* (consp (message-to message)) + then *private-font-color* + else *public-font-color*)) + + (:b (:i (:princ-safe (message-handle message)))) + (if* (not (message-real message)) + then (html " (unverified)")) + ((:font :size 1) + " -- (" + (:princ (message-time message)) + (if* (consp (message-to message)) + then (html " to: " + (:princ-safe (message-to message)))) + ")") + + "  " + (if* (or ownerp + (and (message-real message) + (equal (message-handle message) + handle))) + then (html + ((:a :href + (format nil "chattop?y=~a&~a" + (message-number message) + (or ownerp qstring))) + "Delete"))) + + (if* ownerp + then + (let ((user (and (message-real message) + (user-from-handle + (message-handle message))))) + (if* (and user (null (user-level user))) + then ; can upgrade if desired + (html " " + ((:a :href + (format nil + "chattop?b=~a&~a" + (user-ustring + user) + ownerp)) + " Upgrade "))))) + :newline + :br + (html-print-list (message-body message) + *html-stream*) + :br) + :newline) + else + (html + :newline + ((:table :border 1 :width "100%" :frame "box") + (:tr + ((:td :width "10%") + (:b (:i (:princ-safe (message-handle message)))) + :br + ((:font :size 1) (:princ (message-time message))) + "  " + ) + (:td + (html-print-list (message-body message) + *html-stream*))))))) + + (if* (eql i last-message) then (return))) + + (if* (not recent-first) + then ; tag most recent message + (html ((:div :id "recent"))))) + + (if* (null handle) + then (html :br + ((:table :border 1) + (:tr + (:td + (if* *restrict-messages* + then (html + + "In order to have access to the other facilities of this chat, " + "such as private messaging and viewing the history of messages " + "you must log in, by clicking on the Login link below.") + else (html + + "In order to have access to the other facilities of this chat, " + "such as private messaging " + "you must log in, by clicking on the Login link below.") + )))))) + + )) + + + + +(defun chatlogin (req ent) + ;; response function for /chatlogin?ucstring" + (let ((chat (chat-from-req req))) + (if* chat + then (do-chat-login req ent + (add-secret req + (add-user req + (chat-query-string chat))) + nil) + else (ancient-link-error req ent)))) + + +(defun do-chat-login (req ent qstring failure) + ;; put up a login screen for this chat + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "Login to Chat")) + (:body + (if* failure + then (html (:blink + (:b "Error: " (:princ-safe failure) :br :br)))) + + (:h1 "Login as an existing user") + ((:form :action (format nil "chatlogincurrent?~a" qstring) + :target "_top" + :method "POST") + ((:input :type "text" :size "15" :name "handle")) "Your Handle" :br + ((:input :type "password" :size "15" :name "password")) "Your password" :br + ((:input :type "submit" :name "submit" :value "login"))) + :hr + (:h1 "Create a new account and login") + ((:form :action (format nil "chatloginnew?~a" qstring) + :method "POST") + ((:input :type "text" :size "15" :name "handle")) "Your Handle" :br + ((:input :type "password" :size "15" :name "password")) "Your password" :br + ((:input :type "password" :size "15" :name "password2")) "Type your password again" :br + ((:input :type "submit" :name "submit" :value "New Account"))))))))) + + +(defun chat-login-current (req ent) + ;; handle a post to chatlogincurrent + + ; guard aginst + (if* (not (eq :post (request-method req))) + then (return-from chat-login-current (ancient-link-error req ent))) + + (let ((chat (chat-from-req req)) + (handle (request-query-value "handle" req)) + (password (request-query-value "password" req))) + ; locate the handle + (let ((user (find handle (users *master-controller*) + :key #'user-handle :test #'equalp))) + (if* (null user) + then (return-from chat-login-current + (do-chat-login req ent + (add-secret req + (add-user req + (chat-query-string chat))) + "That user name is unknown"))) + (if* (not (equal password (user-password user))) + then (return-from chat-login-current + (do-chat-login req ent + (add-secret req + (add-user req + (chat-query-string chat))) + "That password is incorrect"))) + + ; worked, do a redirect + (with-http-response (req ent :response *response-moved-permanently*) + (setf (reply-header-slot-value req :location) + (format nil "chat?~a&x=~a" + (add-secret req + (chat-query-string chat)) + (user-ustring user))) + (set-chat-cookie req (user-cookie user)) + (with-http-body (req ent) + (html "redirect")))))) + + + +(defun chatloginnew (req ent) + ;; response function when a new user is being defined + + + (if* (not (eq :post (request-method req))) + then (return-from chatloginnew (ancient-link-error req ent))) + + (let* ((handle (request-query-value "handle" req)) + (password (request-query-value "password" req)) + (password2 (request-query-value "password2" req)) + (chat (chat-from-req req)) + (qstring (and chat (chat-query-string chat)))) + + (if* (null chat) + then (return-from chatloginnew (ancient-link-error req ent))) + + + (if* (equal "" password) + then (return-from chatloginnew + (do-chat-login req ent qstring "No password given"))) + + (if* (not (equal password password2)) + then (return-from chatloginnew + (do-chat-login req ent qstring "Passwords don't match"))) + + (dolist (user (users *master-controller*)) + (if* (equalp (user-handle user) handle) + then (return-from chatloginnew + (do-chat-login req ent qstring "That user name exists")))) + + ; add new user + (let (new-ustring new-pstring new-cookie) + (mp:with-process-lock ((master-lock *master-controller*)) + (loop + (setq new-ustring (make-unique-string)) + (setq new-pstring (make-unique-string)) + (if* (dolist (user (users *master-controller*) t) + (if* (or (equal new-ustring (user-ustring user)) + (equal new-ustring (user-pstring user))) + then ; already in use + (return nil))) + then (return))) + ; leave the loop with new-ustring being unique among users + (push (make-user :handle handle + :password password + :ustring new-ustring + :pstring new-pstring + :cookie (setq new-cookie (make-unique-string))) + (users *master-controller*)) + (dump-existing-chat *chat-home*)) + + ; go to the chat as the user + (with-http-response (req ent :response + *response-moved-permanently*) + (setf (reply-header-slot-value req :location) + (format nil "chat?~a&x=~a" + (add-secret req qstring) new-ustring)) + (set-chat-cookie req new-cookie) + (with-http-body (req ent) + "move to the chat"))))) + + + + + + + + + + + + + + + +(defun html-chk-string-to-lhtml (form) + ;; look for {< to start html and >} to end it. + ;; + (multiple-value-bind (match full first quoted last) + (match-regexp "\$.*\${<\$.*\$>}\$.*\$" form :newlines-special nil) + (declare (ignore full)) + (if* match + then ; contains embedded html + (append (string-to-lhtml first) + (list quoted) + (string-to-lhtml last)) + else (string-to-lhtml form)))) + + + + +(defun string-to-lhtml (form) + ;; convert the string to a list of lhtml forms + ;; + ;; break the text into lines separated by :br's. + ;; look for http://'s in the lines and replace them with + ;; links or inline images + + (let (res (i 0) (start 0) (max (length form))) + (loop + ; we go around one last time when (eq i max) in which + ; case we pretent there's a linefeed at the end + (let ((ch + (if* (>= i max) + then #\linefeed + else (schar form i)))) + + (if* (or (eq ch #\return) (eq ch #\linefeed)) + then ; end of line + (if* (not (eq start i)) + then (let ((line (subseq form start i))) + (loop + (if* (or (null line) + (equal line "")) + then (return)) + (multiple-value-bind (pref link rest) + (scan-for-http line) + (if* link + then (push (de-angle pref) res) + (push link res) + (setq line rest) + else (push (de-angle pref) res) + (setq line nil)))))) + (push :br res) + + (incf i) + (if* (and (eq ch #\return) + ( i max) then (return)))) + (nreverse res))) + + +(defun de-angle (str) + ;; replace < and > in strings by their entity tags + (if* (find #\< str) + then (setq str (replace-regexp str "<" "<"))) + (if* (find #\> str) + then (setq str (replace-regexp str ">" ">"))) + str) + + +(defun scan-for-http (line) + ;; look for http:// in the line and if found return it as + ;; a link or image lhtml + ;; + + (multiple-value-bind (ok whole) + (match-regexp "http://[^ >]+" line :return :index) + (if* ok + then ; found one + (let (http) + (setq http (subseq line (car whole) (cdr whole))) + + (values + ; value 1 -- everything before the http + (subseq line 0 (car whole)) + + ; value 2 - the link + + (do ((i (1- (length http)) (1- i))) + ((< i 0) + ; didn't find a . .. set to a link + `((:a :href ,http :target "_blank") (:princ-safe ,http))) + + (if* (eq (schar http i) #\.) + then ; found a period + (let ((type (subseq http (1+ i)))) + (if* (member type '("gif" "jpg" "png") + :test #'equalp) + then ; an image link + (return + `((:img :src ,http))) + else (setq i 0) ; stop search + )))) + + ; value 3 - the rest of the line + (subseq line (cdr whole)))) + else line))) + + +;; chatmaster page + +(defun chatmaster (req ent) + ;; commands + ;; + (let* ((chat (chat-from-req req)) + (is-owner + (equal (and chat (secret-key chat)) + (request-query-value "s" req))) + (act (request-query-value "act" req))) + (if* (not is-owner) + then (illegal-access req ent) + (return-from chatmaster nil)) + + (if* (equal act "set-msg-count") + then ; set the message count to the given value + (let ((val (compute-integer-value + (request-query-value "val" req)))) + (if* (>= val 0) + then (format t " set msg count to ~d~%" val) + (set-saved-chat-messages chat val))) + elseif (equal act "set-idle") + then (let ((val (compute-integer-value + (request-query-value "val" req)))) + (if* (> val 0) + then (format t " set idle timeout ~d mins~%" val) + (setq *idle-timeout* (* 60 val)))) + elseif (equal act "set-redirects") + then (set-redirects req chat)) + + (if* (equal "yes" (request-query-value "shut" req)) + then ; shutting down the chat + (with-http-response (req ent) + (with-http-body (req ent) + (html (:body (:h1 "Shutdown"))))) + (mp:process-run-function "killer" #'shutdown-chat) + (sleep 10) + (exit 0) + (return-from chatmaster nil)) + + + (multiple-value-bind (total-messages private-messages) + (compute-chat-statistics chat) + + (with-http-response (req ent) + (with-http-body (req ent) + (html (:html + (:head (:title "Chat Master")) + (:body + (:h2 "Statistics") + "There are " (:princ total-messages) + " messages in the chat and " + (:princ private-messages) + " of those are private" + :br + + ((:form :method "POST") + "Reduce the number of stored messages to " + ((:input :type "text" :name "val" :value total-messages + :size 6)) + ((:input :type "hidden" :name "act" :value "set-msg-count")) + ((:input :type "submit" :value "do it"))) + :br + + + + (:h2 "Control") + ((:form :method "POST") + "Idle timeout in minutes: " + ((:input :type "text" + :name "val" + :value (truncate *idle-timeout* 60) + :size 4)) + ((:input :type "hidden" + :name "act" + :value "set-idle")) + ((:input :type "submit" + :value "Set It"))) + :br + + ((:form :method "POST") + ((:input :type "checkbox" + :name "shut" + :value "yes")) + "Shut down the chat " + ((:input :type "submit" + :value "really kill it"))) + :br + + (show-redirects chat) + + ))))) + + ))) + + +(defun show-redirects (chat) + ;; display redirect dialog + (html + (:h2 "Redirects") + + ((:form :method "POST") + ((:input :type "hidden" + :name "act" + :value "set-redirects")) + ((:table :border 1) + + ; show current ones + (dolist (redir (chat-redirects chat)) + (html + :newline + (:tr + (:td + ((:input :type "text" :size 50 + :name (redir-info-name redir) + :value (redirect-info redir))) + :br + "ipaddr: " + ((:input :type "text" :size 50 + :name (redir-ipaddr-name redir) + :value (socket:ipaddr-to-dotted + (redirect-ipaddr redir)))) + ", mask bits: " + ((:input :type "text" :size 4 + :name (redir-maskbits-name redir) + :value (redirect-maskbits redir))) + :br + "to: " + ((:input :type "text" :size 50 + :name (redir-to-name redir) + :value (redirect-to redir))) + + :br + ((:input :type "checkbox" + :if* (redirect-before redir) + :checked "checked" + :name (redir-before-name redir) + :value "xxxx")) + "applies only to people not logged on" + + + :br + ((:input :type "radio" + :name (redir-state-name redir) + :value "active" + :if* (redirect-active redir) :checked "checked")) + "On, " + ((:input :type "radio" + :name (redir-state-name redir) + :value "disabled" + :if* (not (redirect-active redir)) :checked "checked")) + "Disabled, " + ((:input :type "radio" + :name (redir-state-name redir) + :value "disrem")) + + "Disable then remove" + :br + "this rule used " (:princ-safe (redirect-use redir)) " time(s)" + :br + ((:input :type "checkbox" + :name (redir-change-name redir) + :value 0)) + ((:font :color "red") "Make Changes") + )))) + + ; show new one + (html + :newline + (:tr + (:td + "info: " ((:input :type "text" :size 50 :name "newinfo")) + :br + "ipaddr:" ((:input :type "text" :size 50 :name "newipaddr")) + ", mask bits" ((:input :type "text" :size 4 :name "newmask")) + :br + "redirect to: " ((:input :type "text" :size 50 :name "newto")) + :br + ((:input :type "checkbox" + :name "newredirbefore" + :value 0)) + "applies only to people not logged on" + :br + ((:input :type "checkbox" :name "newdo" :value "1")) + ((:font :color "red") "Add this entry"))))) + + ((:input :type "submit" :value "Change Redirects"))))) + + +(defun set-redirects (req chat) + ;; change the redirect information for this chat + + (let (changed) + (dolist (redir (chat-redirects chat)) + (if* (request-query-value (redir-change-name redir) req) + then ; something changed in here + (set-redir-info chat + redir + req + (redir-info-name redir) + (redir-ipaddr-name redir) + (redir-maskbits-name redir) + (redir-to-name redir) + (redir-before-name redir) + (redir-state-name redir)) + (setq changed t))) + (if* (request-query-value "newdo" req) + then ; add a new entry + (let ((redir (make-redirect))) + (setf (redirect-index redir) + (incf (redirect-counter chat))) + (set-redir-info chat + redir + req + "newinfo" + "newipaddr" + "newmask" + "newto" + "newredirbefore" + "newxxxxxx") + (setf (redirect-active redir) t) + + (setf (chat-redirects chat) + (append (chat-redirects chat) (list redir))) + + (setq changed t) + + )) + + (if* changed then (dump-existing-chat *chat-home*)))) + + + +(defun set-redir-info (chat redir req ninfo nipaddr nmask nto nbefore nstate) + (setf (redirect-info redir) (request-query-value ninfo req)) + (let ((ipaddr (or + (ignore-errors (socket:lookup-hostname + (request-query-value nipaddr req))) + 0))) + (setf (redirect-ipaddr redir) ipaddr)) + + (let ((maskbits (or (compute-integer-value + (request-query-value nmask req)) + 32))) + (setf (redirect-maskbits redir) maskbits) + (setf (redirect-mask redir) + (logand #xffffffff (ash -1 (- 32 maskbits)))) + ) + + (setf (redirect-to redir) (request-query-value nto req)) + (setf (redirect-before redir) (request-query-value nbefore req)) + + (let ((state (request-query-value nstate req))) + (if* (equal state "active") + then (setf (redirect-active redir) t) + elseif (equal state "disabled") + then (setf (redirect-active redir) nil) + elseif (equal state "disrem") + then ; eliminate + (setf (chat-redirects chat) + (delete redir (chat-redirects chat)))))) + + + + + + + + + + +;; generate temp names for form objects + +(defun redir-info-name (redir) + (format nil "~a-info" (redirect-index redir))) + +(defun redir-ipaddr-name (redir) + (format nil "~a-ipaddr" (redirect-index redir))) + +(defun redir-maskbits-name (redir) + (format nil "~a-maskbits" (redirect-index redir))) + +(defun redir-before-name (redir) + (format nil "~a-before" (redirect-index redir))) + +(defun redir-to-name (redir) + (format nil "~a-to" (redirect-index redir))) + +(defun redir-change-name (redir) + (format nil "~a-change" (redirect-index redir))) + +(defun redir-state-name (redir) + (format nil "~a-state" (redirect-index redir))) + + + + + +;; Chat archiver +;; +;; The chat archiver stores chat info to files + +(let (last-master-controller) +(defun start-chat-archiver (master-controller) + (and t (if* (not (eq master-controller last-master-controller)) + then ; we've already started the process + (setq last-master-controller master-controller) + (mp:process-run-function "chat archiver" + #'chat-archiver master-controller))))) + +(defun chat-archiver (master-controller) + (let ((sleep-time 30) + (did-work)) + (loop + (if* (not (eq *master-controller* master-controller)) + then ; chat has been restarted, let this process die + (return)) + + (format t "Chat archiver awoken~%") + (setq did-work nil) + + ; write out the data + (dolist (controller (controllers master-controller)) + (dolist (chat (chats controller)) + (mp:with-process-lock ((chat-message-lock chat)) + (format t " arch ~d num ~d~%" + (chat-message-archive chat) + (chat-message-number chat)) + (if* (or (< (chat-message-archive chat) + (chat-message-number chat)) + (chat-messages-deleted chat)) + then ; must do work + (archive-chat chat) + (setq did-work t))))) + + ; adjust archive time so that we sleep longer when + ; the chat is inactive. + (if* did-work + then (setq sleep-time 30) + else (setq sleep-time (min (+ sleep-time 30) + (* 30 60) ; 30 minutes + ))) + + (format t "Chat archiver going to sleep~%") + (sleep sleep-time)))) + + + +(defun find-index-of-message (chat number) + ;; find index of message 'number' or the first one after that + (let ((messages (chat-messages chat)) + (message-next (chat-message-next chat))) + (do ((i (1- message-next) (1- i))) + ((< i 0) 0) + (let* ((message (svref messages i)) + (num (message-number message))) + (if* (and num + (< num number)) + then (return (1+ i)) + elseif (eql num number) + then (return i)))))) + +(defun archive-chat (chat) + ;; write out new messages for this chat + ;; we are inside a process lock for this chat's message lock + ;; so we can alter the fields at will + (let ((messages (chat-messages chat)) + (message-next (chat-message-next chat)) + (message-archive (chat-message-archive chat))) + + ; we have to find the location of the + ; message-archive message + (if* (> message-next 0) + then ; it better be greater than 0 since to be zero + ; would be no messages stored + + ; locate the message numbered message-archive + (let ((start-to-save + (find-index-of-message chat message-archive))) + + (with-open-file (archive-port (archive-filename chat) + :direction :output + :if-exists :append + :if-does-not-exist :create + ;:external-foramt :utf-8 + ) + (do ((i start-to-save (1+ i))) + ((>= i message-next)) + (if* (eq t (message-to (svref messages i))) + then ; a public message, archive it + (pprint (svref messages i) archive-port)) + ) + (if* (chat-messages-deleted chat) + then (pprint `(:delete ,@(chat-messages-deleted chat)) + archive-port) + (setf (chat-messages-deleted chat) nil))) + + (setf (chat-message-archive chat) + (1+ (message-number (svref messages (1- message-next))))))))) + +(defun archive-filename (chat) + (format nil "~a/~a" *chat-home* (chat-filename chat))) + + + +(defmethod set-style ((style color-style)) + (setq *top-frame-bgcolor* (color-style-bgcolor style) + *top-frame-font-color* (color-style-font-color style) + *public-font-color* (color-style-font-color style) + *top-frame-vlink-color* (color-style-vlink-color style) + *top-frame-link-color* (color-style-link-color style) + *top-frame-alink-color* (color-style-alink-color style))) + +(if* (not (boundp '*top-frame-bgcolor*)) + then (set-style *normal-style*)) + +;; for franz chats uncomment this since some people like this style better +;(set-style *white-style*) +;(setq *quick-return-path* "/xyzzy") +;-------- + +(defun chat-transcript (uc-string filename) + ;; generate a transcript of the chat with the given uc-string + ;; to the given filename + ; + ; find chat + (let* ((query-alist (form-urlencoded-to-query uc-string)) + (u (cdr (assoc "u" query-alist :test #'equalp))) + (c (cdr (assoc "c" query-alist :test #'equalp)))) + + (let ((chat + (dolist (controller (controllers *master-controller*)) + (if* (equal u (ustring controller)) + then (return + (dolist (chat (chats controller)) + (if* (equal c (ustring chat)) + then (return chat)))))))) + (if* (null chat) + then (error "can't find chat with uc-string ~s" uc-string)) + + (with-open-file (*html-stream* filename :direction :output + :if-exists :supersede + ;:external-format :utf-8 + ) + (html + (:head + (:title "Transcript of " + (:princ-safe (chat-name chat)))) + (:body + (:h1 "Transcript of " + (:princ-safe (chat-name chat))) + (show-chat-info chat (chat-message-next chat) nil nil nil nil))))))) + + + +;; viewer tracking + +(defun track-viewer (chat user req) + ;; note that this user/req has read the postings for this chat + (let* ((time (get-universal-time)) + (viewers (chat-viewers chat)) + (ipaddr (socket:remote-host (request-socket req))) + (empty-ent)) + + + (mp::with-process-lock ((viewers-lock viewers)) + + ;; scan list of viewers. + ;; set emptyent to the first viewent with a null time, thus meaning + ;; it's a free entry + ;; if an entry already exists for this user or ipaddr use it + (dolist (viewent (viewers-list viewers) + ; not there yet + (if* empty-ent + then ; replace old one + (setf (viewent-time empty-ent) time + (viewent-user empty-ent) user + (viewent-ipaddr empty-ent) ipaddr + (viewent-hostname empty-ent) nil) + else + (push (setq empty-ent + (make-viewent :time time + :user user + :ipaddr ipaddr)) + (viewers-list viewers)) + )) + (if* user + then (if* (eq user (viewent-user viewent)) + then ; update this one + (setf (viewent-time viewent) time) + (if* (not (eql ipaddr (viewent-ipaddr viewent))) + then ; hmm, changed ipaddr + (setf (viewent-ipaddr viewent) ipaddr + (viewent-hostname viewent) nil)) + (return)) + else ; ipaddr test + (if* (and (null (viewent-user viewent)) + (eql ipaddr (viewent-ipaddr viewent))) + then (setf (viewent-time viewent) time) + (return))) + (if* (null (viewent-time viewent)) + then (if* (null empty-ent) + then (setf empty-ent viewent)) + elseif (> (- time (viewent-time viewent)) *max-active-time*) + then ; this one is too old + (setf (viewent-time viewent) nil) + (if* (null empty-ent) + then (setq empty-ent viewent))))))) + +(defun chatviewers (req ent) + ;; display page of chat viewers (except us) + (let* ((chat (chat-from-req req)) + (user (user-from-req req)) + (time (get-universal-time)) + (is-owner + (equal (and chat (secret-key chat)) + (request-query-value "s" req))) + (qstring) + (viewers) + (idletime) + ) + (if* (null chat) + then (return-from chatviewers (ancient-link-error req ent))) + + (if* (and user (zerop (user-time user))) + then (setf (user-time user) (get-universal-time))) + + (if* (> (setq idletime (- (get-universal-time) (user-time user))) + (+ 10 *idle-timeout*)) + then (do-idle-timedout req ent nil) + (return-from chatviewers)) + (setq qstring + (add-secret req + (add-user req + (chat-query-string chat)))) + (setq viewers (chat-viewers chat)) + + (setq idletime (truncate idletime 60)) ; cvt to minutes + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + ((:meta :http-equiv "Refresh" + :content + (format nil "30;url=chatviewers?~a" qstring))) + (:body + + ((:font :size 2) + ((:a :href (concatenate 'string + "chatenter?pp=*&" qstring) + :target "chatenter" + ) + "Send to All") + :hr + :newline + (:pre + (mp::with-process-lock ((viewers-lock viewers)) + (dolist (viewent (viewers-list viewers)) + (let* ((vtime (viewent-time viewent)) + (vuser (viewent-user viewent)) + (alive-time (if* vtime then (- time vtime))) + (idle-time (if* vuser + then (- time (or (user-time vuser) 0)) + else 0))) + + + (if* (and alive-time + (> alive-time *max-active-time*)) + then (setq vtime nil) + (setf (viewent-time viewent) nil)) + + ; cvt to minutes + (setq idle-time (min 120 (truncate idle-time 60))) + + (if* vtime + then ; fill in the hostname if it's not there yet + #+(and allegro (version>= 6 0)) + (if* (null (viewent-hostname viewent)) + then (setf (viewent-hostname + viewent) + (socket::dns-query + (viewent-ipaddr viewent) + :type :ptr + :repeat 1 + :timeout 0))) + + (if* (not (eq vuser user)) + then ; list this one + (if* vuser + then + (html + ; link to add a user + ((:a :href + (format nil + "chatenter?ppp=~a&~a" + (user-pstring vuser) + qstring) + :target "chatenter") + "(+)") + + " " + + + ; link to create a private message + ((:a :href + (format nil + "chatenter?pp=~a&~a" + (user-pstring vuser) + qstring) + :target "chatenter" + ) + (:princ-safe + (user-handle vuser)))) + + else ; ip address + + (html + (:princ + (or (viewent-hostname viewent) + (socket:ipaddr-to-dotted + (viewent-ipaddr viewent)))))) + (html + " (" + (:princ (- time vtime)) + "s)") + + (if* (> idle-time 2) + then (html + " [idle: " + (:princ idle-time) + "m] ")) + + (if* (or *show-machine-name-to-all* + is-owner) + then ; name then ip address + (html + " @" + (:princ-safe + (or (viewent-hostname viewent) + (socket:ipaddr-to-dotted + (viewent-ipaddr viewent)))))) + (html :newline))))))))))))))) + + + + +(defun chattranscript (req ent) + (let* ((chat (or (chat-from-req req) + (return-from chattranscript (ancient-link-error req ent)))) + (title (format nil "full transcript of chat ~a as of ~a" + (chat-name chat) (compute-chat-date + (get-universal-time))))) + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:title (:princ-safe title)) + (:body + (:h1 (:princ-safe title)) + (let ((*top-frame-bgcolor* "#xffffff") ; white + (*public-font-color* "#x000000") ; black + ) + (show-chat-info chat (chat-message-next chat) nil + "bogushandle" nil nil)) + ))))))) + +(defun redir-check (req ent chat before) + ;; check if this request should be redirected + ;; before is true if we are in the before login state + (let ((redirects (chat-redirects chat))) + (if* redirects + then (let ((ipaddr (socket:remote-host (request-socket req)))) + (dolist (redir redirects) + (if* (and (redirect-active redir) + (eq before (redirect-before redir)) + (eql (logand (redirect-ipaddr redir) + (redirect-mask redir)) + (logand ipaddr + (redirect-mask redir)))) + then ; a match! + (incf (redirect-use redir)) + (with-http-response (req ent + :response + *response-moved-permanently*) + (setf (reply-header-slot-value req :location) + (redirect-to redir)) + (with-http-body (req ent) + (html "redirect"))) + (return t))))))) + + + + + + + + + + + + +;;;;; chat test code +;; +;; + +(defun block-test (testers &rest args) + (dotimes (i testers) + (let ((name (format nil "tester-~d" i)) + (delay (max 1 (random 10)))) + + (mp:process-run-function name + #'(lambda () + (apply #'test-chat + :name name + :delay delay + args)))))) + + + + + + + + +(defun test-chat (&key uc-string + (count 100) + (reads 5) + (delay 2) + (name "dummy1") + (machine "localhost") + (port 8000) + (protocol :http/1.1)) + (let ((reader-url + (format nil "http://~a:~d/chattop?~a&~a" + machine + port + uc-string + (query-to-form-urlencoded + `(("count" . 10) + ("secs" . 5))))) + (post-url + (format nil "http://~a:~d/chatenter?~a" + machine + port + uc-string))) + + (dotimes (i count) + ; post first + (let ((message (format nil "message ~d from ~a~%" i name))) + (do-http-request post-url + :protocol protocol + :method :post + :query `(("secs" . 5) ; not used + ("handle" . ,name) + ("body" . ,message))) + (sleep delay) + (dotimes (i reads) + ; read it now + (do-http-request reader-url + :method :get + :protocol protocol) + (sleep delay)))))) + + +;;; fix up old chats + +(defun fixupchat () + (setf (users *master-controller*) (nreverse (users *master-controller*))) + (dolist (user (users *master-controller*)) + (setf (user-ustring user) (make-unique-string)) + (setf (user-pstring user) (make-unique-string))) + (dump-existing-chat *chat-home*) + ) + + + Added: vendor/portableaserve/aserve/examples/examples.cl =================================================================== --- vendor/portableaserve/aserve/examples/examples.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/examples.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1240 @@ +;; -*- mode: common-lisp; package: net.aserve.examples -*- +;; +;; examples.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: examples.cl,v 1.7 2004/01/27 10:53:44 rudi Exp $ + +;; Description: +;; Allegro iServe examples + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + +;; examples of web pages +(defpackage #:net.aserve.examples ;; aserve example + (:use #:common-lisp #:acl-compat.excl #:net.html.generator #:net.aserve)) + +(in-package #:net.aserve.examples) + +;; don't flush all publishing done so far. since we have other +;; example files this is bad news. +; (unpublish :all t) + +(defparameter *example-pathname* *load-pathname*) ; where this file is +(defmacro example-file (name) + ;; create an absolute address for this file we'll load + `(merge-pathnames ,name *example-pathname*)) + +(defvar *hit-counter* 0) + + +(publish :path "/" + :content-type "text/html" + :function + #'(lambda (req ent) + ;(print (net.aserve::compute-request-headers req)) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:head (:title "Welcome to Portable AllegroServe on " + (:princ (lisp-implementation-type)))) + (:body (:center ((:img :src "aservelogo.gif"))) + (:h1 "Welcome to Portable AllegroServe on " + (:princ (lisp-implementation-type))) + (:p "These links show off some of AllegroServe's capabilities. ") + (:i "This server's host name is " + (:princ-safe (header-slot-value req :host))) + #+unix + (:i ", the process id is " + (:princ (net.aserve::getpid))) + :br + (:princ (incf *hit-counter*)) " hits" + :p + (:b "Sample pages") :br + #+allegro + ((:a :href "gc") "Garbage Collector Stats") :br + ((:a :href "apropos") "Apropos") + :br + ((:a :href "pic") "Sample jpeg") :br + ((:a :href "pic-redirect") "Redirect to previous picture") :br + ((:a :href "pic-gen") "generated jpeg") "- hit reload to switch images" :br + ((:a :href "pic-multi") "test of publish-multi") " - click more than once on this link" :br + ((:a :href "cookietest") "test cookies") :br + ((:a :href "secret") "Test manual authorization") + " (name: " (:b "foo") ", password: " (:b "bar") ")" + :br + ((:a :href "secret-auth") "Test automatic authorization") + " (name: " + (:b "foo2") + " password: " + (:b "bar2") ")" + :br + ((:a :href "local-secret") "Test source based authorization") " This will only work if you can use " + "http:://localhost ... to reach this page" + :br + ((:a :href "local-secret-auth") + "Like the preceding but uses authorizer objects") + :br + ((:a :href "timeout") "Test timeout") + " this will take a while to time out." + :br + ((:a :href "getfile-old") "Client to server file transfer") " - the old way" + :br + ((:a :href "getfile") "Client to server file transfer") " - the new way, with 1,000,000 byte file transfer limit" + :br + ((:a :href "missing-link") "Missing Link") + " should get an error when clicked" + + :br + #+unix + (html + ((:a :href "long-slow") "long, slow, cpu-bound") + " action to demonstrate how AllegroServe " + "in multiple Unix process mode can be responsive" + " even if one AllegroServe process is wedged." + " You probably do " + (:b "not") + " want to click on this link if you are running" + " AllegroServe is its normal single Unix process" + " mode.") + + + :br + ;; run only in an international lisp. + ;; test at runtime since we may switch back + ;; and forth between international and 8 bit + ;; modes + (if* (member :ics *features* :test #'eq) + then (html + :br + ((:a :href "ichars") + "International Character Display") + + :br + ((:a :href "icharcount") + "(International) Character Counter") + :br + ;; published in puzzle.cl + ((:a :href "wordpuzzle") + "Word Puzzle") + :br + ;; published in urian.cl + ((:a :href "urian") + "International Web Page Character Finder") + :br + ;; published in locale.cl + ((:a :href "locale") + "Locale Demo") + :br + )) + + #+(and unix (or (and allegro (version>= 6 1)) mcl)) + (html + "cgi tests: " + ((:a :href "cgi0") "show environment") + ", " + ((:a :href "cgi1") "handle unix-style headers") + ", " + ((:a :href "cgi2") "redirect") + ", " + ((:a :href "cgi3") "set status to unauthorized request")) + :hr + ((:img :src "aservepowered.gif")) " <-- feel free to use this image on your AllegroServe-based web site" + )))))) + + + +;; a very simple page. This is so simple it doesn't put out the required +;; tags (like <html>) yet I suspect that most browsers will display it +;; correctly regardless. +(publish :path "/hello" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "Hello World!"))))) + +;; this is the "/hello" example above modified to put out the correct +;; html tags around the page. +(publish :path "/hello2" + :content-type "text/html" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:body "Hello World!"))))))) + +;; display the current gc statistics. +#+allegro +(publish :path "/gc" + :content-type "text/html" + :function + #'(lambda (req ent) + (macrolet ((build-gsgc-table () + `(html + ,@(mapcar + #'(lambda (kind) + `(:tr (:td (:princ ,kind)) + (:td (:princ-safe + (sys:gsgc-parameter ,kind))))) + '(:generation-spread + :current-generation + :tenure-limit + :free-bytes-new-other + :free-percent-new + :free-bytes-new-pages + :expansion-free-percent-new + :expansion-free-percent-old + :quantum + ))))) + + + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Allegro gc parameters")) + (:body + ((:table :bgcolor "silver" :bordercolor "blue" + :border "3" :cellpadding "3" + :cellspacing "3") + (:tr (:td (:b "gsgc parameter")) (:td (:b "Value"))) + (build-gsgc-table))))))))) + + + +;; display a picture from a file. +(publish-file :path "/pic" :file (example-file "prfile9.jpg") + :content-type "image/jpeg") + + + +(publish-file :path "/aservelogo.gif" :file (example-file "aservelogo.gif") + :content-type "image/gif") + +(publish-file :path "/aservepowered.gif" :file (example-file "aservepowered.gif") + :content-type "image/gif") + +;; this is a demonstration of how you can return a jpeg +;; image that was created on the fly (rather than read from +;; a file via publish-file). +;; We don't want to actually create the image here, so we +;; cheat and read it from a file, but it shows that you can +;; send any stream of bytes and they will be given the correct +;; mime type. +;; +(publish :path "/pic-gen" + :content-type "image/jpeg" + :function + (let ((selector 0)) ; chose one of two pictures + #'(lambda (req ent) + (with-http-response (req ent :format :binary) + (with-http-body (req ent) + ; here is where you would generate the picture. + ; we're just reading it from a file in this example + (let ((stream (request-reply-stream req))) + (with-open-file (p (nth selector + `(,(example-file "prfile9.jpg") + ,(example-file "fresh.jpg"))) + :element-type '(unsigned-byte 8)) + + (setq selector (mod (1+ selector) 2)) + + (loop + (let ((val (read-byte p nil nil))) + (if* (null val) + then ;eof + (return)) + (write-byte val stream) + ))))))))) + + + +;; do a redirect to the picture + +(publish :path "/pic-redirect" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent + :response *response-moved-permanently*) + (setf (reply-header-slot-value req :location) "pic") + (with-http-body (req ent) + ;; this is optional and most likely unnecessary since most + ;; browsers understand the redirect response + (html + (:html + (:head (:title "Object Moved")) + (:body + (:h1 "Object Moved") + "The picture you're looking for is now at " + ((:a :href "pic") "This location")))))))) + + + +;; this publish-multi example is simple but really doesn't show +;; the full power of publish-multi. +;; It doesn't show that we can include the contents of files +;; The :function case doesn't make use of the old cached value to +;; decide if it wants to return the old value or create a new one. +(publish-multi :path "/pic-multi" + :content-type "text/html" + :items (list + '(:string "<html><body>The first line is constant ") + (let (last-clicked) + #'(lambda (req ent old-time cached-value) + (declare (ignore req ent old-time cached-value)) + (if* (null last-clicked) + then (setq last-clicked + (get-universal-time)) + "this is your first click " + else (let* ((new (get-universal-time)) + (diff (- new last-clicked))) + (setq last-clicked new) + (format nil "~d seconds since the last click " diff))))) + '(:string "The last line is constant</body></html>"))) + + + + + + + + + +;; +;; here's a form using the 'post' method +;; +(publish :path "/tform" + :content-type "text/html" + :function + (let ((name "unknown")) + #'(lambda (req ent) + (let ((body (get-request-body req))) + (format t "got body ~s~%" body) + (let ((gotname (assoc "username" + (form-urlencoded-to-query body) + :test #'equal))) + (if* gotname + then (setq name (cdr gotname))))) + + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "test form")) + (:body "Hello " (:princ-safe name) ", " + "Enter your name: " + ((:form :action "/tform" + :method "post") + ((:input :type "text" + :maxlength 10 + :size 10 + :name "username")))))))))) + + + + +;; example of a form that uses that 'get' method +;; +(publish + :path "/apropos" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((lookup (assoc "symbol" (request-query req) :test #'equal))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Allegro Apropos")) + ((:body :background "aserveweb/fresh.jpg") + "New Apropos of " + ((:form :action "apropos" + :method "get") + ((:input :type "text" + :maxlength 40 + :size 20 + :name "symbol"))) + #+allegro + " The apropos function in ACL is case sensitive." + :p + + (if* lookup + then (html :hr (:b "Apropos") " of " + (:princ-safe (cdr lookup)) + :br + :br) + (let ((ans (apropos-list (cdr lookup)))) + (if* (null ans) + then (html "No Match Found") + else (macrolet ((my-td (str) + `(html ((:td + :bgcolor "blue") + ((:font :color "white" + :size "+1") + (:b ,str)))))) + + (html ((:table + :bgcolor "silver" + :bordercolor "blue" + :border 3 + :cellpadding 3 + ) + + (:tr + (my-td "Symbol") + (my-td "boundp") + (my-td "fboundp")) + + + (dolist (val ans) + (html (:tr + (:td (:prin1-safe val)) + (:td (:prin1 (and (boundp val) t))) + (:td (:prin1 (and (fboundp val) t)))) + :newline))))))) + else (html "Enter name and type enter"))) + :newline)))))) + + +;; a preloaded picture file +(publish-file :path "/aserveweb/fresh.jpg" + :file (example-file "fresh.jpg") + :content-type "image/jpeg" + :preload t) + +;; a preloaded text file +(publish-file :path "/foo" + :file (example-file "foo.txt") + :content-type "text/plain" + :preload t) + +(publish-file :path "/foo.txt" + :file (example-file "foo.txt") + :content-type "text/plain" + :preload nil) + + +;; some entries for benchmarking +(publish-file :path "/file2000" + :file (example-file "file2000.txt") + :content-type "text/plain" + :preload nil) + +(publish-file :path "/file2000-preload" + :file (example-file "file2000.txt") + :content-type "text/plain" + :preload t) + +(publish :path "/dynamic-page" + :content-type "text/plain" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "This is a dynamic page"))))) + +;; an example which causes the web browser to put up the +;; name/password box and if you enter the name "foo" and password "bar" +;; then you get access to the secret info. +(publish :path "/secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (multiple-value-bind (name password) (get-basic-authorization req) + (if* (and (equal name "foo") (equal password "bar")) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))) + else + (with-http-response (req ent :response + *response-unauthorized*) + (set-basic-authorization req + "secretserver") + (with-http-body (req ent) + (html (:h1 "You Failed") + "You failed to enter the correct name/password") + )))))) + + +(publish :path "/local-secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((net-address (ash (socket:remote-host + (request-socket req)) + -24))) + (if* (equal net-address 127) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You are on the local network")))) + else + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html (:head (:title "Unauthorized")) + (:body + "You cannot access this page " + "from your location"))))))))) + + +(publish :path "/local-secret-auth" + :content-type "text/html" + :authorizer (make-instance 'location-authorizer + :patterns '((:accept "127.0" 8) + :deny)) + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You made it to the secret page")))))) + +;; these two urls show how to transfer a user-selected file from +;; the client browser to the server. +;; +;; We use two urls (/getfile to put up the form and /getfile-post to +;; handle the post action of the form). We could have done it all +;; with one url but since there's a lot of code it helps in the +;; presentation to separate the two. +;; +(publish :path "/getfile-old" + :content-type "text/html; charset=utf-8" + :function #'(lambda (req ent) (getfile-function + req ent "/getfile-got-old"))) + +(publish :path "/getfile" + :content-type "text/html; charset=utf-8" + :function #'(lambda (req ent) (getfile-function + req ent "/getfile-got"))) + + +(defun getfile-function (req ent posturl) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head "get file") + (:body + ((:form :enctype "multipart/form-data" + :method "post" + :action posturl) + "Let me know what file to grab" + :br + ((:input :type "file" + :name "thefile" + :value "*.txt")) + :br + ((:input :type "text" :name "textthing")) + "Enter some text" + :br + ((:input :type "checkbox" :name "checkone")) + "check box one" + :br + ((:input :type "checkbox" :name "checktwo")) + "check box two" + :br + ((:input :type "submit")))))))) + + +(publish :path "/secret-auth" + :content-type "text/html" + :authorizer (make-instance 'password-authorizer + :allowed '(("foo2" . "bar2") + ("foo3" . "bar3") + ) + :realm "SecretAuth") + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))))) + + + +;; +;; this demonstrates the use of the low level multipart access functions. +;; In this code we parse the result of get-multipart-header ourselves +;; and we use get-multipart-sequence. +;; In the example that follows (associate with path "/getfile-got") +;; we show now to use the higher level functions to retrive multipart +;; data +(publish :path "/getfile-got-old" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + + (with-http-response (req ent) + (let ((h nil) + (files-written) + (text-strings) + ) + (loop + ; get headers for the next item + (if* (null (setq h (get-multipart-header req))) + then ; no more items + (return)) + ; we can get the filename from the header if + ; it was an <input type="file"> item. If there is + ; no filename, we just create one. + (pprint h) + (pprint (multiple-value-list (parse-multipart-header h))) + (let ((cd (assoc :content-disposition h :test #'eq)) + (filename) + (sep)) + (if* (and cd (consp (cadr cd))) + then (setq filename (cdr (assoc "filename" + (cddr (cadr cd)) + :test #'equalp))) + (if* filename + then ;; locate the part of the filename + ;; after the last directory separator. + ;; the common lisp pathname functions are + ;; no help since the filename syntax + ;; may be foreign to the OS on which + ;; the server is running. + (setq sep + (max (or (position #\/ filename + :from-end t) -1) + (or (position #\\ filename + :from-end t) -1))) + (setq filename + (subseq filename (1+ sep) + (length filename))))) + (if* (and filename (not (equal filename ""))) + then (push filename files-written) + (with-open-file (pp filename :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (format t "writing file ~s~%" filename) + (let ((buffer (make-array 4096 + :element-type + '(unsigned-byte 8)))) + + (loop (let ((count (get-multipart-sequence + req + buffer))) + (if* (null count) then (return)) + (write-sequence buffer pp :end count))))) + elseif (null filename) + then ; no filename, just grab as a text + ; string + (let ((buffer (make-string 1024))) + (loop + (let ((count (get-multipart-sequence + req buffer + :external-format :utf8-base))) + (if* count + then (push (subseq buffer 0 count) + text-strings) + else (return)))))))) + + + + ;; now send back a response for the browser + + (with-http-body (req ent + :external-format :utf8-base) + (html (:html (:head (:title "form example")) + (:body "-- processed the form, files written --" + (dolist (file (nreverse files-written)) + (html :br "file: " + (:b (:prin1-safe file)))) + :br + "-- Non-file items Returned: -- " :br + (dolist (ts (reverse text-strings)) + (html (:princ-safe ts) :br)))))))))) + + +;; +;; this retrieves data from a multipart form using the high level +;; functions. You can compare this code to that above to see which +;; method you prefer +;; +(publish :path "/getfile-got" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (let ((files-written) + (text-strings) + (overlimit) + ) + (loop + (multiple-value-bind (kind name filename content-type) + (parse-multipart-header + (get-multipart-header req)) + + (case kind + (:eof (return)) ; no more to read + (:data + (push (cons name (get-all-multipart-data req)) + text-strings)) + (:file + (let ((contents (get-all-multipart-data + req + :type :binary + :limit 1000000 ; abitrary limit + ))) + ; find the tail of the filename, can't use + ; lisp pathname code since the filename syntax + ; may not correspond to this lisp's native os + (let ((sep (max (or (position #\/ filename + :from-end t) -1) + (or (position #\\ filename + :from-end t) -1)))) + (if* sep + then (setq filename + (subseq filename (1+ sep))))) + (if* (eq contents :limit) + then ; tried to give us too much + (setq overlimit t) + elseif (equal filename "") ; no file given + thenret ; ignore + else + (with-open-file (p filename + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (format + t "writing file ~s, content-type ~s~%" + filename content-type) + (push filename files-written) + (write-sequence contents p))))) + (t ; all else ignore but read to next header + (get-all-multipart-data req :limit 1000))))) + + + + + ;; now send back a response for the browser + + (with-http-body (req ent + :external-format :utf8-base) + (html (:html (:head (:title "form example")) + (:body "-- processed the form, files written --" + (dolist (file (nreverse files-written)) + (html :br "file: " + (:b (:prin1-safe file)))) + (if* overlimit + then (html :br + "File given was over our " + "limit in the size we " + "will accept")) + :br + "-- Non-file items Returned: -- " :br + (dolist (ts (reverse text-strings)) + (html + "item name: " (:princ-safe (car ts)) + ", item value: " + (:princ-safe (cdr ts)) + :br)))))))))) + + + +(publish :path "/cookietest" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (set-cookie-header req + :name "froba" + :value "vala" + :path "/" + :expires :never) + (set-cookie-header req + :name "frob2" + :value "val2" + :path "/" + :expires :never) + (set-cookie-header req + :name "frob3-loooooooooooooong" + :value "val3-loooooooooooooong" + :path "/" + :expires :never) + (set-cookie-header req + :name "the time" + :value (net.aserve::universal-time-to-date + (get-universal-time)) + :path "/cookieverify" + :expires (+ (get-universal-time) + (* 20 60) ; 20 mins + ) + ) + + (with-http-body (req ent) + (html (:head (:title "Cookie Test")) + (:body "you should have a cookie now." + " Go " + ((:a :href "cookieverify") "here") + " to see if they were saved")))))) + +(publish :path "/cookieverify" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((cookie-info (get-cookie-values req))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Cookie results")) + (:body + "The following cookies were returned: " + (:prin1-safe cookie-info)))))))) + + + +(publish :path "/timeout" + :content-type "text/html" + :function + #'(lambda (req ent) + ;; do nothing interesting so that the timeout will + ;; occur + (with-http-response (req ent :timeout 15) + (loop (sleep 5))))) + + + +(publish :path "/long-slow" + :content-type "text/plain" + :function + #'(lambda (req ent) + ;; chew up cpu time in a look that blocks + ;; the scheduler from running so this aserve + ;; won't accept any more connections and we can + ;; demo the multiple process version + ; takes 50 secs on a 1.2ghz Athlon + (locally (declare (optimize (speed 3) (safety 0))) + (dotimes (aa 500) + (declare (fixnum aa)) + (dotimes (j 300) + (declare (fixnum j)) + (dotimes (i 10000) + (declare (fixnum i)) + (let ((k (+ i j))) + (declare (fixnum k)) + (setf k (- i j)) + (setf k (+ i j k)) + (setf k (- i j k))))))) + + + (with-http-response (req ent) + (with-http-body (req ent) + (html "done"))))) + + + +;; cgi publishing, we publish a shell script that only works +;; on Unix shells: +#+unix +(publish :path "/cgi0" :function + #'(lambda (req ent) + (net.aserve::run-cgi-program req ent + "aserve/examples/cgitest.sh" + :env '(("HTTP_CONNECTION" + . "hack replaced value") + ("NewHead" . "NewVal"))))) + +#+unix +(publish :path "/cgi1" :function + #'(lambda (req ent) + (net.aserve::run-cgi-program req ent "aserve/examples/cgitest.sh 1"))) + +#+unix +(publish :path "/cgi2" :function + #'(lambda (req ent) + (net.aserve::run-cgi-program req ent "aserve/examples/cgitest.sh 2"))) + +#+unix +(publish :path "/cgi3" :function + #'(lambda (req ent) + (net.aserve::run-cgi-program req ent "aserve/examples/cgitest.sh 3"))) + + +;;;;;; directory publishing. These will only work on a particular +;; set of machines so you'll have to modify them to point to an +;; existing tree of pages on your machine if you want to see this work. + +;; the franz home page +#+ignore (publish-directory :prefix "/" + :destination "/net/tanya/home/httpd/html/" + ) + +#+ignore +(publish-directory :prefix "/int" + :destination "/net/tanya/www/internal/htdocs/") + + + + +;; a separate world: + +(defparameter *server2* (make-instance 'wserver)) + +(publish-directory :server *server2* + :prefix "/" + :destination "/home/httpd/html/") + +;; +;; International Characters +;; + +(publish + :path "/icharcount" + :content-type "text/html; charset=utf-8" + :function + + #-(and allegro ics (version>= 6 0)) + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (princ #.(format nil "~ +This page available only with International Allegro CL post 6.0 beta") + *html-stream*)))) + + #+(and allegro ics (version>= 6 0)) + #'(lambda (req ent) + (let* ((body (get-request-body req)) + (text (if* body + then (cdr (assoc "quotation" + (form-urlencoded-to-query + body + :external-format :utf8-base) + :test #'equal))))) + + (with-http-response (req ent) + (with-http-body (req ent + :external-format :utf8-base) + (if* text + then ;; got the quotation, analyze it + (let ((results (analyze-text text))) + (html (:html (:head + (:title "Character Counts")) + (:body + (html (:pre (:princ-safe text))) + (:p "Quote by Character Names:") + (:table + (dotimes (i (length text)) + (html (:tr + (:td (:princ (schar text i))) + (:td (:prin1 (schar text i))))))) + (:p "Sorted by occurrence:") + ((:table :border 1) + (dolist (r results) + (html (:tr + (:td + (:princ + (format nil "u+~4,'0x" + (char-code (car r))))) + (:td (:princ (car r))) + (:td (:prin1 (car r))) + (:td (:princ (cdr r))))))))))) + else ;; ask for quotation + (html (:html + (:head (:title "Character Counter")) + (:body + ((:form :action "icharcount" + :method "POST") + (:h1 "AllegroServe Demo") + (:p #.(format nil "~ +Below are links containing international character samples you can use to copy +and paste into the following form. +Note that even characters that don't display (due to missing fonts) can still +be copied and pasted into the form below.")) + (:ul (:li ((:a href #.(format nil "~ +http://www.columbia.edu/kermit/utf8.html") + target "_blank") + "UTF-8 Sampler")) + (:li ((:a href #.(format nil "~ +http://www.trigeminal.com/samples/provincial.html") + target "_blank") + #.(format nil "~ +The \"anyone can be provincial!\" page")))) + "Enter your favorite quote:" + :br + ((:textarea :name "quotation" :rows 15 + :cols 50)) + :br + ((:input :type "submit" + :value "count it")))))))))))) + +(defun analyze-text (text) + (let ((char-ht (make-hash-table)) + (results nil)) + (dotimes (i (length text)) + (let ((ch (schar text i))) + (if* (gethash ch char-ht) + then (incf (gethash ch char-ht)) + else (setf (gethash ch char-ht) 1)))) + (maphash #'(lambda (k v) + (push (cons k v) results)) + char-ht) + (sort results #'(lambda (x y) (> (cdr x) (cdr y)))))) + +(publish + :path "/ichars" + :content-type "text/html" + :function + + #-(and allegro ics (version>= 6 0)) + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (princ #.(format nil "~ +This page available only with International Allegro CL post 6.0") + *html-stream*)))) + + ;; Need pre-final.1's :try-variant change to find-external-format + #+(and allegro ics (version>= 6 0)) + #'(lambda (req ent) + (let* ((body (get-request-body req)) + (query (if* body + then (form-urlencoded-to-query body))) + (lisp-ef (or (if* query + then (cdr (assoc "lisp-ef" query :test #'equal))) + ":utf8")) + (http-charset (or (if* query + then (cdr (assoc "http-charset" query + :test #'equal))) + "utf-8")) + (http-content-type (format nil "text/html; charset=~a" + http-charset))) + + (setq lisp-ef + (or (read-from-string lisp-ef) + :latin1-base)) + (with-http-response (req ent) + (with-http-body (req ent + :external-format (crlf-base-ef + (find-external-format + lisp-ef + :try-variant t))) + (html + (:html + (:head (:title (:princ-safe + (format nil "Character Display: ~a / ~a" + lisp-ef http-charset))) + ((:meta http-equiv "content-type" + content http-content-type))) + (:body + ((:form :action "ichars" :method "POST") + "HTTP content-type: " (:strong (:prin1 http-content-type)) + :br + "with-http-body's external-format: " (:strong (:prin1 lisp-ef)) + :br + :br + "Note that the way characters are displayed depends upon " + "the browser's fonts, and how the browser interprets " + "the HTTP content-type." + :br + :br + (:center + ((:table :border 1 + :cellpadding 2) + (:tr (:th "Charset") (:th "Lisp Character") (:th "Display")) + (:tr (:td "Latin-1")) + (:tr (:td "Latin-1") + (:td (:prin1 #\a)) + (:td (:princ #\a))) + (:tr (:td "Latin-1") + (:td (:prin1 #\b)) + (:td (:princ #\b))) + (:tr (:td "Latin-1") + (:td (:prin1 #\c)) + (:td (:princ #\c))) + (:tr (:td "Latin-1") + (:td (:prin1 #\cent_sign)) + (:td (:princ #\cent_sign))) + (:tr (:td "Latin-1") + (:td (:prin1 #\pound_sign)) + (:td (:princ #\pound_sign))) + (:tr (:td "Latin-1") + (:td (:prin1 #\latin_small_letter_thorn)) + (:td (:princ #\latin_small_letter_thorn))) + (:tr (:td "Latin-1") + (:td (:prin1 #\latin_capital_letter_ae)) + (:td (:princ #\latin_capital_letter_ae))) + (:tr (:td "Latin-1") + (:td (:prin1 #\latin_capital_letter_thorn)) + (:td (:princ #\latin_capital_letter_thorn))) + (:tr (:td "Latin-1") + (:td (:prin1 #\latin_capital_letter_i_with_circumflex)) + (:td (:princ #\latin_capital_letter_i_with_circumflex))) + (:tr (:td "Latin-2")) + (:tr (:td "Latin-2") + (:td (:prin1 #\latin_small_letter_u_with_ring_above)) + (:td (:princ #\latin_small_letter_u_with_ring_above))) + (:tr (:td "Latin-2") + (:td (:prin1 #\latin_capital_letter_n_with_caron)) + (:td (:princ #\latin_capital_letter_n_with_caron))) + (:tr (:td "Latin-2") + (:td (:prin1 #\latin_capital_letter_l_with_stroke)) + (:td (:princ #\latin_capital_letter_l_with_stroke))) + (:tr (:td "Latin-3")) + (:tr (:td "Latin-3") + (:td (:prin1 #\latin_small_letter_j_with_circumflex)) + (:td (:princ #\latin_small_letter_j_with_circumflex))) + (:tr (:td "Latin-3") + (:td (:prin1 #\latin_capital_letter_h_with_stroke)) + (:td (:princ #\latin_capital_letter_h_with_stroke))) + (:tr (:td "Latin-3") + (:td (:prin1 #\latin_capital_letter_c_with_circumflex)) + (:td (:princ #\latin_capital_letter_c_with_circumflex))) + (:tr (:td "Latin-4")) + (:tr (:td "Latin-4") + (:td (:prin1 #\latin_small_letter_u_with_ogonek)) + (:td (:princ #\latin_small_letter_u_with_ogonek))) + (:tr (:td "Latin-4") + (:td (:prin1 #\latin_capital_letter_i_with_macron)) + (:td (:princ #\latin_capital_letter_i_with_macron))) + (:tr (:td "Latin-4") + (:td (:prin1 #\latin_capital_letter_g_with_cedilla)) + (:td (:princ #\latin_capital_letter_g_with_cedilla))) + (:tr (:td "Latin-5")) + (:tr (:td "Latin-5") + (:td (:prin1 #\cyrillic_capital_letter_ukrainian_ie)) + (:td (:princ #\cyrillic_capital_letter_ukrainian_ie))) + (:tr (:td "Latin-5") + (:td (:prin1 #\cyrillic_small_letter_nje)) + (:td (:princ #\cyrillic_small_letter_nje))) + (:tr (:td "Latin-5") + (:td (:prin1 #\cyrillic_capital_letter_ya)) + (:td (:princ #\cyrillic_capital_letter_ya))) + (:tr (:td "Latin-6")) + (:tr (:td "Latin-6") + (:td (:prin1 #\arabic_letter_feh)) + (:td (:princ #\arabic_letter_feh))) + (:tr (:td "Latin-6") + (:td (:prin1 #\arabic_letter_hah)) + (:td (:princ #\arabic_letter_hah))) + (:tr (:td "Latin-6") + (:td (:prin1 #\arabic_letter_yeh_with_hamza_above)) + (:td (:princ #\arabic_letter_yeh_with_hamza_above))) + (:tr (:td "Latin-7")) + (:tr (:td "Latin-7") + (:td (:prin1 #\greek_capital_letter_delta)) + (:td (:princ #\greek_capital_letter_delta))) + (:tr (:td "Latin-7") + (:td (:prin1 #\greek_small_letter_eta)) + (:td (:princ #\greek_small_letter_eta))) + (:tr (:td "Latin-7") + (:td (:prin1 #\greek_capital_letter_sigma)) + (:td (:princ #\greek_capital_letter_sigma))) + (:tr (:td "Latin-8")) + (:tr (:td "Latin-8") + (:td (:prin1 #\hebrew_letter_alef)) + (:td (:princ #\hebrew_letter_alef))) + (:tr (:td "Latin-8") + (:td (:prin1 #\hebrew_letter_bet)) + (:td (:princ #\hebrew_letter_bet))) + (:tr (:td "Latin-8") + (:td (:prin1 #\hebrew_letter_gimel)) + (:td (:princ #\hebrew_letter_gimel))) + (:tr (:td "Latin-15")) + (:tr (:td "Latin-15") + (:td (:prin1 #\latin_small_ligature_oe)) + (:td (:princ #\latin_small_ligature_oe))) + (:tr (:td "Latin-15") + (:td (:prin1 #\latin_capital_ligature_oe)) + (:td (:princ #\latin_capital_ligature_oe))) + (:tr (:td "Japanese")) + (:tr (:td "Japanese") + (:td (:prin1 #\hiragana_letter_a)) + (:td (:princ #\hiragana_letter_a))) + (:tr (:td "Japanese") + (:td (:prin1 #\hiragana_letter_i)) + (:td (:princ #\hiragana_letter_i))) + (:tr (:td "CJK")) + (:tr (:td "CJK") + (:td (:prin1 #\cjk_compatibility_ideograph-f900)) + (:td (:princ #\cjk_compatibility_ideograph-f900))) + (:tr (:td "CJK") + (:td (:prin1 #\cjk_compatibility_ideograph-f901)) + (:td (:princ #\cjk_compatibility_ideograph-f901))) + (:tr (:td "CJK") + (:td (:prin1 #\cjk_compatibility_ideograph-f902)) + (:td (:princ #\cjk_compatibility_ideograph-f902))) + (:tr (:td "Ligature")) + (:tr (:td "Ligature") + (:td (:prin1 #\latin_small_ligature_fi)) + (:td (:princ #\latin_small_ligature_fi))) + (:tr (:td "Ligature") + (:td (:prin1 #\latin_small_ligature_fl)) + (:td (:princ #\latin_small_ligature_fl))) + )) + :br + :br + (:princ-safe (format nil "~ +Switch Lisp External-Format (Current is ~s): " + (ef-name (find-external-format lisp-ef)))) + ((:select name "lisp-ef") + ((:option value ":utf8-base" :selected "selected") + ":utf8-base") + ((:option value ":iso8859-1") ":iso8859-1") + ((:option value ":iso8859-2") ":iso8859-2") + ((:option value ":iso8859-3") ":iso8859-3") + ((:option value ":iso8859-4") ":iso8859-4") + ((:option value ":iso8859-5") ":iso8859-5") + ((:option value ":iso8859-6") ":iso8859-6") + ((:option value ":iso8859-7") ":iso8859-7") + ((:option value ":iso8859-8") ":iso8859-8") + ((:option value ":iso8859-15")":iso8859-15") + ((:option value ":shiftjis") ":shiftjis") + ((:option value ":euc") ":euc") + ((:option value ":932") ":932 (Windows 932)") + ((:option value ":1250") ":1250 (Windows 1250)") + ((:option value ":1254") ":1254 (Windows 1254)") + ((:option value ":1251") ":1251 (Windows 1251)") + ((:option value ":1255") ":1255 (Windows 1255)") + ) + :br + (:princ-safe (format nil "~ +Switch HTTP Charset: (Current is ~s): " + http-charset)) + ((:select name "http-charset") + ((:option value "utf-8" :selected "selected") "utf-8") + ((:option value "iso-8859-1") "iso-8859-1") + ((:option value "iso-8859-2") "iso-8859-2") + ((:option value "iso-8859-3") "iso-8859-3") + ((:option value "iso-8859-4") "iso-8859-4") + ((:option value "iso-8859-5") "iso-8859-5") + ((:option value "iso-8859-6") "iso-8859-6") + ((:option value "iso-8859-7") "iso-8859-7") + ((:option value "iso-8859-8") "iso-8859-8") + ((:option value "iso-8859-15") "iso-8859-15") + ((:option value "shift_jis") "shift_jis") + ((:option value "euc-jp") "euc-jp") + ((:option value "windows-932") "windows-932") + ((:option value "windows-1250") + "windows-1250") + ((:option value "windows-1254") + "windows-1254") + ((:option value "windows-1251") + "windows-1251") + ((:option value "windows-1255") + "windows-1255") + ) + :br + :br + ((:input :type "submit" :value "Redisplay"))))))) + )))) Added: vendor/portableaserve/aserve/examples/file2000.txt =================================================================== --- vendor/portableaserve/aserve/examples/file2000.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/file2000.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this is a sample file of roughly 2000 bytes used to do benchmarks on the retrieval speed of AllegroServe this Added: vendor/portableaserve/aserve/examples/foo.txt =================================================================== --- vendor/portableaserve/aserve/examples/foo.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/foo.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +this is a test of +returning a text +file and now this is +it for the file +next line +and one more line Added: vendor/portableaserve/aserve/examples/fresh.jpg =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/fresh.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/prfile9.jpg =================================================================== (Binary files differ) Property changes on: vendor/portableaserve/aserve/examples/prfile9.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: vendor/portableaserve/aserve/examples/puzzle.cl =================================================================== --- vendor/portableaserve/aserve/examples/puzzle.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/puzzle.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,828 @@ +;; -*- mode: common-lisp; package: net.aserve.examples -*- +;; +;; puzzle.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: puzzle.cl,v 1.3 2002/12/26 19:55:44 rudi Exp $ + +;; Description: +;; Allegro Serve puzzle example + + +;; Original Author: Charles A. Cox, Franz Inc. + + + +(defpackage puzzle + (:use :common-lisp :acl-compat.excl)) + +(in-package :puzzle) + +(eval-when (compile load eval) + (require :aserve)) + +(defpackage puzzle + (:use :net.html.generator :net.aserve)) + +(defparameter .directions. + (make-array + 8 + :initial-contents '((-1 . -1) ; nw + (-1 . 0) ; n + (-1 . +1) ; ne + (0 . -1) ; w + (0 . +1) ; e + (+1 . -1) ; sw + (+1 . 0) ; s + (+1 . +1) ; se + ))) + +;; Bitmap of all Unicode characters whose name includes "letter". +(defparameter .unicode-letters-bm. + (let ((a (make-array #.(expt 2 16) :element-type 'bit + :initial-element 0))) + (dolist + (c '(#x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 #x0048 #x0049 + #x004a #x004b #x004c #x004d #x004e #x004f #x0050 #x0051 #x0052 + #x0053 #x0054 #x0055 #x0056 #x0057 #x0058 #x0059 #x005a #x0061 + #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 #x0068 #x0069 #x006a + #x006b #x006c #x006d #x006e #x006f #x0070 #x0071 #x0072 #x0073 + #x0074 #x0075 #x0076 #x0077 #x0078 #x0079 #x007a #x00c0 #x00c1 + #x00c2 #x00c3 #x00c4 #x00c5 #x00c6 #x00c7 #x00c8 #x00c9 #x00ca + #x00cb #x00cc #x00cd #x00ce #x00cf #x00d0 #x00d1 #x00d2 #x00d3 + #x00d4 #x00d5 #x00d6 #x00d8 #x00d9 #x00da #x00db #x00dc #x00dd + #x00de #x00df #x00e0 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 + #x00e7 #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef + #x00f0 #x00f1 #x00f2 #x00f3 #x00f4 #x00f5 #x00f6 #x00f8 #x00f9 + #x00fa #x00fb #x00fc #x00fd #x00fe #x00ff #x0100 #x0101 #x0102 + #x0103 #x0104 #x0105 #x0106 #x0107 #x0108 #x0109 #x010a #x010b + #x010c #x010d #x010e #x010f #x0110 #x0111 #x0112 #x0113 #x0114 + #x0115 #x0116 #x0117 #x0118 #x0119 #x011a #x011b #x011c #x011d + #x011e #x011f #x0120 #x0121 #x0122 #x0123 #x0124 #x0125 #x0126 + #x0127 #x0128 #x0129 #x012a #x012b #x012c #x012d #x012e #x012f + #x0130 #x0131 #x0134 #x0135 #x0136 #x0137 #x0138 #x0139 #x013a + #x013b #x013c #x013d #x013e #x013f #x0140 #x0141 #x0142 #x0143 + #x0144 #x0145 #x0146 #x0147 #x0148 #x0149 #x014a #x014b #x014c + #x014d #x014e #x014f #x0150 #x0151 #x0154 #x0155 #x0156 #x0157 + #x0158 #x0159 #x015a #x015b #x015c #x015d #x015e #x015f #x0160 + #x0161 #x0162 #x0163 #x0164 #x0165 #x0166 #x0167 #x0168 #x0169 + #x016a #x016b #x016c #x016d #x016e #x016f #x0170 #x0171 #x0172 + #x0173 #x0174 #x0175 #x0176 #x0177 #x0178 #x0179 #x017a #x017b + #x017c #x017d #x017e #x017f #x0180 #x0181 #x0182 #x0183 #x0184 + #x0185 #x0186 #x0187 #x0188 #x0189 #x018a #x018b #x018c #x018d + #x018e #x018f #x0190 #x0191 #x0192 #x0193 #x0194 #x0195 #x0196 + #x0197 #x0198 #x0199 #x019a #x019b #x019c #x019d #x019e #x019f + #x01a0 #x01a1 #x01a2 #x01a3 #x01a4 #x01a5 #x01a6 #x01a7 #x01a8 + #x01a9 #x01aa #x01ab #x01ac #x01ad #x01ae #x01af #x01b0 #x01b1 + #x01b2 #x01b3 #x01b4 #x01b5 #x01b6 #x01b7 #x01b8 #x01b9 #x01ba + #x01bb #x01bc #x01bd #x01be #x01bf #x01c0 #x01c1 #x01c2 #x01c3 + #x01c4 #x01c5 #x01c6 #x01c7 #x01c8 #x01c9 #x01ca #x01cb #x01cc + #x01cd #x01ce #x01cf #x01d0 #x01d1 #x01d2 #x01d3 #x01d4 #x01d5 + #x01d6 #x01d7 #x01d8 #x01d9 #x01da #x01db #x01dc #x01dd #x01de + #x01df #x01e0 #x01e1 #x01e2 #x01e3 #x01e4 #x01e5 #x01e6 #x01e7 + #x01e8 #x01e9 #x01ea #x01eb #x01ec #x01ed #x01ee #x01ef #x01f0 + #x01f1 #x01f2 #x01f3 #x01f4 #x01f5 #x01fa #x01fb #x01fc #x01fd + #x01fe #x01ff #x0200 #x0201 #x0202 #x0203 #x0204 #x0205 #x0206 + #x0207 #x0208 #x0209 #x020a #x020b #x020c #x020d #x020e #x020f + #x0210 #x0211 #x0212 #x0213 #x0214 #x0215 #x0216 #x0217 #x0250 + #x0251 #x0252 #x0253 #x0254 #x0255 #x0256 #x0257 #x0258 #x0259 + #x025a #x025b #x025c #x025d #x025e #x025f #x0260 #x0261 #x0262 + #x0263 #x0264 #x0265 #x0266 #x0267 #x0268 #x0269 #x026a #x026b + #x026c #x026d #x026e #x026f #x0270 #x0271 #x0272 #x0273 #x0274 + #x0275 #x0276 #x0277 #x0278 #x0279 #x027a #x027b #x027c #x027d + #x027e #x027f #x0280 #x0281 #x0282 #x0283 #x0284 #x0285 #x0286 + #x0287 #x0288 #x0289 #x028a #x028b #x028c #x028d #x028e #x028f + #x0290 #x0291 #x0292 #x0293 #x0294 #x0295 #x0296 #x0297 #x0298 + #x0299 #x029a #x029b #x029c #x029d #x029e #x029f #x02a0 #x02a1 + #x02a2 #x02a3 #x02a4 #x02a5 #x02a6 #x02a7 #x02a8 #x02b0 #x02b1 + #x02b2 #x02b3 #x02b4 #x02b5 #x02b6 #x02b7 #x02b8 #x02b9 #x02ba + #x02bb #x02bc #x02bd #x02be #x02bf #x02c0 #x02c1 #x02c2 #x02c3 + #x02c4 #x02c5 #x02c6 #x02c8 #x02c9 #x02ca #x02cb #x02cc #x02cd + #x02ce #x02cf #x02d0 #x02d1 #x02d2 #x02d3 #x02d4 #x02d5 #x02d6 + #x02d7 #x02de #x02e0 #x02e1 #x02e2 #x02e3 #x02e4 #x02e5 #x02e6 + #x02e7 #x02e8 #x02e9 #x0386 #x0388 #x0389 #x038a #x038c #x038e + #x038f #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397 + #x0398 #x0399 #x039a #x039b #x039c #x039d #x039e #x039f #x03a0 + #x03a1 #x03a3 #x03a4 #x03a5 #x03a6 #x03a7 #x03a8 #x03a9 #x03aa + #x03ab #x03ac #x03ad #x03ae #x03af #x03b0 #x03b1 #x03b2 #x03b3 + #x03b4 #x03b5 #x03b6 #x03b7 #x03b8 #x03b9 #x03ba #x03bb #x03bc + #x03bd #x03be #x03bf #x03c0 #x03c1 #x03c2 #x03c3 #x03c4 #x03c5 + #x03c6 #x03c7 #x03c8 #x03c9 #x03ca #x03cb #x03cc #x03cd #x03ce + #x03da #x03dc #x03de #x03e0 #x03e2 #x03e3 #x03e4 #x03e5 #x03e6 + #x03e7 #x03e8 #x03e9 #x03ea #x03eb #x03ec #x03ed #x03ee #x03ef + #x03f3 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407 #x0408 + #x0409 #x040a #x040b #x040c #x040e #x040f #x0410 #x0411 #x0412 + #x0413 #x0414 #x0415 #x0416 #x0417 #x0418 #x0419 #x041a #x041b + #x041c #x041d #x041e #x041f #x0420 #x0421 #x0422 #x0423 #x0424 + #x0425 #x0426 #x0427 #x0428 #x0429 #x042a #x042b #x042c #x042d + #x042e #x042f #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 + #x0437 #x0438 #x0439 #x043a #x043b #x043c #x043d #x043e #x043f + #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447 #x0448 + #x0449 #x044a #x044b #x044c #x044d #x044e #x044f #x0451 #x0452 + #x0453 #x0454 #x0455 #x0456 #x0457 #x0458 #x0459 #x045a #x045b + #x045c #x045e #x045f #x0460 #x0461 #x0462 #x0463 #x0464 #x0465 + #x0466 #x0467 #x0468 #x0469 #x046a #x046b #x046c #x046d #x046e + #x046f #x0470 #x0471 #x0472 #x0473 #x0474 #x0475 #x0476 #x0477 + #x0478 #x0479 #x047a #x047b #x047c #x047d #x047e #x047f #x0480 + #x0481 #x0490 #x0491 #x0492 #x0493 #x0494 #x0495 #x0496 #x0497 + #x0498 #x0499 #x049a #x049b #x049c #x049d #x049e #x049f #x04a0 + #x04a1 #x04a2 #x04a3 #x04a6 #x04a7 #x04a8 #x04a9 #x04aa #x04ab + #x04ac #x04ad #x04ae #x04af #x04b0 #x04b1 #x04b2 #x04b3 #x04b6 + #x04b7 #x04b8 #x04b9 #x04ba #x04bb #x04bc #x04bd #x04be #x04bf + #x04c0 #x04c1 #x04c2 #x04c3 #x04c4 #x04c7 #x04c8 #x04cb #x04cc + #x04d0 #x04d1 #x04d2 #x04d3 #x04d6 #x04d7 #x04d8 #x04d9 #x04da + #x04db #x04dc #x04dd #x04de #x04df #x04e0 #x04e1 #x04e2 #x04e3 + #x04e4 #x04e5 #x04e6 #x04e7 #x04e8 #x04e9 #x04ea #x04eb #x04ee + #x04ef #x04f0 #x04f1 #x04f2 #x04f3 #x04f4 #x04f5 #x04f8 #x04f9 + #x0531 #x0532 #x0533 #x0534 #x0535 #x0536 #x0537 #x0538 #x0539 + #x053a #x053b #x053c #x053d #x053e #x053f #x0540 #x0541 #x0542 + #x0543 #x0544 #x0545 #x0546 #x0547 #x0548 #x0549 #x054a #x054b + #x054c #x054d #x054e #x054f #x0550 #x0551 #x0552 #x0553 #x0554 + #x0555 #x0556 #x0559 #x0561 #x0562 #x0563 #x0564 #x0565 #x0566 + #x0567 #x0568 #x0569 #x056a #x056b #x056c #x056d #x056e #x056f + #x0570 #x0571 #x0572 #x0573 #x0574 #x0575 #x0576 #x0577 #x0578 + #x0579 #x057a #x057b #x057c #x057d #x057e #x057f #x0580 #x0581 + #x0582 #x0583 #x0584 #x0585 #x0586 #x05d0 #x05d1 #x05d2 #x05d3 + #x05d4 #x05d5 #x05d6 #x05d7 #x05d8 #x05d9 #x05da #x05db #x05dc + #x05dd #x05de #x05df #x05e0 #x05e1 #x05e2 #x05e3 #x05e4 #x05e5 + #x05e6 #x05e7 #x05e8 #x05e9 #x05ea #x0621 #x0622 #x0623 #x0624 + #x0625 #x0626 #x0627 #x0628 #x0629 #x062a #x062b #x062c #x062d + #x062e #x062f #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 + #x0637 #x0638 #x0639 #x063a #x0641 #x0642 #x0643 #x0644 #x0645 + #x0646 #x0647 #x0648 #x0649 #x064a #x0670 #x0671 #x0672 #x0673 + #x0674 #x0675 #x0676 #x0677 #x0678 #x0679 #x067a #x067b #x067c + #x067d #x067e #x067f #x0680 #x0681 #x0682 #x0683 #x0684 #x0685 + #x0686 #x0687 #x0688 #x0689 #x068a #x068b #x068c #x068d #x068e + #x068f #x0690 #x0691 #x0692 #x0693 #x0694 #x0695 #x0696 #x0697 + #x0698 #x0699 #x069a #x069b #x069c #x069d #x069e #x069f #x06a0 + #x06a1 #x06a2 #x06a3 #x06a4 #x06a5 #x06a6 #x06a7 #x06a8 #x06a9 + #x06aa #x06ab #x06ac #x06ad #x06ae #x06af #x06b0 #x06b1 #x06b2 + #x06b3 #x06b4 #x06b5 #x06b6 #x06b7 #x06ba #x06bb #x06bc #x06bd + #x06be #x06c0 #x06c1 #x06c2 #x06c3 #x06c4 #x06c5 #x06c6 #x06c7 + #x06c8 #x06c9 #x06ca #x06cb #x06cc #x06cd #x06ce #x06d0 #x06d1 + #x06d2 #x06d3 #x06d5 #x0905 #x0906 #x0907 #x0908 #x0909 #x090a + #x090b #x090c #x090d #x090e #x090f #x0910 #x0911 #x0912 #x0913 + #x0914 #x0915 #x0916 #x0917 #x0918 #x0919 #x091a #x091b #x091c + #x091d #x091e #x091f #x0920 #x0921 #x0922 #x0923 #x0924 #x0925 + #x0926 #x0927 #x0928 #x0929 #x092a #x092b #x092c #x092d #x092e + #x092f #x0930 #x0931 #x0932 #x0933 #x0934 #x0935 #x0936 #x0937 + #x0938 #x0939 #x0958 #x0959 #x095a #x095b #x095c #x095d #x095e + #x095f #x0960 #x0961 #x0985 #x0986 #x0987 #x0988 #x0989 #x098a + #x098b #x098c #x098f #x0990 #x0993 #x0994 #x0995 #x0996 #x0997 + #x0998 #x0999 #x099a #x099b #x099c #x099d #x099e #x099f #x09a0 + #x09a1 #x09a2 #x09a3 #x09a4 #x09a5 #x09a6 #x09a7 #x09a8 #x09aa + #x09ab #x09ac #x09ad #x09ae #x09af #x09b0 #x09b2 #x09b6 #x09b7 + #x09b8 #x09b9 #x09dc #x09dd #x09df #x09e0 #x09e1 #x09f0 #x09f1 + #x0a05 #x0a06 #x0a07 #x0a08 #x0a09 #x0a0a #x0a0f #x0a10 #x0a13 + #x0a14 #x0a15 #x0a16 #x0a17 #x0a18 #x0a19 #x0a1a #x0a1b #x0a1c + #x0a1d #x0a1e #x0a1f #x0a20 #x0a21 #x0a22 #x0a23 #x0a24 #x0a25 + #x0a26 #x0a27 #x0a28 #x0a2a #x0a2b #x0a2c #x0a2d #x0a2e #x0a2f + #x0a30 #x0a32 #x0a33 #x0a35 #x0a36 #x0a38 #x0a39 #x0a59 #x0a5a + #x0a5b #x0a5c #x0a5e #x0a85 #x0a86 #x0a87 #x0a88 #x0a89 #x0a8a + #x0a8b #x0a8f #x0a90 #x0a93 #x0a94 #x0a95 #x0a96 #x0a97 #x0a98 + #x0a99 #x0a9a #x0a9b #x0a9c #x0a9d #x0a9e #x0a9f #x0aa0 #x0aa1 + #x0aa2 #x0aa3 #x0aa4 #x0aa5 #x0aa6 #x0aa7 #x0aa8 #x0aaa #x0aab + #x0aac #x0aad #x0aae #x0aaf #x0ab0 #x0ab2 #x0ab3 #x0ab5 #x0ab6 + #x0ab7 #x0ab8 #x0ab9 #x0ae0 #x0b05 #x0b06 #x0b07 #x0b08 #x0b09 + #x0b0a #x0b0b #x0b0c #x0b0f #x0b10 #x0b13 #x0b14 #x0b15 #x0b16 + #x0b17 #x0b18 #x0b19 #x0b1a #x0b1b #x0b1c #x0b1d #x0b1e #x0b1f + #x0b20 #x0b21 #x0b22 #x0b23 #x0b24 #x0b25 #x0b26 #x0b27 #x0b28 + #x0b2a #x0b2b #x0b2c #x0b2d #x0b2e #x0b2f #x0b30 #x0b32 #x0b33 + #x0b36 #x0b37 #x0b38 #x0b39 #x0b5c #x0b5d #x0b5f #x0b60 #x0b61 + #x0b85 #x0b86 #x0b87 #x0b88 #x0b89 #x0b8a #x0b8e #x0b8f #x0b90 + #x0b92 #x0b93 #x0b94 #x0b95 #x0b99 #x0b9a #x0b9c #x0b9e #x0b9f + #x0ba3 #x0ba4 #x0ba8 #x0ba9 #x0baa #x0bae #x0baf #x0bb0 #x0bb1 + #x0bb2 #x0bb3 #x0bb4 #x0bb5 #x0bb7 #x0bb8 #x0bb9 #x0c05 #x0c06 + #x0c07 #x0c08 #x0c09 #x0c0a #x0c0b #x0c0c #x0c0e #x0c0f #x0c10 + #x0c12 #x0c13 #x0c14 #x0c15 #x0c16 #x0c17 #x0c18 #x0c19 #x0c1a + #x0c1b #x0c1c #x0c1d #x0c1e #x0c1f #x0c20 #x0c21 #x0c22 #x0c23 + #x0c24 #x0c25 #x0c26 #x0c27 #x0c28 #x0c2a #x0c2b #x0c2c #x0c2d + #x0c2e #x0c2f #x0c30 #x0c31 #x0c32 #x0c33 #x0c35 #x0c36 #x0c37 + #x0c38 #x0c39 #x0c60 #x0c61 #x0c85 #x0c86 #x0c87 #x0c88 #x0c89 + #x0c8a #x0c8b #x0c8c #x0c8e #x0c8f #x0c90 #x0c92 #x0c93 #x0c94 + #x0c95 #x0c96 #x0c97 #x0c98 #x0c99 #x0c9a #x0c9b #x0c9c #x0c9d + #x0c9e #x0c9f #x0ca0 #x0ca1 #x0ca2 #x0ca3 #x0ca4 #x0ca5 #x0ca6 + #x0ca7 #x0ca8 #x0caa #x0cab #x0cac #x0cad #x0cae #x0caf #x0cb0 + #x0cb1 #x0cb2 #x0cb3 #x0cb5 #x0cb6 #x0cb7 #x0cb8 #x0cb9 #x0cde + #x0ce0 #x0ce1 #x0d05 #x0d06 #x0d07 #x0d08 #x0d09 #x0d0a #x0d0b + #x0d0c #x0d0e #x0d0f #x0d10 #x0d12 #x0d13 #x0d14 #x0d15 #x0d16 + #x0d17 #x0d18 #x0d19 #x0d1a #x0d1b #x0d1c #x0d1d #x0d1e #x0d1f + #x0d20 #x0d21 #x0d22 #x0d23 #x0d24 #x0d25 #x0d26 #x0d27 #x0d28 + #x0d2a #x0d2b #x0d2c #x0d2d #x0d2e #x0d2f #x0d30 #x0d31 #x0d32 + #x0d33 #x0d34 #x0d35 #x0d36 #x0d37 #x0d38 #x0d39 #x0d60 #x0d61 + #x0e81 #x0e82 #x0e84 #x0e87 #x0e88 #x0e8a #x0e8d #x0e94 #x0e95 + #x0e96 #x0e97 #x0e99 #x0e9a #x0e9b #x0e9c #x0e9d #x0e9e #x0e9f + #x0ea1 #x0ea2 #x0ea3 #x0ea5 #x0ea7 #x0eaa #x0eab #x0ead #x0eae + #x0f40 #x0f41 #x0f42 #x0f43 #x0f44 #x0f45 #x0f46 #x0f47 #x0f49 + #x0f4a #x0f4b #x0f4c #x0f4d #x0f4e #x0f4f #x0f50 #x0f51 #x0f52 + #x0f53 #x0f54 #x0f55 #x0f56 #x0f57 #x0f58 #x0f59 #x0f5a #x0f5b + #x0f5c #x0f5d #x0f5e #x0f5f #x0f60 #x0f61 #x0f62 #x0f63 #x0f64 + #x0f65 #x0f66 #x0f67 #x0f68 #x0f69 #x0f90 #x0f91 #x0f92 #x0f93 + #x0f94 #x0f95 #x0f97 #x0f99 #x0f9a #x0f9b #x0f9c #x0f9d #x0f9e + #x0f9f #x0fa0 #x0fa1 #x0fa2 #x0fa3 #x0fa4 #x0fa5 #x0fa6 #x0fa7 + #x0fa8 #x0fa9 #x0faa #x0fab #x0fac #x0fad #x0fb1 #x0fb2 #x0fb3 + #x0fb4 #x0fb5 #x0fb6 #x0fb7 #x0fb9 #x10a0 #x10a1 #x10a2 #x10a3 + #x10a4 #x10a5 #x10a6 #x10a7 #x10a8 #x10a9 #x10aa #x10ab #x10ac + #x10ad #x10ae #x10af #x10b0 #x10b1 #x10b2 #x10b3 #x10b4 #x10b5 + #x10b6 #x10b7 #x10b8 #x10b9 #x10ba #x10bb #x10bc #x10bd #x10be + #x10bf #x10c0 #x10c1 #x10c2 #x10c3 #x10c4 #x10c5 #x10d0 #x10d1 + #x10d2 #x10d3 #x10d4 #x10d5 #x10d6 #x10d7 #x10d8 #x10d9 #x10da + #x10db #x10dc #x10dd #x10de #x10df #x10e0 #x10e1 #x10e2 #x10e3 + #x10e4 #x10e5 #x10e6 #x10e7 #x10e8 #x10e9 #x10ea #x10eb #x10ec + #x10ed #x10ee #x10ef #x10f0 #x10f1 #x10f2 #x10f3 #x10f4 #x10f5 + #x10f6 #x1e00 #x1e01 #x1e02 #x1e03 #x1e04 #x1e05 #x1e06 #x1e07 + #x1e08 #x1e09 #x1e0a #x1e0b #x1e0c #x1e0d #x1e0e #x1e0f #x1e10 + #x1e11 #x1e12 #x1e13 #x1e14 #x1e15 #x1e16 #x1e17 #x1e18 #x1e19 + #x1e1a #x1e1b #x1e1c #x1e1d #x1e1e #x1e1f #x1e20 #x1e21 #x1e22 + #x1e23 #x1e24 #x1e25 #x1e26 #x1e27 #x1e28 #x1e29 #x1e2a #x1e2b + #x1e2c #x1e2d #x1e2e #x1e2f #x1e30 #x1e31 #x1e32 #x1e33 #x1e34 + #x1e35 #x1e36 #x1e37 #x1e38 #x1e39 #x1e3a #x1e3b #x1e3c #x1e3d + #x1e3e #x1e3f #x1e40 #x1e41 #x1e42 #x1e43 #x1e44 #x1e45 #x1e46 + #x1e47 #x1e48 #x1e49 #x1e4a #x1e4b #x1e4c #x1e4d #x1e4e #x1e4f + #x1e50 #x1e51 #x1e52 #x1e53 #x1e54 #x1e55 #x1e56 #x1e57 #x1e58 + #x1e59 #x1e5a #x1e5b #x1e5c #x1e5d #x1e5e #x1e5f #x1e60 #x1e61 + #x1e62 #x1e63 #x1e64 #x1e65 #x1e66 #x1e67 #x1e68 #x1e69 #x1e6a + #x1e6b #x1e6c #x1e6d #x1e6e #x1e6f #x1e70 #x1e71 #x1e72 #x1e73 + #x1e74 #x1e75 #x1e76 #x1e77 #x1e78 #x1e79 #x1e7a #x1e7b #x1e7c + #x1e7d #x1e7e #x1e7f #x1e80 #x1e81 #x1e82 #x1e83 #x1e84 #x1e85 + #x1e86 #x1e87 #x1e88 #x1e89 #x1e8a #x1e8b #x1e8c #x1e8d #x1e8e + #x1e8f #x1e90 #x1e91 #x1e92 #x1e93 #x1e94 #x1e95 #x1e96 #x1e97 + #x1e98 #x1e99 #x1e9a #x1e9b #x1ea0 #x1ea1 #x1ea2 #x1ea3 #x1ea4 + #x1ea5 #x1ea6 #x1ea7 #x1ea8 #x1ea9 #x1eaa #x1eab #x1eac #x1ead + #x1eae #x1eaf #x1eb0 #x1eb1 #x1eb2 #x1eb3 #x1eb4 #x1eb5 #x1eb6 + #x1eb7 #x1eb8 #x1eb9 #x1eba #x1ebb #x1ebc #x1ebd #x1ebe #x1ebf + #x1ec0 #x1ec1 #x1ec2 #x1ec3 #x1ec4 #x1ec5 #x1ec6 #x1ec7 #x1ec8 + #x1ec9 #x1eca #x1ecb #x1ecc #x1ecd #x1ece #x1ecf #x1ed0 #x1ed1 + #x1ed2 #x1ed3 #x1ed4 #x1ed5 #x1ed6 #x1ed7 #x1ed8 #x1ed9 #x1eda + #x1edb #x1edc #x1edd #x1ede #x1edf #x1ee0 #x1ee1 #x1ee2 #x1ee3 + #x1ee4 #x1ee5 #x1ee6 #x1ee7 #x1ee8 #x1ee9 #x1eea #x1eeb #x1eec + #x1eed #x1eee #x1eef #x1ef0 #x1ef1 #x1ef2 #x1ef3 #x1ef4 #x1ef5 + #x1ef6 #x1ef7 #x1ef8 #x1ef9 #x1f00 #x1f01 #x1f02 #x1f03 #x1f04 + #x1f05 #x1f06 #x1f07 #x1f08 #x1f09 #x1f0a #x1f0b #x1f0c #x1f0d + #x1f0e #x1f0f #x1f10 #x1f11 #x1f12 #x1f13 #x1f14 #x1f15 #x1f18 + #x1f19 #x1f1a #x1f1b #x1f1c #x1f1d #x1f20 #x1f21 #x1f22 #x1f23 + #x1f24 #x1f25 #x1f26 #x1f27 #x1f28 #x1f29 #x1f2a #x1f2b #x1f2c + #x1f2d #x1f2e #x1f2f #x1f30 #x1f31 #x1f32 #x1f33 #x1f34 #x1f35 + #x1f36 #x1f37 #x1f38 #x1f39 #x1f3a #x1f3b #x1f3c #x1f3d #x1f3e + #x1f3f #x1f40 #x1f41 #x1f42 #x1f43 #x1f44 #x1f45 #x1f48 #x1f49 + #x1f4a #x1f4b #x1f4c #x1f4d #x1f50 #x1f51 #x1f52 #x1f53 #x1f54 + #x1f55 #x1f56 #x1f57 #x1f59 #x1f5b #x1f5d #x1f5f #x1f60 #x1f61 + #x1f62 #x1f63 #x1f64 #x1f65 #x1f66 #x1f67 #x1f68 #x1f69 #x1f6a + #x1f6b #x1f6c #x1f6d #x1f6e #x1f6f #x1f70 #x1f71 #x1f72 #x1f73 + #x1f74 #x1f75 #x1f76 #x1f77 #x1f78 #x1f79 #x1f7a #x1f7b #x1f7c + #x1f7d #x1f80 #x1f81 #x1f82 #x1f83 #x1f84 #x1f85 #x1f86 #x1f87 + #x1f88 #x1f89 #x1f8a #x1f8b #x1f8c #x1f8d #x1f8e #x1f8f #x1f90 + #x1f91 #x1f92 #x1f93 #x1f94 #x1f95 #x1f96 #x1f97 #x1f98 #x1f99 + #x1f9a #x1f9b #x1f9c #x1f9d #x1f9e #x1f9f #x1fa0 #x1fa1 #x1fa2 + #x1fa3 #x1fa4 #x1fa5 #x1fa6 #x1fa7 #x1fa8 #x1fa9 #x1faa #x1fab + #x1fac #x1fad #x1fae #x1faf #x1fb0 #x1fb1 #x1fb2 #x1fb3 #x1fb4 + #x1fb6 #x1fb7 #x1fb8 #x1fb9 #x1fba #x1fbb #x1fbc #x1fc2 #x1fc3 + #x1fc4 #x1fc6 #x1fc7 #x1fc8 #x1fc9 #x1fca #x1fcb #x1fcc #x1fd0 + #x1fd1 #x1fd2 #x1fd3 #x1fd6 #x1fd7 #x1fd8 #x1fd9 #x1fda #x1fdb + #x1fe0 #x1fe1 #x1fe2 #x1fe3 #x1fe4 #x1fe5 #x1fe6 #x1fe7 #x1fe8 + #x1fe9 #x1fea #x1feb #x1fec #x1ff2 #x1ff3 #x1ff4 #x1ff6 #x1ff7 + #x1ff8 #x1ff9 #x1ffa #x1ffb #x1ffc #x207f #x210c #x2111 #x211c + #x2128 #x2129 #x212d #x249c #x249d #x249e #x249f #x24a0 #x24a1 + #x24a2 #x24a3 #x24a4 #x24a5 #x24a6 #x24a7 #x24a8 #x24a9 #x24aa + #x24ab #x24ac #x24ad #x24ae #x24af #x24b0 #x24b1 #x24b2 #x24b3 + #x24b4 #x24b5 #x24b6 #x24b7 #x24b8 #x24b9 #x24ba #x24bb #x24bc + #x24bd #x24be #x24bf #x24c0 #x24c1 #x24c2 #x24c3 #x24c4 #x24c5 + #x24c6 #x24c7 #x24c8 #x24c9 #x24ca #x24cb #x24cc #x24cd #x24ce + #x24cf #x24d0 #x24d1 #x24d2 #x24d3 #x24d4 #x24d5 #x24d6 #x24d7 + #x24d8 #x24d9 #x24da #x24db #x24dc #x24dd #x24de #x24df #x24e0 + #x24e1 #x24e2 #x24e3 #x24e4 #x24e5 #x24e6 #x24e7 #x24e8 #x24e9 + #x3041 #x3042 #x3043 #x3044 #x3045 #x3046 #x3047 #x3048 #x3049 + #x304a #x304b #x304c #x304d #x304e #x304f #x3050 #x3051 #x3052 + #x3053 #x3054 #x3055 #x3056 #x3057 #x3058 #x3059 #x305a #x305b + #x305c #x305d #x305e #x305f #x3060 #x3061 #x3062 #x3063 #x3064 + #x3065 #x3066 #x3067 #x3068 #x3069 #x306a #x306b #x306c #x306d + #x306e #x306f #x3070 #x3071 #x3072 #x3073 #x3074 #x3075 #x3076 + #x3077 #x3078 #x3079 #x307a #x307b #x307c #x307d #x307e #x307f + #x3080 #x3081 #x3082 #x3083 #x3084 #x3085 #x3086 #x3087 #x3088 + #x3089 #x308a #x308b #x308c #x308d #x308e #x308f #x3090 #x3091 + #x3092 #x3093 #x3094 #x30a1 #x30a2 #x30a3 #x30a4 #x30a5 #x30a6 + #x30a7 #x30a8 #x30a9 #x30aa #x30ab #x30ac #x30ad #x30ae #x30af + #x30b0 #x30b1 #x30b2 #x30b3 #x30b4 #x30b5 #x30b6 #x30b7 #x30b8 + #x30b9 #x30ba #x30bb #x30bc #x30bd #x30be #x30bf #x30c0 #x30c1 + #x30c2 #x30c3 #x30c4 #x30c5 #x30c6 #x30c7 #x30c8 #x30c9 #x30ca + #x30cb #x30cc #x30cd #x30ce #x30cf #x30d0 #x30d1 #x30d2 #x30d3 + #x30d4 #x30d5 #x30d6 #x30d7 #x30d8 #x30d9 #x30da #x30db #x30dc + #x30dd #x30de #x30df #x30e0 #x30e1 #x30e2 #x30e3 #x30e4 #x30e5 + #x30e6 #x30e7 #x30e8 #x30e9 #x30ea #x30eb #x30ec #x30ed #x30ee + #x30ef #x30f0 #x30f1 #x30f2 #x30f3 #x30f4 #x30f5 #x30f6 #x30f7 + #x30f8 #x30f9 #x30fa #x3105 #x3106 #x3107 #x3108 #x3109 #x310a + #x310b #x310c #x310d #x310e #x310f #x3110 #x3111 #x3112 #x3113 + #x3114 #x3115 #x3116 #x3117 #x3118 #x3119 #x311a #x311b #x311c + #x311d #x311e #x311f #x3120 #x3121 #x3122 #x3123 #x3124 #x3125 + #x3126 #x3127 #x3128 #x3129 #x312a #x312b #x312c #x3131 #x3132 + #x3133 #x3134 #x3135 #x3136 #x3137 #x3138 #x3139 #x313a #x313b + #x313c #x313d #x313e #x313f #x3140 #x3141 #x3142 #x3143 #x3144 + #x3145 #x3146 #x3147 #x3148 #x3149 #x314a #x314b #x314c #x314d + #x314e #x314f #x3150 #x3151 #x3152 #x3153 #x3154 #x3155 #x3156 + #x3157 #x3158 #x3159 #x315a #x315b #x315c #x315d #x315e #x315f + #x3160 #x3161 #x3162 #x3163 #x3165 #x3166 #x3167 #x3168 #x3169 + #x316a #x316b #x316c #x316d #x316e #x316f #x3170 #x3171 #x3172 + #x3173 #x3174 #x3175 #x3176 #x3177 #x3178 #x3179 #x317a #x317b + #x317c #x317d #x317e #x317f #x3180 #x3181 #x3182 #x3183 #x3184 + #x3185 #x3186 #x3187 #x3188 #x3189 #x318a #x318b #x318c #x318d + #x318e #xfb20 #xfb21 #xfb22 #xfb23 #xfb24 #xfb25 #xfb26 #xfb27 + #xfb28 #xfb29 #xfb2a #xfb2b #xfb2c #xfb2d #xfb2e #xfb2f #xfb30 + #xfb31 #xfb32 #xfb33 #xfb34 #xfb35 #xfb36 #xfb38 #xfb39 #xfb3a + #xfb3b #xfb3c #xfb3e #xfb40 #xfb41 #xfb43 #xfb44 #xfb46 #xfb47 + #xfb48 #xfb49 #xfb4a #xfb4b #xfb4c #xfb4d #xfb4e #xfb50 #xfb51 + #xfb52 #xfb53 #xfb54 #xfb55 #xfb56 #xfb57 #xfb58 #xfb59 #xfb5a + #xfb5b #xfb5c #xfb5d #xfb5e #xfb5f #xfb60 #xfb61 #xfb62 #xfb63 + #xfb64 #xfb65 #xfb66 #xfb67 #xfb68 #xfb69 #xfb6a #xfb6b #xfb6c + #xfb6d #xfb6e #xfb6f #xfb70 #xfb71 #xfb72 #xfb73 #xfb74 #xfb75 + #xfb76 #xfb77 #xfb78 #xfb79 #xfb7a #xfb7b #xfb7c #xfb7d #xfb7e + #xfb7f #xfb80 #xfb81 #xfb82 #xfb83 #xfb84 #xfb85 #xfb86 #xfb87 + #xfb88 #xfb89 #xfb8a #xfb8b #xfb8c #xfb8d #xfb8e #xfb8f #xfb90 + #xfb91 #xfb92 #xfb93 #xfb94 #xfb95 #xfb96 #xfb97 #xfb98 #xfb99 + #xfb9a #xfb9b #xfb9c #xfb9d #xfb9e #xfb9f #xfba0 #xfba1 #xfba2 + #xfba3 #xfba4 #xfba5 #xfba6 #xfba7 #xfba8 #xfba9 #xfbaa #xfbab + #xfbac #xfbad #xfbae #xfbaf #xfbb0 #xfbb1 #xfbd3 #xfbd4 #xfbd5 + #xfbd6 #xfbd7 #xfbd8 #xfbd9 #xfbda #xfbdb #xfbdc #xfbdd #xfbde + #xfbdf #xfbe0 #xfbe1 #xfbe2 #xfbe3 #xfbe4 #xfbe5 #xfbe6 #xfbe7 + #xfbe8 #xfbe9 #xfbfc #xfbfd #xfbfe #xfbff #xfe80 #xfe81 #xfe82 + #xfe83 #xfe84 #xfe85 #xfe86 #xfe87 #xfe88 #xfe89 #xfe8a #xfe8b + #xfe8c #xfe8d #xfe8e #xfe8f #xfe90 #xfe91 #xfe92 #xfe93 #xfe94 + #xfe95 #xfe96 #xfe97 #xfe98 #xfe99 #xfe9a #xfe9b #xfe9c #xfe9d + #xfe9e #xfe9f #xfea0 #xfea1 #xfea2 #xfea3 #xfea4 #xfea5 #xfea6 + #xfea7 #xfea8 #xfea9 #xfeaa #xfeab #xfeac #xfead #xfeae #xfeaf + #xfeb0 #xfeb1 #xfeb2 #xfeb3 #xfeb4 #xfeb5 #xfeb6 #xfeb7 #xfeb8 + #xfeb9 #xfeba #xfebb #xfebc #xfebd #xfebe #xfebf #xfec0 #xfec1 + #xfec2 #xfec3 #xfec4 #xfec5 #xfec6 #xfec7 #xfec8 #xfec9 #xfeca + #xfecb #xfecc #xfecd #xfece #xfecf #xfed0 #xfed1 #xfed2 #xfed3 + #xfed4 #xfed5 #xfed6 #xfed7 #xfed8 #xfed9 #xfeda #xfedb #xfedc + #xfedd #xfede #xfedf #xfee0 #xfee1 #xfee2 #xfee3 #xfee4 #xfee5 + #xfee6 #xfee7 #xfee8 #xfee9 #xfeea #xfeeb #xfeec #xfeed #xfeee + #xfeef #xfef0 #xfef1 #xfef2 #xfef3 #xfef4 #xff21 #xff22 #xff23 + #xff24 #xff25 #xff26 #xff27 #xff28 #xff29 #xff2a #xff2b #xff2c + #xff2d #xff2e #xff2f #xff30 #xff31 #xff32 #xff33 #xff34 #xff35 + #xff36 #xff37 #xff38 #xff39 #xff3a #xff41 #xff42 #xff43 #xff44 + #xff45 #xff46 #xff47 #xff48 #xff49 #xff4a #xff4b #xff4c #xff4d + #xff4e #xff4f #xff50 #xff51 #xff52 #xff53 #xff54 #xff55 #xff56 + #xff57 #xff58 #xff59 #xff5a #xff66 #xff67 #xff68 #xff69 #xff6a + #xff6b #xff6c #xff6d #xff6e #xff6f #xff71 #xff72 #xff73 #xff74 + #xff75 #xff76 #xff77 #xff78 #xff79 #xff7a #xff7b #xff7c #xff7d + #xff7e #xff7f #xff80 #xff81 #xff82 #xff83 #xff84 #xff85 #xff86 + #xff87 #xff88 #xff89 #xff8a #xff8b #xff8c #xff8d #xff8e #xff8f + #xff90 #xff91 #xff92 #xff93 #xff94 #xff95 #xff96 #xff97 #xff98 + #xff99 #xff9a #xff9b #xff9c #xff9d #xffa1 #xffa2 #xffa3 #xffa4 + #xffa5 #xffa6 #xffa7 #xffa8 #xffa9 #xffaa #xffab #xffac #xffad + #xffae #xffaf #xffb0 #xffb1 #xffb2 #xffb3 #xffb4 #xffb5 #xffb6 + #xffb7 #xffb8 #xffb9 #xffba #xffbb #xffbc #xffbd #xffbe #xffc2 + #xffc3 #xffc4 #xffc5 #xffc6 #xffc7 #xffca #xffcb #xffcc #xffcd + #xffce #xffcf #xffd2 #xffd3 #xffd4 #xffd5 #xffd6 #xffd7 #xffda + #xffdb #xffdc)) + (setf (aref a c) 1)) + a)) + +(defmacro cjk-p (code) + `(or + ;; CJK Ideographs + (<= #x4e00 ,code #x9fff) + ;; Hangul Syllables + (<= #xac00 ,code #xd7a3))) + +(defmacro puzzle-rows (puzzle) + `(first (array-dimensions ,puzzle))) + +(defmacro puzzle-cols (puzzle) + `(second (array-dimensions ,puzzle))) + +(defun get-random-dir () + (aref .directions. (random 8))) + +(defun get-random-start (puzzle) + (cons (random (puzzle-rows puzzle)) + (random (puzzle-cols puzzle)))) + +;; Insert a word into a puzzle. +(defun insert (word puzzle &key (install nil) + (dir (get-random-dir)) + (start (get-random-start puzzle)) + (attempt 0) + (extend-limit 0) + (attempt-limit 100) + &aux (length (length word)) + (roff 0) + (coff 0)) + (macrolet ((retry () + `(progn + (incf attempt) + (setq start (get-random-start puzzle) + dir (get-random-dir)) + (go :restart)))) + (tagbody + :restart + (do ((row (car start) (+ row (car dir))) + (col (cdr start) (+ col (cdr dir))) + (i 0 (1+ i))) + ((>= i (length word)) + ;; if we're not already installing, then we arrive here when + ;; we've passed all the tests and can begin installing. + (if* (not install) + then (setq install t) + (go :restart))) + ;; If we're installing, then just slap in the letter. Otherwise, + ;; check if the letter fits and/or if the puzzle needs extending. + (if* install + then (setf (aref puzzle row col) (schar word i)) + else (if* (or (< row 0) + (< col 0) + (>= row (first (array-dimensions puzzle))) + (>= col (second (array-dimensions puzzle))) + (>= attempt attempt-limit)) + then ;; Don't allow puzzle size to extend unless we've tried + ;; several attempts. + (if* (>= attempt attempt-limit) + then (incf extend-limit) + (setq attempt 0)) + (multiple-value-bind (npuzzle nroff ncoff) + ;; We add 1 randomly to the row extension and to + ;; the column extension to work around the problem where + ;; the puzzle may already be completely full. + (extend-puzzle puzzle + extend-limit + (+ (car start) (* (car dir) + (- length (random 2)))) + (+ (cdr start) (* (cdr dir) + (- length (random 2))))) + (if* npuzzle + then (setq puzzle npuzzle) + (incf roff nroff) + (incf coff ncoff) + (incf row nroff) (incf (car start) nroff) + (incf col ncoff) (incf (cdr start) ncoff) + else ;; extend-puzzle rejected because of + ;; extend-limit, so we just loop around to + ;; try again... + (retry)))) + (if* (and (aref puzzle row col) + (not (eq (aref puzzle row col) + (schar word i)))) + then ;; existing letters in puzzle didn't match. So we + ;; try again... + (retry))))) + (values puzzle start dir roff coff))) + +(defun extend-puzzle (puzzle extend-limit erow ecol + &aux (prows (puzzle-rows puzzle)) + (pcols (puzzle-cols puzzle))) + (let* ((shift-rows (if* (minusp erow) + then (- erow))) + (shift-cols (if* (minusp ecol) + then (- ecol))) + (new-rows (+ prows (or shift-rows (max 0 (- (1+ erow) prows))))) + (new-cols (+ pcols (or shift-cols (max 0 (- (1+ ecol) pcols)))))) + (if* (or (> new-rows extend-limit) + (> new-cols extend-limit)) + then ;; reject + (return-from extend-puzzle nil)) + (setq shift-rows (or shift-rows 0)) + (setq shift-cols (or shift-cols 0)) + (setq puzzle (adjust-array puzzle (list new-rows new-cols) + :initial-element nil)) + (if* (or (minusp erow) (minusp ecol)) + then (do ((r (- new-rows shift-rows 1) (1- r))) + ((< r 0)) + (do ((c (- new-cols shift-cols 1) (1- c))) + ((< c 0)) + (setf (aref puzzle (+ r shift-rows) (+ c shift-cols)) + (aref puzzle r c))) + (do ((c 0 (1+ c))) + ((>= c shift-cols)) + (setf (aref puzzle (+ r shift-rows) c) nil))) + (do ((r 0 (1+ r))) + ((>= r shift-rows)) + (do ((c 0 (1+ c))) + ((>= c new-cols)) + (setf (aref puzzle r c) nil)))) + (values puzzle shift-rows shift-cols))) + +(defun make-puzzle (word-list fill) + ;; We actually make the puzzle twice, throwing away the first one after + ;; getting its size. The idea is that words are likely to be more evenly + ;; distributed in the second puzzle. + (if* (not word-list) + then (return-from make-puzzle nil)) + (let ((puzzle (make-puzzle-1 word-list + (make-array '(1 1) + :initial-element nil + :adjustable t) + "none"))) + (make-puzzle-1 word-list + (make-array (array-dimensions puzzle) + :initial-element nil + :adjustable t) + fill))) + +(defun make-puzzle-1 (word-list puzzle fill + &aux (answers nil) + (fill-sym (intern fill :keyword))) + (dolist (word word-list) + (multiple-value-bind (npuzzle start dir roff coff) (insert word puzzle) + (setq puzzle npuzzle) + (dolist (a answers) + (incf (car (second a)) roff) + (incf (cdr (second a)) coff)) + (push (list word start dir) answers))) + (dotimes (i (apply #'* (array-dimensions puzzle))) + (if* (not (row-major-aref puzzle i)) + then (setf (row-major-aref puzzle i) + + (ecase fill-sym + (:|ascii-lc| (code-char (+ (random 26) #.(char-code #\a)))) + (:|none| #\space) + (:|unicode-nocjk| (loop (let ((c (random #.(expt 2 16)))) + (if* (= 1 (aref .unicode-letters-bm. c)) + then (return (code-char c)))))) + (:|unicode-cjk| (loop (let ((c (random #.(expt 2 16)))) + (if* (= 1 (aref .unicode-letters-bm. c)) + then (return (code-char c))) + (if* (cjk-p c) + then (return (code-char c)))))))))) + (values puzzle + (coerce + (sort answers #'(lambda (x y) + (string< (car x) (car y)))) + 'array))) + + +(defun mark-puzzle (puzzle index answers) + (let* ((answer (aref answers index)) + (start (second answer)) + (dir (third answer)) + (length (length (car answer))) + (row (car start)) + (col (cdr start))) + (dotimes (i length) + (setf (aref puzzle row col) (cons (aref puzzle row col) nil)) + (incf row (car dir)) + (incf col (cdr dir))))) + + +(defun unmark (puzzle row col) + (if* (consp (aref puzzle row col)) + then (setf (aref puzzle row col) (car (aref puzzle row col))) + t)) + +(defun words-list (words-string) + (do ((words nil) + (words-chars (coerce words-string 'list))) + ((null words-chars) (nreverse words)) + (let ((word nil)) + (loop + (let ((char (pop words-chars))) + (if* (or (null char) + (member char '(#\space #\newline #\tab #\return + #\linefeed))) + then (push (coerce (nreverse word) 'string) words) + (return) + else (push char word))))))) + + +(defun cannot-do-puzzle (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (princ #.(format nil "~ +This page available only with International Allegro CL post 6.0 beta") + *html-stream*)))) + + +(defun can-do-puzzle (req ent) + (let ((puzzle-url (symbol-name (gensym "/wordpuzzle"))) + (puzzle nil) + (answers nil)) + ;; publish new url on the fly. + ;; Enhancement To Do: Allow puzzles to be deallocated, either by timeout + ;; or some other mechanism. + + (publish + :path puzzle-url + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent &aux (marked nil)) + (let ((lookup + (assoc "index" (request-query req :external-format + :utf8-base) + :test #'string=))) + (if* lookup + then (setq marked t) + (mark-puzzle puzzle (read-from-string (cdr lookup)) + answers))) + (let* ((rq (request-query req :external-format :utf8-base)) + (words-string (cdr (assoc "words" rq :test #'string=))) + (fill (cdr (assoc "fill" rq :test #'string=)))) + (if* words-string + then (multiple-value-setq (puzzle answers) + (make-puzzle (words-list words-string) fill)))) + (with-http-response (req ent) + (with-http-body (req ent + :external-format :utf8-base) + (html + (:html + (:head (:title "Puzzle")) + (:body + (:p #.(format nil "~ +Characters that appear as dots or empty boxes or question-marks likely look +that way because your browser is missing the needed font(s).")) + (if* puzzle + then (html + (:center + ((:table border 0 width "75%") + (:tr (:td #.(format nil "~ +Click on letter in puzzle to see its character description.")) + (:td #.(format nil "~ +Click on word to see its puzzle location."))) + (:tr + (:td + ((:table border 0) + (dotimes (r (puzzle-rows puzzle)) + (html + (:tr + (dotimes (c (puzzle-cols puzzle)) + (html + ((:td :if* (unmark puzzle r c) + :bgcolor "lime") + ((:a href + (format nil "/wp_echo?char=~a" + (uriencode-string + (format + nil "u+~4,'0x:~s" + (char-code + (aref puzzle r c)) + (aref puzzle r c))))) + (:tt (:princ + (aref puzzle r c)))))))))))) + (:td + ((:table border 0) + (dotimes (i (length answers)) + (let ((url (format nil "~a?index=~a" + puzzle-url i))) + (html + (:tr + (:td + ((:a href url) + (:princ + (car + (aref answers i))))))))))))))) + else (html + (:p "No words entered"))) + (:p ((:a :href "/wordpuzzle") "New Puzzle")) + (if* marked + then (html + (:p ((:a :href puzzle-url) "Clear Answer"))))))))))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:html + (:head (:title "Enter Words")) + (:body + (:p + #.(format nil "~ +Enter words separated by spaces or newlines. Click on `make puzzle' button ~ +below to generate the puzzle.")) + ((:form :action puzzle-url + :method "POST") + ((:textarea :name "words" :rows 15 :cols 50)) + (:dl + (:dt "Please select category of fill letters:") + (:dd ((:input :type "radio" + :name "fill" + :value "ascii-lc" + :checked "checked") + "English Lower Case Only.")) + (:dd ((:input :type "radio" + :name "fill" + :value "unicode-nocjk") + "All Unicode Letters " + (:em "except ") + "Chinese-Japanese-Korean ideographs.")) + (:dd ((:input :type "radio" + :name "fill" + :value "unicode-cjk") + "All Unicode Letters " + (:em "including ") + "Chinese-Japanese-Korean ideographs.")) + (:dd ((:input :type "radio" + :name "fill" + :value "none") + "No fill characters."))) + ((:input :type "submit" + :value "make puzzle")) + (:p #.(format nil "~ +Below are links containing international character samples you can use to copy +and paste into the word list. +Note that even characters that don't display (due to missing fonts) can still +be copied and pasted.")) + (:ul (:li ((:a href #.(format nil "~ +http://www.columbia.edu/kermit/utf8.html") + target "_blank") + "UTF-8 Sampler")) + (:li ((:a href #.(format nil "~ +http://www.trigeminal.com/samples/provincial.html") + target "_blank") + #.(format nil "~ +The \"anyone can be provincial!\" page")))))))))))) + + +;; +;; the entry link to this demo: +;; +(publish + :path "/wordpuzzle" + :content-type "text/html; charset=utf-8" + :function + #-(and allegro ics (version>= 6 0 pre-final 1)) + #'(lambda (req ent) + (cannot-do-puzzle req ent)) + + + #+(and allegro ics (version>= 6 0 pre-final 1)) + #'(lambda (req ent) + ; test at runtime in case we compiled with an international lisp + ; and are running in an 8bit lisp + (if* (member :ics *features* :test #'eq) + then (can-do-puzzle req ent) + else (cannot-do-puzzle req ent)))) + + +(publish + :path "/wp_echo" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (let ((lookup + (assoc "char" (request-query req) + :test #'string=))) + (if* lookup + then (setq lookup + (let ((*read-base* 16)) + (read-from-string + (subseq (cdr lookup) + #.(length "u+") + #.(length "u+xxxx")))))) + (with-http-response (req ent) + (with-http-body (req ent + :external-format :utf8-base) + (html + (:html + (:head (:title "Character Description")) + (:body + (:p + (:princ (format nil "Unicode value: U+~4,'0x" + lookup))) + (:p + "Lisp Character Name: " + ((:font :size "+3") + (:prin1 (code-char lookup)))) + (:p + "Browser Font Display: " + ((:font :size "+3") + (:princ (code-char lookup))) + :br + #.(format nil "~ +Characters that appear as dots or empty boxes or question-marks likely look +that way because your browser is missing the needed font(s).")) + (let ((uglyph (format nil "~ +http://charts.unicode.org/Glyphs/~2,'0x/U~4,'0x.gif" + (ldb (byte 8 8) lookup) + lookup))) + (html ((:table border 0) + (:tr + (:td #.(format nil "~ +Glyph GIF (from Unicode web site -- not all characters have gifs):") + :br + (:princ (format nil "[Loading from `~a'.]" + uglyph))) + (:td + ((:img :src uglyph + :alt (format nil "~s" (code-char lookup)) + :border 2))))))) + (if* (cjk-p lookup) + then (if* (<= #xac00 lookup #xd7a3) + then (html (:p "Character is a Hangul Syllable.")) + else (html (:p #.(format nil "~ +Character is an ideograph from Chinese, Japanese, or Korean."))))) + (:p #.(format nil "~ +Use browser `Back' button to return to puzzle.")))))))))) Added: vendor/portableaserve/aserve/examples/tutorial.cl =================================================================== --- vendor/portableaserve/aserve/examples/tutorial.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/tutorial.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,156 @@ +;; -*- mode: common-lisp; package: tutorial -*- +;; +;; turorial.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: tutorial.cl,v 1.3 2002/12/26 19:55:44 rudi Exp $ + +;; Description: +;; iserver tutorial examples + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +(defpackage :tutorial + (:use :common-lisp :acl-compat.excl :net.aserve :net.html.generator)) + +(in-package :tutorial) + + +(publish :path "/hello" + :content-type "text/plain" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (princ "Hello World!" *html-stream*))))) + +(publish :path "/hello2" + :content-type "text/html" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html (:head (:title "Hello World Test")) + (:body + ((:font :color "red") "Hello ") + ((:font :color "blue") "World!")))))))) + + + +(publish :path "/hello-count" + :content-type "text/html" + :function + (let ((count 0)) + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "Hello Counter")) + (:body + ((:font :color (nth (random 5) + '("red" "blue" + "green" "purple" "black"))) + "Hello World had been called " + (:princ (incf count)) + " times"))))))))) + + +(publish :path "/queryform" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((name (cdr (assoc "name" (request-query req) + :test #'equal)))) + (with-http-response (req ent) + (with-http-body (req ent) + (if* name + then ; form was filled out, just say it + (html (:html + (:head (:title "Hi to " (:princ-safe name))) + (:body "Your name is " + (:b (:princ-safe name))))) + else ; put up the form + (html (:html + (:head (:title "Tell me your name")) + (:body + ((:form :action "queryform") + "Your name is " + ((:input :type "text" + :name "name" + :maxlength "20")))))))))))) + + +(publish :path "/charcount" + :content-type "text/html" + :function + #'(lambda (req ent) + (let* ((body (get-request-body req)) + (text (if* body + then (cdr (assoc "quotation" + (form-urlencoded-to-query body) + :test #'equal))))) + (with-http-response (req ent) + (with-http-body (req ent) + (if* text + then ; got the quotation, analyze it + (html + (:html + (:head (:title "Character Counts") + (:body + (:table + (do ((i #.(char-code #\a) (1+ i))) + ((> i #.(char-code #\z))) + (html (:tr + (:td (:princ (code-char i))) + (:td (:princ + (count (code-char i) + text))))))))))) + else ; ask for quotation + (html + (:html + (:head (:title "quote character counter") + (:body + ((:form :action "charcount" + :method "POST") + "Enter your favorite quote " + :br + ((:textarea + :name "quotation" + :rows 30 + :cols 50)) + :br + ((:input :type "submit" + :name "submit" + :value "count it"))))))))))))) + + + + + + + + + Added: vendor/portableaserve/aserve/examples/urian.cl =================================================================== --- vendor/portableaserve/aserve/examples/urian.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/examples/urian.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,453 @@ +;; -*- mode: common-lisp; package: net.aserve.examples -*- +;; +;; urian.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: urian.cl,v 1.3 2003/12/02 14:20:39 rudi Exp $ + +;; Description: +;; urian example + + +;; +;; Web page character analyzer. +;; This example retrieves a web page associated with a url, parses it with +;; parse-html, and then displays all texts found to have non-ascii characters. +;; Each character is a link. Clicking on one of these links displays a +;; description of the linked character. +;; +;; Original Author: Charles A. Cox, Franz Inc., October 2000 +;; +;; To use, compile/load this file into Allegro CL 6.0. Then, +;; start allegroserve, eg, (net.aserve:start :port 8000) starts on port 8000. +;; The main published page for this example is "/urian". + +(defpackage :urian + (:use :common-lisp :excl)) + +(in-package :urian) + +(eval-when (compile load eval) + #+allegro + (if* (not (featurep '(:version>= 6 0))) + then (error "This file not supported in Allegro CL releases earlier than 6.0")) + #-allegro (error "This file not supported on non-Allegro platforms")) + +(eval-when (compile load eval) + (require :aserve) + (handler-case (require :phtml) + ; didn't find it, check to see if it's where it would be in + ; a non-user file layout + (error (c) + (declare (ignore c)) + (let (name) + (if* (or (probe-file (setq name (concatenate 'string + (directory-namestring *load-pathname*) + "../xmlutils/phtml.fasl"))) + (probe-file (setq name (concatenate 'string + (directory-namestring *load-pathname*) + "../../xmlutils/phtml.fasl")))) + + then (load name) + else (format t " not at ~s~%, tn is ~s~%" name + *load-pathname*) + (error "can't locate phtml module")))))) + +(defpackage :urian + (:use :net.html.generator :net.aserve :net.html.parser)) + +(pushnew :x-sjis (ef-nicknames (find-external-format :shiftjis))) +(pushnew :shift-jis (ef-nicknames (find-external-format :shiftjis))) +(pushnew :iso-8859-1 (ef-nicknames (find-external-format :latin1))) +(pushnew :windows-1252 (ef-nicknames (find-external-format :1252))) + +(defparameter *blocks* + '((#x0000 #x007f "Basic Latin") + (#x0080 #x00ff "Latin-1 Supplement") + (#x0100 #x017f "Latin Extended-A") + (#x0180 #x024f "Latin Extended-B") + (#x0250 #x02af "IPA Extensions") + (#x02b0 #x02ff "Spacing Modifier Letters") + (#x0300 #x036f "Combining Diacritical Marks") + (#x0370 #x03ff "Greek") + (#x0400 #x04ff "Cyrillic") + (#x0530 #x058f "Armenian") + (#x0590 #x05ff "Hebrew") + (#x0600 #x06ff "Arabic") + (#x0700 #x074f "Syriac ") + (#x0780 #x07bf "Thaana") + (#x0900 #x097f "Devanagari") + (#x0980 #x09ff "Bengali") + (#x0a00 #x0a7f "Gurmukhi") + (#x0a80 #x0aff "Gujarati") + (#x0b00 #x0b7f "Oriya") + (#x0b80 #x0bff "Tamil") + (#x0c00 #x0c7f "Telugu") + (#x0c80 #x0cff "Kannada") + (#x0d00 #x0d7f "Malayalam") + (#x0d80 #x0dff "Sinhala") + (#x0e00 #x0e7f "Thai") + (#x0e80 #x0eff "Lao") + (#x0f00 #x0fff "Tibetan") + (#x1000 #x109f "Myanmar ") + (#x10a0 #x10ff "Georgian") + (#x1100 #x11ff "Hangul Jamo") + (#x1200 #x137f "Ethiopic") + (#x13a0 #x13ff "Cherokee") + (#x1400 #x167f "Unified Canadian Aboriginal Syllabics") + (#x1680 #x169f "Ogham") + (#x16a0 #x16ff "Runic") + (#x1780 #x17ff "Khmer") + (#x1800 #x18af "Mongolian") + (#x1e00 #x1eff "Latin Extended Additional") + (#x1f00 #x1fff "Greek Extended") + (#x2000 #x206f "General Punctuation") + (#x2070 #x209f "Superscripts and Subscripts") + (#x20a0 #x20cf "Currency Symbols") + (#x20d0 #x20ff "Combining Marks for Symbols") + (#x2100 #x214f "Letterlike Symbols") + (#x2150 #x218f "Number Forms") + (#x2190 #x21ff "Arrows") + (#x2200 #x22ff "Mathematical Operators") + (#x2300 #x23ff "Miscellaneous Technical") + (#x2400 #x243f "Control Pictures") + (#x2440 #x245f "Optical Character Recognition") + (#x2460 #x24ff "Enclosed Alphanumerics") + (#x2500 #x257f "Box Drawing") + (#x2580 #x259f "Block Elements") + (#x25a0 #x25ff "Geometric Shapes") + (#x2600 #x26ff "Miscellaneous Symbols") + (#x2700 #x27bf "Dingbats") + (#x2800 #x28ff "Braille Patterns") + (#x2e80 #x2eff "CJK Radicals Supplement") + (#x2f00 #x2fdf "Kangxi Radicals") + (#x2ff0 #x2fff "Ideographic Description Characters") + (#x3000 #x303f "CJK Symbols and Punctuation") + (#x3040 #x309f "Hiragana") + (#x30a0 #x30ff "Katakana") + (#x3100 #x312f "Bopomofo") + (#x3130 #x318f "Hangul Compatibility Jamo") + (#x3190 #x319f "Kanbun") + (#x31a0 #x31bf "Bopomofo Extended") + (#x3200 #x32ff "Enclosed CJK Letters and Months") + (#x3300 #x33ff "CJK Compatibility") + (#x3400 #x4db5 "CJK Unified Ideographs Extension A") + (#x4e00 #x9fff "CJK Unified Ideographs") + (#xa000 #xa48f "Yi Syllables") + (#xa490 #xa4cf "Yi Radicals") + (#xac00 #xd7a3 "Hangul Syllables") + (#xd800 #xdb7f "High Surrogates") + (#xdb80 #xdbff "High Private Use Surrogates") + (#xdc00 #xdfff "Low Surrogates") + (#xe000 #xf8ff "Private Use") + (#xf900 #xfaff "CJK Compatibility Ideographs") + (#xfb00 #xfb4f "Alphabetic Presentation Forms") + (#xfb50 #xfdff "Arabic Presentation Forms-A") + (#xfe20 #xfe2f "Combining Half Marks") + (#xfe30 #xfe4f "CJK Compatibility Forms") + (#xfe50 #xfe6f "Small Form Variants") + (#xfe70 #xfefe "Arabic Presentation Forms-B") + (#xfeff #xfeff "Specials") + (#xff00 #xffef "Halfwidth and Fullwidth Forms") + (#xfff0 #xfffd "Specials"))) + +(publish + :path "/urian" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (let* ((uri (cdr (assoc "uri" (request-query req) :test #'equal))) + (results nil)) + (when uri + (unless (find #\: uri) + (setq uri (concatenate 'string "http://" uri))) + (setq results (chanal uri))) + (with-http-response (req ent) + (with-http-body (req ent + :external-format :utf8-base) + (html + (:html + (:head (:title (:princ-safe + (format nil "String Analysis~@[ for `~a'~]" + uri)))) + (:body + (if* (stringp results) + then (html (:p "AllegroServe got error: " + (:b (:princ-safe results)))) + else (when results + (when (first results) + (html + (:p (:princ-safe + (format nil "Server set charset to `~s'." + (car (first results)))) + :br + (:princ-safe + (format nil "Switched to External-Format `~s'." + (ef-name (cdr (first results)))))))) + (when (second results) + (html + (:p (:princ-safe + (format + nil + "A page meta tag specified charset as `~s'." + (car (second results)))) + :br + (:princ-safe + (format + nil "Switched to external-format: `~s'." + (ef-name (cdr (second results)))))))) + (html (:p "Scanned URL: " ((:a :href uri + target "_blank") + (:princ-safe uri)))) + (if* (cddr results) + then (html + (:p + "The following texts were found to contain " + "non-ASCII characters. " + :br + "Click on a character for its description.")) + "Strings found on URL: " + (dolist (result (cddr results)) + (html + :hr + (san-html result *html-stream*))) + else (html + (:p + "No texts containing non-ASCII characters " + "were found on the page."))))) + :hr + (macrolet ((item (title url) + ;; Assumes title and url are string literals + (let ((ref (format nil "/urian?uri=~a" + (uriencode-string url)))) + `(html + (:ul (:li (:princ-safe ,title) + " (" + (:princ-safe ,url) + ")" + :br + ((:a href ,url + target "_blank") + "View Page (new browser window)") + :br + ((:a href ,ref) "Analyze"))))))) + (html + (:p + "Select a sample page:" + (item "UTF-8 Sampler" + "http://www.columbia.edu/kermit/utf8.html") + (item "The \"anyone can be provincial!\" page" + "http://www.trigeminal.com/samples/provincial.html") + (item "The Japan Netscape Netcenter Page" + "http://home.netscape.com/ja") + (item "The Spain Yahoo! Page" + "http://es.yahoo.com")))) + :br + ((:form :action "urian" + :method "get") + "Or Enter New URL to analyze: " + ((:input :type "text" :name "uri" :size 50))))))))))) + +(defun san-html (string stream) + (net.html.generator:html-stream + stream + (net.html.generator:html + (:p "\"" + (dotimes (i (length string)) + (net.html.generator:html + ((:a href + (format nil "/chdescribe?char=~a" + (net.aserve:uriencode-string + (format nil "u+~4,'0x:~s" + (char-code + (schar string i)) + (schar string i))))) + (:princ (schar string i))))) + "\"")))) + +(defun chanal (uri + &aux (server-ef nil) + (lhtml nil) + (metatag-ef nil)) + (handler-case + (multiple-value-bind (body response-code headers ruri) + (net.aserve.client:do-http-request uri :external-format :latin1-base) + (declare (ignore response-code ruri)) + (setq server-ef (let ((content-type (cdr (assoc :content-type + headers)))) + (find-charset-from-content-type content-type))) + (setq lhtml (net.html.parser:parse-html body)) + (setq metatag-ef (update-ef lhtml)) + (cons server-ef + (cons metatag-ef + (delete-duplicates + (chanal-body lhtml (or (cdr metatag-ef) + (cdr server-ef) + ;; www.yahoo.co.jp uses euc without + ;; specifying it. Let's try using + ;; euc, then, as default. + (crlf-base-ef + (find-external-format :latin1)))) + :test #'string=)))) + (error (c) + (format nil "~a" c)))) + +(defun chanal-body (body ef) + (if* (stringp body) + then (let ((s (octets-to-string + (string-to-octets body :external-format :latin1-base) + :external-format ef))) + (dotimes (i (length s)) + (when (> (char-code (schar s i)) #x7f) + ;; non-ascii + (return-from chanal-body (list s)))) + nil) + elseif (consp body) + then ;; skip unparsed <script> and <style> forms + (if* (or (eq :script (car body)) + (eq :style (car body)) + (eq :comment (car body)) + (and (listp (car body)) + (or (eq :script (caar body)) + (eq :style (caar body))))) + then nil + else (nconc (chanal-body (car body) ef) + (chanal-body (cdr body) ef))))) + +(defun find-charset-from-content-type (content-type) + (let ((charsetp (search "charset=" content-type + :test #'string-equal)) + (cs-name nil)) + (when charsetp + (setq cs-name (subseq content-type + (1+ (position #\= content-type + :start charsetp)) + (position #\; content-type + :start charsetp))) + (cons cs-name + (crlf-base-ef + (find-external-format + (let ((*package* (find-package :keyword))) + (read-from-string + (string-downcase cs-name))))))))) + +(defun update-ef (lhtml) + (when (listp lhtml) + (dolist (html-body lhtml) + (when (eq :html (car html-body)) + (let ((html-component (second html-body))) + (when (eq :head (car html-component)) + (dolist (x (cdr html-component)) + (let ((charset-string (charset-metatag-p x))) + (when charset-string + (return-from update-ef + (find-charset-from-content-type charset-string))))))))))) + +(defun charset-metatag-p (head-component) + (when (listp head-component) + (let ((arg-tag (car head-component))) + (when (and (listp arg-tag) + (eq :meta (car arg-tag))) + (when (equalp '(:http "http" :equiv "content-type" :content) + (subseq arg-tag 1 6)) + (return-from charset-metatag-p (elt arg-tag 6))) + (when (equalp '(:http-equiv "content-type" :content) + (subseq arg-tag 1 4)) + (return-from charset-metatag-p (elt arg-tag 4))))))) + + +(defmacro cjk-p (code) + `(or + ;; CJK Ideographs + (<= #x4e00 ,code #x9fff) + ;; Hangul Syllables + (<= #xac00 ,code #xd7a3))) + +(publish + :path "/chdescribe" + :content-type "text/html; charset=utf-8" + :function + #'(lambda (req ent) + (let ((lookup + (assoc "char" (request-query req) + :test #'string=))) + (when lookup + (setq lookup + (let ((*read-base* 16)) + (read-from-string + (subseq (cdr lookup) + #.(length "u+") + #.(length "u+xxxx")))))) + (with-http-response (req ent) + (with-http-body (req ent + :external-format :utf8-base) + (html + (:html + (:head (:title "Character Description")) + (:body + (:p + (:princ (format nil "Unicode value: U+~4,'0x" + lookup))) + (:p + "Lisp Character Name: " + ((:font :size "+3") + (:prin1 (code-char lookup)))) + (:p + "Browser Font Display: " + ((:font :size "+3") + (:princ (code-char lookup))) + :br + #.(format nil "~ +Characters that appear as dots or empty boxes or question-marks likely look +that way because your browser is missing the needed font(s).")) + (unless (cjk-p lookup) + (let ((uglyph (format nil "~ +http://charts.unicode.org/Glyphs/~2,'0x/U~4,'0x.gif" + (ldb (byte 8 8) lookup) + lookup))) + (html ((:table border 0) + (:tr + (:td #.(format nil "~ +Glyph GIF (from Unicode web site -- not all characters have gifs):") + :br + (:princ (format nil "[Loading from `~a'.]" + uglyph))) + (:td + ((:img :src uglyph + :alt (format nil "~s" (code-char lookup)) + :border 2)))))))) + (html + (:p "Character is in the " + (:b + (:princ + (dolist (b *blocks*) + (when (<= lookup (second b)) + (return (third b)))))) + " unicode block.") + (when (cjk-p lookup) + (html + (:p "More information may be available from Unicode site: " + (let ((upage (format nil "~ +http://charts.unicode.org/unihan/unihan.acgi$0x~4,'0x" + lookup))) + (html + ((:a href upage) (:princ-safe upage)))))))))))))))) Added: vendor/portableaserve/aserve/headers.cl =================================================================== --- vendor/portableaserve/aserve/headers.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/headers.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1131 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; headers.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: headers.cl,v 1.7 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; header parsing + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +(in-package :net.aserve) + +(defvar *header-byte-array* + ;; unsigned-byte 8 vector contains the characters referenced by + ;; the *header-lookup-array* . All characters are downcased. + ) + +(defvar *header-lookup-array* + ;; indexed by the length of the header name. + ;; value is list of (hba-index header-number) for all headers + ;; that have a name this length + ;; hba index is the index in the *header-byte-array* where the header + ;; name begins. + ;; the header-number is in index into.. + ) + + +;; *header-keyword-array* defvar'ed in main.cl +;; indexed by header-number, holds the keyword naming this header + +(defvar *header-name-array* + ;; indexed by header-number, holds the string containing the 'pretty' + ;; version of this header + ) + +(defvar *header-client-array* + ;; indexed by header number, contains a kwd symbol specifying how + ;; to treat his header when proxying a client request to a server + ) + +(defvar *header-server-array* + ;; indexed by header number, contains a kwd symbol specifying how + ;; to treat his header when proxying a server response to a client + ) + +#+ignore +(defvar *header-cache-match-array* + ;; indexed by header number. contains a kwd symbol or nil + ;; describing how matching should be done + ) + +(defvar *header-count* + ;; the number of headers we're tracking + ) + + +(defconstant *header-block-size* 4096) ; bytes in a header block +(defconstant *header-block-used-size-index* + ;; where the size of lower part of the buffer is kept + (- *header-block-size* 2)) +(defconstant *header-block-data-start-index* + ;; where the start of the lowest data block is stored + (- *header-block-size* 4)) + +(defmacro header-block-header-index (index) + ;; where in the buffer the 2byte entry for header 'index' is located + `(- *header-block-size* 6 (ash ,index 1))) + +(eval-when (compile eval) + ;; the headers from the http spec + ;; Following the header name we specify how to + ;; 1. transfer client request headers and + ;; 2 server response headers + ;; (header-name client server) + ;; client/server + ;; :p - pass this header on + ;; :np - don't pass this header on verbatim + ;; :nf - this header won't be found + ;; 3. how the proxy-cache compares a new request-header against + ;; the request header stored with a cached response. + ;; :mx - need exact match + ;; :mp - either exact match or no value for new request-header + ;; nil - no match needed + ;; + ;;***** note well: adding something to this table must be accompanied + ;; by modifying *headers-count* above and then removing all caches + ;; if we're using a proxy cache. + (defparameter *http-headers* + '(("Accept" :p :nf :mp) + ("Accept-Charset" :p :nf :mp) + ("Accept-Encoding" :p :nf :mp) + ("Accept-Language" :p :nf :mp) + ("Accept-Ranges" :p :nf :mx) + ("Age" :nf :p nil) + ("Allow" :nf :p nil) + ("Authorization" :p :nf :mx) + ("Cache-control" :p :p :mp) + ("Connection" :np :np nil) + ("Content-Disposition" :nf :nf nil) ; in multipart/form-data bodies + ("Content-Encoding" :p :p :mx) + ("Content-Language" :p :p :mx) + ("Content-Length" :np :np nil) + ("Content-Location" :p :p :mx) + ("Content-Md5" :p :p :mx) + ("Content-Range" :p :p :mx) + ("Content-Type" :p :p :mx) + ("Cookie" :p :p :mx) + ("Date" :p :p nil) + ("Etag" :nf :p nil) + ("Expect" :p :nf :mx) + ("Expires" :nf :p nil) + ("From" :p :nf :mp) ; mp? + ("Host" :p :nf :mx) + ("If-Match" :p :nf :mx) + ("If-Modified-Since" :p :n nil) + ("If-None-Match" :p :nf :mx) + ("If-Range" :p :nf :mx) + ("If-Unmodified-Since" :p :nf nil) + ("Last-Modified" :nf :p nil) + ("Location" :nf :p nil) + ("Max-Forwards" :np :nf nil) + ("Pragma" :p :p nil) ; on reloads browsers add pragms + ("Proxy-Authenticate" :nf :p nil) + ("Proxy-Authorization" :p :nf :mx) + ("Range" :p :nf :mx) + ("Referer" :p :nf nil) ; should we match? who cares.. + ("Retry-After" :nf :p nil ) + ("Server" :nf :p nil) + ("Set-Cookie" :nf :p nil) + ("Status" :nf :nf nil) ; not real header but found in cgi responses + ("TE" :p :nf :mx) + ("Trailer" :np :np nil) + ("Transfer-Encoding" :np :np nil) + ("Upgrade" :np :nf nil) + ("User-Agent" :p :nf :mp) + ("Vary" :nf :p nil) + ("Via" :np :np nil) ; modified by proxy both dierctions + ("Warning" :p :p :mx) + ("WWW-Authenticate" :nf :p nil) + ))) + +;; number of headers. +;; we take advantage of this being a constant in the code below and +;; in the proxy caches. If this number should change all proxy caches +;; should be removed. +(defconstant *headers-count* #.(length *http-headers*)) + +(defmacro header-block-data-start () + ;; return index right above the first data index object stored + `(- *header-block-size* 4 (* *headers-count* 2))) + + + + +(eval-when (compile eval) + (defmacro build-header-lookup-table () + (let ((max-length 0) + (total-length 0)) + ; compute max and total length + (dolist (header *http-headers*) + (setq header (car header)) + (let ((len (length header))) + (setq max-length (max max-length len)) + (incf total-length len))) + + (let ((header-byte-array (make-array total-length + :element-type '(unsigned-byte 8))) + (header-lookup-array (make-array (1+ max-length) :initial-element nil))) + + (let ((hba -1) + (header-number -1) + (header-kwds) + (plists) + ) + (dolist (header *http-headers*) + (setq header (car header)) + (let ((len (length header))) + + (setq header (string-downcase header)) + (let ((header-keyword (read-from-string + (format nil ":~a" + header)))) + (push header-keyword header-kwds) + (push (list (1+ hba) + (incf header-number)) + (aref header-lookup-array len)) + (push (cons header-keyword header-number) plists) + ) + + (dotimes (i len) + (setf (aref header-byte-array (incf hba)) + (char-code (schar header i)))))) + + + `(progn (setq *header-byte-array* ',header-byte-array) + (setq *header-lookup-array* ',header-lookup-array) + (setq *header-keyword-array* + ',(make-array (length header-kwds) + :initial-contents + (reverse header-kwds))) + (setq *header-name-array* + ',(make-array (length *http-headers*) + :initial-contents + (mapcar #'first *http-headers*))) + + (setq *header-client-array* + ',(make-array (length *http-headers*) + :initial-contents + (mapcar #'second *http-headers*))) + + (setq *header-server-array* + ',(make-array (length *http-headers*) + :initial-contents + (mapcar #'third *http-headers*))) + + #+ignore + (setq *header-cache-match-array* + ',(make-array (length *http-headers*) + :initial-contents + (mapcar #'fourth *http-headers*))) + + (setq *header-count* + ;; number of distinct headers + ,(1+ header-number)) + + (if* (not (eql *header-count* *headers-count*)) + then (error "setq *headers-count* to ~d in headers.cl" + *header-count*)) + + + (dolist (hkw ',plists) + (setf (get (car hkw) 'kwdi) (cdr hkw))) + + )))))) + + + +(build-header-lookup-table) + + + +(defparameter *header-block-sresource* + ;; 4096 element usb8 arrays + ;; used to hold header contents with index at the end + (create-sresource + :create #'(lambda (sresource &optional size) + (declare (ignore sresource)) + (if* size + then (error "size can't be specifed for header blocks")) + + (make-array *header-block-size* + :element-type '(unsigned-byte 8))))) + +(defparameter *header-block-plus-sresource* + ;; (+ 4096 100) element usb8 arrays + ;; used to hold things slight larger than a header block will hold + (create-sresource + :create #'(lambda (sresource &optional size) + (declare (ignore sresource)) + (if* size + then (error "size can't be specifed for header blocks")) + + (make-array (+ *header-block-size* 100) + :element-type '(unsigned-byte 8))))) + +(defparameter *header-index-sresource* + ;; used in parsing to hold location of header info in header-block + (create-sresource + :create #'(lambda (sresource &optional size) + (declare (ignore sresource)) + (if* size + then (error "size can't be specifed for header index")) + + (make-array *header-count* :initial-element nil)) + :init #'(lambda (sresource buffer) + (declare (ignore sresource)) + (dotimes (i (length buffer)) + (setf (svref buffer i) nil))))) + +(defun get-header-block () + (get-sresource *header-block-sresource*)) + + + + +(defun free-header-blocks (blocks) + ;; free a list of blocks + (dolist (block blocks) + (free-sresource *header-block-sresource* block))) + +(defun free-header-block (block) + (if* (and block (atom block)) + then (free-sresource *header-block-sresource* block) + elseif block + then (error "bad value passed to free-header-block ~s" block))) + + +(defun get-header-plus-block () + (get-sresource *header-block-plus-sresource*)) + +(defun free-header-plus-block (block) + (if* block then (free-sresource *header-block-plus-sresource* block))) + + +;; parsed header array +;; We have to work with headers and to reduce consing we work with +;; them in place in a structure called a parsed header block +;; This is stored in a 4096 byte usb8 vector. +;; The layout is: +;; headers and values .. empty .. data-block header-index-block min-db size +;; +;; The headers and values are exactly what's read from the web client/server. +;; they end in a crlf after the last value. +;; +;; The size is a 2 byte value specifying the index after the last +;; header value. It says where we can add new headers if we want. +;; All values greater than 2 bytes are stored in big endian form. +;; +;; min-db is a 2 byte value telling where the lowest data-block entry starts +;; +;; The header-index-block is 2 bytes per entry and specifies an index +;; into the data-block where a descriptor for the value associated with +;; this header are located. This file lists the headers we know about +;; and each is given an index. The header-index-block is stored +;; so that index 0 is closest to the end of the array +;; The data blocks have the format +;; count(1) start1(2) end1(2) ... ... startN(2) endN(2) +;; which describes how many header values there are and where they +;; are. end is one byte beyond the header value. + +(defmacro unsigned-16-value (array index) + (let ((gindex (gensym))) + `(let ((,gindex ,index)) + (declare (fixnum ,gindex)) + (the fixnum + (+ (the fixnum (ash (aref ,array ,gindex) 8)) + (aref ,array (1+ ,gindex))))))) + +(defsetf unsigned-16-value (array index) (value) + (let ((gindex (gensym)) + (gvalue (gensym))) + `(let ((,gindex ,index) + (,gvalue ,value)) + (setf (aref ,array ,gindex) (hipart ,gvalue)) + (setf (aref ,array (1+ ,gindex)) (lopart ,gvalue)) + ,gvalue))) + +(defmacro hipart (x) + `(the fixnum (logand #xff (ash (the fixnum ,x) -8)))) + +(defmacro lopart (x) + `(the fixnum (logand #xff (the fixnum ,x)))) + + + +(defun parse-header-block-internal (buff start end ans) + ;; the buff is an (unsigned-byte 8) array containing headers + ;; and their values from start to just before end. + ;; ans is a simple-vector large enough to hold *header-count* values. + ;; + ;; modify ans to store by header-number showing what, if any, values + ;; are associated with this header. The values are a list + ;; of cons (start . end) meaning the value is from start to end-1 + ;; spaces are trimmed from the sides + ;; + + (let ((i start) + (state 0) + beginhv + beginh + hnum + ch + otherheaders + otherheadername + ) + (macrolet ((tolower-set (loc) + ;; return the value at loc, convert it to lower + ;; case and store back if the conversion was done + (let ((var (gensym))) + `(let ((,var ,loc)) + (if* (<= #.(char-int #\A) ,var #.(char-int #\Z)) + then ; must lower case + (incf ,var #.(- (char-int #\a) (char-int #\A))) + (setf ,loc ,var)) + ,var)))) + + (block done + (loop + ;(format t "i: ~d, st ~d ch ~s~%" i state (code-char (aref buff i))) + (case state + (0 ; beginning a header + (if* (>= i end) + then (return)) + + ; starting out look for something in the character range + (setq ch (tolower-set (aref buff i))) + (if* (not (<= #.(char-int #\a) ch #.(char-int #\z))) + then ; this can't be a header start + ; skip to the eol + (setq state 1) + else ; got a header start, skip to the next colon + (setq beginh i) + (incf i) + (loop + (if* (>= i end) then (return-from done)) + + (setq ch (tolower-set (aref buff i))) + (if* (eq ch #.(char-int #\:)) + then ; found a header + (setq hnum + (locate-header buff beginh i)) + (incf i) + (if* (null hnum) + then ; unknown header, save specially + (setq otherheadername + (buffer-subseq-to-string + buff beginh (1- i)))) + (setq state 2) ; skip to value + (return) + else (incf i))))) + + (1 ; skip to eol ( a linefeed in this case) + (if* (>= i end) then (return)) + (loop + (setq ch (aref buff i)) + (if* (eq ch #.(char-int #\linefeed)) + then (setq state 0) + (incf i) + (return) + else (incf i)) + (if* (>= i end) then (return-from done)) + )) + + (2 ; accumulate a header value + (if* (>= i end) then (return)) + (if* (null beginhv) then (setq beginhv i)) + (loop + (setq ch (aref buff i)) + (if* (eq ch #.(char-int #\linefeed)) + then (incf i) + (return)) + (incf i) + (if* (>= i end) then (return-from done))) + + ; hit eol, but there still could be a continuation + (setq state 3)) + + (3 ; read a header line, now this could be a continuation + ; or a new header or eo headers + (if* (or (>= i end) + (not (eq (aref buff i) #.(char-int #\space)))) + then ; end of one header's value + ; backup and ignore cr lf + (let ((back (1- i))) + (loop + (let ((ch (aref buff back))) + (if* (or (eq ch #.(char-code #\return)) + (eq ch #.(char-code #\linefeed))) + then (decf back) + else (return)))) + + (incf back) + + ; now strip spaces from beginning + (loop + (if* (>= beginhv back) + then (return) + elseif (eq (aref buff beginhv) #.(char-code #\space)) + then (incf beginhv) + else (return))) + + ; strip from end + (loop + (if* (>= beginhv back) + then (return) + elseif (eq (aref buff (1- back)) + #.(char-code #\space)) + then (decf back) + else (return))) + + ; must keep the header items in the same order + ; they were received (according to the http spec) + (if* hnum + then ; known header + (let ((cur (svref ans hnum)) + (new (list (cons beginhv back)))) + (if* cur + then (setq cur (append cur new)) + else (setq cur new)) + + (setf (svref ans hnum) cur)) + else ; unknown header + (push (cons otherheadername + (buffer-subseq-to-string + buff beginhv back)) + otherheaders)) + + + (setq beginhv nil) + (setq state 0)) + else (setq state 2)))))) + + otherheaders))) + +(defun parse-header-block (buff start end) + (let ((ans (get-sresource *header-index-sresource*)) + (otherheaders)) + + (setq otherheaders (parse-header-block-internal buff start end ans)) + + ; store the info in ans into the buffer at the end + + (let* ((table-index (header-block-header-index 0)) + (data-index (header-block-data-start))) + (dotimes (i (length ans)) + (let ((data (svref ans i))) + (if* data + then ; must store data and an index to it + (let* ((data-len (length data)) + (size (+ 1 ; count + (ash data-len 2) ; 4 bytes per data entry + ))) + (decf data-index size) + + (setf (unsigned-16-value buff table-index) data-index) + + (setf (aref buff data-index) data-len) + (let ((i (1+ data-index))) + (dolist (datum data) + (setf (unsigned-16-value buff i) (car datum)) + (incf i 2) + + (setf (unsigned-16-value buff i) (cdr datum)) + (incf i 2)))) + else ; nothing there, zero it out + (setf (aref buff table-index) 0) + (setf (aref buff (1+ table-index)) 0))) + (decf table-index 2)) + + (setf (unsigned-16-value buff *header-block-used-size-index*) end) + (setf (unsigned-16-value buff *header-block-data-start-index* ) + data-index) + + + (if* (> end data-index) + then (error "header is too large"))) + + (free-sresource *header-index-sresource* ans) + otherheaders)) + + +(defun free-req-header-block (req) + ;; if the req has an associated header block, give it back + (free-sresource *header-block-sresource* (request-header-block req)) + (setf (request-header-block req) nil)) + + +(defun header-buffer-values (buff header-index) + ;; the buff is a usb8 array that has been built by parse-header-block + ;; we are asked to return the location of the value(s) for the header + ;; with the given index + ;; we return nil if the header has no value + ;; otherwise we return values + ;; start index + ;; end index + ;; list of (start-index . end-index) for the rest of the values, if any + + ;; be a nice guy and handle a symbolic header keyword name + (if* (symbolp header-index) + then (let ((ans (get header-index 'kwdi))) + (if* (null ans) + then (error "no such header as ~s" header-index)) + (setq header-index ans))) + + + (let ((table-index (header-block-header-index header-index)) + (data-index)) + + (setq data-index (unsigned-16-value buff table-index)) + + + (if* (< 0 data-index (length buff)) + then ; get values + (let ((count (aref buff data-index)) + (first-start (unsigned-16-value buff (+ 1 data-index))) + (first-end (unsigned-16-value buff (+ 3 data-index)))) + (if* (> count 1) + then ; must get a list of the rest + (incf data-index 5) + (let (res) + (dotimes (i (1- count)) + (push (cons (unsigned-16-value buff data-index) + (unsigned-16-value buff + (+ 2 data-index))) + res) + (incf data-index 4)) + (values first-start + first-end + (nreverse res))) + else (values first-start first-end)))))) + + +(defun buffer-subseq-to-string (buff start end) + ;; extract a subsequence of the usb8 buff and return it as a string + (let ((str (make-string (- end start)))) + (do ((i start (1+ i)) + (ii 0 (1+ ii))) + ((>= i end)) + (setf (schar str ii) + (code-char (aref buff i)))) + str)) + +(defun header-buffer-req-header-value (req header) + ;; see header-buffer-header-value for what this does. + (let ((buff (request-header-block req))) + ; there will be no buffer for http/0.9 requests + (and buff + (header-buffer-header-value (request-header-block req) header)))) + + +(defun header-buffer-header-value (buff header) + ;; header is a number or keyword symbol. + ;; return nil or the header value as a string + ;; + ;; according to the http spec, multiple headers with the same name + ;; is only allowed when the header value is a comma separated list + ;; of items, and the sequence of header values can be considered + ;; as one big value separated by commas + ;; + (if* (symbolp header) + then (setq header (get header 'kwdi))) + + (if* (fixnump header) + then + (multiple-value-bind (start end others) + (header-buffer-values buff header) + ; we only get the first value + (if* start + then (let ((ans (buffer-subseq-to-string buff start end))) + (if* others + then ; must concatente the others as well + (let (res) + (dolist (oth others) + (push (buffer-subseq-to-string buff + (car oth) + (cdr oth)) + res) + (push ", " res)) + (apply #'concatenate 'string ans res)) + else ans)))))) + + + +(defun locate-header (buff start end) + ;; find the header-index of the header between start and end in buff. + ;; buffer is an usb8 array. + ;; return nil if no match + (let ((size (- end start)) + (hba *header-byte-array*)) + (if* (< 0 size (length *header-lookup-array*)) + then (dolist (header (svref *header-lookup-array* size)) + (let ((begin (car header))) + (if* (dotimes (i size t) + (if* (not (eq (aref buff (+ start i)) + (aref hba (+ begin i)))) + then (return nil))) + then ; match + (return (cadr header)))))))) + + + + +(defun compute-client-request-headers (sock) + ;; for the client code we return a list of headers or signal + ;; an error. + ;; + (let* ((buff (get-sresource *header-block-sresource*)) + (end (read-headers-into-buffer sock buff))) + (if* end + then (prog1 (parse-and-listify-header-block buff end) + (free-sresource *header-block-sresource* buff)) + else (free-sresource *header-block-sresource* buff) + (error "Incomplete headers sent by server")))) + + +(defun parse-and-listify-header-block (buff end) + ;; buff is a header-block + ;; parse the headers in the block and then extract the info + ;; in assoc list form + (let ((ans (get-sresource *header-index-sresource*)) + (headers)) + + ; store the non-standard headers in the header array + (setq headers (parse-header-block-internal buff 0 end ans)) + + ; now cons up the headers + (dotimes (i *header-count*) + (let ((res (svref ans i))) + (if* res + then (let ((kwd (svref *header-keyword-array* i))) + (dolist (ent res) + (let ((start (car ent)) + (end (cdr ent))) + (let ((str (make-string (- end start)))) + (do ((i start (1+ i)) + (ii 0 (1+ ii))) + ((>= i end)) + (setf (schar str ii) + (code-char + (aref buff i)))) + + (push (cons kwd str) headers)))))))) + + (free-sresource *header-index-sresource* ans) + + headers)) + +(defun listify-parsed-header-block (buff) + ;; the header block buff has been parsed. + ;; we just extract all headers in conses + (let (res) + (dotimes (i *headers-count*) + (let ((val (header-buffer-header-value buff i))) + (if* val + then (push (cons (aref *header-keyword-array* i) val) res)))) + (nreverse res))) + + + +(defun initialize-header-block (buf) + ;; set the parsed header block buf to the empty state + + ; clear out the indicies pointing to the values + (let ((index (header-block-header-index 0))) + (dotimes (i *header-count*) + (setf (unsigned-16-value buf index) 0) + (decf index 2))) + + ; no headers yet + (setf (unsigned-16-value buf *header-block-used-size-index*) 0) + + ; start of where to put data + (setf (unsigned-16-value buf *header-block-data-start-index*) + (header-block-data-start)) + + buf) + + + +(defun copy-headers (frombuf tobuf header-array) + ;; copy the headers denoted as :p (pass) in header array + ;; in frombuf to the tobuf + ;; + ;; return the index after the last header stored. + (let ((toi 0) + (data-index (header-block-data-start)) + (this-data-index) + (header-index (header-block-header-index 0))) + (dotimes (i (length header-array)) + (if* (eq :p (svref header-array i)) + then ; passed intact + (multiple-value-bind (start end others) + (header-buffer-values frombuf i) + (if* start + then (let ((items (1+ (length others)))) + (decf data-index (1+ (* items 4))) + (setf (aref tobuf data-index) items) + + (setf (unsigned-16-value tobuf header-index) + data-index) + + + (setq this-data-index (1+ data-index))) + (loop + (if* (null start) then (return)) + (let ((name (svref *header-name-array* i))) + + ; copy in header name + (dotimes (j (length name)) + (setf (aref tobuf toi) (char-code (schar name j))) + (incf toi)) + + (setf (aref tobuf toi) #.(char-code #\:)) + (incf toi) + (setf (aref tobuf toi) #.(char-code #\space)) + (incf toi) + + ; set the start address + (setf (unsigned-16-value tobuf this-data-index) + toi) + (incf this-data-index 2) + + + ; copy in the header value + (do ((j start (1+ j))) + ((>= j end)) + (setf (aref tobuf toi) (aref frombuf j)) + (incf toi)) + + ; set the end address + (setf (unsigned-16-value tobuf this-data-index) + toi) + (incf this-data-index 2) + + + ; add the obligatory crlf + (setf (aref tobuf toi) #.(char-code #\return)) + (incf toi) + (setf (aref tobuf toi) #.(char-code #\linefeed)) + (incf toi)) + (let ((next (pop others))) + (if* next + then (setq start (car next) + end (cdr next)) + else (return)))) + else (setf (unsigned-16-value tobuf header-index) 0))) + else ; clear out the header index + (setf (unsigned-16-value tobuf header-index) 0)) + (decf header-index 2)) + + (setf (unsigned-16-value tobuf *header-block-used-size-index*) toi) + (setf (unsigned-16-value tobuf *header-block-data-start-index* ) + data-index) + + toi)) + + +(defun insert-header (buff header value) + ;; insert the header (kwd symbol or integer) at the end of the current buffer + ;; end is the index of the next buffer position to fill + ;; return the index of the first unfilled spot of the buffer + ;; + (if* (symbolp header) + then (let ((val (get header 'kwdi))) + (if* (null val) + then (error "no such header as ~s" header)) + (setq header val))) + (let ((end (unsigned-16-value buff *header-block-used-size-index*)) + (starth) + (endh)) + (let ((name (svref *header-name-array* header))) + (dotimes (j (length name)) + (setf (aref buff end) (char-code (schar name j))) + (incf end)) + (setf (aref buff end) #.(char-code #\:)) + (incf end) + (setf (aref buff end) #.(char-code #\space)) + (incf end) + (setq starth end) + (dotimes (j (length value)) + (setf (aref buff end) (char-code (schar value j))) + (incf end)) + (setq endh end) + (setf (aref buff end) #.(char-code #\return)) + (incf end) + (setf (aref buff end) #.(char-code #\linefeed)) + (incf end)) + + ; now insert the information about this header in the data list + (let ((this-data-index (unsigned-16-value buff (header-block-header-index + header))) + (data-start (unsigned-16-value buff *header-block-data-start-index*))) + (let ((count 0)) + (if* (not (zerop this-data-index)) + then ; must copy this one down and add to it + (setq count (aref buff this-data-index))) + (incf count) ; for our new one + (decf data-start (+ 1 (* count 4))) + (setf (unsigned-16-value buff (header-block-header-index header)) + data-start) + (setf (unsigned-16-value buff *header-block-data-start-index*) + data-start) + (setf (aref buff data-start) count) + ; copy in old stuff + (incf this-data-index) + (incf data-start) + (dotimes (i (* 4 (1- count))) + (setf (aref buff data-start) (aref buff this-data-index)) + (incf data-start) + (incf this-data-index)) + + ; store in new info + (setf (unsigned-16-value buff data-start) starth) + (setf (unsigned-16-value buff (+ 2 data-start)) endh))) + + ; new end of headers + (setf (unsigned-16-value buff *header-block-used-size-index*) end))) + + + +(defun insert-non-standard-header (buff name value) + ;; insert a header that's not know by index into the buffer + ;; + (setq name (string name)) + + (let ((end (unsigned-16-value buff *header-block-used-size-index*))) + (if* (> (+ end (length name) (length value) 4) + (header-block-data-start)) + then ; no room + (return-from insert-non-standard-header nil)) + + (dotimes (i (length name)) + (setf (aref buff end) (char-code (aref name i))) + (incf end)) + + (setf (aref buff end) #.(char-code #\:)) + (incf end) + + (setf (aref buff end) #.(char-code #\space)) + (incf end) + + (dotimes (i (length value)) + (setf (aref buff end) (char-code (aref value i))) + (incf end)) + + (setf (aref buff end) #.(char-code #\return)) + (incf end) + + (setf (aref buff end) #.(char-code #\linefeed)) + (incf end) + + (setf (unsigned-16-value buff *header-block-used-size-index*) end))) + + + + + +#+ignore +(defun insert-end-of-headers (buff end) + ;; put in the final crlf + (setf (aref buff end) #.(char-code #\return)) + (incf end) + (setf (aref buff end) #.(char-code #\linefeed)) + (incf end) + end) + + + +(defun header-match-values (request-block cache-block i exactp) + ;; compare the header value for the current request vrs the cache-block + ;; they match if they are identical + ;; or if (not exact) and the request-block value is not given. + ;; + (multiple-value-bind (rstart rend rest) + (header-buffer-values request-block i) + (multiple-value-bind (cstart cend cest) + (header-buffer-values cache-block i) + + (or (and (null rstart) (null cstart)) ; both not present + (and (null rstart) (not exactp)) ; not given in request and !exact + + ; check for both present and identical + (and rstart cstart + (eql (- rend rstart) (- cend cstart)) ; same size + (equal rest cest) + + (loop + (do ((rr rstart (1+ rr)) + (cc cstart (1+ cc))) + ((>= rr rend)) + (if* (not (eq (aref request-block rr) + (aref cache-block cc))) + then (return-from header-match-values nil))) + + (if* rest + then (setq rstart (caar rest) + rend (cdar rest) + + cstart (caar cest) + cend (cdar cest)) + (pop rest) + (pop cest) + else (return t)))))))) + + +(defun header-match-prefix-string (buff header string) + ;; match the prefix of the header vlue against the given string + + (if* (symbolp header) + then (let ((val (get header 'kwdi))) + (if* (null val) + then (error "no such header as ~s" header)) + (setq header val))) + + (multiple-value-bind (rstart rend) + (header-buffer-values buff header) + (if* (and rstart (>= (- rend rstart) (length string))) + then ; compare byte by byte + (dotimes (i (length string) t) + (if* (not (eql (ausb8 buff rstart) + (char-code (schar string i)))) + then (return nil)) + (incf rstart))))) + + +(defun header-empty-p (buff header) + ;; test to see if there is no value for this header + + (if* (symbolp header) + then (let ((val (get header 'kwdi))) + (if* (null val) + then (error "no such header as ~s" header)) + (setq header val))) + + (header-buffer-values buff header)) + + + +(defun add-trailing-crlf (buff xx) + ;; buff is a parsed header block. + ;; find the end of the data and add a crlf and then return the + ;; index right after the linefeed + (declare (ignore xx)) + (let ((size (unsigned-16-value buff *header-block-used-size-index*))) + (if* (not (<= 0 size (header-block-data-start))) + then (error "buffer likely isn't a parsed header block")) + + (setf (aref buff size) #.(char-code #\return)) + (setf (aref buff (1+ size)) #.(char-code #\linefeed)) + + (+ size 2))) + + + +#+ignore (defun testit () + ;; test the parsing + (let ((str (format nil "Date: 12 jul 2000 ~c~%User-Agent: zipp ~c~%Host: foo.com ~c~%Via: foo~c~% bar~c~% baz~c~%User-Agent: snorter~c~%" + #\return + #\return + #\return + #\return + #\return + #\return + #\return))) + (let ((thebuf (get-sresource *header-block-sresource*))) + (dotimes (i (length str)) + (setf (aref thebuf i) + (char-int (schar str i)))) + (parse-header-block thebuf 0 (length str)) + (setq *xx* thebuf) + + (format t "original~%") + (dump-header-block thebuf) + + (insert-header thebuf :last-modified "dec 11, 1945") + (insert-header thebuf :user-agent "new agent") + + (format t "after mod~%") + (dump-header-block thebuf) + + (let ((newbuf (get-sresource *header-block-sresource*))) + (copy-headers thebuf newbuf *header-client-array*) + (format t "after copy ~%") + (dump-header-block newbuf)) + ))) + + + + +(defun dump-header-block (thebuf &optional (str t)) + ;; debugging function to print out the contents of a block + ;; buffer that has been parsed and the parse table stored in it. + (dotimes (i *header-count*) + (multiple-value-bind (start end rest) + (header-buffer-values thebuf i) + (if* start + then (push (cons start end) rest)) + (dolist (res rest) + + (if* res + then (format str "~d: ~a ~s '" + i + (svref *header-name-array* i) + res) + (do ((ind (car res) (1+ ind))) + ((>= ind (cdr res))) + (write-char (code-char (aref thebuf ind)) str)) + (format str "'") + (terpri str)))))) + +(defun compute-request-headers (req) + ;; compute an alist of all headers from the request + ;; This is slow so it's meant to be used during debugging only. + ;; + (let (res) + (dotimes (i *header-count*) + (let ((val (header-buffer-req-header-value req i))) + (if* val + then (push (cons (aref *header-keyword-array* i) + val) + res)))) + (nreverse res))) + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/htmlgen/.cvsignore =================================================================== --- vendor/portableaserve/aserve/htmlgen/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/htmlgen/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/htmlgen/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.6/Mon Feb 9 14:11:02 2004// +/ChangeLog/1.2/Sun Jun 9 11:34:59 2002// +/htmlgen.asd/1.10/Thu Aug 5 04:46:48 2004// +/htmlgen.cl/1.7/Tue Dec 2 14:20:39 2003// +/test.cl/1.2/Sun Jun 9 11:34:59 2002// +D Added: vendor/portableaserve/aserve/htmlgen/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/htmlgen/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/htmlgen Added: vendor/portableaserve/aserve/htmlgen/CVS/Root =================================================================== --- vendor/portableaserve/aserve/htmlgen/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/htmlgen/ChangeLog =================================================================== --- vendor/portableaserve/aserve/htmlgen/ChangeLog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/ChangeLog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,51 @@ +2002-01-25 John Foderaro <jkf(a)tiger.franz.com> + + * the html macro will now macroexpand forms it sees before + determining if they are markup for expressions to evaluate + +2001-05-14 John Foderaro <jkf(a)tiger.franz.com> + + * add a method for specifying that an entity argument name should + listed alone without being followed by an equal sign and value. + This is an incompatible change in the unlikely event that you + have code that gives the symbol || as an argument value and + you expect this to be printed as ="" by the html printer + +2001-04-13 John Foderaro <jkf(a)tiger.franz.com> + + * add more support for templates + +2000-04-24 <jkf@CROW> + + * add html-print and html-print-list to print the lisp + form of html (lhtml) + +2000-04-16 <jkf@DEEDEE> + + * htmlgen/htmlgen.cl - when printing option values inside + a tag, a symbol is now printed as the string + that is its symbol-name + + +2000-03-29 John Foderaro <jkf(a)tiger.franz.com> + + * Undo previous change: html-stream must be passed a stream, + you can't pass in t or nil. + +2000-03-20 John Foderaro <jkf(a)tiger.franz.com> + + * html-stream will now accept t and nil as streams and + then use *terminal-io* and *standard-output* respectively. + +2000-02-08 John Foderaro <jkf(a)tiger.franz.com> + + * package htmlgen -> net.html.generator + +2000-02-04 John Foderaro <jkf(a)tiger.franz.com> + + * add escaping of characters inside attrib value + +1999-12-03 jkf <jkf(a)main.verada.com> + + * htmlgen.cl - added :if* operator inside a tag + Added: vendor/portableaserve/aserve/htmlgen/htmlgen.asd =================================================================== --- vendor/portableaserve/aserve/htmlgen/htmlgen.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/htmlgen.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +;;; -*- mode: lisp -*- + +(defpackage #:htmlgen-system + (:use #:cl #:asdf)) +(in-package #:htmlgen-system) + +(defclass acl-file (cl-source-file) ()) +(defmethod source-file-type ((c acl-file) (s module)) "cl") + +(defsystem htmlgen + :author "John K. Foderaro" + :licence "LLGPL" + :default-component-class acl-file + :components ((:file "htmlgen")) + :depends-on (acl-compat) + :perform (load-op :after (op htmlgen) + (pushnew :htmlgen cl:*features*))) + Added: vendor/portableaserve/aserve/htmlgen/htmlgen.cl =================================================================== --- vendor/portableaserve/aserve/htmlgen/htmlgen.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/htmlgen.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,753 @@ +;; -*- mode: common-lisp; package: net.html.generator -*- +;; +;; htmlgen.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; +;; $Id: htmlgen.cl,v 1.7 2003/12/02 14:20:39 rudi Exp $ + +;; Description: +;; html generator + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + +(defpackage :net.html.generator + (:use :common-lisp :acl-compat.excl) + (:export #:html + #:html-print + #:html-print-subst + #:html-print-list + #:html-print-list-subst + #:html-stream + #:*html-stream* + + + ;; should export with with-html-xxx things too I suppose + )) + +(in-package :net.html.generator) + +;; JSC - Handling binary output hack +;; The problem is that aserve uses the same socket for transfering +;; binary data (e.g. images) and text data (e.g. HTML). This kludge +;; solves this problem at the cost of I/O performance. + +(defun write-html-string (string &optional stream &key (start 0) end) + (if (and stream (equal (stream-element-type stream) + '(unsigned-byte 8))) + (loop :for i :from start :below (or end (length string)) + :do (write-byte (char-code (schar string i)) stream)) +; (loop :for c :across (subseq string start end) +; :do (write-byte (char-code c) stream)) + (write-string string stream :start start :end (or end (length string))))) + +;; html generation + +(defvar *html-stream*) ; all output sent here + +(defstruct (html-process (:type list) (:constructor + make-html-process (key has-inverse + macro special + print + name-attr + ))) + key ; keyword naming this tag + has-inverse ; t if the / form is used + macro ; the macro to define this + special ; if true then call this to process the keyword and return + ; the macroexpansion + print ; function used to handle this in html-print + name-attr ; attribute symbols which can name this object for subst purposes + ) + + +(defparameter *html-process-table* + (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes + ) + +(defvar *html-stream* nil) ; where the output goes + +(defmacro html (&rest forms &environment env) + ;; just emit html to the curfent stream + (process-html-forms forms env)) + +(defmacro html-out-stream-check (stream) + ;; ensure that a real stream is passed to this function + `(let ((.str. ,stream)) + (if* (not (streamp .str.)) + then (error "html-stream must be passed a stream object, not ~s" + .str.)) + .str.)) + + +(defmacro html-stream (stream &rest forms) + ;; set output stream and emit html + `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms))) + + + +(defun process-html-forms (forms env) + (let (res) + (flet ((do-ent (ent args argsp body) + ;; ent is an html-process object associated with the + ;; html tag we're processing + ;; args is the list of values after the tag in the form + ;; ((:tag &rest args) ....) + ;; argsp is true if this isn't a singleton tag (i.e. it has + ;; a body) .. (:tag ...) or ((:tag ...) ...) + ;; body is the body if any of the form + ;; + (let (spec) + (if* (setq spec (html-process-special ent)) + then ; do something different + (push (funcall spec ent args argsp body) res) + elseif (null argsp) + then ; singleton tag, just do the set + (push `(,(html-process-macro ent) :set) res) + nil + else (if* (equal args '(:unset)) + then ; ((:tag :unset)) is a special case. + ; that allows us to close off singleton tags + ; printed earlier. + (push `(,(html-process-macro ent) :unset) res) + nil + else ; some args + (push `(,(html-process-macro ent) ,args + ,(process-html-forms body env)) + res) + nil))))) + + + + (do* ((xforms forms (cdr xforms)) + (form (car xforms) (car xforms))) + ((null xforms)) + + (setq form (macroexpand form env)) + + (if* (atom form) + then (if* (keywordp form) + then (let ((ent (gethash form *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent nil nil nil))) + elseif (stringp form) + then ; turn into a print of it + (push `(write-html-string ,form *html-stream*) res) + else (push form res)) + else (let ((first (car form))) + (if* (keywordp first) + then ; (:xxx . body) form + (let ((ent (gethash first + *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent nil t (cdr form)))) + elseif (and (consp first) (keywordp (car first))) + then ; ((:xxx args ) . body) + (let ((ent (gethash (car first) + *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent (cdr first) t (cdr form)))) + else (push form res)))))) + `(progn ,@(nreverse res)))) + + +(defun html-atom-check (args open close body) + (if* (and args (atom args)) + then (let ((ans (case args + (:set `(write-html-string ,open *html-stream*)) + (:unset `(write-html-string ,close *html-stream*)) + (t (error "illegal arg ~s to ~s" args open))))) + (if* (and ans body) + then (error "can't have a body form with this arg: ~s" + args) + else ans)))) + +(defun html-body-form (open close body) + ;; used when args don't matter + `(progn (write-html-string ,open *html-stream*) + ,@body + (write-html-string ,close *html-stream*))) + + +(defun html-body-key-form (string-code has-inv args body) + ;; do what's needed to handle given keywords in the args + ;; then do the body + (if* (and args (atom args)) + then ; single arg + (return-from html-body-key-form + (case args + (:set `(write-html-string ,(format nil "<~a>" string-code) + *html-stream*)) + (:unset (if* has-inv + then `(write-html-string ,(format nil "</~a>" string-code) + *html-stream*))) + (t (error "illegal arg ~s to ~s" args string-code))))) + + (if* (not (evenp (length args))) + then (warn "arg list ~s isn't even" args)) + + + (if* args + then `(progn (write-string ,(format nil "<~a" string-code) + *html-stream*) + ,@(do ((xx args (cddr xx)) + (res)) + ((null xx) + (nreverse res)) + (if* (eq :if* (car xx)) + then ; insert following conditionally + (push `(if* ,(cadr xx) + then (write-string + ,(format nil " ~a" (caddr xx)) + *html-stream*) + (prin1-safe-http-string ,(cadddr xx))) + res) + (pop xx) (pop xx) + else + + (push `(write-string + ,(format nil " ~a" (car xx)) + *html-stream*) + res) + (push `(prin1-safe-http-string ,(cadr xx)) res))) + + + (write-string ">" *html-stream*) + ,@body + ,(if* (and body has-inv) + then `(write-string ,(format nil "</~a>" string-code) + *html-stream*))) + else `(progn (write-string ,(format nil "<~a>" string-code) + *html-stream*) + ,@body + ,(if* (and body has-inv) + then `(write-string ,(format nil "</~a>" string-code) + *html-stream*))))) + + + +(defun princ-http (val) + ;; print the given value to the http stream using ~a + (format *html-stream* "~a" val)) + +(defun prin1-http (val) + ;; print the given value to the http stream using ~s + (format *html-stream* "~s" val)) + + +(defun princ-safe-http (val) + (emit-safe *html-stream* (format nil "~a" val))) + +(defun prin1-safe-http (val) + (emit-safe *html-stream* (format nil "~s" val))) + + +(defun prin1-safe-http-string (val) + ;; used only in a parameter value situation + ;; + ;; if the parameter value is the symbol with the empty print name + ;; then turn this into a singleton object. Thus || is differnent + ;; than "". + ;; + ;; print the contents inside a string double quotes (which should + ;; not be turned into "'s + ;; symbols are turned into their name + (if* (and (symbolp val) + (equal "" (symbol-name val))) + thenret ; do nothing + else (write-char #\= *html-stream*) + (if* (or (stringp val) + (and (symbolp val) + (setq val (symbol-name val)))) + then (write-char #\" *html-stream*) + (emit-safe *html-stream* val) + (write-char #\" *html-stream*) + else (prin1-safe-http val)))) + + + +(defun emit-safe (stream string) + ;; send the string to the http response stream watching out for + ;; special html characters and encoding them appropriately + (do* ((i 0 (1+ i)) + (start i) + (end (length string))) + ((>= i end) + (if* (< start i) + then (write-html-string string + stream + :start start + :end i))) + + + (let ((ch (schar string i)) + (cvt )) + (if* (eql ch #\<) + then (setq cvt "<") + elseif (eq ch #\>) + then (setq cvt ">") + elseif (eq ch #\&) + then (setq cvt "&") + elseif (eq ch #\") + then (setq cvt """)) + (if* cvt + then ; must do a conversion, emit previous chars first + + (if* (< start i) + then (write-sequence string + stream + :start start + :end i)) + (write-string cvt stream) + + (setq start (1+ i)))))) + + + +(defun html-print-list (list-of-forms stream &key unknown) + ;; html print a list of forms + (dolist (x list-of-forms) + (html-print-subst x nil stream unknown))) + + +(defun html-print-list-subst (list-of-forms subst stream &key unknown) + ;; html print a list of forms + (dolist (x list-of-forms) + (html-print-subst x subst stream unknown))) + + +(defun html-print (form stream &key unknown) + (html-print-subst form nil stream unknown)) + + +(defun html-print-subst (form subst stream unknown) + ;; Print the given lhtml form to the given stream + (assert (streamp stream)) + + + (let* ((attrs) + (attr-name) + (name) + (possible-kwd (if* (atom form) + then form + elseif (consp (car form)) + then (setq attrs (cdar form)) + (caar form) + else (car form))) + print-handler + ent) + (if* (keywordp possible-kwd) + then (if* (null (setq ent (gethash possible-kwd *html-process-table*))) + then (if* unknown + then (return-from html-print-subst + (funcall unknown form stream)) + else (error "unknown html tag: ~s" possible-kwd)) + else ; see if we should subst + (if* (and subst + attrs + (setq attr-name (html-process-name-attr ent)) + (setq name (getf attrs attr-name)) + (setq attrs (html-find-value name subst))) + then + (return-from html-print-subst + (if* (functionp (cdr attrs)) + then + (funcall (cdr attrs) stream) + else (html-print-subst + (cdr attrs) + subst + stream + unknown))))) + + (setq print-handler + (html-process-print ent))) + (if* (atom form) + then (if* (keywordp form) + then (funcall print-handler ent :set nil nil nil nil stream) + elseif (stringp form) + then (write-string form stream) + else (princ form stream)) + elseif ent + then (funcall print-handler + ent + :full + (if* (consp (car form)) then (cdr (car form))) + form + subst + unknown + stream) + else (error "Illegal form: ~s" form)))) + + +(defun html-find-value (key subst) + ; find the (key . value) object in the subst list. + ; A subst list is an assoc list ((key . value) ....) + ; but instead of a (key . value) cons you may have an assoc list + ; + (let ((to-process nil) + (alist subst)) + (loop + (do* ((entlist alist (cdr entlist)) + (ent (car entlist) (car entlist))) + ((null entlist) (setq alist nil)) + (if* (consp (car ent)) + then ; this is another alist + (if* (cdr entlist) + then (push (cdr entlist) to-process)) + (setq alist ent) + (return) ; exit do* + elseif (equal key (car ent)) + then (return-from html-find-value ent))) + + (if* (null alist) + then ; we need to find a new alist to process + + (if* to-process + then (setq alist (pop to-process)) + else (return)))))) + +(defun html-standard-print (ent cmd args form subst unknown stream) + ;; the print handler for the normal html operators + (ecase cmd + (:set ; just turn it on + (format stream "<~a>" (html-process-key ent))) + (:full ; set, do body and then unset + (let (iter) + (if* args + then (if* (and (setq iter (getf args :iter)) + (setq iter (html-find-value iter subst))) + then ; remove the iter and pre + (setq args (copy-list args)) + (remf args :iter) + (funcall (cdr iter) + (cons (cons (caar form) + args) + (cdr form)) + subst + stream) + (return-from html-standard-print) + else + (format stream "<~a" (html-process-key ent)) + (do ((xx args (cddr xx))) + ((null xx)) + ; assume that the arg is already escaped + ; since we read it + ; from the parser + (format stream " ~a=\"~a\"" (car xx) (cadr xx))) + (format stream ">")) + else (format stream "<~a>" (html-process-key ent))) + (dolist (ff (cdr form)) + (html-print-subst ff subst stream unknown))) + (if* (html-process-has-inverse ent) + then ; end the form + (write-html-string (format nil "</~a>" (html-process-key ent)) stream))))) + + + + + + + + +;; -- defining how html tags are handled. -- +;; +;; most tags are handled in a standard way and the def-std-html +;; macro is used to define such tags +;; +;; Some tags need special treatment and def-special-html defines +;; how these are handled. The tags requiring special treatment +;; are the pseudo tags we added to control operations +;; in the html generator. +;; +;; +;; tags can be found in three ways: +;; :br - singleton, no attributes, no body +;; (:b "foo") - no attributes but with a body +;; ((:a href="foo") "balh") - attributes and body +;; + + + +(defmacro def-special-html (kwd fcn print-fcn) + ;; kwd - the tag we're defining behavior for. + ;; fcn - function to compute the macroexpansion of a use of this + ;; tag. args to fcn are: + ;; ent - html-process object holding info on this tag + ;; args - list of attribute-values following tag + ;; argsp - true if there is a body in this use of the tag + ;; body - list of body forms. + ;; print-fcn - function to print an lhtml form with this tag + ;; args to fcn are: + ;; ent - html-process object holding info on this tag + ;; cmd - one of :set, :unset, :full + ;; args - list of attribute-value pairs + ;; subst - subsitution list + ;; unknown - function to call for unknown tags + ;; stream - stream to write to + ;; + `(setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd nil nil ,fcn ,print-fcn nil))) + + +(def-special-html :newline + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + (if* body + then (error "can't have a body with :newline -- body is ~s" body)) + + `(terpri *html-stream*)) + + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent unknown subst)) + (if* (eq cmd :set) + then (terpri stream) + else (error ":newline in an illegal place: ~s" form))) + ) + + +(def-special-html :princ + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-http ,bod)) + body))) + + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent subst unknown)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (write-html-string (format nil "~a" (cadr form)) stream) + else (error ":princ must be given an argument"))) + ) + +(def-special-html :princ-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-safe-http ,bod)) + body))) + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent unknown subst)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (emit-safe stream (format nil "~a" (cadr form))) + else (error ":princ-safe must be given an argument")))) + +(def-special-html :prin1 + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-http ,bod)) + body))) + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore ent args unknown subst)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (format stream "~s" (cadr form)) + else (error ":prin1 must be given an argument"))) + + ) + + +(def-special-html :prin1-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-safe-http ,bod)) + body))) + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent subst unknown)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (emit-safe stream (format nil "~s" (cadr form))) + else (error ":prin1-safe must be given an argument")) + ) + ) + + +(def-special-html :comment + #'(lambda (ent args argsp body) + ;; must use  syntax + (declare (ignore ent args argsp)) + `(progn (write-html-string "" *html-stream*))) + + #'(lambda (ent cmd args form subst unknown stream) + (declare (ignore ent cmd args subst unknown)) + (write-html-string (format nil "" (cadr form)) stream))) + + + + +(defmacro def-std-html (kwd has-inverse name-attrs) + (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) + (string-code (string-downcase (string kwd)))) + `(progn (setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd ,has-inverse + ',mac-name + nil + #'html-standard-print + ',name-attrs)) + (defmacro ,mac-name (args &rest body) + (html-body-key-form ,string-code ,has-inverse args body))))) + + + +(def-std-html :a t nil) +(def-std-html :abbr t nil) +(def-std-html :acronym t nil) +(def-std-html :address t nil) +(def-std-html :applet t nil) +(def-std-html :area nil nil) + +(def-std-html :b t nil) +(def-std-html :base nil nil) +(def-std-html :basefont nil nil) +(def-std-html :bdo t nil) +(def-std-html :bgsound nil nil) +(def-std-html :big t nil) +(def-std-html :blink t nil) +(def-std-html :blockquote t nil) +(def-std-html :body t nil) +(def-std-html :br nil nil) +(def-std-html :button nil nil) + +(def-std-html :caption t nil) +(def-std-html :center t nil) +(def-std-html :cite t nil) +(def-std-html :code t nil) +(def-std-html :col nil nil) +(def-std-html :colgroup nil nil) + +(def-std-html :dd t nil) +(def-std-html :del t nil) +(def-std-html :dfn t nil) +(def-std-html :dir t nil) +(def-std-html :div t nil) +(def-std-html :dl t nil) +(def-std-html :dt t nil) + +(def-std-html :em t nil) +(def-std-html :embed t nil) + +(def-std-html :fieldset t nil) +(def-std-html :font t nil) +(def-std-html :form t :name) +(def-std-html :frame t nil) +(def-std-html :frameset t nil) + +(def-std-html :h1 t nil) +(def-std-html :h2 t nil) +(def-std-html :h3 t nil) +(def-std-html :h4 t nil) +(def-std-html :h5 t nil) +(def-std-html :h6 t nil) +(def-std-html :head t nil) +(def-std-html :hr nil nil) +(def-std-html :html t nil) + +(def-std-html :i t nil) +(def-std-html :iframe t nil) +(def-std-html :ilayer t nil) +(def-std-html :img nil :id) +(def-std-html :input nil nil) +(def-std-html :ins t nil) +(def-std-html :isindex nil nil) + +(def-std-html :kbd t nil) +(def-std-html :keygen nil nil) + +(def-std-html :label t nil) +(def-std-html :layer t nil) +(def-std-html :legend t nil) +(def-std-html :li t nil) +(def-std-html :link nil nil) +(def-std-html :listing t nil) + +(def-std-html :map t nil) +(def-std-html :marquee t nil) +(def-std-html :menu t nil) +(def-std-html :meta nil nil) +(def-std-html :multicol t nil) + +(def-std-html :nobr t nil) +(def-std-html :noembed t nil) +(def-std-html :noframes t nil) +(def-std-html :noscript t nil) + +(def-std-html :object t nil) +(def-std-html :ol t nil) +(def-std-html :optgroup t nil) +(def-std-html :option t nil) + +(def-std-html :p t nil) +(def-std-html :param t nil) +(def-std-html :plaintext nil nil) +(def-std-html :pre t nil) + +(def-std-html :q t nil) + +(def-std-html :s t nil) +(def-std-html :samp t nil) +(def-std-html :script t nil) +(def-std-html :select t nil) +(def-std-html :server t nil) +(def-std-html :small t nil) +(def-std-html :spacer nil nil) +(def-std-html :span t :id) +(def-std-html :strike t nil) +(def-std-html :strong t nil) +(def-std-html :style t nil) +(def-std-html :sub t nil) +(def-std-html :sup t nil) + +(def-std-html :table t :name) +(def-std-html :tbody t nil) +(def-std-html :td t nil) +(def-std-html :textarea t nil) +(def-std-html :tfoot t nil) +(def-std-html :th t nil) +(def-std-html :thead t nil) +(def-std-html :title t nil) +(def-std-html :tr t nil) +(def-std-html :tt t nil) + +(def-std-html :u t nil) +(def-std-html :ul t nil) + +(def-std-html :var t nil) + +(def-std-html :wbr nil nil) + +(def-std-html :xmp t nil) Added: vendor/portableaserve/aserve/htmlgen/test.cl =================================================================== --- vendor/portableaserve/aserve/htmlgen/test.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/htmlgen/test.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,73 @@ +(defpackage :user (:use :htmlgen)) + +(defun simple-table-a () + (with-open-file (p "~/public_html/test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body (:table + (:tr (:td "0") (:td "0")) + (:tr (:td "1") (:td "1")) + (:tr (:td "2") (:td "4")) + (:tr (:td "3") (:td "9")) + (:tr (:td "4") (:td "16")) + (:tr (:td "5") (:td "25")))))))) + +(defun simple-table-b () + (with-open-file (p "~/public_html/test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body ((:table border 2) + (:tr (:td "0") (:td "0")) + (:tr (:td "1") (:td "1")) + (:tr (:td "2") (:td "4")) + (:tr (:td "3") (:td "9")) + (:tr (:td "4") (:td "16")) + (:tr (:td "5") (:td "25")))))))) + + +(defun simple-table-c (count) + (with-open-file (p "~/public_html/test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body ((:table border 2) + (dotimes (i count) + (html (:tr (:td (:princ i)) + (:td (:princ (* i i)))))))))))) + +(defun simple-table-d (count border-width backg-color border-color) + (with-open-file (p "~/public_html/test.html" + :direction :output + :if-exists :supersede) + + (html-stream p + (:html + (:head (:title "Test Table")) + (:body ((:table border border-width + bordercolor border-color + bgcolor backg-color + cellpadding 3) + (:tr ((:td bgcolor "blue") + ((:font :color "white" :size "+1") + "Value")) + ((:td bgcolor "blue") + ((:font :color "white" :size "+1") + "Square")) + ) + (dotimes (i count) + (html (:tr (:td (:princ i)) + (:td (:princ (* i i)))))))))))) + + + Added: vendor/portableaserve/aserve/license-allegroserve.txt =================================================================== --- vendor/portableaserve/aserve/license-allegroserve.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/license-allegroserve.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,66 @@ +Prequel to the Gnu Lesser General Public License + +Copyright (c) 2000 Franz Inc., Berkeley, CA 94704 + +Franz Inc. has adopted the concept of the GNU Lesser General Public +License version 2.1 ("LGPL") to govern the use and distribution of +AllegroServe. However, LGPL uses terminology that is more appropriate +for a program written in C than one written in Lisp. Nevertheless, +LGPL can still be applied to a Lisp program if certain clarifications +are made. This document details those clarifications. + +Accordingly, the license for AllegroServe consists of this document +plus LGPL. Wherever there is a conflict between this document and +LGPL, this document takes precedence over LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. + +A Lisp application may include the same set of Lisp objects as does a +Library, but this does not mean that the application is necessarily a +"work based on the Library" it contains. + +The AllegroServe Library consists of everything in the AllegroServe +distribution file set before any modifications are made to the files. +If any of the functions or classes in the AllegroServe Library are +redefined in other files, then those redefinitions ARE considered a +work based on the AllegroServe Library. If additional methods are +added to generic functions in the AllegroServe Library, those +additional methods are NOT considered a work based on the AllegroServe +Library. If AllegroServe classes are subclassed, these subclasses are +NOT considered a work based on the AllegroServe Library. If the +AllegroServe Library is modified to explicitly call other functions +that are neither part of Lisp itself nor an available add-on module to +Lisp, then the functions called by the modified AllegroServe Library +ARE considered a work based on the AllegroServe Library. The goal is +to ensure that the AllegroServe Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the AllegroServe +Library, but it must be done in a way such that the AllegroServe +Library will still run without that proprietary code present. + +Section 5 of the LGPL distinguishes between the case of a library +being dynamically linked at runtime and one being statically linked at +build time. Section 5 of the LGPL states that the former results in an +executable that is a "work that uses the Library." Section 5 of the +LGPL states that the latter results in one that is a "derivative of +the Library", which is therefore covered by LGPL. Since Lisp only +offers one choice, which is to link the Library into an executable at +build time, we declare that, for the purpose applying LGPL to the +AllegroServe Library, an executable that results from linking a "work +that uses the AllegroServe Library" with the Library is considered a +"work that uses the Library" and is therefore NOT covered by LGPL. +Because of this declaration, section 6 of LGPL is not applicable to +the AllegroServe Library. However, in connection with each +distribution of this executable, you must also deliver, in accordance +with the terms and conditions of the LGPL, the source code of +AllegroServe Library (or your derivative thereof) that is incorporated +into this executable. Added: vendor/portableaserve/aserve/license-lgpl.txt =================================================================== --- vendor/portableaserve/aserve/license-lgpl.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/license-lgpl.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,459 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + Added: vendor/portableaserve/aserve/load.cl =================================================================== --- vendor/portableaserve/aserve/load.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/load.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,352 @@ +;; load in aserve +;; +;; $Id: load.cl,v 1.5 2004/04/26 18:18:37 kevinrosenberg Exp $ +;; + +; +; loading this file will compile and load AllegroServe and Webactions +; +; calling (make-aserve.fasl) will build +; aserve.fasl - just allegroserve +; webactions/webactions.fasl - just webactions +; + +(defvar *loadswitch* :compile-if-needed) +(defparameter *aserve-root* (directory-namestring *load-pathname*)) + +(defparameter *aserve-files* + ;; this list is in cl/src/sys/make.cl as well... keep in sync + '("htmlgen/htmlgen" + "packages" + "macs" + "main" + "headers" + "parse" + "decode" + "publish" + "authorize" + "log" + "client" + "proxy" + "cgi" + )) + +(defparameter *aserve-other-files* + ;; other files that make up the aserve dist + '("readme.txt" + "source-readme.txt" + "ChangeLog" + "htmlgen/ChangeLog" + "license-lgpl.txt" + "license-allegroserve.txt" + "examples/examples.cl" + "examples/foo.txt" + "examples/fresh.jpg" + "examples/prfile9.jpg" + "examples/tutorial.cl" + "examples/aservelogo.gif" + "examples/aservepowered.gif" + "examples/chat.cl" + "examples/file2000.txt" + "examples/puzzle.cl" + "examples/urian.cl" + "examples/locale.cl" + "load.cl" + "test/t-aserve.cl" + "test/server.pem" + "test/testdir/suba/subsuba/foo.html" + "test/testdir/suba/access.cl" + "test/testdir/suba/foo.html" + "test/testdir/suba/subd/ddd.html" + "test/testdir/subc/ccc.html" + "test/testdir/subd/ddee.html" + "test/testdir/access.cl" + "test/testdir/aaa.foo" + "test/testdir/bbb.ign" + "test/testdir/ccc.html" + "test/testdir/readme" + "test/testdir/subb/access.cl" + "test/testdir/subb/foo.html" + "examples/cgitest.sh" + "doc/aserve.html" + "doc/tutorial.html" + "doc/htmlgen.html" + "doc/cvs.html" + )) + +(defparameter *aserve-examples* + '("examples/examples" + "examples/puzzle" + "examples/urian" + "examples/locale" + )) + +(defparameter *aserve-international-only* + ;; files that should only be loaded into a international lisp + '("examples/puzzle" + "examples/urian" + "examples/locale" + )) + + + +(defparameter *webactions-files* + ;; this list of source files that are compiled to make + ;; webactions + '("webactions/clpage" + "webactions/webact" + "webactions/websession" + + "webactions/clpcode/clp" + "webactions/clpcode/wa" + "webactions/clpcode/http" + "webactions/clpcode/time")) + +(defparameter *webactions-other-files* + ;; other files to distribute with a source distribution + '("webactions/load.cl" + "webactions/doc/using-webactions.html" + "webactions/doc/webactions.html" + "webactions/test/t-webactions.cl" + "webactions/test/sitea/project.cl" + "webactions/test/sitea/file1.clp" + "webactions/test/sitea/file2.clp" + "webactions/test/sitea/file3.clp")) + + +#-allegro +(defun >-num (x y) + "Return T if x and y are numbers and x > y" + (and (numberp x) (numberp y) (> x y))) + +#-allegro +(defun newer-file-p (file1 file2) + "Is file1 newer (written later than) file2?" + (>-num (if (probe-file file1) (file-write-date file1)) + (if (probe-file file2) (file-write-date file2)))) + +#-allegro +(defun compile-file-if-needed (src-path &rest args) + "Compiles a file if needed, returns path. For CLISP, needs to be +passed a non-logical pathname" + (unless dest-path + (setq dest-path (compile-file-pathname src-path)) + (setq dest-path + (make-pathname :defaults dest-path + :directory (append-binary-directory + (pathname-directory dest-path))))) + (when (or (not (probe-file dest-path)) + (newer-file-p src-path dest-path)) + (ensure-directories-exist dest-path) + (compile-file src-path :output-file dest-path)) + dest-path) + +;; end experimental + +(eval-when (compile eval load) + (require :sock) ;; so we can tell if we have hiper sockets + ) +;(setq *features* (delete :hiper-socket *features*)) + +(with-compilation-unit nil + (dolist (file (append *aserve-files* *aserve-examples* + *webactions-files*)) + #+allegro-cl-lite + (progn + ;; aServe doesn't work very well under 5.0.1 Lite due to + ;; socket problem which are patched in the normal 5.0.1 but + ;; not the lite version + (if* (equal file "examples/examples") + then (load (merge-pathnames (format nil "~a.cl" file) + *load-pathname*)) + else (excl:load-compiled (merge-pathnames (format nil "~a.cl" file) + *load-pathname*))) + (gc t) ; must compact to keep under the heap limit + ) + #-allegro-cl-lite + (if* (or (member :ics *features* :test #'eq) + (not (member file *aserve-international-only* :test #'equal))) + then (progn (case *loadswitch* + (:compile-if-needed (compile-file-if-needed + (merge-pathnames (format nil "~a.cl" file) + *load-pathname*))) + (:compile (compile-file + (merge-pathnames (format nil "~a.cl" file) + *load-pathname*))) + (:load nil)) + (load (merge-pathnames + (format nil "~a.fasl" file) + *load-pathname*)))))) + + + +;; after running this function you'll have a lisp binary +;; with the webserver loaded. +;; you can cd to aserveserver and start with +;; nohup ./aserverserver -f ../examples/examples.fasl >& errs & +;; and it will run the server in the background, serving the aserve +;; examples. +;; +(defun makeapp () + (run-shell-command "rm -fr aserveserver" :show-window :hide) + (make-aserve.fasl) + (generate-application + "aserveserver" + "aserveserver/" + '(:sock :process :defftype :foreign + :ffcompat "aserve.fasl") + ; strange use of find-symbol below so this form can be read without + ; the net.aserve package existing + :restart-init-function (find-symbol (symbol-name :start-cmd) :net.aserve) + :application-administration '(:resource-command-line + ;; Quiet startup: + "-Q") + :read-init-files nil + :print-startup-message nil + :purify nil + :include-compiler nil + :include-devel-env nil + :include-debugger t + :include-tpl t + :include-ide nil + :discard-arglists t + :discard-local-name-info t + :discard-source-file-info t + :discard-xref-info t + + :ignore-command-line-arguments t + :suppress-allegro-cl-banner nil)) + + +(defun make-distribution () + ;; make a distributable version of aserve + + (run-shell-command (format nil "rm -fr ~aaserve-dist" *aserve-root*) + :show-window :hide) + + (copy-files-to *aserve-files* "aserve.fasl" :root *aserve-root*) + + (dolist (file '("aserve.fasl" + "doc/aserve.html" + "doc/tutorial.html" + "doc/htmlgen.html" + "doc/cvs.html" + "readme.txt" + "examples/examples.cl" + "examples/examples.fasl" + "examples/foo.txt" + "examples/fresh.jpg" + "examples/prfile9.jpg" + "examples/cgitest.sh")) + (copy-files-to (list file) + (format nil "aserve-dist/~a" file) + :root *aserve-root*))) + + +;; checklist for publishing aserve source for source-master: +;; 1. incf version number in main.cl,doc/aserve.html, edit ChangeLog and commit +;; 2. make clean +;; 3. start lisp and load aserve/load to compile all files, there should +;; be no warnings. +;; 4. start the server (net.aserve:start :port 8000) +;; and run through the samples from Netscape and IE +;; 5a. :cl test/t-aserve +;; 5b: :cl webactions/test/t-webactions +;; 6. (make-src-distribution) +;; 7. (ftp-publish-src) +;; 8. on cobweb in /fi/opensource/src/aserve +;; do cvs update to put code on opensource site +;; 9. on spot run /fi/sa/bin/aserve-sync +;; 10. ftp upload.sourceforge.net and put the tar file in the +;; incoming directory, then go to the aserve sourceforge web page and +;; select the file manager and publish it. +;; 11. cd /www/opensource/devel/www/aserve +;; on cobweb and rsync the files with SourceForge + + +(defparameter aserve-version-name + (apply #'format nil "aserve-~d.~d.~d" + (symbol-value + (find-symbol + (symbol-name :*aserve-version*) + :net.aserve)))) + + +(defun make-aserve.fasl () + ;; make both aserve and webactions + (copy-files-to *aserve-files* "aserve.fasl" :root *aserve-root* + :verbose t) + (copy-files-to *webactions-files* "webactions/webactions.fasl" + :root *aserve-root* + :verbose t) + ) + + + +(defun make-src-distribution (&optional (dist-name aserve-version-name)) + ;; make a source distribution of aserve + + (run-shell-command (format nil "rm -fr ~aaserve-src" *aserve-root*) + :show-window :hide) + + (dolist (file (append (mapcar (lambda (file) (format nil "~a.cl" file)) + (append *aserve-files* + *webactions-files*)) + *aserve-other-files* + *webactions-other-files*)) + (copy-files-to (list file) + (format nil "aserve-src/~a/~a" dist-name file) + :root *aserve-root*))) + + +(defun ftp-publish-src () + ;; assuming tha we've made the source distribution, tar it + ;; and copy it to the ftp directory + (run-shell-command + (format nil "(cd ~aaserve-src ; tar cfz ~a.tgz ~a)" + *aserve-root* + aserve-version-name + aserve-version-name) + :show-window :hide) + (run-shell-command + (format nil "cp ~aaserve-src/~a.tgz /net/cobweb/home/ftp/pub/aserve" + *aserve-root* + aserve-version-name) + :show-window :hide)) + +(defun publish-docs () + ;; copy documentation to the external web site + (run-shell-command + (format nil "cp ~adoc/htmlgen.html ~adoc/aserve.html ~adoc/tutorial.html /net/cobweb/www/opensource/devel/www/aserve" + *aserve-root* + *aserve-root* + *aserve-root*) + :show-window :hide) + (run-shell-command "rsh cobweb bin/sync-a-opensource" + :show-window :hide)) + + + + +(defun copy-files-to (files dest &key (root "") verbose) + ;; copy the contents of all files to the file named dest. + ;; append .fasl to the filenames (if no type is present) + + (setq dest (concatenate 'string root dest)) + (ensure-directories-exist dest) + + (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (p dest :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if* verbose + then (format t "Creating ~s~%" dest)) + (dolist (file files) + (setq file (concatenate 'string root file)) + (if* (and (null (pathname-type file)) + (not (probe-file file))) + then (setq file (concatenate 'string file ".fasl"))) + (with-open-file (in file :element-type '(unsigned-byte 8)) + (loop + (let ((count (read-sequence buffer in))) + (if* (<= count 0) then (return)) + (write-sequence buffer p :end count)))))))) Added: vendor/portableaserve/aserve/loadonly.cl =================================================================== --- vendor/portableaserve/aserve/loadonly.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/loadonly.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +(defparameter *loadswitch* :load) Added: vendor/portableaserve/aserve/log.cl =================================================================== --- vendor/portableaserve/aserve/log.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/log.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,168 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; log.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: log.cl,v 1.12 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; iserve's logging + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +(in-package :net.aserve) + +(defvar *enable-logging* t) ; to turn on/off the standard logging method + +(defmethod logmess (message) + ;; send log message to the default vhost's error stream + (logmess-stream message (vhost-error-stream + (wserver-default-vhost + *wserver*)))) + + + +(defmethod logmess-stream (message stream) + ;; send the log message to the given stream which should be a + ;; stream object and not a stream indicator (like t) + ;; If the stream has a lock use that. + (multiple-value-bind (csec cmin chour cday cmonth cyear) + (decode-universal-time (get-universal-time)) + (let* ((*print-pretty* nil) + (str (format + nil + "~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%" + (acl-compat.mp:process-name acl-compat.mp:*current-process*) + cmonth cday (mod cyear 100) + chour cmin csec + message)) + (lock #+allegro (getf (excl::stream-property-list stream) :lock) + #-allegro nil)) + (if* lock + then (acl-compat.mp:with-process-lock (lock) + (if* (open-stream-p stream) + then (write-sequence str stream) + (finish-output stream))) + else (write-sequence str stream) + (finish-output stream))))) + +(defmethod brief-logmess (message) + ;; omit process name and month, day, year + (multiple-value-bind (csec cmin chour) + (decode-universal-time (get-universal-time)) + (let* ((*print-pretty* nil) + (stream (vhost-error-stream + (wserver-default-vhost + *wserver*))) + (str (format nil + "~2,'0d:~2,'0d:~2,'0d - ~a~%" + chour cmin csec + message)) + (lock #+allegro (getf (excl::stream-property-list stream) :lock) + #-allegro nil)) + (if* lock + then (acl-compat.mp:with-process-lock (lock) + (setq stream (vhost-error-stream + (wserver-default-vhost + *wserver*))) + (write-sequence str stream) + (finish-output stream)) + else (write-sequence str stream) + (finish-output stream))))) + + + + + +(defun log-timed-out-request-read (socket) + (logmess (format nil "No request read from address ~a" + (acl-compat.socket:ipaddr-to-dotted (acl-compat.socket:remote-host socket))))) + + + +(defmethod log-request ((req http-request)) + ;; after the request has been processed, write out log line + (if* *enable-logging* + then (let* ((ipaddr (acl-compat.socket:remote-host (request-socket req))) + (time (request-reply-date req)) + (code (let ((obj (request-reply-code req))) + (if* obj + then (response-number obj) + else 999))) + (length (or (request-reply-content-length req) + #+(and allegro (version>= 6)) + (excl::socket-bytes-written + (request-socket req)))) + + (stream (vhost-log-stream (request-vhost req))) + + (lock #+allegro (and (streamp stream) + (getf (excl::stream-property-list stream) + :lock)) + #-allegro nil)) + + (macrolet ((do-log () + '(progn (format stream + "~a - - [~a] ~s ~s ~s~%" + (acl-compat.socket:ipaddr-to-dotted ipaddr) + (maybe-universal-time-to-date time) + (request-raw-request req) + code + (or length -1)) + (force-output stream)))) + + (if* lock + then (acl-compat.mp:with-process-lock (lock) + ; in case stream switched out while we weren't busy + ; get the stream again + (setq stream (vhost-log-stream (request-vhost req))) + (do-log)) + else (do-log)))))) + + + + +(defun log-proxy (uri level action extra) + ;; log information from the proxy module + ;; + (brief-logmess + (format nil "~a ~d ~a ~a~@[ ~s~]" + (or (getf (acl-compat.mp:process-property-list acl-compat.mp:*current-process*) + 'short-name) + (acl-compat.mp:process-name acl-compat.mp:*current-process*)) + level + action + (if* (stringp uri) + then uri + else (puri:render-uri uri nil)) + extra)) + (force-output (vhost-error-stream + (wserver-default-vhost + *wserver*)))) + + + + Added: vendor/portableaserve/aserve/macs.cl =================================================================== --- vendor/portableaserve/aserve/macs.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/macs.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,225 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; macs.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; +;; $Id: macs.cl,v 1.10 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; useful internal macros + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + +;; macros used by iserve + + +(in-package :net.aserve) + +;; add features based on the capabilities of the host lisp +#+(and allegro (version>= 6 1)) +(pushnew :io-timeout *features*) ; support i/o timeouts + +;; Note for people using this code in non-Allegro lisps. +;; +;; The if* macro used in this code can be found at: +;; +;; http://www.franz.com/~jkf/ifstar.txt +;; + + +;; macros to speed up some common character operations +(defmacro find-it (ch buff start end) + ;; return position of ch in buff from [start end} + ;; + (let ((pos (gensym))) + `(do ((,pos ,start (1+ ,pos))) + ((>= ,pos ,end)) + (if* (eq (schar ,buff ,pos) ,ch) + then (return ,pos))))) + +(defmacro find-it-rev (ch buff start end) + ;; return position of ch in buff from [start end} + ;; searching backwards + ;; + (let ((pos (gensym))) + `(do ((,pos (1- ,end) (1- ,pos))) + ((< ,pos ,start)) + (if* (eq (schar ,buff ,pos) ,ch) + then (return ,pos))))) + +(defmacro buffer-substr (buff start end) + ;; return a string holding the chars in buff from [start end } + ;; + (let ((res (gensym)) + (i (gensym)) + (pos (gensym))) + `(let ((,res (make-string (- ,end ,start)))) + (do ((,i 0 (1+ ,i)) + (,pos ,start (1+ ,pos))) + ((>= ,pos ,end)) + (setf (schar ,res ,i) (schar ,buff ,pos))) + ,res))) + +(defmacro buffer-match (buff start str) + ;; return t if the buffer buff contains the same string as str + (let ((pos (gensym)) + (i (gensym)) + (len (gensym))) + + `(do ((,pos ,start (1+ ,pos)) + (,i 0 (1+ ,i)) + (,len (length ,str))) + ((>= ,i ,len) t) + (if* (not (eq (schar ,buff ,pos) (schar ,str ,i))) + then (return nil))))) + +(defmacro buffer-match-ci (buff start str) + ;; return t if the buffer buff contains the same string as str + ;; case insensitive version where str contains each char doubled + (let ((pos (gensym)) + (i (gensym)) + (len (gensym)) + (xchar (gensym))) + + `(do ((,pos ,start (1+ ,pos)) + (,i 0 (+ 2 ,i)) + (,len (length ,str))) + ((>= ,i ,len) t) + (let ((,xchar (schar ,buff ,pos))) + (if* (not (or (eq ,xchar (schar ,str ,i)) + (eq ,xchar (schar ,str (1+ ,i))))) + then (return nil)))))) + + +(defmacro rational-read-sequence (&rest args) + ;; acl's read-sequence was changed to conform to the + ;; bogus ansi definition where the whole buffer was filled up. + ;; even for socket stream. + ;; rational-read-sequence does read-sequence the right way. +#-(and allegro (version>= 6 0 pre-final 9)) +`(read-sequence ,@args) +#+(and allegro (version>= 6 0 pre-final 9)) +`(read-sequence ,@args :partial-fill t) +) + + + + +;;;; response macros + + +;---- unsigned byte 8 array macros: + +(defmacro ausb8 (vec index) + ; like aref but it declares the type + `(aref (the (simple-array (unsigned-byte 8) 1) ,vec) ,index)) + +(defmacro copy-usb8 (from-vector from-start + to-vector to-start + count) + ;; copy count bytes from from-vector[start] to to-vector[start]. + ;; vectors are usb8 + (let ((from (gensym)) + (to (gensym)) + (i (gensym))) + + + `(do ((,from ,from-start (1+ ,from)) + (,to ,to-start (1+ ,to)) + (,i ,count (1- ,i))) + ((<= ,i 0)) + (setf (ausb8 ,to-vector ,to) + (ausb8 ,from-vector ,from))))) + + +(defmacro copy-usb8-up (from-vector from-start + to-vector to-start + count) + ;; copy count bytes from from-vector[start] to to-vector[start], + ;; going from the top down. this is designed to be used if we are + ;; copying upward in place so we have to copy from the top down + ;; + ;; vectors are usb8 + (let ((from (gensym)) + (to (gensym)) + (i (gensym))) + + + `(do* ((,i ,count (1- ,i)) + (,from (+ ,from-start ,i -1) (1- ,from)) + (,to (+ ,to-start ,i -1) (1- ,to))) + ((<= ,i 0)) + (setf (ausb8 ,to-vector ,to) + (ausb8 ,from-vector ,from))))) + + +;------------- + + + + +(defmacro dlogmess (&rest args) + ;; for now we just disable completely the log messages. + ;; in the future we'll turn on and off the log messages + ;; at runtime with a switch. + (declare (ignore args)) + nil) + + +;--------------- +; acl 6.1 and newer support timeouts on read/write for hiper streams +; Thus we can avoid using global timeouts in certain cases. +; + +; with-timeout-local: use with-timeout if that all we've got +; else use read-write timeouts +; +#-(and allegro (version>= 6 1)) +(defmacro with-timeout-local ((time &rest actions) &body body) + ;; same as with-timeout + `(acl-compat.mp:with-timeout (,time ,@actions) ,@body)) ; ok w-t + + +#+(and allegro (version>= 6 1)) +(defmacro with-timeout-local ((time &rest actions) &body body) + (declare (ignore time)) + (let ((g-blocktag (gensym))) + `(block ,g-blocktag + (handler-bind ((socket-error + #'(lambda (c) + (if* (member (stream-error-identifier c) + '(:read-timeout :write-timeout) + :test #'eq) + then ; must handle this + (return-from ,g-blocktag + (progn ,@actions)))))) + ,@body)))) + + + Added: vendor/portableaserve/aserve/main.cl =================================================================== --- vendor/portableaserve/aserve/main.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/main.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3038 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; main.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: main.cl,v 1.45 2005/10/20 07:54:06 nhabedi Exp $ + +;; Description: +;; aserve's main loop + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + + +(in-package :net.aserve) + +(defparameter *aserve-version* '(1 2 42)) + +#+allegro +(eval-when (eval load) + (require :sock) + (require :process) + #+ (and allegro (version>= 6)) (require :acldns) ; not strictly required but this is preferred +) + +(provide :aserve) + +(defparameter *aserve-version-string* + ;; for when we need it in string format + (format nil "~d.~d.~d" + (car *aserve-version*) + (cadr *aserve-version*) + (caddr *aserve-version*))) + +;;;;;;; debug support + +(defparameter *debug-all* nil) ; all of the debugging switches +(defparameter *debug-log* nil) ; all debugging switches that write info + ; to the *debug-stream* +(defparameter *debug-current* nil) ; current switches set + +(defparameter *debug-stream* *initial-terminal-io*) + +; set to true to automatically close sockets about to be gc'ed +; open sockets should never be subject to gc unless there's a bug +; in the code leading to leaks. +(defvar *watch-for-open-sockets* #+allegro t #-allegro nil) + +(defmacro define-debug-kind (name class what) + `(progn (ecase ,class + (:all (pushnew ,name *debug-all*)) + (:log (pushnew ,name *debug-log*) + (pushnew ,name *debug-all*))) + (setf (get ,name 'debug-description) ,what))) + +(define-debug-kind :notrap :all + "If set than errors in handlers cause a break loop to be entered") + +(define-debug-kind :xmit :log + "If set then most of the traffic between clients and servers is also sent to the debug stream") + +(define-debug-kind :info :log + "General information") + + + +(defun debug-on (&rest args) + ;; add the given debug kinds to the log list + (if* (null args) + then (note-debug-set) + else (dolist (arg args) + (case arg + (:all (setq *debug-current* *debug-all*)) + (:log (setq *debug-current* + (union *debug-current* *debug-log*))) + (t (pushnew arg *debug-current*)))))) + +(defun debug-off (&rest args) + ;; turn off the debugging + (if* (null args) + then (note-debug-set) + else (dolist (arg args) + (case arg + (:all (setq *debug-current* nil)) + (:log (setq *debug-current* + (set-difference *debug-current* *debug-log*))) + (t (setq *debug-current* (remove arg *debug-current*))))))) + +(defun note-debug-set () + ;; describe what debugging switches exist and if they are on + ;; and off + (dolist (kind *debug-all*) + (format t "~7s ~4a ~a~%" + kind + (if* (member kind *debug-current*) + then "on" + else "off") + (get kind 'debug-description)))) + + + +(defmacro debug-format (kind &rest args) + ;; do the format to *debug-stream* if the kind of this info + ;; is matched by the value of *debug-current* + `(if* (member ,kind *debug-current* :test #'eq) + then (write-sequence + (concatenate 'string + (format nil "d> (~a): " (acl-compat.mp:process-name acl-compat.mp:*current-process*)) + (format nil ,@args)) + *debug-stream*))) + + +(defmacro format-dif (debug-key &rest args) + ;; do the format and also do the same format to the + ;; debug stream if the given debug keyword is set + ;; do the format and then send to *initial-terminal-io* + `(progn (format ,@args) + (if* (member ,debug-key *debug-current* :test #'eq) + then ; do extra consing to ensure that it all be written out + ; at once + (write-sequence + (concatenate 'string + (format nil "x>(~a): " + (acl-compat.mp:process-name acl-compat.mp:*current-process*)) + (format nil ,@(cdr args))) + *debug-stream*)))) + +(defmacro if-debug-action (kind &body body) + ;; only do if the debug value is high enough + `(progn (if* (member ,kind *debug-current* :test #'eq) + then ,@body))) + +(defun check-for-open-socket-before-gc (socket) + (if* (open-stream-p socket) + then (logmess + (format nil + "socket ~s is open yet is about to be gc'ed. It will be closed" + socket)) + (ignore-errors (close socket)))) + + +;;;;;;;;;;; end debug support ;;;;;;;;;;;; + + +;; foreign function imports +#+(and allegro unix) +(progn + (ff:def-foreign-call (setuid "setuid") ((x :int)) :returning :int) + (ff:def-foreign-call (setgid "setgid") ((x :int)) :returning :int) + (ff:def-foreign-call (getpid "getpid") (:void) :returning :int) + (ff:def-foreign-call (unix-fork "fork") (:void) :returning :int) + (ff:def-foreign-call (unix-kill "kill") ((pid :int) (sig :int)) + :returning :int) + +) +#+(and lispworks unix) +(progn + (fli:define-foreign-function (setuid "setuid" :source) + ((x :int)) + :result-type :int + :language :ansi-c) + (fli:define-foreign-function (setgid "setgid" :source) + ((x :int)) + :result-type :int + :language :ansi-c) + (fli:define-foreign-function (getpid "getpid" :source) + () + :result-type :int + :language :ansi-c) + (fli:define-foreign-function (unix-fork "fork" :source) + () + :result-type :int + :language :ansi-c) + (fli:define-foreign-function (unix-kill "kill" :source) + ((pid :int) (sig :int)) + :result-type :int + :language :ansi-c) + (fli:define-foreign-function (unix-signal "signal" :source) + ((sig :int) (hdl :int)) + :result-type :void + :language :ansi-c)) + +#+(and cmu unix) +(progn + (alien:def-alien-routine "setuid" integer (x integer)) + (alien:def-alien-routine "setgid" integer (x integer)) + (alien:def-alien-routine "getpid" integer) + (alien:def-alien-routine ("fork" unix-fork) integer) + (alien:def-alien-routine ("kill" unix-kill) integer (pid integer) (sig integer)) + (alien:def-alien-routine ("signal" unix-signal) c-call:void (sig integer) (hdl integer)) +) + +#+(and clisp unix) +(defun getpid () (unix:getpid)) + +#+ (and sbcl unix) +(progn + (defun getpid () (sb-posix:getpid)) + (defun setuid (uid) (sb-posix:setuid uid)) + (defun setgid (gid) (sb-posix:setgid gid)) + (defun unix-fork () (sb-posix:fork))) + + + +#+openmcl +(defun getpid () (ccl::getpid)) + +;; more specials +(defvar *max-socket-fd* 0) ; the maximum fd returned by accept-connection +(defvar *aserve-debug-stream* nil) ; stream to which to seen debug messages +(defvar *debug-connection-reset-by-peer* nil) ; true to signal these too + + +;; NDL 2004-06-04 -- external-formats are implementation-dependent... +(defvar *default-aserve-external-format* #-lispworks :latin1-base #+lispworks :latin-1) + + +(defvar *worker-request*) ; set to current request object + +(defvar *read-request-timeout* 20) +(defvar *read-request-body-timeout* 60) +(defvar *http-response-timeout* + #+io-timeout 300 ; 5 minutes for timeout if we support i/o timeouts + #-io-timeout 120 ; 2 minutes if we use this for i/o timeouts too. + ) + +; this is only useful on acl6.1 where we do timeout on I/O operations +(defvar *http-io-timeout* 120) + +; usually set to the default server object created when aserve is loaded. +; users may wish to set or bind this variable to a different server +; object so it is the default for publish calls. +; Also bound to the current server object in accept threads, thus +; user response functions can use this to find the current wserver object. +(defvar *wserver*) + + +; type of socket stream built. +; :hiper is possible in acl6 +(defvar *socket-stream-type* + #+(and allegro (version>= 6)) :hiper + #-(and allegro (version>= 6)) :stream +) + +;; specials from other files +(defvar *header-block-sresource*) +(defvar *header-index-sresource*) +(defvar *header-keyword-array* + ;; indexed by header-number, holds the keyword naming this header + ) + +(defvar *not-modified-entity*) ; used to send back not-modified message + + +;;;;;;;;;;;;; end special vars + + +(defclass wserver () + ;; all the information contained in a web server + ( + ;; + ;;-- user visible slots -- + ;; (accessors exported) + + (socket ;; listening socket + :initform nil + :initarg :socket + :accessor wserver-socket) + + (enable-keep-alive ;; do keep alive if it's possible + :initform t + :initarg :enable-keep-alive + :accessor wserver-enable-keep-alive) + + (enable-chunking ;; do chunking if it's possible + :initform t + :initarg :enable-chunking + :accessor wserver-enable-chunking) + + (locators + ;; list of locators objects in search order + :initform (list (make-instance 'locator-exact + :name :exact) + (make-instance 'locator-prefix + :name :prefix)) + :accessor wserver-locators) + + (filters + ;; if non nil is is a list of functions + ;; of one arg (a request object) + ;; to be called before looking for a locator. This function can + ;; modify the request if it feels like it. + :initform nil + :accessor wserver-filters) + + (log-function + ;; function to call after the request is done to + ;; do the logging + :initarg :log-function + :initform nil ; no logging initially + :accessor wserver-log-function) + + (log-stream + ;; place for log-function to store stream to log to if + ;; it makes sense to do so. + :initarg :log-stream + :initform *initial-terminal-io* + :accessor wserver-log-stream) + + (accept-hook + ;; if non-nil the function to call passing the socket about to be + ;; processed by aserve, and charged with returning the socket to + ;; process + :initarg :accept-hook + :initform nil + :accessor wserver-accept-hook) + + (external-format + ;; used to bind *default-aserve-external-format* in each thread + :initarg :external-format + :initform :latin1-base + :accessor wserver-external-format) + + (vhosts + ;; map names to vhost objects + :initform (make-hash-table :test #'equalp) + :accessor wserver-vhosts) + + (default-vhost + ;; vhost representing situations with no virtual host + :initarg :default-vhost + :initform (make-instance 'vhost) + :accessor wserver-default-vhost) + + (response-timeout + ;; seconds a response is allowed to take before it gives up + :initarg :response-timeout + :initform *http-response-timeout* + :accessor wserver-response-timeout) + + (io-timeout + ;; seconds an I/O operation to an http client is allowed to take + ;; before an error is signalled. This is only effective on + ;; acl6.1 or newer. + :initarg :io-timeout + :initform *http-io-timeout* + :accessor wserver-io-timeout) + + ;; + ;; -- internal slots -- + ;; + + (terminal-io ;; stream active when we started server + :initform *terminal-io* + :initarg :terminal-io + :accessor wserver-terminal-io) + + (worker-threads ;; list of threads that can handle http requests + :initform nil + :accessor wserver-worker-threads) + + (free-workers ;; estimate of the number of workers that are idle + :initform #-openmcl-native-threads 0 #+openmcl-native-threads (ccl:make-semaphore) + :accessor wserver-free-workers) + + #+openmcl-native-threads + (work-list + :initform (ccl::make-locked-dll-header) + :accessor wserver-work-list) + + (accept-thread ;; thread accepting connetions and dispatching + :initform nil + :accessor wserver-accept-thread) + + (link-scan-threads ;; threads scanning cached entries for links + :initform nil + :accessor wserver-link-scan-threads) + + (uri-scan-threads ;; list of uri scanning processes + :initform nil + :accessor wserver-uri-scan-threads) + + (invalid-request + ;; entity to invoke given a request that can't be + ;; satisfied + :initform nil ; will build on demand if not present + :accessor wserver-invalid-request) + + (denied-request + ;; entity to invoke given a request that was denied + :initform nil ; will build on demand if not present + :accessor wserver-denied-request) + + (ipaddrs + ;; list of the ip addresses by which this wserver has been contacted + :initform nil + :accessor wserver-ipaddrs + ) + + (pcache + ;; proxy cache + :initform nil + :accessor wserver-pcache) + + (shutdown-hooks + ;; list of functions to call, passing this wserver object as an arg + ;; when the server shuts down + :initform nil + :accessor wserver-shutdown-hooks) + + (ssl + :initform nil + :initarg :ssl + :accessor wserver-ssl) + )) + + + +(defmethod print-object ((wserver wserver) stream) + (print-unreadable-object (wserver stream :type t :identity t) + (format stream "port ~a" + (let ((sock (wserver-socket wserver))) + (if* sock + then (acl-compat.socket:local-port sock) + else "-no socket-"))))) + + +#+openmcl-native-threads +(defstruct (work-list-element (:include ccl::dll-node)) + semaphore ; used to wake up the worker thread + socket) + +;;;;; virtual host class +(defclass vhost () + ((log-stream :accessor vhost-log-stream + :initarg :log-stream + :initform (ensure-stream-lock *trace-output*)) + (error-stream :accessor vhost-error-stream + :initarg :error-stream + :initform (ensure-stream-lock *trace-output*)) + (names :accessor vhost-names + :initarg :names + :initform nil) + + ; vhost specific filters, see wserver-filters for doc + (filters :accessor vhost-filters + :initarg :filters + :initform nil) + + ; property list for users to store per-vhost specific info + (plist :accessor vhost-plist + :initarg :plist + :initform nil) + )) + +(defmethod print-object ((vhost vhost) stream) + (print-unreadable-object (vhost stream :type t :identity t) + (format stream "~{ ~a~}" + (let ((names (vhost-names vhost))) + (if* (or (null names) (consp names)) + then names + else (list names)))))) + + +;;;;;; macros + +(defmacro with-http-response ((req ent + &key timeout + (check-modified t) + (response '*response-ok*) + content-type + format + ) + &body body) + ;; + ;; setup to response to an http request + ;; do the checks that can shortciruit the request + ;; + (let ((g-req (gensym)) + (g-ent (gensym)) + (g-timeout (gensym)) + (g-format (gensym)) + (g-check-modified (gensym))) + `(let* ((,g-req ,req) + (,g-ent ,ent) + (,g-format ,format) + (,g-timeout ,(or timeout + + `(or + (entity-timeout ,g-ent) + (wserver-response-timeout *wserver*)))) + (,g-check-modified ,check-modified) + ) + (catch 'with-http-response + ;(format t "timeout is ~d~%" ,g-timeout) + (compute-strategy ,g-req ,g-ent ,g-format) + (up-to-date-check ,g-check-modified ,g-req ,g-ent) + (acl-compat.mp::with-timeout ((if* (and (fixnump ,g-timeout) ; ok w-t + (> ,g-timeout 0)) + then ,g-timeout + else 9999999) + (timedout-response ,g-req ,g-ent)) + ,(if* response + then `(setf (request-reply-code ,g-req) ,response)) + ,(if* content-type + then `(setf (request-reply-content-type ,g-req) ,content-type) + else `(setf (request-reply-content-type ,g-req) (content-type ,g-ent))) + ,@body + ))))) + + +#+(and allegro (version>= 6 0)) +(defun warn-if-crlf (external-format) + (let ((ef (find-external-format external-format))) + (if* (not (eq (crlf-base-ef ef) ef)) + then (warn "~ +External-format `~s' passed to make-http-client-request filters line endings. +Problems with protocol may occur." (ef-name ef))))) + +(defmacro with-http-body ((req ent + &key headers + (external-format + '*default-aserve-external-format*)) + &body body) + (declare (ignorable external-format)) + (let ((g-req (gensym)) + (g-ent (gensym)) + (g-headers (gensym)) + #+allegro (g-external-format (gensym)) + ) + `(let ((,g-req ,req) + (,g-ent ,ent) + (,g-headers ,headers) + #+(and allegro (version>= 6 0 pre-final 1)) + (,g-external-format (find-external-format ,external-format)) + ) + (declare #+allegro (ignore-if-unused ,g-req ,g-ent ,g-external-format) + #-allegro (ignorable ,g-req ,g-ent)) + ,(if* body + then `(compute-response-stream ,g-req ,g-ent)) + (if* (entity-headers ,g-ent) + then (bulk-set-reply-headers ,g-req (entity-headers ,g-ent))) + (if* ,g-headers + then (bulk-set-reply-headers ,g-req ,g-headers)) + (send-response-headers ,g-req ,g-ent :pre) + (if* (not (member :omit-body (request-reply-strategy ,g-req) + :test #'eq)) + then (let ((*html-stream* (request-reply-stream ,g-req))) + #+(and allegro (version>= 6 0 pre-final 1)) + (if* (and (streamp *html-stream*) + (not (eq ,g-external-format + (stream-external-format *html-stream*)))) + then (warn-if-crlf ,g-external-format) + (setf (stream-external-format *html-stream*) + ,g-external-format)) + (progn ,@body))) + + (if* (member :keep-alive (request-reply-strategy ,g-req) :test #'eq) + then ; force the body to be read so we can continue + (get-request-body ,g-req)) + (send-response-headers ,g-req ,g-ent :post)))) + + + +(defmacro atomic-incf (var) + #+openmcl-native-threads + `(ccl::atomic-incf ,var) + #+sbcl + `(acl-compat.mp::atomic-incf ,var) + #-(or openmcl-native-threads sbcl) + `(acl-compat.mp:without-scheduling (incf ,var))) + +(defmacro atomic-decf (var) + #+openmcl-native-threads + `(ccl::atomic-decf ,var) + #+sbcl + `(acl-compat.mp::atomic-decf ,var) + #-(or openmcl-native-threads sbcl) + `(acl-compat.mp:without-scheduling (decf ,var))) + + +;;;;;;;;; end macros + + + + + +(eval-when (compile load eval) + ;; these are the common headers and are stored in slots in + ;; the objects + ;; the list consists of ("name" . name) + ;; where name is symbol naming the accessor function + (defparameter *fast-headers* + (let (res) + (dolist (name '(:connection + :date + :transfer-encoding + :accept + :host + :user-agent + :content-length)) + (push (list name ;; keyword symbol name + (read-from-string (format nil "reply-~a" name)) ;; symbol name + ;; accessor name + (read-from-string + (format nil "request-header-~a" name))) res)) + res)) + + (defparameter *fast-reply-headers* + ;; list of headers for the reply that at stored in slots of + ;; the http request object + (let (res) + (dolist (name '(:date + :content-type + :content-length)) + (push (list name ;; string name + + ;; symbol naming slot + (read-from-string + (concatenate 'string (symbol-name :reply-) + (string name))) + + ;; accessor name + (read-from-string + (format nil "request-reply-~a" name))) res)) + res)) + + ) + + + + + +(defmacro header-slot-value (req name) + ;; name is a keyword symbol naming the header value. + ;; retrive the slot's value from the http-request req req. + (let (ent) + (if* (stringp name) + then (header-name-error name)) + (if* (setq ent (assoc name *fast-headers* :test #'eq)) + then ; has a fast accesor + `(or (,(third ent) ,req) + (setf (,(third ent) ,req) + (header-buffer-req-header-value ,req ,name) + )) + else ; must get it from the alist + `(header-slot-value-other ,req ,name)))) + +;; The following is a workaround for a CormanLisp 2.0 bug. +;; When fixed I'll remove this code. +;; See my bug report to the mailing list: +;; http://groups.yahoo.com/group/cormanlisp/message/1131 +;; +#+cormanlisp +(defun request-headers (req) + (declare (ignore req))) + +#+cormanlisp +(defun (setf request-headers) (value req) + (declare (ignore req value))) + +(defun header-slot-value-other (req name) + ;; handle out of the the 'extra' headers + (let ((ent (assoc name (request-headers req) :test #'eq))) + (if* ent + then (cdr ent) + else (let ((ans (header-buffer-req-header-value req name))) + (push (cons name ans) (request-headers req)) + ans)))) + + + + +(defsetf header-slot-value (req name) (newval) + ;; set the header value regardless of where it is stored + (let (ent) + (if* (stringp name) + then (header-name-error name)) + (if* (setq ent (assoc name *fast-headers* :test #'eq)) + then `(setf (,(third ent) ,req) ,newval) + else (let ((genvar (gensym)) + (nreq (gensym))) + `(let* ((,nreq ,req) + (,genvar (assoc ,name (request-headers ,nreq) + :test #'eq))) + (if* (null ,genvar) + then (push (setq ,genvar (cons ,name nil)) + (request-headers ,nreq))) + (setf (cdr ,genvar) ,newval)))))) + +(defmacro reply-header-slot-value (req name) + ;; name is a string naming the header value (all lower case) + ;; retrive the slot's value from the http-request req req. + (let (ent) + (if* (stringp name) + then (header-name-error name)) + (if* (setq ent (assoc name *fast-reply-headers* :test #'eq)) + then ; has a fast accesor + `(,(third ent) ,req) + else ; must get it from the alist + `(cdr (assoc ,name (request-reply-headers ,req) :test #'eq))))) + +(defsetf reply-header-slot-value (req name) (newval) + ;; set the header value regardless of where it is stored + (let (ent) + (if* (stringp name) + then (header-name-error name)) + (if* (setq ent (assoc name *fast-reply-headers* :test #'eq)) + then `(setf (,(third ent) ,req) ,newval) + else (let ((genvar (gensym)) + (nreq (gensym))) + `(let* ((,nreq ,req) + (,genvar (assoc ,name (request-reply-headers ,nreq) + :test #'eq))) + (if* (null ,genvar) + then (push (setq ,genvar (cons ,name nil)) + (request-reply-headers ,nreq))) + (setf (cdr ,genvar) ,newval)))))) + + +(defun header-name-error (name) + (error "You attempted to reference header ~s. Headers are now named +by keyword symbols and not by strings" + name)) + +(defmacro header-slot-value-integer (req name) + ;; if the header value exists and has an integer value + ;; return two values: the value of the integer and t + ;; else return nil + + `(header-decode-integer (header-slot-value ,req ,name))) + + + + + + +(defclass http-header-mixin () + ;; List of all the important headers we can see in any of the protocols. + ;; + #.(let (res) + ;; generate a list of slot descriptors for all of the + ;; fast header slots + (dolist (head *fast-headers*) + (push `(,(third head) :accessor ,(third head) + :initform nil + :initarg + ,(intern (symbol-name (second head)) :keyword)) + res)) + res)) + + + + + + + + + + + +(defclass http-request (http-header-mixin) + ;; + ;; incoming request and information about the reply we send to it + ;; + ( + ;; + ;; -- external slots -- + ;; (accessors exported) + + (method ;; keyword giving the command in this request :get .. etc. + :initarg :method + :accessor request-method) + + (uri ;; uri object holding the current request with the scheme, host + ;; and port filled in. + :initarg :uri + :accessor request-uri) + + (raw-uri ;; uri object holding the actual uri from the command + :initarg :raw-uri + :accessor request-raw-uri) + + (decoded-uri-path + :initarg :decoded-uri-path + :accessor request-decoded-uri-path) + + (protocol ;; symbol naming the http protocol (e.g. :http/1.0) + :initarg :protocol + :reader request-protocol) + + (protocol-string ;; string naming the protcol requested + :initarg :protocol-string + :reader request-protocol-string) + + (socket ;; the socket we're communicating through + :initarg :socket + :reader request-socket) + + (wserver ;; wserver object for web server this request came to + :initarg :wserver + :reader request-wserver) + + (raw-request ;; the actual command line from the browser + :initarg :raw-request + :reader request-raw-request) + + (vhost ;; the virtual host to which this request is directed + :initarg :vhost + :initform (wserver-default-vhost *wserver*) + :accessor request-vhost) + + ;; + ;; -- internal slots -- + ;; + + (query-alist + ;; list of conses (name . value) for the query part of the + ;; current uri. This slot is filled in when information + ;; is first requested by the request-query function + :initform :empty + :accessor request-query-alist) + + + (headers ;; alist of headers *not* stored in slots + ;* use header-slot-value to retrieve header values + ; rather than looking here since not all headers are stored + ; here + :initform nil + :accessor request-headers) + + (header-block ;; *header-block-sresource* object + :initform nil + :accessor request-header-block) + + (request-body + ;; if we've read the request body then this + ;; is the string holding it. + :initform nil + :accessor request-request-body) + + + + + ;; response + (reply-code ;; one of the *response-xx* objects + :initform nil + :accessor request-reply-code) + + (reply-date + :initform (get-universal-time) ; when we're responding + :reader request-reply-date) + + (reply-headers ;; alist of headers to send out + :initform nil + :accessor request-reply-headers) + + (reply-content-type ;; mime type of the response + :initform nil + :accessor request-reply-content-type) + + (reply-stream ;; stream to which to send response + :initform nil + :accessor request-reply-stream) + + (reply-content-length + :initform nil ;; nil means "i don't know" + :accessor request-reply-content-length) + + (reply-strategy ;; list of strategy objects + :initform nil + :accessor request-reply-strategy) + + (reply-plist ;; general stuff in a property list form + :initform nil + :accessor request-reply-plist) + + (reply-protocol-sring + ;; A web server announces the highest minor level of the + ;; major level of the protocol that was requested by the client. + ;; Thus for now we're always http/1.1 + :initform "HTTP/1.1" + :accessor request-reply-protocol-string) + ) + + + + ) + + +(defstruct (response (:constructor make-resp (number desc))) + number + desc) + +(defparameter *response-continue* (make-resp 100 "Continue")) +(defparameter *response-ok* (make-resp 200 "OK")) +(defparameter *response-created* (make-resp 201 "Created")) +(defparameter *response-accepted* (make-resp 202 "Accepted")) +(defparameter *response-partial-content* + (make-resp 206 "Partial Content")) +(defparameter *response-moved-permanently* (make-resp 301 "Moved Permanently")) +(defparameter *response-found* (make-resp 302 "Found")) +(defparameter *response-see-other* (make-resp 303 "See Other")) +(defparameter *response-not-modified* (make-resp 304 "Not Modified")) +(defparameter *response-temporary-redirect* + (make-resp 307 "Temporary Redirect")) +(defparameter *response-bad-request* (make-resp 400 "Bad Request")) +(defparameter *response-unauthorized* (make-resp 401 "Unauthorized")) +(defparameter *response-not-found* (make-resp 404 "Not Found")) +(defparameter *response-requested-range-not-satisfiable* + (make-resp 416 "Requested range not satisfiable")) +(defparameter *response-internal-server-error* + (make-resp 500 "Internal Server Error")) +(defparameter *response-not-implemented* (make-resp 501 "Not Implemented")) + +(defparameter *responses* + (list *response-continue* + *response-ok* + *response-created* + *response-accepted* + *response-moved-permanently* + *response-found* + *response-see-other* + *response-not-modified* + *response-temporary-redirect* + *response-bad-request* + *response-unauthorized* + *response-not-found* + *response-requested-range-not-satisfiable* + *response-partial-content* + )) + +(defvar *crlf* (make-array 2 :element-type 'character :initial-contents + '(#\return #\linefeed))) + +(defvar *thread-index* 0) ; globalcounter to gen process names + + + + +(defun start (&key (port 80 port-p) + host + (listeners 5) + (chunking t) + (keep-alive t) + (server *wserver*) + debug ; set debug level + setuid + setgid + proxy + proxy-proxy ; who if anyone the proxy proxies to + cache ; enable proxy cache + restore-cache ; restore a proxy cache + debug-stream ; stream to which to send debug messages + accept-hook + ssl ; enable ssl + ssl-password ; for ssl: pswd to decode priv key in cert + os-processes ; to fork and run multiple instances + (external-format nil efp); to set external format + ) + ;; -exported- + ;; + ;; start the web server + ;; return the server object + #+mswindows + (declare (ignore setuid setgid)) + #-(or (and allegro (version>= 6 2 beta)) + (and :lispworks4.4 (not :cl-ssl))) + (declare (ignore ssl-password)) + + (declare (ignore debug)) ; for now + + (if* debug-stream + then (setq *aserve-debug-stream* + (if* (eq debug-stream t) + then *standard-output* + else debug-stream))) + + (if* (eq server :new) + then (setq server (make-instance 'wserver))) + + (if* efp then (setf (wserver-external-format server) external-format)) + + (if* ssl + then (if* (pathnamep ssl) + then (setq ssl (namestring ssl))) + + (if* (not (stringp ssl)) + then (error "The ssl argument should be a string or pathname holding the filename of the certificate and private key file")) + + (setq accept-hook + #'(lambda (socket) + (funcall 'acl-compat.socket::make-ssl-server-stream socket + :certificate ssl + #+(or (and allegro (version>= 6 2 beta)) + (and :lispworks4.4 (not :cl-ssl))) :certificate-password + #+(or (and allegro (version>= 6 2 beta)) + (and :lispworks4.4 (not :cl-ssl))) ssl-password))) + (setq chunking nil) ; doesn't work well through ssl + (if* (not port-p) + then ; ssl defaults to port 443 + (setq port 443))) + + (setf (wserver-accept-hook server) accept-hook) + + + ; shut down existing server + (shutdown :server server) + + (if* proxy + then (enable-proxy :server server :proxy-proxy proxy-proxy)) + + (if* (and (or restore-cache cache) + os-processes) + then ; coordinating the cache between processes is something we're + ; not ready to do ... *yet*. + (error "Can't have caching and os-processes in the same server")) + + #-unix + (if* os-processes + then (error "os-processes supported on Unix only at this time")) + + + (if* restore-cache + then (restore-proxy-cache restore-cache :server server) + elseif cache + then ; cache argument can have many forms + (let ((memory-size #.(* 10 1024 1024)) ; default 10mb + (disk-caches nil)) + (if* (atom cache) + then (if* (integerp cache) + then (setq memory-size cache)) + else (do ((info cache (cddr info))) + ((null info)) + (case (car info) + (:memory (setq memory-size (cadr info))) + (:disk (let ((dsize (cadr info))) + (if* (atom dsize) + then (if* (not (integerp dsize)) + then (setq dsize + #.(* 10 1024 1024))) + + (push (cons nil dsize) disk-caches) + + else (push dsize disk-caches)))) + (t (error "unknown disk cache info specifier: ~s" + (car info)))))) + + (create-proxy-cache :server server :size memory-size) + (dolist (disk-cache disk-caches) + (add-disk-cache :server server + :filename (car disk-cache) + :size (cadr disk-cache))))) + + + + + (let* ((main-socket (acl-compat.socket:make-socket :connect :passive + :local-port port + :local-host host + :reuse-address t + :format :bivalent + + :type + *socket-stream-type* + )) + (is-a-child)) + + #+(and unix (not openmcl)) + (progn + (if* (fixnump setgid) then (setgid setgid)) + (if* (fixnump setuid) then (setuid setuid))) + + (setf (wserver-socket server) main-socket) + (setf (wserver-terminal-io server) *terminal-io*) + (setf (wserver-enable-chunking server) chunking) + (setf (wserver-enable-keep-alive server) keep-alive) + (setf (wserver-ssl server) ssl) + + #+(and unix (not openmcl)) + (if* os-processes + then ; create a number of processes, letting only the main + ; one keep access to the tty + (if* (not (and (integerp os-processes) + (>= os-processes 1))) + then (error "os-processes should be an integer greater than zero")) + (let (children child) + (dotimes (i (1- os-processes)) + (if* (zerop (setq child (unix-fork))) + then ; we're a child, let the *lisp-listener* go + ; catatonic + #+allegro + (excl::unix-signal 15 0) ; let term kill it + #-allegro + (net.aserve::unix-signal 15 0) + (setq is-a-child t + children nil) + (return) ; exit dotimes + else (push child children))) + (if* children + then ; setup to kill children when main server + ; shutdown + (push #'(lambda (wserver) + (declare (ignore wserver)) + (dolist (proc children) + (unix-kill proc 15) ; 15 is sigterm + ) + ; allow zombies to die + (sleep 2) + (loop (if* (null + (acl-compat.system:reap-os-subprocess :wait nil)) + then (return)))) + (wserver-shutdown-hooks server))))) + + (let ((*wserver* server)) ; bind it too for privacy + (if* (or (null listeners) (eq 0 listeners)) + then (start-simple-server) + elseif (and (fixnump listeners) (> listeners 0)) + then (start-lisp-thread-server listeners) + else (error "listeners should be nil or a non-negative fixnum, not ~s" + listeners))) + + + (if* is-a-child then (loop (sleep 10000))) + + server + )) + + +(defun shutdown (&key (server *wserver*) save-cache) + ;; shutdown the neo server + ; first kill off old processes if any + (let ((proc (wserver-accept-thread server))) + (if* proc + then ; we want this thread gone and the socket closed + ; so that we can reopen it if we want to. + (acl-compat.mp:process-kill proc) + (acl-compat.mp:process-allow-schedule) + (let ((oldsock (wserver-socket server))) + (if* oldsock then (ignore-errors (close oldsock)))) + (setf (wserver-accept-thread server) nil))) + + (dolist (th (wserver-worker-threads server)) + (acl-compat.mp:process-kill th) + (acl-compat.mp:process-allow-schedule)) + + (setf (wserver-worker-threads server) nil) + + (dolist (hook (wserver-shutdown-hooks server)) + (funcall hook server)) + + (if* save-cache + then (save-proxy-cache save-cache :server server) + else (kill-proxy-cache :server server))) + + + + +(defun start-simple-server () + ;; do all the serving on the main thread so it's easier to + ;; debug problems + (let ((main-socket (wserver-socket *wserver*)) + (ipaddrs (wserver-ipaddrs *wserver*)) + (*default-aserve-external-format* (wserver-external-format *wserver*))) + (unwind-protect + (loop + (restart-case + (let ((sock (acl-compat.socket:accept-connection main-socket)) + (localhost)) + (if* (not (member (setq localhost (acl-compat.socket:local-host sock)) + ipaddrs)) + then ; new ip address by which this machine is known + (push localhost ipaddrs) + (setf (wserver-ipaddrs *wserver*) ipaddrs)) + (if* *watch-for-open-sockets* + then (schedule-finalization + sock + #'check-for-open-socket-before-gc)) + + ; disable the nagle alorithm + ;; TODO: implement set-socket-options in acl-compat + #+allegro + (socket:set-socket-options sock :nodelay t) + + #+io-timeout + (acl-compat.socket:socket-control + sock + :read-timeout (wserver-io-timeout *wserver*) + :write-timeout (wserver-io-timeout *wserver*)) + + (process-connection sock)) + + (:loop () ; abort out of error without closing socket + nil))) + (close main-socket)))) + + +(defun start-lisp-thread-server (listeners) + ;; start a server that consists of a set of lisp threads for + ;; doing work and a lisp thread for accepting connections + ;; and farming out the work + + ; create worker threads + #-openmcl-native-threads + (setf (wserver-free-workers *wserver*) 0) + (dotimes (i listeners) (make-worker-thread)) + + + ; create accept thread + (setf (wserver-accept-thread *wserver*) + (acl-compat.mp:process-run-function + (list :name (format nil "aserve-accept-~d" (incf *thread-index*)) + :initial-bindings + `((*wserver* . ',*wserver*) + #+ignore (*debug-io* . ',(wserver-terminal-io *wserver*)) + ,@acl-compat.excl:*cl-default-special-bindings*) + :run-reasons '(:enable)) + #'http-accept-thread))) + +(defun make-worker-thread () + (let* ((name (format nil "~d-aserve-worker" (incf *thread-index*))) + (proc (acl-compat.mp:make-process :name name + :initial-bindings + `((*wserver* . ',*wserver*) + #+ignore (*debug-io* . ',(wserver-terminal-io + *wserver*)) + ,@acl-compat.excl:*cl-default-special-bindings*) + ))) + (acl-compat.mp:process-preset proc #'http-worker-thread) + (push proc (wserver-worker-threads *wserver*)) + #-openmcl-native-threads + (atomic-incf (wserver-free-workers *wserver*)) + #+openmcl-native-threads + (ccl:process-enable proc) + (setf (getf (acl-compat.mp:process-property-list proc) 'short-name) + (format nil "w~d" *thread-index*)) + )) + + +(defun http-worker-thread () + ;; made runnable when there is an socket on which work is to be done + (let* ((*print-level* 5) + (*worker-request* nil) + (*default-aserve-external-format* + (wserver-external-format *wserver*)) + #+openmcl-native-threads (semaphore (ccl:make-semaphore)) + #+openmcl-native-threads (qelem (make-work-list-element + :semaphore semaphore)) + ) + ;; lots of circular data structures in the caching code.. we + ;; need to restrict the print level + (loop + #+openmcl-native-threads + (progn + (ccl::locked-dll-header-enqueue qelem (wserver-work-list *wserver*)) + (ccl:signal-semaphore (wserver-free-workers *wserver*)) ; tell the server that a worker thread is available + (ccl:wait-on-semaphore semaphore)) ;wait until we have a socket + (let ((sock #-openmcl-native-threads (car (acl-compat.mp:process-run-reasons acl-compat.mp:*current-process*)) + #+openmcl-native-threads (work-list-element-socket qelem))) + #-allegro + (when (eq sock :kill) (return)) + (restart-case + (if* (not (member :notrap *debug-current* :test #'eq)) + then (handler-case (process-connection sock) + (error (cond) + (if* (connection-reset-error cond) + thenret ; don't print these errors, + else (logmess + (format nil "~agot error ~a~%" + (if* *worker-request* + then (format + nil + "while processing command ~s~%" + (request-raw-request + *worker-request*)) + else "") + cond + ))))) + else ; in debugging mode where we don't ignore errors + ; still, we want to ignore connection-reset-by-peer + ; since they are often not errors + (catch 'out-of-connection + (handler-bind + ((stream-error + #'(lambda (c) + (if* (and + (not *debug-connection-reset-by-peer*) + (connection-reset-error c)) + then (throw 'out-of-connection nil))))) + (process-connection sock))) + + ) + (abandon () + :report "Abandon this request and wait for the next one" + nil)) + #-openmcl-native-threads + (progn + (atomic-incf (wserver-free-workers *wserver*)) + (acl-compat.mp:process-revoke-run-reason acl-compat.mp:*current-process* sock))) + + ))) + +(defun connection-reset-error (c) + ;; return true if this is what results from a connection reset by + ;; peer + (or (and (typep c 'stream-error) + (or #+(or allegro lispworks) + (eq (stream-error-identifier c) :connection-reset) + #+(and allegro unix) + (eq (stream-error-code c) 32) ; sigpipe + #+(and allegro aix) + (eq (stream-error-code c) 73) + #+openmcl + (and (typep c 'ccl::simple-stream-error) + (stringp (simple-condition-format-control c)) + (search "Connection reset by peer" + (simple-condition-format-control c) + :test #'char=)) + #+sbcl + (and (stringp (simple-condition-format-control c)) + (find "Connection reset by peer" + (simple-condition-format-arguments c) + :test #'equal)))) + #+sbcl + (and (typep c 'simple-error) + (stringp (simple-condition-format-control c)) + (search "SIGPIPE at " + (simple-condition-format-control c) + :test #'char=)))) + +(defun http-accept-thread () + ;; loop doing accepts and processing them + ;; ignore sporatic errors but stop if we get a few consecutive ones + ;; since that means things probably aren't going to get better. + (let* ((error-count 0) + #-openmcl-native-threads (workers nil) + (server *wserver*) + (main-socket (wserver-socket server)) + (ipaddrs (wserver-ipaddrs server))) + (unwind-protect + + (loop + (handler-case + (let ((sock (acl-compat.socket:accept-connection main-socket)) + (localhost)) + + ; optional.. useful if we find that sockets aren't being + ; closed + (if* *watch-for-open-sockets* + then (schedule-finalization + sock + #'check-for-open-socket-before-gc)) + + ; track all the ipaddrs by which we're reachable + (if* (not (member (setq localhost (acl-compat.socket:local-host sock)) + ipaddrs)) + then ; new ip address by which this machine is known + (push localhost ipaddrs) + (setf (wserver-ipaddrs *wserver*) ipaddrs)) + + #+io-timeout + (acl-compat.socket:socket-control + sock + :read-timeout (wserver-io-timeout *wserver*) + :write-timeout (wserver-io-timeout *wserver*)) + + ; another useful test to see if we're losing file + ; descriptors + #+allegro + (let ((fd (excl::stream-input-fn sock))) + (if* (> fd *max-socket-fd*) + then (setq *max-socket-fd* fd) + (logmess (format nil + "Maximum socket file descriptor number is now ~d" fd)))) + + + (setq error-count 0) ; reset count + + #-openmcl-native-threads + ; find a worker thread + ; keep track of the number of times around the loop looking + ; for one so we can handle cases where the workers are all busy + (let ((looped 0)) + (loop + (if* (null workers) + then (case looped + (0 nil) + ((1 2 3) (logmess "all threads busy, pause") + (sleep 1)) + + (4 (logmess "forced to create new thread") + (make-worker-thread)) + + (5 (logmess "can't even create new thread, quitting") + (return-from http-accept-thread nil))) + + (setq workers (wserver-worker-threads server)) + (incf looped)) + (if* (null (acl-compat.mp:process-run-reasons (car workers))) + then (atomic-decf (wserver-free-workers server)) + (acl-compat.mp:process-add-run-reason (car workers) sock) + (pop workers) + (return) ; satisfied + ) + (pop workers))) + #+openmcl-native-threads + (loop + ;; Wait (for up to a second) for some worker thread + ;; to become free. If that wait times out, create + ;; a new worker thread. + (if (not (ccl:timed-wait-on-semaphore + (wserver-free-workers *wserver*) 1 )) + (make-worker-thread) + (return + (let* ((q (ccl::locked-dll-header-dequeue + (wserver-work-list *wserver*)))) + (setf (work-list-element-socket q) sock) + (ccl:signal-semaphore + (work-list-element-semaphore q)) + )))) + ) + (error (cond) + (logmess (format nil "accept: error ~s on accept ~a" + error-count cond)) + ;; we seem to get a string of connection reset by peers, + ;; perhaps due to connections that piled up before + ;; we started work. So we don't want to close down + ;; the accepting loop ever, thus we'll ignore the + ;; code below. + #+ignore + (if* (> (incf error-count) 4) + then (logmess "accept: too many errors, bailing") + (return-from http-accept-thread nil))))) + (ignore-errors (progn + (acl-compat.mp:without-scheduling + (if* (eql (wserver-socket server) main-socket) + then (setf (wserver-socket server) nil))) + (close main-socket)))))) + + + + + +(defun start-cmd () + ;; start using the command line arguments + (let ((port 8001)) + (do* ((args (cdr (acl-compat.system:command-line-arguments)) (cdr args)) + (arg (car args) (car args))) + ((null args)) + (if* (equal "-f" arg) + then (load (cadr args)) + (pop args) + elseif (equal "-p" arg) + then (setq port (read-from-string (cadr args))) + (pop args) + elseif (equal "-I" arg) + then (pop args) + else (warn "unknown arg ~s" arg))) + (dotimes (i 20) + (handler-case (progn (start :port port) (loop (sleep 100000))) + (error (cond) + (format t " got error ~a~%" cond) + (format t "restarting~%")))))) + + +(defun process-connection (sock) + ;; read an http request from the socket and process + ;; it. + ;; If the response indicates 'keep alive' then loop around for + ;; another request. + ;; When this function returns the given socket has been closed. + ;; + + ; run the accept hook on the socket if there is one + (let ((ahook (wserver-accept-hook *wserver*))) + (if* ahook then (setq sock (funcall ahook sock)))) + + + (unwind-protect + (let (req error-obj (chars-seen (list nil))) + ;; get first command + (loop + + (with-timeout-local (*read-request-timeout* + (debug-format :info "request timed out on read~%") + ; this is too common to log, it happens with + ; every keep alive socket when the user stops + ; clicking + ;;(log-timed-out-request-read sock) + (return-from process-connection nil)) + (multiple-value-setq (req error-obj) + (ignore-errors (read-http-request sock chars-seen)))) + + (if* (null req) + then ; end of file, means do nothing + ; (logmess "eof when reading request") + ; end this connection by closing socket + (if* error-obj + then (brief-logmess + (format nil "While reading http request~:_ from ~a:~:_ ~a" + (socket:ipaddr-to-dotted + (socket::remote-host sock)) + error-obj))) + + ; notify the client if it's still listening + (if* (car chars-seen) + then (ignore-errors + (format sock "HTTP/1.0 400 Bad Request~a~a" + *crlf* *crlf*) + (force-output sock))) + + (return-from process-connection nil) + else ;; got a request + (setq *worker-request* req) + + (handle-request req) + (force-output-noblock (request-socket req)) + + (log-request req) + + (setq *worker-request* nil) + (free-req-header-block req) + + (let ((sock (request-socket req))) + (if* (member :keep-alive + (request-reply-strategy req) + :test #'eq) + then ; continue to use it + (debug-format :info "request over, keep socket alive~%") + (force-output-noblock sock) + (setf (car chars-seen) nil) ; for next use + else (return)))))) + ;; do it in two stages since each one could error and both have + ;; to be attempted + (ignore-errors (force-output-noblock sock)) + (ignore-errors (close sock :abort t)))) + +(defun force-output-noblock (stream) + ;; do a force-output but don't get hung up if we get blocked on output + ;; this happens enough with sockets that it's a real concern + ; 30 seconds is enough time to wait + (with-timeout-local (30) + (force-output stream))) + + + +(defun read-http-request (sock chars-seen) + ;; read the request from the socket and return and http-request + ;; object and an indication if any characters were read + ;; + ;; return chars-seeen as the third value since the second + ;; value will be reserved for the error object from the ignore-errors + + (let ((buffer (get-request-buffer)) + (req) + (end) + (raw-cmd)) + + (unwind-protect + (progn + (loop + ; loop until a non blank line is seen and is stored in + ; the buffer + ; + ; we handle the case of a blank line before the command + ; since the spec says that we should (even though we don't have to) + + + (multiple-value-setq (buffer end) + (read-sock-line sock buffer 0 chars-seen)) + + + (if* (null end) + then ; eof or error before crlf + (return-from read-http-request nil)) + + + (debug-format :info "got line of size ~d: " end) + (if-debug-action :info + (dotimes (i end) (write-char (schar buffer i) + *initial-terminal-io*)) + (terpri *initial-terminal-io*) (force-output *initial-terminal-io*)) + + (if* (not (eql 0 end)) + then (return) ; out of loop + )) + + (setq raw-cmd (buffer-substr buffer 0 end)) + + (multiple-value-bind (cmd uri protocol) + (parse-http-command buffer end) + (if* (or (null cmd) (null protocol)) + then ; no valid command found + (return-from read-http-request nil)) + + (if* (null (puri:uri-path uri)) + then (setf (puri:uri-path uri) "/")) + + (setq req (make-instance 'http-request + :method cmd + :uri (puri:copy-uri uri) + :raw-uri uri + :decoded-uri-path + (uridecode-string (puri:uri-path uri)) + + :protocol protocol + :protocol-string (case protocol + (:http/1.0 "HTTP/1.0") + (:http/1.1 "HTTP/1.1") + (:http/0.9 "HTTP/0.9")) + :socket sock + :wserver *wserver* + :raw-request raw-cmd + )) + + + (if* (and (not (eq protocol :http/0.9)) + #+ignore (null (read-request-headers req sock buffer)) + (null (new-read-request-headers req sock)) + ) + then (debug-format :info "no headers, ignore~%") + (return-from read-http-request nil)) + + ; insert the host name and port into the uri + (let ((host (header-slot-value req :host))) + (if* host + then (let ((colonpos (find-it #\: host 0 (length host))) + (uri (request-uri req)) + (port)) + (if* colonpos + then ; host:port + (setq + port (string-to-number + host (1+ colonpos) + (length host)) + host (buffer-substr host + 0 colonpos))) + (if* (null (uri-host uri)) + then (setf (uri-host uri) host) + (if* port + then (setf (uri-port uri) port))) + + (setf (uri-scheme uri) + (if* (wserver-ssl *wserver*) + then :https + else :http)) + + ;; set virtual host in the request + (let ((vhost + (gethash host (wserver-vhosts *wserver*)))) + (setf (request-vhost req) + (or vhost (wserver-default-vhost *wserver*)))) + + )))) + + + req ; return req object + ) + + ; cleanup forms + (if* buffer then (free-request-buffer buffer))))) + + + + + + + + + + + + + + +(defvar *http-command-list* + '(("GET " . :get) + ("HEAD " . :head) + ("POST " . :post) + ("PUT " . :put) + ("OPTIONS " . :options) + ("DELETE " . :delete) + ("TRACE " . :trace) + ("CONNECT " . :connect))) + + + + +(defmethod get-request-body ((req http-request) + &key (external-format :octets ef-supplied)) + (let* ((result + ;; return a string that holds the body of the http-request + ;; cache it for later too + (or (request-request-body req) + (setf (request-request-body req) + (get-request-body-retrieve req))))) + (if* ef-supplied ; spr27296 + then (values + (octets-to-string + (string-to-octets result :external-format :octets) + :external-format external-format)) + else result))) + + +(defun get-request-body-retrieve (req) + ;; get the guts of the body into a string. + ;; we'll always use the :octets external format to retrieve the string + ;; so the characters may not be correct however later external + ;; format processing will fix that. + (let (#+allegro (original-ef (stream-external-format (request-socket req)))) + + ; must read using the octets external format because the + ; content length is in terms of octets + #+allegro + (setf (stream-external-format (request-socket req)) + (find-external-format :octets)) + + (unwind-protect + (if* (member (request-method req) '(:put :post)) + then (multiple-value-bind (length believe-it) + (header-slot-value-integer req :content-length) + (if* believe-it + then ; we know the length + (prog1 (let ((ret (make-string length))) + (read-sequence-with-timeout + ret length + (request-socket req) + *read-request-body-timeout*)) + + ; netscape (at least) is buggy in that + ; it sends a crlf after + ; the body. We have to eat that crlf. + ; We could check + ; which browser is calling us but it's + ; not clear what + ; is the set of buggy browsers + (let ((ch (read-char-no-hang + (request-socket req) + nil nil))) + (if* (eq ch #\return) + then ; now look for linefeed + (setq ch (read-char-no-hang + (request-socket req) + nil nil)) + (if* (eq ch #\linefeed) + thenret + else (unread-char + ch (request-socket req))) + elseif ch + then (unread-char ch (request-socket + req))))) + + + else ; no content length given + + (if* (equalp "keep-alive" + (header-slot-value req + :connection)) + then ; must be no body + "" + else ; read until the end of file + (with-timeout-local + (*read-request-body-timeout* + nil) + (let ((ans (make-array + 2048 + :element-type 'character + :fill-pointer 0)) + (sock (request-socket req)) + (ch)) + (loop (if* (eq :eof + (setq ch + (read-char + sock nil :eof))) + then (return ans) + else (vector-push-extend + ch ans)))))))) + else "" ; no body + ) + ; uwp cleanup + #+allegro + (setf (stream-external-format (request-socket req)) original-ef) + ))) + +;; multipart code +;; used when enctype=multipart/form-data is used + +; new version that uses binary mode to transfer data + +(defstruct mp-info + buffer ; usb8 buffer if we're active + left ; bytes of content-length left to read + state ; state where the buffer pointer is pointed + cur ; current buffer pointer + after ; after the boundary value + end ; index after last byte in the buffer + boundary ; boundary vector + socket ; socket we're reading from + ) + +(defmethod start-multipart-capture ((req http-request)) + ;; begin the grab of the body. + ;; user doesn't have to call this, it's called automatically + (let* ((ctype (header-slot-value req :content-type)) + (parsed (and ctype (parse-header-value ctype))) + (boundary (and (equalp "multipart/form-data" (cadar parsed)) + (cdr (assoc "boundary" (cddar parsed) :test #'equal)))) + (len (header-slot-value-integer req :content-length)) + (mpbuffer)) + + (if* (null boundary) + then ; not in the right form, give up + (return-from start-multipart-capture nil)) + + (setq mpbuffer (get-sresource *header-block-sresource*)) + + (setf (aref mpbuffer 0) #.(char-code #\return)) + (setf (aref mpbuffer 1) #.(char-code #\linefeed)) + + (setf (getf (request-reply-plist req) 'mp-info) + (make-mp-info :buffer mpbuffer + :left len + :state :start + :cur 0 ; we'll start the buffer with cr,lf + :end 2 ; since the first boundary may not have it + :socket (request-socket req) + + ;; boundary is a case insensitive usb8 array + ;; <cr><lf>--boundary-downcased + ;; + :boundary + (let ((array (make-array (+ 2 ; crlf + 2 ; -- + (length boundary)) + :element-type '(unsigned-byte 8)))) + (setf (aref array 0) #.(char-code #\return)) + (setf (aref array 1) #.(char-code #\linefeed)) + (setf (aref array 2) #.(char-code #\-)) + (setf (aref array 3) #.(char-code #\-)) + + (dotimes (i (length boundary)) + (setf (aref array (+ i 4)) + (char-code (char-downcase (schar boundary i))))) + array) + )))) + + +(defparameter *crlf-crlf-usb8* + ;; the correct way to end a block of headers + (make-array 4 :element-type '(unsigned-byte 8) + :initial-contents + (list #.(char-code #\return) + #.(char-code #\linefeed) + #.(char-code #\return) + #.(char-code #\linefeed)))) + +(defparameter *lf-lf-usb8* + ;; the incorrect way to end a block of headers but still found + ;; in some Unix apps + (make-array 2 :element-type '(unsigned-byte 8) + :initial-contents + (list #.(char-code #\linefeed) + #.(char-code #\linefeed)))) + +(defmethod get-multipart-header ((req http-request)) + ;; return an alist holding the header info for the next request. + ;; or nil if this is the end of the line + + (let ((mp-info (getf (request-reply-plist req) 'mp-info))) + + (if* (null mp-info) + then (start-multipart-capture req) + ; satisify normal requests for the body with an empty string + (setf (request-request-body req) "") + (setq mp-info (getf (request-reply-plist req) 'mp-info))) + + (if* (null mp-info) + then ; no headers left + (return-from get-multipart-header nil)) + + (loop + (case (mp-info-state mp-info) + (:header (return)) ; ok + ((:body :start) + (loop + (multiple-value-bind (pos state after) + (scan-forward mp-info) + (if* (eq state :partial) + then (if* (not (shift-buffer-up-and-read mp-info)) + then ; no more data, bogus end though + (setf (mp-info-state mp-info) :last-boundary) + (return)) + else (setf (mp-info-cur mp-info) pos + (mp-info-state mp-info) state + (mp-info-after mp-info) after) + (return))))) + (:boundary (scan-forward mp-info)) + (:last-boundary ; no more space + ; free up the buffer + (free-sresource *header-block-sresource* (mp-info-buffer + mp-info)) + (setf (mp-info-buffer mp-info) nil) + ;; + (return-from get-multipart-header nil)))) + + ; in the header state, must find the end of the + ; header block <cr><lf><cr><lf> + (let* ((buffer (mp-info-buffer mp-info)) + cur + headers + endhead) + + (loop + (setq cur (mp-info-cur mp-info)) + (setq endhead (search-usb8 buffer + cur + (mp-info-end mp-info) + *crlf-crlf-usb8*)) + (if* (integerp endhead) + then (incf endhead 4) ; cr lf cr lf + (return)) + + (if* (not (shift-buffer-up-and-read mp-info)) + then ; failed to find the end of the headers + (error "end of headers not found, badly formed request"))) + + ; found the end of the headers. + (let ((ans (get-sresource *header-index-sresource*))) + (parse-header-block-internal buffer cur endhead ans) + (dotimes (i (length ans)) + (dolist (ent (svref ans i)) + (push (cons (svref *header-keyword-array* i) + (parse-header-value + (buffer-subseq-to-string buffer (car ent) (cdr ent)))) + headers))) + (free-sresource *header-index-sresource* ans)) + + (setf (mp-info-cur mp-info) endhead) + (setf (mp-info-state mp-info) :body) ; pointing at the body + + headers))) + +(defun search-usb8 (buffer start end pattern) + ;; look for the pattern in the buffer + (do* ((i start (1+ i)) + (patlen (length pattern)) + (realend (- end patlen -1))) + ((>= i realend)) + (dotimes (j patlen (return-from search-usb8 i)) + (if* (not (eq (aref buffer (+ i j)) (aref pattern j))) + then ; no match + (return nil))))) + + + + +(defun shift-buffer-up-and-read (mp-info) + ;; bring bytes from cur to end to the top of the buffer. + ;; + ;; read in more bytes. + ;; + ;; + ;; return true if more any bytes. nil means that there is + ;; no more data to read or no more space for data. + ;; + (let ((cur (mp-info-cur mp-info)) + (mpbuffer (mp-info-buffer mp-info)) + (left)) + + (if* (zerop (setq left (mp-info-left mp-info))) + then nil ; nothing to do, since no more data left + else ; shift up buffer if needed + (if* (> cur 0) + then (do ((end (mp-info-end mp-info)) + (i cur (1+ i))) + ((>= i end)) + (setf (aref mpbuffer (- i cur)) (aref mpbuffer i))) + (setf (mp-info-cur mp-info) 0) + (decf (mp-info-end mp-info) cur)) + + (if* (eql (mp-info-end mp-info) (length mpbuffer)) + then ; no room to store anything else + nil + else ; read as much as we acn + (let* ((end (mp-info-end mp-info)) + (pos (rational-read-sequence mpbuffer + (mp-info-socket mp-info) + :start end + :end (min + (length mpbuffer) + (+ end left))))) + (if* (<= pos end) + then ; no bytes read, eof + nil + else + (if-debug-action + :xmit + (format t "~%multipart read ~d bytes~%" + (- pos end)) + (do ((i end (1+ i))) + ((>= i pos)) + (write-char (code-char (aref mpbuffer i)))) + (format t "<end-of-read>~%") + (force-output)) + + + (decf (mp-info-left mp-info) + (- pos end)) + (setf (mp-info-end mp-info) pos) + t ; read something in + )))))) + + + +;; for debugging +#+ignore +(defun dump-mp-info (mp-info) + (let ((buff (mp-info-buffer mp-info))) + (format t "dump, state is ~s, cur = ~s, after is ~s, end is ~s~%" + (mp-info-state mp-info) (mp-info-cur mp-info) + (mp-info-after mp-info) + (mp-info-end mp-info) + ) + (format t "buf:~%") + + (do ((v (mp-info-cur mp-info) (1+ v))) + ((>= v (mp-info-end mp-info))) + (write-char (code-char (aref buff v)))) + (format t "<<end>>~%") + )) + + +(defun scan-forward (mp-info) + ;; scan forward to the next interesting thing + ;; + ;; rfc2046 describes the multipart syntax + ;; + ;; If the current state is :boundary then we are being called + ;; to locate the next header. If we find it we set cur to point + ;; to it and set the state to :header. If no more data is available + ;; (and this will never happen if the client works correctly) we + ;; set the state to :last-boundary + ;; nil is returned + ;; + ;; If the current state is :body or :start + ;; we look forward to find the point a which the next :boundary + ;; starts. We give up at the end of the bytes read into the buffer + ;; we don't change cur or the state of the mp-info + ;; We return two values: + ;; the point at which that transition occurs to boundary + ;; a symbol describing what we found + ;; :body,:state - found nothing interesting, we're still in the same + ;; state we started in (either :body or :state) + ;; :boundary - we've identified a boundary between items + ;; :last-boundary - we've indentified the final boundary + ;; :partial - we've identified something that could be + ;; a boundary or last-boundary but don't have enough + ;; data to tell. + ;(dump-mp-info mp-info) + (case (mp-info-state mp-info) + (:boundary + ;; skip past boundary if it's in the buffer + ;; this is called only in get-multipart-header + (loop + (let ((past (mp-info-after mp-info))) + (if* (< past (mp-info-end mp-info)) + then ; inside the buffer + (setf (mp-info-cur mp-info) past) + (setf (mp-info-state mp-info) :header) + (return) + else (if* past + then ; adjust 'past' location to account for shifting + ; buffer contents up + (decf (mp-info-after mp-info) + (mp-info-cur mp-info))) + (if* (not (shift-buffer-up-and-read mp-info)) + then ; no more data + (setf (mp-info-state mp-info) :last-boundary) + (setf (mp-info-after mp-info) (mp-info-cur mp-info)) + (return)))))) + (:last-boundary nil) + + ((:body :start) + ;; looking for a boundary or partial boundary + (let* ((cur (mp-info-cur mp-info)) + (end (mp-info-end mp-info)) + (boundary (mp-info-boundary mp-info)) + (len-boundary (length boundary)) + ) + (if* (eql cur end) + then (if* (not (shift-buffer-up-and-read mp-info)) + then ; no more data available + (setf (mp-info-state mp-info) :last-boundary) + (return-from scan-forward (values 0 :last-boundary 0)))) + (setq cur (mp-info-cur mp-info) + end (mp-info-end mp-info)) + + (do* ((i cur (1+ i)) + (mpbuffer (mp-info-buffer mp-info))) + ((>= i end) + (values end (mp-info-state mp-info))) + + (let* ((ch (aref mpbuffer i))) + (if* (eq ch #.(char-code #\return)) + then ; this could match + (do ((j i (1+ j)) + (ind 0 (1+ ind))) + + (nil) + (if* (>= ind len-boundary) + then ; matched the whole boundary + ; may be followed by white space + ; then crlf (for boundary) + ; or -- (for closing boundary) + + (do ((jj j (1+ jj))) + ((>= jj end) + ; can't tell yet + (return-from scan-forward + (values i :partial))) + + (if* (member (aref mpbuffer jj) + '(#.(char-code #\space) + #.(char-code #\tab))) + thenret ; pass over + else ; we need at least 2 chars in the buff + ; to see crlf or -- + (if* (>= (1+ jj) end) + then ; only one char + (return-from scan-forward + (values i :partial))) + + (if* (and (eql (aref mpbuffer jj) + #.(char-code #\return)) + (eql (aref mpbuffer (1+ jj)) + #.(char-code #\linefeed))) + then (return-from scan-forward + (values i :boundary (+ jj 2))) + elseif (and (eq (aref mpbuffer jj) + #.(char-code #\-)) + (eq (aref mpbuffer (1+ jj)) + #.(char-code #\-))) + then (return-from scan-forward + (values i :last-boundary (+ jj 2))) + else ; nothing we recognize + (return)))) + + ; if here then doesn't match boundary + (return) + elseif (>= j end) + then ; end of buffer before end of boundary + (return-from scan-forward + (values i :partial))) + + ; boundary value is downcased so we must downcase + ; value in buffer. we had to do the downcasing since + ; I found cases where a case insensitive match had + ; to be done + (let ((bufch (aref mpbuffer j))) + (if* (<= #.(char-code #\A) bufch #.(char-code #\Z)) + then (incf bufch #.(- (char-code #\a) + (char-code #\A)))) + (if* (not (eq bufch (aref boundary ind))) + then (return))))))))))) + + + + +(defmethod get-multipart-sequence ((req http-request) + buffer + &key (start 0) + (end (length buffer)) + (external-format + *default-aserve-external-format* + ef-spec)) + ;; fill the buffer with the chunk of data. + ;; start at 'start' and go no farther than (1- end) in the buffer + ;; return the index of the first character not placed in the buffer. + + + ;; Since external-format not used in all versions + (declare (ignorable external-format ef-spec)) + + #-(and allegro (version>= 6 0 pre-final 1)) + (if* ef-spec + then (warn "~ +For this version of Lisp, external-format is ignored ~ +in get-multipart-sequence")) + + (let* ((mp-info (getf (request-reply-plist req) 'mp-info)) + mpbuffer + cur + pos + kind + text-mode + after) + + + (typecase buffer + ((array (unsigned-byte 8) (*)) + ) + ((array character (*)) + (setq text-mode t)) + #+lispworks (string (setq text-mode t)) + (t + (error + "This function only accepts (array (unsigned-byte 8)) or character arrays"))) + (if* (null mp-info) + then (error "get-multipart-sequence called before get-multipart-header")) + + (setq mpbuffer (mp-info-buffer mp-info) + cur (mp-info-cur mp-info)) + + (loop + (case (mp-info-state mp-info) + ((:header :boundary :last-boundary) + ; no data left + (return-from get-multipart-sequence nil)) + (:start + (error "get-multipart-sequence called before get-multipart-header")) + ((:body :partial) + (if* (eq (mp-info-state mp-info) :partial) + then ; this was set below. we will return the partial + ; at then end of the buffer + (setf (mp-info-state mp-info) :body) + (setq pos (mp-info-end mp-info)) + else (multiple-value-setq (pos kind after) (scan-forward mp-info)) + (setf (mp-info-after mp-info) after) + (setq cur (mp-info-cur mp-info)) ; scan-forward can change + ) + + (if* (> pos cur) + then ; got something to return + (let* ((tocopy (min (- end start) (- pos cur))) + (items tocopy)) + (if* text-mode + then + ; here is where we should do + ; external format processing + #+(and allegro (version>= 6 0 pre-final 1)) + (multiple-value-setq (buffer items tocopy) + (octets-to-string + mpbuffer + :string buffer + :start cur + :end pos + :string-start start + :string-end (length buffer) + :external-format external-format + :truncate t)) + #-(and allegro (version>= 6 0 pre-final 1)) + (dotimes (i tocopy) + (setf (aref buffer (+ start i)) + (code-char (aref mpbuffer (+ cur i))))) + else + (dotimes (i tocopy) + (setf (aref buffer (+ start i)) + (aref mpbuffer (+ cur i))))) + (if* (zerop items) + then ; didn't find enough bytes to make + ; a character + (if* (null (shift-buffer-up-and-read mp-info)) + then ; no more bytes available + (return-from get-multipart-sequence nil)) + ; loop around + else (setf (mp-info-cur mp-info) (+ cur tocopy)) + (return-from get-multipart-sequence + (+ start items)))) + elseif (eq kind :partial) + then ; may be a boundary, can't tell + (if* (null (shift-buffer-up-and-read mp-info)) + then ; no more data, partial will never match + ; so return the partial, this special + ; state is recognized in this routine + (setf (mp-info-state mp-info) :partial) + ; loop around + ) + elseif (or (eq kind :boundary) + (eq kind :last-boundary)) + then ; hit a boundary, nothing more to return + (setf (mp-info-state mp-info) kind + (mp-info-cur mp-info) pos) + (return-from get-multipart-sequence nil))))))) + + +(defun parse-multipart-header (header) + ;; look for known patterns in the mulitpart header and return + ;; the information we can find. Header is the return value from + ;; get-multipart-header + ;; + ;; return values: + ;; 1. nil, :eof, :file, :data, :nofile - description of the header + ;; 2. name - name of the item + ;; 3. filename - if type is :file then this is the filename + ;; 4. content-type - if type is :file this this is the content-type + (if* (and (consp header) (consp (car header))) + then (let ((cd (assoc :content-disposition header :test #'eq)) + (ct (assoc :content-type header :test #'eq)) + (name) + (filename) + (content-type)) + (if* (and cd + (consp (cadr cd)) + (eq :param (car (cadr cd))) + (equal "form-data" (cadr (cadr cd)))) + then (let ((fd (cddr (cadr cd)))) + (let ((aname (assoc "name" fd :test #'equal))) + (if* aname then (setq name (cdr aname)))) + (let ((afname (assoc "filename" fd :test #'equal))) + (if* afname then (setq filename (cdr afname)))))) + (if* (and (consp ct) (stringp (cadr ct))) + then (setq content-type (cadr ct))) + + (values (if* filename + then (if* (equalp filename "") + then :nofile + else :file) + else :data) + name + filename + content-type)) + elseif (null header) + then :eof + else nil ; doesn't match anything we know about + )) + + +(defun get-all-multipart-data (req &key (type :text) + (size 4096) + (external-format + *default-aserve-external-format*) + (limit nil) + ) + ;; retreive all the data for one multipart item + ;; + (let (res buffer (total-size 0) index) + (loop + (if* (null buffer) + then (setq buffer + (ecase type + (:text (make-string size)) + (:binary (make-array size :element-type '(unsigned-byte 8)))) + index 0)) + (let ((nextindex (get-multipart-sequence + req buffer + :start index + :external-format external-format))) + (if* (null nextindex) + then (if* (> index 0) + then (incf total-size index) + (push buffer res)) + (return)) + (if* (>= nextindex (length buffer)) + then ; full buffer + (incf total-size (length buffer)) + (if* (and limit (> total-size limit)) + then ; we in the overlimit stage, just + ; keep reading but don't save + (setq index 0) + else ; save away this full buffer + (push buffer res) + (setq buffer nil)) + else (setq index nextindex)))) + + ; read it all, data in res + (if* (zerop total-size) + then (case type + (:text "") + (:binary (make-array 0 :element-type '(unsigned-byte 8)))) + elseif (and limit (> total-size limit)) + then (values :limit total-size) ; over limit return + elseif (null (cdr res)) + then ; just one buffer + (subseq (car res) 0 total-size) + else ; multiple buffers, must build result + (let ((result (case type + (:text (make-string total-size)) + (:binary (make-array total-size + :element-type + '(unsigned-byte 8)))))) + (do ((to 0) + (buffs (nreverse res) (cdr buffs))) + ((null buffs)) + (replace result (car buffs) + :start1 to) + (incf to (length (car buffs)))) + result)))) + + + + + + + + + + + + +;; end multipart code + + + + + + + + + +(defun read-sequence-with-timeout (string length sock timeout) + ;; read length bytes into sequence, timing out after timeout + ;; seconds + ;; return nil if things go wrong. + (declare (ignorable timeout)) + (with-timeout-local (timeout nil) + (let ((got 0)) + (loop + (let ((this (rational-read-sequence string sock :start got))) + (if* (<= this got) + then (return nil) ; eof too early + else (setq got this) + (if* (>= got length ) then (return string)))))))) + + + + +(defun read-sock-line (sock buffer start chars-seen) + ;; read a line of data into the socket buffer, starting at start. + ;; return buffer and index after last character in buffer. + ;; get bigger buffer if needed. + ;; If problems occur free the passed in buffer and return nil. + ;; + ;; returns + ;; buffer + ;; num of chars in buff + ;; t if any characters have been read + + + (let ((max (length buffer)) + (prevch)) + (loop + (let ((ch (read-char sock nil :eof))) + (if* (eq ch :eof) + then (debug-format :info"eof on socket~%") + (free-request-buffer buffer) + (return-from read-sock-line nil)) + + (if* (null (car chars-seen)) + then (setf (car chars-seen) t)) + + (if* (eq ch #\linefeed) + then (if* (eq prevch #\return) + then (decf start) ; back up to toss out return + ) + (setf (schar buffer start) #-cormanlisp #\null #+cormanlisp #\nul) ; null terminate + + ; debug output + ; dump out buffer + (debug-format :info "read on socket: ") + (if-debug-action :info + (dotimes (i start) + (write-char (schar buffer i) *initial-terminal-io*)) + (terpri *initial-terminal-io*)) + ;; end debug + + (return-from read-sock-line (values buffer start)) + else ; store character + (if* (>= start max) + then ; must grow the string + (let ((new-buffer (get-request-buffer (+ max 1024)))) + (if* (null new-buffer) + then ;; too large, give up + (free-request-buffer buffer) + (return-from read-sock-line nil) + else ; got it + (dotimes (i start) + (setf (schar new-buffer i) + (schar buffer i))) + (setq max (length new-buffer)) + (free-request-buffer buffer) + (setq buffer new-buffer)))) + ; buffer is big enough + (setf (schar buffer start) ch) + (incf start)) + + (setq prevch ch))))) + + + +(defmethod request-query ((req http-request) &key (post t) (uri t) + (external-format + *default-aserve-external-format*)) + ;; decode if necessary and return the alist holding the + ;; args to this url. In the alist items the value is the + ;; cdr of the alist item. + ;; + ;; If uri is true then we look for query information in the uri + ;; (following a question mark) + ;; If post is true and this is a post request then we look for + ;; query information in the body of the query. + ;; If both are true (and this is a post) then we look both places. + ;; + ;; + (let ((alist (request-query-alist req)) + (signature (cons post uri))) + + (if* (not (eq alist :empty)) + then (let ((given-sig (getf (request-reply-plist req) + 'request-query-sig))) + (if* (equal given-sig signature) + then ; same args as before, cached value is legit + (return-from request-query alist)))) + + (let (res) + (if* uri + then (let ((arg (uri-query (request-uri req)))) + (if* arg + then (setq res (form-urlencoded-to-query + arg + :external-format external-format))))) + + (if* post + then (if* (and (eq (request-method req) :post) + (equal (header-slot-value req :content-type) + "application/x-www-form-urlencoded")) + then (setf res + (append res + (form-urlencoded-to-query + (get-request-body req) + :external-format external-format))))) + (setf (getf (request-reply-plist req) 'request-query-sig) + signature) + (setf (request-query-alist req) res)))) + + +(defun request-query-value (key req &key (post t) (uri t) (test #'equal) + (external-format + *default-aserve-external-format*)) + ;; access the value of the given key in the request's + ;; request query. We do this so often that it's useful + ;; to make this a function + (cdr (assoc key (request-query req :post post :uri uri + :external-format external-format) + :test test))) + + +(defsetf request-query-value + (key req &key (post t) (uri t) + ;; NDL 2004-06-04 -- LispWorks cannot "externalise" the object which you get + ;; upon evaluating #'equal, in functions which invoker this setf expander, + ;; but it's perfectly happy to work with #'equal itself. Protect from + ;; one level of evaluation. + (test #-(or sbcl lispworks) #'equal #+(or sbcl lispworks) '#'equal) + (external-format *default-aserve-external-format*)) + (newvalue) + ;; make it appear that the query alist contains this extra key/value + `(let ((ent (assoc ,key (request-query ,req :post ,post :uri ,uri + :external-format ,external-format) + :test ,test))) + (if* ent + then (setf (cdr ent) ,newvalue) + else (push (cons ,key ,newvalue) (request-query-alist ,req))) + + ,newvalue)) + + +(defun header-decode-integer (val) + ;; if val is a string holding an integer return its value + ;; and t, + ;; else nil + (if* val + then (let (ans) + (setq ans (string-to-number val 0 (length val))) + (if* (integerp ans) + then (values ans t))))) + + +(defun date-to-universal-time (date) + ;; convert a date string to lisp's universal time + ;; we accept all 3 possible date formats + + (flet ((cvt (str start-end) + (let ((res 0)) + (do ((i (car start-end) (1+ i)) + (end (cdr start-end))) + ((>= i end) res) + (setq res + (+ (* 10 res) + (- (char-code (schar str i)) #.(char-code #\0)))))))) + ;; check preferred type first (rfc1123 (formerly refc822)): + ;; Sun, 06 Nov 1994 08:49:37 GMT + (multiple-value-bind (ok whole + day + month + year + hour + minute + second) + (match-regexp + "[A-Za-z]+, \$[0-9]+\$ \$[A-Za-z]+\$ \$[0-9]+\$ \$[0-9]+\$:\$[0-9]+\$:\$[0-9]+\$ GMT" + date + :return :index) + (declare (ignore whole)) + (if* ok + then (return-from date-to-universal-time + (encode-universal-time + (cvt date second) + (cvt date minute) + (cvt date hour) + (cvt date day) + (compute-month date (car month)) + (cvt date year) + 0)))) + + ;; now second best format (but used by Netscape sadly): + ;; Sunday, 06-Nov-94 08:49:37 GMT + ;; + (multiple-value-bind (ok whole + day + month + year + hour + minute + second) + (match-regexp + + "[A-Za-z]+, \$[0-9]+\$-\$[A-Za-z]+\$-\$[0-9]+\$ \$[0-9]+\$:\$[0-9]+\$:\$[0-9]+\$ GMT" + date + :return :index) + + (declare (ignore whole)) + + (if* ok + then (return-from date-to-universal-time + (encode-universal-time + (cvt date second) + (cvt date minute) + (cvt date hour) + (cvt date day) + (compute-month date (car month)) + (cvt date year) ; cl does right thing with 2 digit dates + 0)))) + + + ;; finally the third format, from unix's asctime + ;; Sun Nov 6 08:49:37 1994 + (multiple-value-bind (ok whole + month + day + hour + minute + second + year + ) + (match-regexp + + "[A-Za-z]+ \$[A-Za-z]+\$ +\$[0-9]+\$ \$[0-9]+\$:\$[0-9]+\$:\$[0-9]+\$ \$[0-9]+\$" + date + :return :index) + + (declare (ignore whole)) + + (if* ok + then (return-from date-to-universal-time + (encode-universal-time + (cvt date second) + (cvt date minute) + (cvt date hour) + (cvt date day) + (compute-month date (car month)) + (cvt date year) + 0)))) + + + )) + + + + + +(defun compute-month (str start) + ;; return the month number given a 3char rep of the string + + (case (schar str start) + (#\A + (if* (eq (schar str (1+ start)) #\p) + then 4 ; april + else 8 ; august + )) + (#\D 12) ; dec + (#\F 2 ) ; feb + (#\J + (if* (eq (schar str (1+ start)) #\a) + then 1 ; jan + elseif (eq (schar str (+ 2 start)) #\l) + then 7 ; july + else 6 ; june + )) + (#\M + (if* (eq (schar str (+ 2 start)) #\r) + then 3 ; march + else 5 ; may + )) + (#\N 11) ; nov + (#\O 10) ;oct + (#\S 9) ; sept + )) + + + +(defun maybe-universal-time-to-date (ut-or-string &optional (time-zone 0)) + ;; given a ut or a string, only do the conversion on the string + (if* (stringp ut-or-string) + then ut-or-string + else (universal-time-to-date ut-or-string time-zone))) + +(defparameter *saved-ut-to-date* nil) + +(defun universal-time-to-date (ut &optional (time-zone 0)) + ;; convert a lisp universal time to rfc 1123 date + ;; + (let ((cval *saved-ut-to-date*)) + (if* (and (eql ut (caar cval)) + (eql time-zone (cdar cval))) + then ; turns out we often repeatedly ask for the same conversion + (cdr cval) + else + (let ((*print-pretty* nil)) + (multiple-value-bind + (sec min hour date month year day-of-week dsp tz) + (decode-universal-time ut time-zone) + (declare (ignore tz dsp)) + (let ((ans + (format + nil + "~a, ~2,'0d ~a ~d ~2,'0d:~2,'0d:~2,'0d~@[ GMT~]" + (svref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") + day-of-week) + date + (svref '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + month) + year + hour + min + sec + (= 0 time-zone)))) + (setf *saved-ut-to-date* (cons (cons ut time-zone) ans)) + ans)))))) + + + +;; ----- simple resource + +(defstruct sresource + data ; list of buffers + create ; create new object for the buffer + init ; optional - used to init buffers taken off the free list + (lock (acl-compat.mp:make-process-lock)) + ) + +(defun create-sresource (&key create init) + (make-sresource :create create :init init)) + +(defun get-sresource (sresource &optional size) + ;; get a new resource. If size is given then ask for at least that + ;; size + (let (to-return) + ;; force new ones to be allocated + (acl-compat.mp:with-process-lock ((sresource-lock sresource)) + (let ((buffers (sresource-data sresource))) + (if* size + then ; must get one of at least a certain size + (dolist (buf buffers) + (if* (>= (length buf) size) + then (setf (sresource-data sresource) + (delete buf buffers :test #'eq)) + (setq to-return buf) + (return))) + + ; none big enough + + else ; just get any buffer + (if* buffers + then (setf (sresource-data sresource) (cdr buffers)) + (setq to-return (car buffers))) + + ))) + + (if* to-return + then ; found one to return, must init + + (let ((init (sresource-init sresource))) + (if* init + then (funcall init sresource to-return))) + to-return + else ; none big enough, so get a new buffer. + (funcall (sresource-create sresource) + sresource + size)))) + +(defun free-sresource (sresource buffer) + ;; return a resource to the pool + ;; we silently ignore nil being passed in as a buffer + (if* buffer + then (acl-compat.mp:with-process-lock ((sresource-lock sresource)) + ;; if debugging + (if* (member buffer (sresource-data sresource) :test #'eq) + then (error "freeing freed buffer")) + ;; + + (push buffer (sresource-data sresource))))) + + + + +;; ----- scratch buffer resource: + +(defparameter *request-buffer-sresource* + (create-sresource + :create #'(lambda (sresource &optional size) + (declare (ignore sresource)) + (make-array (or size 2048) + :element-type 'character)))) + +(defun get-request-buffer (&optional size) + (get-sresource *request-buffer-sresource* size)) + +(defun free-request-buffer (buffer) + (free-sresource *request-buffer-sresource* buffer)) + + + + +;;----------------- + + +(defun string-to-number (string &optional (start 0) (end (length string))) + ;; convert the string into a number. + ;; the number is integer base 10 + ;; this is faster than creating a string input stream and + ;; doing a lisp read + ;; string must be a simple string + ;; + ;; we allow whitespace before and after the number, anything else + ;; will cause us to return 0 + ;; + (let ((ans) + (state :pre)) + (do ((i start) + (ch) + (digit)) + ((>= i end) + (if* (member state '(:number :post) :test #'eq) + then ans + else nil)) + + (setq ch (schar string i) + digit (- (char-code ch) #.(char-code #\0))) + + (case state + (:pre (if* (member ch '(#\space #\tab #\linefeed #\return) :test #'eq) + then (incf i) + else (setq state :number-first))) + (:number-first + (if* (<= 0 digit 9) + then (setq ans digit) + (incf i) + (setq state :number) ; seen a digit + else (return-from string-to-number nil) ; bogus + )) + (:number + (if* (<= 0 digit 9) + then (setq ans (+ (* ans 10) digit)) + (incf i) + else (setq state :post))) + + (:post + (if* (member ch '(#\space #\tab #\linefeed #\return) :test #'eq) + then (incf i) + else (return-from string-to-number nil))))))) + +(defun get-host-port (string &optional (port 80)) + ;; return the host and port from the string + ;; which should have the form: "www.foo.com" or "www.foo.com:9000" + ;; + ;; port is the default value for the port arg + ;; + ;; return two values: + ;; host string + ;; port integer + ;; or nil if there host string is malformed. + ;; + (let ((parts (split-on-character string #\:))) + (if* (null (cdr parts)) + then (values (car parts) port) + elseif (null (cddr parts)) + then ; exactly two + (if* (equal "" (cadr parts)) + then ; treat nothing after a colon like no colon present + (values (car parts) port) + else (setq port (string-to-number (cadr parts))) + (if* port + then (values (car parts) port)))))) + +;------- + +#+allegro +(defun ensure-stream-lock (stream) + ;; ensure that the stream has a lock object on it so that + ;; it can be used as log stream. + ;; + ;; return the stream object passed in. + ;; + (if* (and (streamp stream) + (null (getf (excl::stream-property-list stream) :lock))) + then (setf (getf (excl::stream-property-list stream) :lock) + (mp:make-process-lock))) + stream) + +#-allegro +;; TODO: implement this and turn on locking in log.cl +(defun ensure-stream-lock (stream) + stream) + + +;;------------------- +;; authorization + +(defmethod get-basic-authorization ((req http-request)) + ;; return the basic authorization information for this request, if any + ;; + ;; basic authorization is used when a name/password dialog is + ;; put up by the browser + ;; + ;; if authorization info in found this request, return two values + ;; name + ;; password + ;; + (let ((auth-value (header-slot-value req :authorization))) + (if* auth-value + then (let ((words (split-into-words auth-value))) + (if* (equalp (car words) "basic") + then (setq auth-value + (split-on-character (base64-decode (cadr words)) #\:)) + (values-list auth-value)))))) + + +(defmethod set-basic-authorization ((req http-request) realm) + ;; declare that you want to get authentication information + ;; for the given realm. + ;; This must be called after with-http-response and before + ;; with-http-body + (setq realm (string realm)) + (setf (reply-header-slot-value req :www-authenticate) + (format nil "Basic realm=~s" realm))) + + + +;======= + +(defun bulk-set-reply-headers (req headers) + ;; given an alist list of headers to set, set the header info + ;; in the correct place (given fast vrs slow headers) + (let ((fast-headers *fast-reply-headers*) + (current-headers (request-reply-headers req))) + (dolist (header headers) + (let ((this (car header)) + (ent)) + (if* (setq ent (assoc this fast-headers :test #'eq)) + then ; a fast one + (setf (slot-value req (second ent)) (cdr header)) + else ; a slow one + (if* (null (setq ent (assoc this + current-headers :test #'eq))) + then ; not present yet + (push (setq ent (cons this nil)) current-headers)) + (setf (cdr ent) (cdr header))))) + (setf (request-reply-headers req) current-headers))) + + +(defun code-to-response (code) + ;; return response object for the given code + (let ((obj (find code *responses* :key #'response-number))) + (if* (null obj) + then (push (setq obj (make-resp code "unknown code")) *responses*)) + obj)) + + + +;=============== +; initially in the webactions codde, now here: +;;------- support for storing variables in the request object + +(defun request-variable-value (req name) + ;; get the value of the named variable in the request variable list + ;; + (cdr (assoc name (getf (request-reply-plist req) 'variables) + :test #'equal))) + +(defsetf request-variable-value .inv-request-variable-value) + +(defun .inv-request-variable-value (req name newvalue) + (let ((ent (assoc name (getf (request-reply-plist req) 'variables) + :test #'equal))) + (if* ent + then (setf (cdr ent) newvalue) + else ; must add an ent + (push (cons name newvalue) + (getf (request-reply-plist req) 'variables)) + newvalue))) + + + Added: vendor/portableaserve/aserve/packages.cl =================================================================== --- vendor/portableaserve/aserve/packages.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/packages.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,219 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; packages.cl +;; +;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2002-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: packages.cl,v 1.6 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; packages and exports for AllegroServe +;; +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +; note: net.html.generator is not defined here since that's a +; standalone package +; +(in-package :cl-user) + +;; NDL 2004-06-04 -- Redefining packages and hoping to get the union of your exports +;; is non-portable. Moved contents of two other :net.aserve package definitions into this one. + +(defpackage :net.aserve + (:use :common-lisp :acl-compat.excl :net.html.generator :puri) + (:export + #:authorize + #:authorizer + #:base64-decode + #:base64-encode + #:compute-strategy + #:computed-entity + ;; don't export, these should be private + ; #:debug-off + ; #:debug-on + #:denied-request + #:enable-proxy + #:ensure-stream-lock + #:entity-plist + #:failed-request + #:form-urlencoded-to-query + #:function-authorizer ; class + #:function-authorizer-function + #:get-basic-authorization + #:get-cookie-values + #:get-all-multipart-data + #:get-multipart-header + #:get-multipart-sequence + #:get-request-body + #:handle-request + #:handle-uri ; add-on component.. + #:header-slot-value + #:http-request ; class + #:locator ; class + #:location-authorizer ; class + #:location-authorizer-patterns + #:map-entities + #:parse-multipart-header + #:password-authorizer ; class + #:process-entity + #:publish + #:publish-file + #:publish-directory + #:publish-multi + #:publish-prefix + #:query-to-form-urlencoded + #:reply-header-slot-value + #:run-cgi-program + #:set-basic-authorization + #:standard-locator + #:unpublish-locator + #:vhost + #:vhost-log-stream + #:vhost-error-stream + #:vhost-names + #:vhost-plist + + #:request-method + #:request-protocol + + #:request-protocol-string + #:request-query + #:request-query-value + #:request-raw-request + #:request-raw-uri + #:request-socket + #:request-uri + #:request-variable-value + #:request-wserver + + #:request-reply-code + #:request-reply-date + #:request-reply-content-length + #:request-reply-content-type + #:request-reply-plist + #:request-reply-protocol-string + #:request-reply-strategy + #:request-reply-stream + + #:set-cookie-header + #:shutdown + #:split-into-words + #:start + #:uridecode-string + #:uriencode-string + #:unpublish + #:url-argument + #:url-argument-alist + #:with-http-response + #:with-http-body + + #:wserver + #:wserver-default-vhost + #:wserver-enable-chunking + #:wserver-enable-keep-alive + #:wserver-external-format + #:wserver-filters + #:wserver-locators + #:wserver-io-timeout + #:wserver-log-function + #:wserver-log-stream + #:wserver-response-timeout + #:wserver-socket + #:wserver-vhosts + + #:*aserve-version* + #:*default-aserve-external-format* + #:*http-io-timeout* + #:*http-response-timeout* + #:*mime-types* + #:*response-accepted* + #:*response-bad-request* + #:*response-continue* + #:*response-created* + #:*response-found* + #:*response-internal-server-error* + #:*response-not-found* + #:*response-not-modified* + #:*response-ok* + #:*response-moved-permanently* + #:*response-see-other* + #:*response-temporary-redirect* + #:*response-unauthorized* + #:*wserver*) + + #+lispworks + (:export #:clp-directory-entity-processor + #:clp-entity + #:def-clp-function + #:emit-clp-entity + #:find-clp-module + #:find-clp-module-function + #:publish-clp + #:request-variable-value + ) + + #+lispworks + (:export + #:initialize-websession-master + #:locate-action-path + #:webaction + #:webaction-entity + #:webaction-from-ent + #:webaction-project + #:websession + #:websession-data + #:websession-key + #:websession-from-req + #:websession-master + #:websession-variable + )) + + +(defpackage :net.aserve.client + (:use :net.aserve :acl-compat.excl :common-lisp) + (:export + #:client-request ; class + #:client-request-close + #:client-request-cookies + #:client-request-headers + #:client-request-protocol + #:client-request-read-sequence + #:client-request-response-code + #:client-request-response-comment + #:client-request-socket + #:client-request-uri + #:client-response-header-value + #:cookie-item + #:cookie-item-expires + #:cookie-item-name + #:cookie-item-path + #:cookie-item-secure + #:cookie-item-value + #:cookie-jar ; class + #:do-http-request + #:make-http-client-request + #:read-client-response-headers + )) Added: vendor/portableaserve/aserve/parse.cl =================================================================== --- vendor/portableaserve/aserve/parse.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/parse.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,779 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; parse.cl +;; +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; +;; $Id: parse.cl,v 1.12 2005/02/20 12:20:45 rudi Exp $ + +;; Description: +;; parsing and encoding code + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +(in-package :net.aserve) + + +;; parseobj -- used for cons-free parsing of strings +(defconstant parseobj-size 20) + +(defstruct parseobj + (start (make-array parseobj-size)) ; first charpos + (end (make-array parseobj-size)) ; charpos after last + (next 0) ; next index to use + (max parseobj-size) + ) + +(defvar *parseobjs* nil) + +(defun allocate-parseobj () + (let (res) + (acl-compat.mp:without-scheduling + (if* (setq res (pop *parseobjs*)) + then (setf (parseobj-next res) 0) + res + else (make-parseobj))))) + +(defun free-parseobj (po) + (acl-compat.mp:without-scheduling + (push po *parseobjs*))) + +(defun add-to-parseobj (po start end) + ;; add the given start,end pair to the parseobj + (let ((next (parseobj-next po))) + (if* (>= next (parseobj-max po)) + then ; must grow it + (let ((ostart (parseobj-start po)) + (oend (parseobj-end po))) + (let ((nstart (make-array (+ 10 (length ostart)))) + (nend (make-array (+ 10 (length ostart))))) + (dotimes (i (length ostart)) + (setf (svref nstart i) (svref ostart i)) + (setf (svref nend i) (svref oend i))) + (setf (parseobj-start po) nstart) + (setf (parseobj-end po) nend) + (setf (parseobj-max po) (length nstart)) + ))) + + (setf (svref (parseobj-start po) next) start) + (setf (svref (parseobj-end po) next) end) + (setf (parseobj-next po) (1+ next)) + next)) + +;;;;;; + + + + + + + + + + + + + + + + + + +(defun parse-http-command (buffer end) + ;; buffer is a string buffer, with 'end' bytes in it. + ;; return 3 values + ;; command (kwd naming it or nil if bogus) + ;; url uri object + ;; protocol (kwd naming it or nil if bogus) + ;; + (let ((blankpos) + (cmd) + (urlstart)) + + ; search for command first + (dolist (possible *http-command-list* + (return-from parse-http-command nil) ; failure + ) + (let ((str (car possible))) + (if* (buffer-match buffer 0 str) + then ; got it + (setq cmd (cdr possible)) + (setq urlstart (length (car possible))) + (return)))) + + + (setq blankpos (find-it #\space buffer urlstart end)) + + (if* (eq blankpos urlstart) + then ; bogus, no url + (return-from parse-http-command nil)) + + + (if* (null blankpos) + then ; must be http/0.9 + (return-from parse-http-command (values cmd + (parse-uri + (buffer-substr buffer + urlstart + end)) + :http/0.9))) + + (let ((url (buffer-substr buffer urlstart blankpos)) + (prot)) + + ; parse url and if that fails get out right away + (if* (null (setq url (parse-uri url))) + then (return-from parse-http-command nil)) + + (if* (buffer-match buffer (1+ blankpos) "HTTP/1.") + then (if* (eq #\0 (schar buffer (+ 8 blankpos))) + then (setq prot :http/1.0) + elseif (eq #\1 (schar buffer (+ 8 blankpos))) + then (setq prot :http/1.1))) + + (values cmd url prot)))) + + + + + + +(defun new-read-request-headers (req sock) + ;; use the new strategy to read in the request headers + ;; + ;; return nil if we don't get all the way to the crlf crlf + (let ((buff (get-sresource *header-block-sresource*)) + (end)) + + (setf (request-header-block req) buff) + ;; read in all the headers, stop at the last crlf + (if* (setq end (read-headers-into-buffer sock buff)) + then (let ((otherheaders (parse-header-block buff 0 end))) + + (if* otherheaders + then ; non standard headers present...store + ; separately + (dolist (otherheader otherheaders) + (setf (car otherheader) + (header-keywordify (car otherheader)))) + + (setf (request-headers req) + (append (request-headers req) otherheaders)))) + + t))) + +(defvar *headername-to-kwd* nil) + +(defun header-keywordify (name) + ;; convert name to keyword.. check cache first + (or (cdr (assoc name *headername-to-kwd* :test #'equal)) + (let ((kwd (intern (if* (eq *current-case-mode* :case-insensitive-upper) + then (string-upcase name) + else name) + (find-package :keyword)))) + (push (cons name kwd) *headername-to-kwd*) + + kwd))) + + + + + + +(defun read-headers-into-buffer (sock buff) + ;; read the header data into the buffer + ;; return the index of the character following the last header + ;; or nil if the whole header wasn't read in + ;; + (let ((len (- (length buff) 500)) ; leave space for index at end + (i 0) + (state 2) + (echo (member :xmit *debug-current*))) + + (loop + (if* (>= i len) + then (return nil)) ; failure + + (let ((ch (read-byte sock nil nil))) + (if* (null ch) + then (format *debug-stream* "early eof reading response after ~d bytes~%" i) + (return nil) ; eof - failure + ) + + ; enable this if things are really messed + ; up and you need to see characters as they come in + #+ignore + (if* echo + then (write-char (code-char ch) *debug-stream*) + (force-output *debug-stream*)) + + + (setf (aref buff i) ch) + (incf i) + (case state + (0 ; seen nothing interesting + (if* (eq ch #.(char-code #\linefeed)) + then (setq state 2) + elseif (eq ch #.(char-code #\return)) + then (setq state 1))) + (1 ; seen cr + (if* (eq ch #.(char-code #\linefeed)) + then (setq state 2) + elseif (eq ch #.(char-code #\return)) + then nil ; stay in 1 + else (setq state 0))) + (2 ; seen [cr] lf + (if* (eq ch #.(char-code #\linefeed)) + then (setq state 4) + elseif (eq ch #.(char-code #\return)) + then (setq state 3) + else (setq state 0))) + (3 ; seen [cr] lf cr + (if* (eq ch #.(char-code #\linefeed)) + then (setq state 4) + elseif (eq ch #.(char-code #\return)) + then (setq state 1) + else (setq state 0)))) + + (if* (eql state 4) + then ; all done + ; back up over [cr] lf + (if* (>= i 2) + then (decf i 2) ; i points at cr if there is one + (if* (not (eq (aref buff i) #.(char-code #\return))) + then (incf i))) + ; i points to the [cr] lf + (if* echo + then + #+allegro (write-sequence buff *debug-stream* + :start 0 + :end i) + ;;; No bivalent terminal streams on non-allegro lisps + #-allegro (write-sequence + (map 'string #'code-char (subseq buff 0 i)) + *debug-stream*) + ) + + (return i)))))) + + + + + + + + + + + + + + +;------- header value parsing +; +; most headers value this format +; value +; value1, value2, value3 +; value; param=val; param2=val +; +; notes: in the comma separated lists, it's legal to use more than one +; comma between values in which case the intermediate "null" values +; are ignored e.g a,,b is the same as a,b +; +; the semicolon introduces a parameter, it doesn't end a value. +; the semicolon has a higher binding power than the comma, +; so A; b=c; d=e, F +; is two values, A and F, with A having parameters b=c and d=e. +; +; A header value that doesn't follow the above rules in +; the one for set-cookie +; set-cookie: val=yes; expires=Fri, 01-Jan-2010 08:00:00 GMT; path=/ +; note how it starts off with param=val, and then the value +; can have commas in it, thus we don't use comm as a separator + +(defconstant ch-alpha 0) +(defconstant ch-space 1) +(defconstant ch-sep 2) ; separators + +(defvar *syntax-table* + (let ((arr (make-array 256 :initial-element ch-alpha))) + + ; the default so we don't have to set it + #+ignore (do ((code (char-code #\!) (1+ code))) + ((> code #.(char-code #\~))) + (setf (svref arr code) ch-alpha)) + + (setf (svref arr (char-code #\space)) ch-space) + (setf (svref arr (char-code #\Page)) ch-space) + (setf (svref arr (char-code #\tab)) ch-space) + (setf (svref arr (char-code #\return)) ch-space) + (setf (svref arr (char-code #\linefeed)) ch-space) + + (setf (svref arr (char-code #\,)) ch-sep) + (setf (svref arr (char-code #\;)) ch-sep) + (setf (svref arr (char-code #\()) ch-sep) + + arr)) + + + +(defun header-value-nth (parsed-value n) + ;; return the nth value in the list of header values + ;; a value is either a string or a list (:param value params..) + ;; + ;; nil is returned if we've asked for a non-existant element + ;; (nil is never a valid value). + ;; + (if* (and parsed-value (not (consp parsed-value))) + then (error "bad parsed value ~s" parsed-value)) + + (let ((val (nth n parsed-value))) + (if* (atom val) + then val + else ; (:param value ...) + (cadr val)))) + + +(defun header-value-member (val parsed-value) + ;; test to see if the given value is a member of the list + ;; of values in the parsed value. parse the value if needed + (setq parsed-value (ensure-value-parsed parsed-value)) + (dolist (par parsed-value) + (if* (consp par) + then (setq par (cadr par))) + (if* (equalp val par) + then (return t)))) + +(defun ensure-value-parsed (str &optional singlep) + ;; parse the header value if it hasn't been parsed. + ;; a parsed value is a cons.. easy to distinguish + (if* (consp str) + then str + else (parse-header-value str singlep))) + + + + +(defun parse-header-value (str &optional singlep (start 0) (end (length str))) + ;; scan the given string and return either a single value + ;; or a list of values. + ;; A single value is a string or (:param value paramval ....) for + ;; values with parameters. A paramval is either a string or + ;; a cons of two strings (name . value) which are the parameter + ;; and its value. + ;; + ;; if singlep is true then we expect to see a single value which + ;; main contain commas. This is seen when Netscape sends + ;; an if-modified-since header and it may in fact be a bug in + ;; Netscape (since parameters aren't defined for if-modified-since's value) + ;; + + ;; split by comma first + (let (po res) + + (if* singlep + then ; don't do the comma split, make everything + ; one string + (setq po (allocate-parseobj)) + (setf (svref (parseobj-start po) 0) start) + (setf (svref (parseobj-end po) 0) end) + (setf (parseobj-next po) 1) + else (setq po (split-string str #\, t nil nil start end))) + + + + ; now for each split, by semicolon + + (dotimes (i (parseobj-next po)) + (let ((stindex (parseobj-next po)) + (params) + (thisvalue)) + (split-string str #\; t nil po + (svref (parseobj-start po) i) + (svref (parseobj-end po) i)) + ; the first object we take whole + (setq thisvalue (trimmed-parseobj str po stindex)) + (if* (not (equal thisvalue "")) + then ; ok, it's real, look for params + (do ((i (1+ stindex) (1+ i)) + (max (parseobj-next po)) + (paramkey nil nil) + (paramvalue nil nil)) + ((>= i max) + (setq params (nreverse params)) + ) + + ; split the param by = + (split-string str #\= t 1 po + (svref (parseobj-start po) i) + (svref (parseobj-end po) i)) + (setq paramkey (trimmed-parseobj str po max)) + (if* (> (parseobj-next po) (1+ max)) + then ; must have been an equal + (setq paramvalue (trimmed-parseobj str po + (1+ max)))) + (push (if* paramvalue + then (cons paramkey paramvalue) + else paramkey) + params) + + (setf (parseobj-next po) max)) + + (push (if* params + then `(:param ,thisvalue + ,@params) + else thisvalue) + res)))) + + (free-parseobj po) + + (nreverse res))) + + +(defun assoc-paramval (key paramvals) + ;; search the paramvals for the given key. + ;; this takes into account that paramvals isn't an assoc + ;; list since the items my be strings or (string . string) + ;; Also we use equalp as the test + ;; + (dolist (val paramvals) + (if* (stringp val) + then (if* (equalp key val) + then (return val)) + elseif (equalp (car val) key) + then (return val)))) + + + + +(defun trimmed-parseobj (str po index) + ;; return the string pointed to by the given index in + ;; the parseobj -- trimming blanks around both sides + ;; + ;; if surrounded by double quotes, trim them off too + + (let ((start (svref (parseobj-start po) index)) + (end (svref (parseobj-end po) index))) + + ;; trim left + (loop + (if* (>= start end) + then (return-from trimmed-parseobj "") + else (let ((ch (schar str start))) + (if* (eq ch-space (svref *syntax-table* + (char-code ch))) + then (incf start) + else (return))))) + + ; trim right + (loop + (decf end) + (let ((ch (schar str end))) + (if* (not (eq ch-space (svref *syntax-table* (char-code ch)))) + then (incf end) + (return)))) + + ; trim matching double quotes + (if* (and (> end (1+ start)) + (eq #\" (schar str start)) + (eq #\" (schar str (1- end)))) + then (incf start) + (decf end)) + + ; make string + (let ((newstr (make-string (- end start)))) + (dotimes (i (- end start)) + (setf (schar newstr i) + (schar str (+ start i)))) + + newstr))) + + + + + + + + +(defun split-string (str split &optional + magic-parens + count + parseobj + (start 0) + (end (length str))) + ;; divide the string where the character split occurs + ;; return the results in parseobj object + (let ((po (or parseobj (allocate-parseobj))) + (st start) + ) + ; states + ; 0 initial, scanning for interesting char or end + (loop + (if* (>= start end) + then (add-to-parseobj po st start) + (return) + else (let ((ch (schar str start))) + + (if* (eq ch split) + then ; end this one + (add-to-parseobj po st start) + (setq st (incf start)) + (if* (and count (zerop (decf count))) + then ; get out now + (add-to-parseobj po st end) + (return)) + elseif (and magic-parens (eq ch #$)) + then ; scan until matching paren + (let ((count 1)) + (loop + (incf start) + (if* (>= start end) + then (return) + else (setq ch (schar str start)) + (if* (eq ch #$) + then (if* (zerop (decf count)) + then (return)) + elseif (eq ch #$) + then (incf count))))) + + (if* (>= start end) + then (add-to-parseobj po st start) + (return)) + elseif (eq ch #\") + then ; double quoted value.. skip over this + (loop + (incf start) + (if* (>= start end) + then (return) + else (setq ch (schar str start)) + (if* (eq ch #\") + then (return) + elseif (eq ch #\$ + then ; single char quote + (incf start) + (if* (>= start end) + then (return))))) + (if* (>= start end) + then (add-to-parseobj po st start) + (return) + else (incf start)) + else (incf start))))) + po)) + + +(defun split-on-character (str char &key count) + ;; given a string return a list of the strings between occurances + ;; of the given character. + ;; If the character isn't present then the list will contain just + ;; the given string. + (let ((loc (position char str)) + (start 0) + (res)) + (if* (null loc) + then ; doesn't appear anywhere, just the original string + (list str) + else ; must do some work + (loop + (push (subseq str start loc) res) + (setq start (1+ loc)) + (if* count then (decf count)) + (setq loc (position char str :start start)) + (if* (or (null loc) + (eql 0 count)) + then (if* (< start (length str)) + then (push (subseq str start) res) + else (push "" res)) + (return (nreverse res))))))) + + + + +(defun split-into-words (str) + ;; split the given string into words (items separated by white space) + ;; + (let ((state 0) + (i 0) + (len (length str)) + (start nil) + (res) + (ch) + (spacep)) + (loop + (if* (>= i len) + then (setq ch #\space) + else (setq ch (char str i))) + (setq spacep (eq ch-space (svref *syntax-table* (char-code ch)))) + + (case state + (0 ; looking for non-space + (if* (not spacep) + then (setq start i + state 1))) + (1 ; have left anchor, looking for space + (if* spacep + then (push (subseq str start i) res) + (setq state 0)))) + (if* (>= i len) then (return)) + (incf i)) + (nreverse res))) + + +(defun parse-range-value (str) + ;; parse the value passed to a Range header + ;; return (n . m) n and m integers meaning bytes from n to m inclusive + ;; (nil . m) meaning the last m bytes + ;; (n . nil) meaning bytes from n to the end + ;; + (let ((top (split-on-character str #\=)) + (res)) + (and (equalp (car top) "bytes") + (stringp (cadr top)) + (dolist (range (split-on-character (cadr top) #\,)) + (let ((startend (split-on-character range #\-)) + (first) + (second)) + (if* (not (equal "" (car startend))) + then (setq first (string-to-number (car startend)))) + (if* (not (equal "" (cadr startend))) + then (setq second (string-to-number (cadr startend)))) + (push (cons first second) res)))) + (nreverse res))) + + + + +;; this isn't needed while the web server is running, it just +;; needs to be run periodically as new mime types are introduced. +#+ignore-until-mime-table-changed +(defun generate-mime-table (&optional (file "/etc/mime.types")) + ;; generate a file type to mime type table based on file type + (let (res) + (with-open-file (p file :direction :input) + (loop + (let ((line (read-line p nil nil))) + (if* (null line) then (return)) + (if* (and (> (length line) 0) + (eq #\# (schar line 0))) + thenret ; comment + else ; real stuff + (let ((data (split-into-words line))) + (if* data then (push data res))))))) + (nreverse res))) + + +(defun match-head-p (val1 val2) + ;; return t if val1 is a prefix of val2 + ;; val1 and val2 are simple strings + (let ((len1 (length val1)) + (len2 (length val2))) + (if* (<= len1 len2) + then (dotimes (i len1 t) + (if* (not (eq (schar val1 i) (schar val2 i))) + then (return nil)))))) + +(defun match-tail-p (val1 val2) + ;; return t if val1 is a suffix of val2 + ;; val1 and val2 are simple strings + (let ((len1 (length val1)) + (len2 (length val2))) + (if* (<= len1 len2) + then (let ((diff (- len2 len1))) + (dotimes (i len1 t) + (if* (not (eq (schar val1 i) (schar val2 (+ diff i)))) + then (return nil))))))) + + +;---- +(defun split-namestring (file) + ;; split the namestring into root and tail and then the tail + ;; into name and type + ;; + ;; any of the return value can be nil if the corresponding item + ;; isn't present. + ;; + ;; rules for splitting the tail into name and type components: + ;; if the last period in the tail is at the beginning or end of the + ;; tail, then the name is exactly the tail and type is nil. + ;; Thus .foo and bar. are just names, no type + ;; but .foo.c has a name of ".foo" and a type of "c" + ;; Thus if there is a non-nil type then it means that + ;; 1. there will be a non nil name as well + ;; 2. to reconstruct the filename you need to add a period between + ;; the name and type. + ;; + (let ((pos (min (or (or (position #\/ file :from-end t) most-positive-fixnum) + #+mswindows (position #\\ file :from-end t)))) + root + tail) + + (if* (equal file "") then (return-from split-namestring nil)) + + (if* (and pos (< pos most-positive-fixnum)) + then ; we have root and tail + (if* (eql pos (1- (length file))) + then ; just have root + (return-from split-namestring + (values file nil nil nil))) + + + (setq root (subseq file 0 (1+ pos)) + tail (subseq file (1+ pos))) + else (setq tail file)) + + + ; split the tail + (let ((pos (position #\. tail :from-end t))) + (if* (or (null pos) + (zerop pos) + (equal pos (1- (length tail)))) + then ; name begins or ends with . so it's not + ; a type separator + (values root tail tail nil) + else ; have all pieces + (values root tail + (subseq tail 0 pos) + (subseq tail (1+ pos))))))) + + + + + + + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/proxy.cl =================================================================== --- vendor/portableaserve/aserve/proxy.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/proxy.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2745 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; proxy.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: proxy.cl,v 1.17 2006/01/21 16:51:44 rudi Exp $ + +;; Description: +;; aserve's proxy and proxy cache + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +(in-package :net.aserve) + +; denotes a request from the browser +(defconstant *browser-level* 100) ; + +(defparameter *extra-lifetime-factor* 1.1) + +; number of seconds to add to expiration time of any entry in cache +(defparameter *extra-lifetime* 0) + + +; true if we are to save cached connections +(defparameter *connection-caching* t) + + + + +; statistics about connection caching + +(defparameter *connections-cached* 0) ; number of connections put in to cache +(defparameter *connections-made* 0) ; number of make-socket calls made +(defparameter *connections-used-cached* 0) ; number of cached connections used +; the cache +(defparameter *connection-cache-queue* (cons nil nil)) ; (first . last) queue of conn-cache objects +(defparameter *connection-cache-expire* 10) ; number of seconds to live + + +; number of seconds we wait for a connect before we consider it timed +; out. Given the chance Linux seems to wait forever for a connection +; so we need to shut it down ourselves. +(defparameter *connection-timed-out-wait* 30) + + +(defstruct pcache + ;; proxy cache + table ; hash table mapping to pcache-ent objects + disk-caches ; list of pcache-disk items + + cleaner ; process doing housecleaning + (cleaner-lock (acl-compat.mp:make-process-lock :name "cache cleaner")) + + size ; specified size of the cache (in blocks) + high-water ; when blocks in cache gets above this start flushing to disk + low-water ; when blocks in cache get below this stop flushing + + (dead-items 0) ; total number of objects on the dead-ent list + + (level0-time 0) ; last time level0 access was done + + queueobj ; queue object holding in-memory cache objects + + dead-ent ; linked list of dead pcache-ents, linked by next field only + + ; hash table of handlers for uris, keyed by host + uri-info-table + + ; pointer to linkscan object if we are doing automatic link scanning + ; in the proxy cache + linkscan + + entry-cached-hook ; funcalled with pcache, pcache-ent and level + + ; requests that completely bypass the cache + (r-direct 0) + + ; ims or non-ims where there is no entry that mathes this url + ; and the request headers + (r-miss 0) + + ; like r-miss except the level is greater than 0 thus this is a + ; cache fill rather than a direct user request + (r-cache-fill 0) + + ; non-ims request. value within the min-freshness contstraints + ; ims request where we know that the value in the cache is fresh + ; and has been modified since the ims time + (r-fast-hit 0) + + ; non-ims request. value is stale but after checking with the + ; origin server we find that our value is up to date + (r-slow-hit 0) + + ; ims request made and cached value is fresh and based on that + ; we know that the client's version is fresh so send + ; not-modified response back + (r-fast-validation 0) + + ; ims request where we return not-modified after checking with + ; the origin server + (r-slow-validation 0) + + + ; stale copy in the cache, we check with the origin server + ; and find that our copy was inconsistent and get a new copy to cache + (r-consistency-miss 0) + + ) + + + +(defstruct pcache-disk + ;; for each disk file on which we are caching + filename + stream + blocks ; total blocks in cache + free-blocks ; number of blocks remaining + free-list ; list of (start . end) blocks that are free + + high-water ; when free blocks is less than this start flushing + low-water ; when free blocks is more than this stop flushing + + (lock (acl-compat.mp:make-process-lock :name "disk pcache")) + ; doubly linked list of pcache-ents in this cache + queueobj + ) + + + + + +; each pcache entry holds the information on a 200 response +; use state +; --- ------ +; >=0 nil in memory cache entry. linked to mru-ent +; >0 :dead in memory entry in use but which will no longer be used +; after the uses are over. linked to dead-ent +; nil :dead in memory entry which is ready to be reclaimed along +; with all the blocks it points to. linked to dead-ent +; + + +(defstruct pcache-ent + key ; the string form of the uri + uri ; the actual uri + last-modified-string ; last modified time from the header + last-modified ; universal time entry was last modified + expires ; universal time when this entry expires + + + data ; data blocks (first is the response header block) + data-length ; number of octets of data + blocks ; number of cache blocks (length of the value in data slot) + code ; response code. 200 or 302 + comment ; response comment + + cookie ; the cookie if any with this request + + ; count of the internal use of this + use ; nil - dead entry. >= 0 - current users of this entry + + (state :new) ; nil - normal , + ; :dead - trying to kill off, + ; :new - filling the entry + + ;; scanned ; true when link scanning has been done + + ; number of times this entry was returned due to a request + (returned 0) + + ; if cached to the disk this tells where + disk-location + pcache-disk + loading-flag ; true when we are loading in from the disk + + ; linked list of pcache-ents + queueobj ; queue object we're stored in + prev + next + + ; scanning for links + ; notes: + ; links is initially nil and once the page has been scanned for links + ; it is t or a list of uri objects + ; or it is :scanning when then pcache-ent is in the to be link scanned + ; level is non-zero when this entry is on the link-scan queue or + ; uri-scan queue. + ; scan-next is valid (nil or non-nil) when this entry is on the + ; link-scan queue or uri-scan queue. + ; + links ; nil or list of uris to img's then list of uris from a links + links-left ; list of uris still to scan + level ; level at which to scan these links + scan-next ; next pcache-ent to scan + + (autoscan-time 0) ; univeral time when last scanned by the link scanner + ) + + +(defstruct queueobj + (items 0) ; number of items in the queue (aside from dummy ones) + (bytes 0) ; number of data bytes cached + (blocks 0) ; number of buffer blocks + mru ; points to dummy pcache-ent at the head of the queue + lru ; points to dummy pcache-ent at the tail of the quee + + ) + + +(defstruct uri-info + ;; information on how to handle a uri or set of uris + host ; string naming the host of the uri + (port 80) + path ; string in regexp form denoting the path. nil means all + path-regexp ; compiled regular expression for the path (or nil) + + ; nil or number of extra seconds of lifetime to add to uri + ; nil means use systemwide default + extra-lifetime + + ; nil or default depth for link scanning + ; nil means use systemwide default + scan-depth + exclude ; list of regexps for links to not scan + exclude-regexp ; compiled regexp versions of dont-follow + + ; called on links to determine at which level they should be followed + scan-function + + ; true if we should follow links to a site different than this page + offsite + ) + + + + + +(defclass locator-proxy (locator) + ;; denotes sending the request to another machine + ;; + ()) + + + +(defun enable-proxy (&key (server *wserver*) + proxy-proxy) + ;; + (let ((locator-proxy-obj + (make-instance 'locator-proxy + :name :proxy + :extra (make-instance 'computed-entity + :function #'(lambda (req ent) + (do-proxy-request req ent)) + :extra (if* proxy-proxy + then (multiple-value-bind (host port) + (get-host-port proxy-proxy) + (if* (null host) + then (error "bad host port specification: ~s" proxy-proxy)) + (cons host port))))))) + + + ; must be first as other locators may not ignore absolute proxy urls + (pushnew locator-proxy-obj (wserver-locators server)) + + )) + +(defmethod standard-locator ((req http-request) (locator locator-proxy)) + ;; see if this is a proxy request and if so return the entity that + ;; denotes we're proxying + (if* (uri-scheme (request-raw-uri req)) + then ; compute entity object + (locator-extra locator))) + + +(defun do-proxy-request (req ent) + ;; a request has come in which has a uri with a scheme part, + ;; thus denoting a request to be proxied (unless it's on our machine). + (let* ((uri (request-raw-uri req)) + (scheme (uri-scheme uri)) + (host (uri-host uri)) + (port (or (uri-port uri) 80)) + ) + (if* (or (not (eq scheme :http)) + (null host)) + then (with-http-response (req ent :response *response-bad-request*) + (with-http-body (req ent) + (html (:html (:head (:title "Bad Request")) + (:body "This url isn't a valid proxy request " + (:princ-safe (puri:render-uri uri nil))))))) + else ; see if it's a local request + (let ((ipaddr (ignore-errors (acl-compat.socket:lookup-hostname host)))) + (if* (null ipaddr) + then (with-http-response (req ent :response + *response-not-found*) + (with-http-body (req ent) + (html + (:html + (:head (:title "404 - Not Found")) + (:body + (:h1 "Host not found") + "The proxy failed to find the address for host " + (:b (:princ-safe host))))))) + (return-from do-proxy-request)) + (if* (and ipaddr + (member ipaddr + (wserver-ipaddrs *wserver*)) + (eq port + (acl-compat.socket:local-port (wserver-socket *wserver*))) + ) + then ; it's us, make it into into a local request + ; and look it up again + (setf (request-raw-uri req) + (puri:copy-uri uri :scheme nil :host nil)) + (handle-request req) + else ; must really proxy + (check-cache-then-proxy-request + req ent t *browser-level*)))))) + + + + +(defmethod unpublish-locator ((locator locator-proxy)) + nil) + + + +(defun proxy-request (req ent &key pcache-ent (respond t) + (level *browser-level*)) + ;; a request has come in with an http scheme given in uri + ;; and a machine name which isn't ours. + ;; + ;; the headers have been parsed. + ;; + ;; send out the request + ;; get the response and if respond is true send back the response + ;; + (let* ((request-body (get-request-body req)) + (outbuf (get-header-block)) + (outend) + (clibuf) + (cliend) + (sock) + (uri (request-raw-uri req)) + (host (uri-host uri)) + (port (uri-port uri)) + (method (request-method req)) + (protocol :http/1.0) + (state :pre-send) + (keep-alive) + (cached-connection) + (phostport (and ent (entity-extra ent))) + (otherheaders)) + + (if* phostport + then ; we're proxying to a proxy. yikes + (setq host (car phostport) + port (cdr phostport))) + + (unwind-protect + (tagbody + + retry-proxy + + (handler-bind ((error + #'(lambda (cond) + (logmess + (format nil "error during proxy: ~a ~% with ~ +cached connection = ~s~%" cond cached-connection)) + (if* cached-connection + then ; retry + (logmess "retry proxy") + (if* sock + then (ignore-errors + (close sock :abort t))) + (go retry-proxy)) + + (if* pcache-ent + then (kill-pcache-ent pcache-ent)) + + + (if* (not (member :notrap *debug-current* + :test #'eq)) + then ; we want to auto-handle the error + (if* (eq state :pre-send) + then ; haven't sent anything + ; so send failed response + (ignore-errors + (proxy-failure-response req ent))) + (return-from proxy-request nil))))) + + + + (setq keep-alive nil ; assume not keep alive + cached-connection nil) + + ; create outgoing headers by copying + (copy-headers (request-header-block req) outbuf + *header-client-array*) + + ;; now insert new headers + + ; content-length is inserted iff this is put or post method + (if* (member method '(:put :post) :test #'eq) + then (insert-header outbuf :content-length + (format nil "~d" + (if* request-body + then (length request-body) + else 0)))) + + ; connection we'll set to 'close' for now but at some point + ; we'll connection caching so we'll want to do some keep-alive'ing + ; + + (insert-header outbuf :connection + (if* *connection-caching* + then "Keep-Alive" + else "close")) + + + ;(logmess "outbuf now") + ;(dump-header-block outbuf *initial-terminal-io*) + + ; send host header if it isn't already there + (if* (null (header-buffer-values (request-header-block req) :host)) + then ; no host given + (insert-header outbuf :host + (if* port + then (format nil "~a:~d" + host port) + else host))) + (dolist (header (request-headers req)) + + (insert-non-standard-header outbuf (car header) (cdr header))) + + (setq outend (add-trailing-crlf outbuf 1)) + + (if-debug-action :xmit + (format *debug-stream* "proxy covnerted headers toward server~%") + (dotimes (i outend) + (write-char (code-char (aref outbuf i)) *debug-stream*)) + (format *debug-stream* "---- end---~%") + (force-output *debug-stream*)) + + + + + + + ; time to make a call to the server + (handler-case + (multiple-value-setq (sock cached-connection) + (get-possibly-cached-connection + host (or port 80))) + (error (cond) + (declare (ignore cond)) + (if* respond + then (with-http-response (req ent :response + *response-not-found*) + (with-http-body (req ent) + (html + (:html + (:head (:title "404 - Not Found")) + (:body + (:h1 "404 - Not Found") + "The proxy failed to connect to machine " + (:b (:princ-safe host)) + " on port " + (:b (:princ-safe (or port 80))))))))) + (return-from proxy-request))) + + #+allegro + (if* *watch-for-open-sockets* + then (schedule-finalization + sock + #'check-for-open-socket-before-gc)) + + + ;; there are bogus ip redirectors out there that want to + ;; see the whole request in the packet. (e.g www.cbs.com) + ;; so we build as much as we can and then blast that out + + ; this is written in this non-pretty way for speed + + + (let ((firstbuf (get-header-block)) + (ind 0) + (cmdstrings + '((:get . #.(make-array 3 + :element-type '(unsigned-byte 8) + :initial-contents + (list + (char-int #\G) + (char-int #\E) + (char-int #\T)))) + (:post . #.(make-array 4 + :element-type '(unsigned-byte 8) + :initial-contents + (list + (char-int #\P) + (char-int #\O) + (char-int #\S) + (char-int #\T)))) + + )) + (prot-strings + '((:http/1.0 . #.(make-array 8 + :element-type '(unsigned-byte 8) + :initial-contents + (list + (char-int #\H) + (char-int #\T) + (char-int #\T) + (char-int #\P) + (char-int #\/) + (char-int #\1) + (char-int #\.) + (char-int #\0) + ))) + (:http/1.1 . #.(make-array 8 + :element-type '(unsigned-byte 8) + :initial-contents + (list + (char-int #\H) + (char-int #\T) + (char-int #\T) + (char-int #\P) + (char-int #\/) + (char-int #\1) + (char-int #\.) + (char-int #\1) + ))))) + + ) + (let ((cmd (cdr (assoc method cmdstrings :test #'eq)))) + + ; write method + (if* cmd + then (dotimes (i (length cmd)) + (setf (ausb8 firstbuf i) (ausb8 cmd i))) + (incf ind (length cmd)) + else ; unusual method, turn method into a string + (let ((str (string-upcase (string method)))) + (dotimes (i (length str)) + (setf (ausb8 firstbuf i) + (char-int (schar str i)))) + (incf ind (length str)))) + + (setf (ausb8 firstbuf ind) #.(char-int #\space)) + (incf ind) + + + ; now the uri + (let ((str (if* phostport + then ; proxying so send http://... + (puri:render-uri (request-raw-uri req) + nil) + else (net.aserve.client::uri-path-etc uri)))) + (dotimes (i (length str)) + ; should do string-to-octets... + (setf (ausb8 firstbuf ind) + (char-int (schar str i))) + (incf ind))) + + (setf (ausb8 firstbuf ind) #.(char-int #\space)) + (incf ind) + + ; now the protocol + + (let ((cmd (cdr (assoc protocol prot-strings :test #'eq)))) + (if* (null cmd) + then (error "can't proxy protocol ~s" protocol)) + (dotimes (i (length cmd)) + (setf (ausb8 firstbuf ind) (ausb8 cmd i)) + (incf ind))) + + (setf (ausb8 firstbuf ind) #.(char-int #\return)) + (incf ind) + (setf (ausb8 firstbuf ind) #.(char-int #\linefeed)) + (incf ind) + + + ; now add as much of the headers as we can + (do ((i 0 (1+ i)) + (tocopy (min (- (length firstbuf) ind) outend))) + ((>= i tocopy) + + ; + (if-debug-action + :xmit + (format *debug-stream* "about to send~%") + (dotimes (i ind) + (write-char (code-char (ausb8 firstbuf i)) + *debug-stream*)) + (format *debug-stream* "<endof xmission>~%")) + (write-sequence firstbuf sock :end ind) + (if* (< i outend) + then ; still more from original buffer left + (write-sequence outbuf sock + :start i + :end outend)) + ) + + (setf (ausb8 firstbuf ind) (ausb8 outbuf i)) + (incf ind)) + + (free-header-block firstbuf))) + + + + + ; now the body if any + (if* request-body + then (write-sequence request-body sock)) + + (force-output sock) + + ; a shutdown would make sense here but it seems to confuse + ; the aol servers + ;(acl-compat.socket:shutdown sock :direction :output) + + (let (protocol response comment header-start given-content-length + body-buffers body-length) + (loop + ; loop until we don't get a 100 continue + ; + ; now read the response and the following headers + (setq outend (read-headers-into-buffer sock outbuf)) + + (if* (null outend) + then ; response coming back was truncated + (error "truncated proxy response")) + + + (multiple-value-setq (protocol response comment header-start) + (parse-response-buffer outbuf)) + + (if* (null protocol) + then ; bogus response + (return-from proxy-request + (proxy-failure-response req ent))) + + (if* (not (eql response 100)) then (return))) + + + (setf (request-reply-code req) + (code-to-response response)) ; for the logging + + (setq otherheaders + (parse-header-block outbuf header-start outend)) + + ; Get the body of the message if any. + ; there is never a response to a :head request although the header + ; fields may imply there is. + ; These response codes don't have a message body: + ; 1xx, 204, 304 + ; All other responses include a message body which may be of zero size + ; + + (if* (setq given-content-length + (header-buffer-header-value outbuf :content-length)) + then (setq given-content-length + (net.aserve.client::quick-convert-to-integer + given-content-length))) + + + + + (if* (not (or (eq (request-method req) :head) + (<= 100 response 199) + (eq response 204) + (eq response 304))) + then ; got to read the body + (multiple-value-setq (body-buffers body-length) + (read-into-block-buffers sock + given-content-length)) + + (if* (and given-content-length + (not (eql body-length given-content-length))) + then (warn "content-length ~s but body length ~d" + given-content-length body-length) + (setq given-content-length body-length))) + + + (setf (request-reply-content-length req) + (or body-length given-content-length 0)) + + (setq keep-alive + (equalp (header-buffer-header-value outbuf :connection) + "keep-alive")) + + (if* keep-alive + then (add-to-connection-cache sock + host + (or port 80)) + else (close sock)) + + (setq sock nil) + + + ; convert the header we received from the server into one + ; to send to the client + (setq clibuf (get-sresource *header-block-sresource*)) + + + (copy-headers outbuf clibuf *header-server-array*) + + ; add content-length if known + (if* given-content-length + then (insert-header clibuf :content-length + (format nil "~s" given-content-length))) + + ; should add a 'via' line + + ; transfer-encoding - + ; we won't chunk back since we know the content length + + (dolist (header otherheaders) + (insert-non-standard-header clibuf (car header) (cdr header))) + + (setq cliend (add-trailing-crlf clibuf 2)) + + + (if-debug-action + :xmit + (format *debug-stream* "~%~%proxy converted headers toward client~%") + (dotimes (i cliend) + (write-char (code-char (aref clibuf i)) + *debug-stream*)) + (format *debug-stream* "---- end---~%") + (force-output *debug-stream*)) + + ; do the response + (setq state :post-send) + + (if* respond + then (ignore-errors + (let ((rsock (request-socket req))) + + (format rsock "HTTP/1.1 ~d ~a~a" response comment *crlf*) + + (write-sequence clibuf rsock :end cliend) + (if* body-length + then (write-body-buffers rsock body-buffers + body-length)) + (force-output rsock)))) + + (if* (and pcache-ent + (eq (request-method req) :get)) + then ; we are caching + (let ((tmp-clibuf clibuf) + (tmp-body-buffers body-buffers)) + (setf clibuf nil + body-buffers nil) + (cache-response req pcache-ent + response comment tmp-clibuf + tmp-body-buffers body-length level) + ; these buffers have been saved in the cache + ; so nil them out so they aren't freed + )) + + (dolist (block body-buffers) (free-header-block block)) + ))) + + ;; cleanup forms + (if* sock + then (ignore-errors (force-output sock)) + (ignore-errors (close sock :abort t))) + + (free-header-block outbuf) + (free-header-block clibuf)))) + + +(defun parse-response-buffer (buff) + ;; the buffer should contain the first line of an http respose + ;; and a response code, a crlf and then headers (but not including + ;; the crlf after the headers) + ;; + (let (protocol response-code comment beginc) + (flet ((match (array list) + ; test if the list of bytes matches the prefix of the array + (do ((i 0 (1+ i)) + (ll list (cdr ll))) + ((null ll) t) + (if* (not (eq (aref array i) (car ll))) + then (return nil))))) + + ;; + (if* (match buff '(#.(char-int #\H) + #.(char-int #\T) + #.(char-int #\T) + #.(char-int #\P) + #.(char-int #\/) + #.(char-int #\1) + #.(char-int #\.))) + then (case (aref buff 7) + (#.(char-int #\0) (setq protocol :http/1.0)) + (#.(char-int #\1) (setq protocol :http/1.1))) + (if* (null protocol) + then (return-from parse-response-buffer nil))) + + ; compute response code + (let ((val 0) + (i 8)) + (loop + (let ((chv (aref buff i))) + (if* (<= #.(char-code #\0) chv #.(char-code #\9)) + then (setq val (+ (* val 10) (- chv #.(char-code #\0)))) + elseif (member chv '(#.(char-code #\space) + #.(char-code #\return) + #.(char-code #\linefeed)) + :test #'eq) + then (if* (not (zerop val)) + then (return) ; whitespace after value, get out + ) + else ; bogus response code + (return-from parse-response-buffer nil)) + (incf i))) + (setq response-code val) + + ; search for begining of comment + (loop + + (let ((chv (aref buff i))) + (if* (member chv '(#.(char-code #\return) + #.(char-code #\linefeed)) + :test #'eq) + then ; end of line before seeing a comment + (return) + elseif (not (eq chv #.(char-code #\space))) + then ; beginning of comment + (setq beginc i) + (return)) + (incf i))) + + + (if* beginc + then ; found beginning, search for end + (loop (let ((chv (aref buff i))) + (if* (member chv '(#.(char-code #\return) + #.(char-code #\linefeed)) + :test #'eq) + then ; hit the end + (return)) + (incf i)))) + ; we have what we need + (if* beginc + then (let ((str (make-array (- i beginc) + :element-type '(unsigned-byte 8)))) + (do ((jj beginc (1+ jj)) + (ii 0 (1+ ii))) + ((>= jj i)) + (setf (aref str ii) + (aref buff jj))) + + (setq comment str))) + + (values protocol response-code comment i))))) + + + +(defun read-into-block-buffers (sock size) + ;; read up to size bytes from sock into a sequnce of block + ;; buffers. + ;; if size is nil then read until end of file. + ;; return a list of block buffers with all full except perhaps + ;; the last one + ;; return a second value which is the number of bytes read + (if* (eql size 0) + then (return-from read-into-block-buffers (values nil 0))) + + (let (res block len bytesleft (bytesread 0) (start 0)) + (setq block (get-sresource *header-block-sresource*)) + (push block res) + (setq len (length block)) + + (setq bytesleft (or size len)) + (loop + (let ((retv (rational-read-sequence block sock + :start start + :end (min len (+ start bytesleft))))) + (if* (<= retv start) + then ; end of file + (return) + else ; read something + (if* size + then (decf bytesleft (- retv start)) + else (incf bytesread (- retv start))) + (if* (<= bytesleft 0) + then (return)) ; all done + (setq start retv) + (if* (>= start len) + then ; need a new block + (push (setq block (get-sresource + *header-block-sresource*)) + res) + (setq start 0))))) + (values (nreverse res) + (if* size + then (- size bytesleft) + else bytesread)))) + + + + + +(defun write-body-buffers (sock buffers length) + ;; write all the data in the buffers to the socket + (if* (> length 0) + then (let ((len (if buffers (length (car buffers)) length))) + (dolist (buff buffers) + (write-sequence buff sock :end (min length len)) + (decf length len) + (if* (<= length 0) then (return)))))) + + +(defun proxy-failure-response (req ent) + (with-http-response (req ent :response *response-not-found*) + (with-http-body (req ent) + (html (:title "not found by proxy") + (:body + (:h1 "not found") + "The proxy could not find the requested uri: " + (:princ-safe (request-raw-uri req))))))) + + +;;;--------------------- connection cache ------------- +(defstruct connection-cache-ent + expire ; time when this entry expires + host + port + socket + ) + + +(defun add-to-connection-cache (socket host port) + (let* ((now (get-universal-time)) + (ent (list (make-connection-cache-ent + :expire (+ now *connection-cache-expire*) + :host host + :port port + :socket socket))) + (queue *connection-cache-queue*)) + + (incf *connections-cached*) + + (acl-compat.mp:without-scheduling + (let ((start (first-valid-entry now queue))) + + (if* (null start) + then ; empty, this is the first entry + (setf (car queue) + (setf (cdr queue) ent)) + ; add at the end + else (setf (cdr (cdr queue)) ent) + (setf (cdr queue) ent)))))) + +(defun first-valid-entry (now queue) + ;; remove expired entries and return the list of entries + ;; beginning with the first non expired entry + (let ((start (car queue))) + ; scan down cache removing expired entries + (loop + (if* (null start) then (return)) + (if* (< (connection-cache-ent-expire + (car start)) + now) + then ; kill this one + (ignore-errors + (close (connection-cache-ent-socket + (car start)) + :abort t)) + (setf (car queue) + (setq start (cdr start))) + else (return))) + + start)) + + +(defun get-possibly-cached-connection (host port) + ;; check the cache and then return a cached connection + ;; build a new one if there isn't one cached + (let ((now (get-universal-time)) + (queue *connection-cache-queue*)) + (acl-compat.mp:without-scheduling + (let ((start (first-valid-entry now queue)) + (prev nil)) + (loop + (if* (null start) then (return)) + + (if* (and (equalp host (connection-cache-ent-host (car start))) + (eql port (connection-cache-ent-port (car start)))) + then ; a match + (if* prev + then ; slice it out + (if* (null (setf (cdr prev) (cdr start))) + then ; we removed last entry, fix last + (setf (cdr queue) prev)) + else ; we're removing the first + (setf (car queue) (cdr start))) + (incf *connections-used-cached*) + (return-from get-possibly-cached-connection + (values (connection-cache-ent-socket (car start)) t))) + + (setq prev start + start (cdr start))))) + + ; get here if there is no match + + (incf *connections-made*) +; (acl-compat.socket:with-pending-connect + (acl-compat.mp:with-timeout (*connection-timed-out-wait* ; ok w-t + (error "connection timed out")) + (acl-compat.socket:make-socket :remote-host host + :remote-port port + :format :bivalent + :type *socket-stream-type* + :nodelay t)))) +;) + + + + + + + + + + + + + + + + +;;;--------------------- proxy cache ------------------ + +(defparameter *min-freshness* 10) ; assume values valid this long +(defparameter *likely-fresh* 60) ; values probably valid this long but check + +; cache items are in one of these states +; fresh - item in case is considered to be valid +; stale - item in cache may be valid but it will requires validate to verify +; + + + + + +; proxy cache actions +; direct - go to the proxy without considering the cache +; hit - found item in the cache and it is fresh +; + + + + + + +(defun create-proxy-cache (&key (server *wserver*) (size #.(* 10 1024 1024))) + ;; create a cache for the proxy + (let (pcache) + (setf (wserver-pcache server) + (setq pcache (make-pcache + :table (make-hash-table :size 1000 :test #'equal) + :queueobj (make-and-init-queueobj) + :uri-info-table (make-hash-table :test #'equalp) + ))) + + (configure-memory-cache :server server :size size) + (start-proxy-cache-processes server pcache))) + + +(defun start-proxy-cache-processes (server pcache) + (let ((name (format nil "~d-cache-cleaner" (incf *thread-index*)))) + (setf (pcache-cleaner pcache) + (acl-compat.mp:process-run-function + name + #'(lambda (server) + (let ((*wserver* server) + (pcache (wserver-pcache server))) + (loop + (if* (null (wserver-accept-thread server)) + then ; we are shutting down, exit thread + (return)) + + (acl-compat.mp:with-process-lock ((pcache-cleaner-lock pcache)) + (ignore-errors (cache-housekeeping))) + (sleep 30)))) + server)) + (setf (getf (acl-compat.mp:process-property-list (pcache-cleaner pcache)) + 'short-name) + (format nil "c~d" *thread-index*)) + ) + + (publish :path "/cache-stats" + :function + #'(lambda (req ent) + (display-proxy-cache-statistics req ent pcache))) + (publish :path "/cache-entries" + :function + #'(lambda (req ent) + (display-proxy-cache-entries req ent pcache))) + + (publish :path "/cache-entries-gc" + :function + #'(lambda (req ent) + #+allegro (gc) + #+cmu (ext:gc) + #+lispworks (hcl:gc-if-needed) + #+mcl (ccl:gc) + #+sbcl (sb-ext:gc) + (display-proxy-cache-statistics req ent pcache))) + + (publish :path "/cache-entries-global-gc" + :function + #'(lambda (req ent) + #+allegro (gc t) + #+cmu (ext:gc :full t) + #+lispworks (hcl:gc-if-needed) ; TODO: do a full gc here + #+mcl (ccl:gc) + #+sbcl (sb-ext:gc :full t) + (display-proxy-cache-statistics req ent pcache))) + + + ) + + +(defun kill-proxy-cache (&key (server *wserver*)) + ;; kill off the cache and return all resources to the pool + + (let ((pcache (wserver-pcache server))) + + (if* (null pcache) then (return-from kill-proxy-cache)) + + (acl-compat.mp:with-process-lock ((pcache-cleaner-lock pcache)) + ;; now we know that the other thread cleaning out + ;; the cache won't call cache-housekeeping while we're + ;; busy doing our business. + + ; this will signal the cache cleaner process to exit + (setf (pcache-cleaner pcache) nil) + + ; clean out and remove the disk caches first + (dolist (pcache-disk (pcache-disk-caches pcache)) + (flush-disk-cache pcache pcache-disk 0) + (ignore-errors (close (pcache-disk-stream pcache-disk))) + (ignore-errors (delete-file (pcache-disk-filename pcache-disk)))) + + (setf (pcache-disk-caches pcache) nil) + + ; now clean the memory cache + (flush-memory-cache pcache 0) + + ; and now return all the blocks on dead list + (flush-dead-entries pcache)))) + + + +(defun configure-memory-cache (&key (server *wserver*) + size) + ;; specify the desired size of the memory cache + (let ((pcache (wserver-pcache server))) + (if* (null pcache) + then (error "There is no memory cache to size")) + + ; store it in blocks + (setf (pcache-size pcache) (truncate size *header-block-size*)) + + (setf (pcache-high-water pcache) (truncate (* .90 (pcache-size pcache)))) + (setf (pcache-low-water pcache) (truncate (* .80 (pcache-size pcache)))))) + +(defun add-disk-cache (&key (server *wserver*) + filename + (size #.(* 10 1024 1024))) + (if* (null filename) + then ; create a filename + (loop + (let ((name (format nil "acache-~x.acf" (random 34567)))) + (if* (not (probe-file name)) + then (setq filename name) + (return))))) + (let* ((blocks (truncate size *header-block-size*)) + (pcache-disk (make-pcache-disk + :filename filename + :queueobj (make-and-init-queueobj) + :high-water (truncate (* .90 blocks)) + :low-water (truncate (* .80 blocks)) + :blocks blocks + :free-blocks blocks + :free-list (list (cons 0 (1- blocks))) + :stream (open filename + :if-exists :supersede + :if-does-not-exist :create + :direction :io + #-(and allegro (version>= 6)) + :element-type + #-(and allegro (version>= 6)) + '(unsigned-byte 8))))) + (push pcache-disk (pcache-disk-caches + (wserver-pcache server))) + filename)) + + + + + + +(defun make-and-init-queueobj () + ; make a queue object with the dummy mru,lru entries + (let ((q (make-queueobj + :mru (make-pcache-ent) + :lru (make-pcache-ent)))) + (setf (pcache-ent-next (queueobj-mru q)) (queueobj-lru q) + (pcache-ent-prev (queueobj-lru q)) (queueobj-mru q)) + q)) + + +(defun display-proxy-cache-statistics (req ent pcache) + + + + ; count number of memory entries + (let ((dead-bytes 0) + (dead-blocks 0)) + (do ((ent (pcache-dead-ent pcache) (pcache-ent-next ent))) + ((null ent)) + (let ((this-data-length (pcache-ent-data-length ent)) + (this-dead-blocks (pcache-ent-blocks ent))) + (if* this-data-length + then (incf dead-bytes this-data-length)) + (if* this-dead-blocks + then (incf dead-blocks this-dead-blocks)))) + + + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "AllegroServe Proxy Cache Statistics")) + (:body + (:h1 "AllegroServe Proxy Cache Statistics") + :p + "Show " ((:a :href "cache-entries") "Cache Entries,") + " Refresh " ((:a :href "cache-stats") "this page") + :br + "Perform a " ((:a :href "cache-entries-gc") "normal gc,") + " Perform a " ((:a :href "cache-entries-global-gc") "global gc") + :br + ((:table :border 2) + (:tr + (:th "Cache Action") + (:th "Count")) + + (dolist (ent + '(("direct" pcache-r-direct) + ("miss (user request)" pcache-r-miss) + ("miss (anticipated request)" pcache-r-cache-fill) + ("consistency miss" pcache-r-consistency-miss) + ("fast hit" pcache-r-fast-hit) + ("fast validation" pcache-r-fast-validation) + ("slow validation" pcache-r-slow-validation))) + (html + (:tr + (:td (:princ (car ent))) + (:td (:princ (funcall (cadr ent) pcache))))))) + + :br + ;; info on connection caching + "Connection caching is " + (:princ (if* *connection-caching* + then "enabled" + else "diabled")) + :br + ((:table :border 2) + (:tr + (:td "make-socket calls") (:td (:princ *connections-made*))) + (:tr + (:td "connections cached") (:td (:princ *connections-cached*))) + (:tr + (:td "cached connections used") + (:td (:princ *connections-used-cached*)))) + + + + :br + ((:table :border 2) + (:tr + (:th "Kind of Entry") + (:th "Count") + (:th "Bytes") + (:th "Blocks")) + + (:tr + (:td "Live entries in memory") + (:td (:princ (queueobj-items (pcache-queueobj pcache))) + (:td (:princ (queueobj-bytes (pcache-queueobj pcache)))) + (:td (:princ (queueobj-blocks (pcache-queueobj pcache))) + " (" + (:princ (* (queueobj-blocks (pcache-queueobj pcache)) + *header-block-size*)) + + " bytes)"))) + + (:tr + (:td "Dead entries in memory") + (:td (:princ (pcache-dead-items pcache))) + (:td (:princ dead-bytes)) + (:td (:princ dead-blocks) + " (" + (:princ (* dead-blocks *header-block-size*)) " bytes)" + )) + ) + :br + "Memory Cache" + ((:table :border 2) + (:tr + (:th "items") + (:th "used-blocks/total-blocks") + (:th "bytes") + ) + (let ((queueobj (pcache-queueobj pcache))) + (html (:tr + (:td (:princ-safe (queueobj-items queueobj))) + (:td (:princ-safe (queueobj-blocks queueobj)) + "/" + (:princ-safe (pcache-size pcache))) + (:td (:princ-safe (queueobj-bytes queueobj))))))) + :br + :br + "Disk Caches" + :br + ((:table :border 2) + (:tr + (:th "filename") + (:th "items") + (:th "blocks") + (:th "bytes") + (:th "free blocks") + (:th "free list") + ) + (dolist (pcache-disk (pcache-disk-caches pcache)) + (let ((queueobj (pcache-disk-queueobj pcache-disk))) + (html (:tr + (:td (:princ-safe (pcache-disk-filename pcache-disk))) + (:td (:princ-safe (queueobj-items queueobj))) + (:td (:princ-safe (queueobj-blocks queueobj))) + (:td (:princ-safe (queueobj-bytes queueobj))) + (:td (:princ-safe (pcache-disk-free-blocks + pcache-disk))) + (:td (:princ-safe (pcache-disk-free-list + pcache-disk)))))))) + :br + "Current memory usage" + :br + (:pre (:princ-safe (with-output-to-string (*standard-output*) + (room t)))) + + ))))))) + + +(defun display-proxy-cache-entries (req ent pcache) + ;; show all the proxy cache entries + (let ((now (get-universal-time))) + (flet ((display-pcache-ent (ent) + + (html (:b "uri: ") + (:princ-safe (pcache-ent-key ent)) + :br + (if* (>= now (pcache-ent-expires ent)) + then (html (:b ((:font :color "red") + "Stale -- "))) + else (html (:b ((:font :color "green") + "Fresh -- ")))) + (:b "Expires: ") + (:princ-safe + (universal-time-to-date (pcache-ent-expires ent))) + + + :br + (:b "Last Modified: ") + (:princ-safe + (universal-time-to-date (pcache-ent-last-modified ent))) + :br + (:b "Size: ") + (:princ (pcache-ent-data-length ent)) + (:b ", State: ") + (:princ-safe (pcache-ent-state ent)) + (:b ", Use: ") + (:princ-safe (pcache-ent-use ent)) + (:b ", Code: ") + (:princ-safe (pcache-ent-code ent)) + (if* (pcache-ent-disk-location ent) + then (html :br + (:b "Disk Location: " + (:princ-safe + (pcache-ent-disk-location ent))))) + :p + :br + ) + + )) + (with-http-response (req ent) + (with-http-body (req ent) + (html + (:html + (:head (:title "Proxy Cache Entries")) + (:body + (:h1 "Proxy cache entries") + :p + "Here is a summary of " ((:a :href "cache-stats") "Cache Statistics.") + :br + "The current time is " (:princ-safe (universal-time-to-date now)) + :br + :br + + (let ((ent (pcache-ent-next (queueobj-mru + (pcache-queueobj pcache)))) + (last-ent (queueobj-lru (pcache-queueobj pcache)))) + (loop + (if* (or (null ent) (eq last-ent ent)) then (return)) + (display-pcache-ent ent) + (setq ent (pcache-ent-next ent)))) + + ; now display the disk caches + (dolist (pcache-disk (pcache-disk-caches pcache)) + (html :hr + :br + "Disk Cache: " (:princ-safe (pcache-disk-filename pcache-disk)) + :br + "Free blocks: " (:princ-safe + (pcache-disk-free-blocks pcache-disk)) + :br + "Free list: " (:princ-safe + (pcache-disk-free-list pcache-disk)) + :br + :br) + + ; display the entries + (do ((ent (pcache-ent-next (queueobj-mru + (pcache-disk-queueobj pcache-disk))) + (pcache-ent-next ent))) + ((or (null ent) + (null (pcache-ent-key ent)))) + + (display-pcache-ent ent))) + + + )))))))) + +#+ignore +(defun verify-memory-cache (tag) + ;; verify that all memory cache items are not on the free list too + + (let ((pcache (wserver-pcache *wserver*))) + (let ((ent (pcache-ent-next (queueobj-mru + (pcache-queueobj pcache)))) + (last-ent (queueobj-lru (pcache-queueobj pcache)))) + (loop + (if* (or (null ent) (eq last-ent ent)) then (return)) + ;; test to see if block are on the free list + (setq *bug* ent) + (dolist (db (pcache-ent-data ent)) + (chk-header-block db tag)) + (setq ent (pcache-ent-next ent)))) + )) + + +; was 'proxy-cache-request' + +(defun check-cache-then-proxy-request (req ent respond level) + ;; if we've got a proxy cache then retrieve it from there + ;; else just proxy the request + + ;; respond is true if we really want to respond, it will be + ;; nil if we just want to ensure that what we need is in the cache + ;; + + (let ((pcache (wserver-pcache *wserver*)) + (rendered-uri)) + + (if* (or (null pcache) + ; should handle :head requests too + (not (eq (request-method req) :get)) + ; don't look in cache if request has cookies + (and (header-slot-value req :authorization) + (progn + (logmess "authorization forces direct") + t)) + ) + then (if* pcache then (incf (pcache-r-direct pcache))) + (return-from check-cache-then-proxy-request + (proxy-request req ent :respond respond))) + + ; clear out the fragment part (after the #) so that we don't match + ; on that. + (setf (puri:uri-fragment (request-raw-uri req)) nil) + (setq rendered-uri + (transform-uri (puri:render-uri (request-raw-uri req) nil))) + + + (dlogmess (format nil "cache: look in cache for ~a, level ~d, ents ~d~%" + rendered-uri + level + (length (gethash rendered-uri (pcache-table pcache))) + )) + + (dolist (pcache-ent (gethash rendered-uri (pcache-table pcache)) + ; not found, must proxy and then cache if the + ; result looks good + (progn + (dlogmess (format nil "not in cache, proxy it level ~d" level)) + (if* (eql *browser-level* level) + then (incf (pcache-r-miss pcache)) + (log-proxy rendered-uri level :mi nil) + else (incf (pcache-r-cache-fill pcache)) + (log-proxy rendered-uri level :pf nil)) + + + (proxy-and-cache-request req ent (get-universal-time) + nil respond level))) + (if* (lock-pcache-ent pcache-ent) + then (unwind-protect + (if* (equal (pcache-ent-cookie pcache-ent) + (header-slot-value req :cookie)) + then ; can use this one + + (multiple-value-bind (response new-pcache-ent) + (use-value-from-cache req ent pcache-ent + level respond) + + + ; run hook only if we're at the browser level + ; (since this will allow us to flush the queue) + ; of if this wasn't a fast hit and thus there + ; is new data to cache + (if* (and (pcache-entry-cached-hook pcache) + (or (eql level *browser-level*) + (not (member response '(:fh :fv :sh) + :test #'eq)))) + then ; we want to do link scanning of this + (if* (null new-pcache-ent) + then (setq new-pcache-ent + pcache-ent)) + + (if* (lock-pcache-ent new-pcache-ent) + then ; it will be unlocked by the hook fcn + (funcall (pcache-entry-cached-hook pcache) + pcache + new-pcache-ent level)))) + (return) + else (dlogmess + (format nil "can't use cached ~s due to cookie difference~%" + rendered-uri)) + (dlogmess (format nil + "cached cookie ~s~%, current cookie: ~s~%" + (pcache-ent-cookie pcache-ent) + (header-slot-value req :cookie)))) + + (unlock-pcache-ent pcache-ent)) + else (logmess "entry could not be locked~%"))))) + + + +(defun proxy-and-cache-request (req ent now pcache-ent respond level) + ;; must send the request to the net via the proxy. + ;; if pcache-ent is non-nil then this is the existing + ;; cache entry which may get updated or killed. + ;; + ;; return the reponse code from the proxy call + ;; return the new pcache-ent that got the new value if the return + ;; code is 200 or 302 + ;; + ;; + (let ((new-ent (make-pcache-ent)) + (rendered-uri + (transform-uri (puri:render-uri (request-raw-uri req) nil))) + (pcache (wserver-pcache *wserver*))) + + (setf (pcache-ent-key new-ent) rendered-uri + (pcache-ent-uri new-ent) (request-raw-uri req)) + + (proxy-request req ent :pcache-ent new-ent :respond respond :level level) + (if* (member (pcache-ent-code new-ent) '(200 + 302 ; redirect + )) + then ; turns out it was modified, must + ; make this the new entry + + (if* pcache-ent + then (dlogmess (format nil "replace cache entry for ~a" + rendered-uri))) + + + (push new-ent + (gethash rendered-uri + (pcache-table pcache))) + + ; put at the head of the memory queue + ; could already be dead from some other threads o + ; be careful + (if* (lock-pcache-ent new-ent) + then (if* (not (eq (pcache-ent-state new-ent) :dead)) + then (move-pcache-ent new-ent nil + (pcache-queueobj pcache))) + (unlock-pcache-ent new-ent)) + + ; and disable the old entry + (if* pcache-ent + then (kill-pcache-ent pcache-ent pcache)) + + elseif (and pcache-ent + (eq (pcache-ent-code new-ent) 304)) + + then ; still not modified, recompute the + ; expiration time since we now know + ; that the item is older + ;* this may end up violation the expiration + ; time in a header from a previous call + (dlogmess (format nil "change expiration date for ~a" + rendered-uri)) + (setf (pcache-ent-expires pcache-ent) + (max (pcache-ent-expires pcache-ent) + (compute-approx-expiration + (pcache-ent-last-modified pcache-ent) + now)))) + + (values (pcache-ent-code new-ent) new-ent))) + + + +(defun use-value-from-cache (req ent pcache-ent level respond) + ;; we've determined that pcache-ent matches the request. + ;; now deal with the issue of it possibily being out of date + ;; + ;; return a keyword specifying the kind of access that was + ;; done + ;; + (let* ((ims (header-slot-value req :if-modified-since)) + (now (get-universal-time)) + (pcache (wserver-pcache *wserver*)) + (fresh)) + + (most-recently-used-ent pcache-ent) + + (dlogmess (format nil "ims is ~s" ims)) + + ; compute if the entry is fresh or stale + (setq fresh (<= now (pcache-ent-expires pcache-ent))) + + + (dlogmess (format nil "ims is ~s, fresh by ~s seconds" ims + (- (pcache-ent-expires pcache-ent) now))) + + + (if* (and ims (not (equal "" ims))) + then ; we're in a conditional get situation, where the + ; condition is If-Modified-Since + (setq ims (date-to-universal-time ims)) + + + (if* fresh + then (if* (< ims (pcache-ent-last-modified pcache-ent)) + then ; it has been modified since the ims time + ; must return the whole thing + (dlogmess "validation->fast hit") + (incf (pcache-r-fast-hit pcache)) + (if* respond + then (send-cached-response req pcache-ent)) + (log-proxy (pcache-ent-key pcache-ent) + level + :fh + (- (pcache-ent-last-modified pcache-ent) + ims)) + :fh + else ; it hasn't been modified since the ims time + (dlogmess "fast validation") + (incf (pcache-r-fast-validation pcache)) + (if* respond + then (send-not-modified-response req ent)) + (log-proxy (pcache-ent-key pcache-ent) + level + :fv + (- (pcache-ent-last-modified pcache-ent) + ims)) + :fv + ) + else ; stale, must revalidate + (let ((code + (proxy-and-cache-request req ent + now pcache-ent respond + level))) + (if* (eql code 304) + then (dlogmess "slow validation") + (incf (pcache-r-slow-validation pcache)) + (log-proxy (pcache-ent-key pcache-ent) + level + :sv + (- (pcache-ent-last-modified pcache-ent) + ims)) + :sv + else (dlogmess "consistency miss") + (incf (pcache-r-consistency-miss + pcache)) + (log-proxy (pcache-ent-key pcache-ent) + level + :cm + (- (pcache-ent-last-modified pcache-ent) + ims)) + :cm + ))) + + else ; unconditional get + (if* fresh + then (dlogmess "fast hit") + (incf (pcache-r-fast-hit pcache)) + (if* respond then (send-cached-response req pcache-ent)) + (log-proxy (pcache-ent-key pcache-ent) + level + :fh + nil) + :fh + else ; issue a validating send + + (insert-header + (request-header-block req) + :if-modified-since + (or (pcache-ent-last-modified-string pcache-ent) + (setf (pcache-ent-last-modified-string pcache-ent) + (universal-time-to-date + (pcache-ent-last-modified pcache-ent))))) + + (multiple-value-bind (code new-pcache-ent) + (proxy-and-cache-request req ent now pcache-ent nil + -1) + ; we didn't respond just sent out a probe + (multiple-value-prog1 + (if* (eql code 304) + then ; hasn't been modified since our + ; cached entry + (dlogmess "slow hit") + (incf (pcache-r-slow-hit pcache)) + (log-proxy (pcache-ent-key pcache-ent) + level + :sh + nil) + :sh + + else ; was modified, so new item is cached + (setq pcache-ent new-pcache-ent) + (dlogmess "consistency miss") + (incf (pcache-r-consistency-miss pcache)) + (log-proxy (pcache-ent-key pcache-ent) + level + :cm + nil) + (values :cm pcache-ent) + ) + (if* respond + then (send-cached-response req pcache-ent)))))))) + + + +(defun compute-approx-expiration (changed now) + ;; compute the expires time based on the last time the file was + ;; change and current time. + (let ((delta (max 1 (ceiling + (* (- now changed) *extra-lifetime-factor*))))) + (+ changed delta))) + + + + +(defun send-not-modified-response (req ent) + ;; return a not-modified response + (with-http-response (req ent :response *response-not-modified*) + (with-http-body (req ent)))) + + + + + + +(defun send-cached-response (req pcache-ent) + ;; send back this response + (dlogmess (format nil "cache: sending back cached response: ~a, length ~d~%" + (puri:render-uri (request-raw-uri req) nil) + (pcache-ent-data-length pcache-ent))) + (incf (pcache-ent-returned pcache-ent)) + + + (if* (pcache-ent-disk-location pcache-ent) + then (retrieve-pcache-from-disk pcache-ent)) + + + (let ((rsock (request-socket req))) + (format rsock "HTTP/1.1 ~d ~a~a" + (pcache-ent-code pcache-ent) + (pcache-ent-comment pcache-ent) *crlf*) + + (setf (request-reply-code req) (code-to-response + (pcache-ent-code pcache-ent))) + + (let ((data (pcache-ent-data pcache-ent)) + (data-length (pcache-ent-data-length pcache-ent))) + + + (setf (request-reply-content-length req) data-length) + + (write-sequence (car data) rsock + :end (add-trailing-crlf (car data) 3)) + (if* data-length + then (write-body-buffers rsock (cdr data) data-length)) + + + (force-output rsock)))) + + + +(defun lock-pcache-ent (pcache-ent) + ;; attempt to increase the use count of this entry by one. + ;; If successful return true. + ;; If the entry is dead return nil + (acl-compat.excl::atomically + (acl-compat.excl::fast + (let ((val (pcache-ent-use pcache-ent))) + (if* val + then (setf (pcache-ent-use pcache-ent) + #-cormanlisp (the fixnum (1+ (the fixnum val))) #+cormanlisp (1+ val))))))) + +(defun unlock-pcache-ent (pcache-ent) + ;; reduce the use count of this entry + (acl-compat.mp:without-scheduling + (let ((val (pcache-ent-use pcache-ent))) + (if* val + then (if* (and (zerop (acl-compat.excl::fast + (decf #-cormanlisp (the fixnum val) #+cormanlisp val))) + (eq (pcache-ent-state pcache-ent) :dead)) + then (setf (pcache-ent-use pcache-ent) nil) + else (setf (pcache-ent-use pcache-ent) val)))))) + +(defun most-recently-used-ent (pcache-ent) + ;; make this entry the most recently used in whatever queue it's on + (let ((queueobj (pcache-ent-queueobj pcache-ent))) + (move-pcache-ent pcache-ent queueobj queueobj))) + +(defun move-pcache-ent (pcache-ent fromq toq) + ;; move the pcache-ent between queues + ;; fromq and toq can be nil or the same. + ;; + (let ((prev (pcache-ent-prev pcache-ent)) + (next (pcache-ent-next pcache-ent))) + + (acl-compat.mp:without-scheduling + ; unlink + (if* (and prev next) + then (setf (pcache-ent-next prev) next + (pcache-ent-prev next) prev)) + + (if* (and fromq (not (eq fromq toq))) + then ; must update counts in the from queue + (decf (queueobj-items fromq)) + (decf (queueobj-bytes fromq) (pcache-ent-data-length pcache-ent)) + (decf (queueobj-blocks fromq) + (pcache-ent-blocks pcache-ent))) + + ; link into the toq, at the mru position + (if* toq + then ;debugging + (if* (eq (pcache-ent-state pcache-ent) :dead) + then (break "shouldn't be dead during move")) + + (let* ((mru-head (queueobj-mru toq)) + (mru (pcache-ent-next mru-head))) + (setf (pcache-ent-next mru-head) pcache-ent + (pcache-ent-prev pcache-ent) mru-head + (pcache-ent-next pcache-ent) mru + (pcache-ent-prev mru) pcache-ent)) + (if* (not (eq fromq toq)) + then ; increment counts + (incf (queueobj-items toq)) + (incf (queueobj-bytes toq) + (pcache-ent-data-length pcache-ent)) + (incf (queueobj-blocks toq) + (pcache-ent-blocks pcache-ent)))) + + (setf (pcache-ent-queueobj pcache-ent) toq)))) + + + + + +(defun kill-pcache-ent (pcache-ent &optional (pcache (wserver-pcache + *wserver*))) + ; make this entry dead + (acl-compat.mp::without-scheduling + + ; stop any scanning of this uri + (setf (pcache-ent-level pcache-ent) -1) + + (let ((state (pcache-ent-state pcache-ent))) + (if* (not (eq :dead state)) + then ; make it dead + (setf (pcache-ent-state pcache-ent) :dead) + + (move-pcache-ent pcache-ent + (pcache-ent-queueobj pcache-ent) + nil ; move to nowhere, + ) + + ; link onto the dead list + (setf (pcache-ent-next pcache-ent) (pcache-dead-ent pcache) + (pcache-dead-ent pcache) pcache-ent) + + ; if currently not in use, then make sure it's never used + (if* (eql 0 (pcache-ent-use pcache-ent)) + then (setf (pcache-ent-use pcache-ent) nil)) + + ;; stats + (incf (pcache-dead-items pcache)) + + ; remove from hash table + (let ((ents (gethash (pcache-ent-key pcache-ent) + (pcache-table pcache)))) + (setf (gethash (pcache-ent-key pcache-ent) + (pcache-table pcache)) + (delete pcache-ent ents :test #'eq))) + + + )))) + + + + +#+ignore +(defun match-request-blocks (request-block cache-block) + ;; compare the header entries that have to match for this + ;; cached request to be used. + ;; + (if* (eq request-block cache-block) + then (error "block reused when it shouldn't have")) + + (let ((hcma *header-cache-match-array*)) + (dotimes (i (length hcma) t) + (let ((ent (svref hcma i))) + (if* ent + then (if* (not (header-match-values request-block + cache-block + i + (eq ent :mx))) + then ; give up + (return nil))))))) + + + + +(defun cache-response (req pcache-ent + response-code comment client-response-header + body-buffers body-length level) + + ;; we are caching, save the information about this response + ;; in the pcache-ent we are passed, which should be blank + + + (dlogmess (format nil "cache: caching response to ~a, code ~d, length ~d~%" + (puri:render-uri (request-raw-uri req) nil) + response-code + body-length + )) + + (let (now uri-info + (pcache (wserver-pcache *wserver*))) + (if* (or (eql response-code 200) + (eql response-code 302) ; redirect + ) + then ; full response + + (setf (pcache-ent-code pcache-ent) response-code) + (setf (pcache-ent-comment pcache-ent) comment) + + (setf (pcache-ent-data pcache-ent) + (cons client-response-header body-buffers)) + + (setf (pcache-ent-data-length pcache-ent) body-length + + (pcache-ent-blocks pcache-ent) + (length (pcache-ent-data pcache-ent))) + + + (setf (pcache-ent-cookie pcache-ent) + (header-slot-value req :cookie)) + + (setf (pcache-ent-state pcache-ent) nil ; means valid data + (pcache-ent-use pcache-ent) 0) + + (setq uri-info (find-uri-info (request-raw-uri req))) + + (if* uri-info + then (dlogmess (format nil "have uri info for ~a" + (request-raw-uri req)))) + + (let* ((last-mod (header-buffer-header-value + client-response-header + :last-modified)) + (last-mod-val (and last-mod + (date-to-universal-time last-mod))) + (expires (header-buffer-header-value + client-response-header + :expires)) + (expires-val (and expires + (date-to-universal-time expires)))) + + + (setq client-response-header nil + body-buffers nil) + + (if* last-mod-val + then (setf (pcache-ent-last-modified-string pcache-ent) last-mod + (pcache-ent-last-modified pcache-ent) last-mod-val) + else ; no value given, store current time minus a + ; second to account for the transit time + + (setf (pcache-ent-last-modified pcache-ent) + (- (setq now (get-universal-time)) 2))) + + (if* expires-val + then ; given expiration date, use it + ;* it may be bogus since people doing ads use this + ; to force cache reloads + (setf (pcache-ent-expires pcache-ent) expires-val) + else ; must compute expiration + (setf (pcache-ent-expires pcache-ent) + (compute-approx-expiration + (pcache-ent-last-modified pcache-ent) + (or now (get-universal-time))))) + + ;; add extra lifetime for certain entries + (incf (pcache-ent-expires pcache-ent) + (if* (and uri-info (uri-info-extra-lifetime uri-info)) + then (uri-info-extra-lifetime uri-info) + else *extra-lifetime*)) + + (if* (pcache-entry-cached-hook pcache) + then (if* (lock-pcache-ent pcache-ent) + then ; it will be unlocked by the hook fcn + (funcall (pcache-entry-cached-hook pcache) + pcache pcache-ent level)))) + + elseif (eql response-code 304) + then ; just set that so the reader of the response will know + ; the result + (setf (pcache-ent-code pcache-ent) response-code)) + + (if* client-response-header + then (free-header-block client-response-header)) + + (if* body-buffers + then (free-header-blocks body-buffers)))) + + +; --- cleaning out old entries + + +(defun cache-housekeeping (&optional (pcache (wserver-pcache *wserver*))) + ;; bring all the caches to within the appropriate tolerance + + ; first clean out disk caches so we can put more memory stuff in them + (dolist (pcache-disk (pcache-disk-caches pcache)) + (if* (> (- (pcache-disk-blocks pcache-disk) + (pcache-disk-free-blocks pcache-disk)) + (pcache-disk-high-water pcache-disk)) + then ; must flush it + (flush-disk-cache pcache + pcache-disk + (pcache-disk-low-water pcache-disk)))) + + ; clear out all entries made dead + (flush-dead-entries pcache) + + ; now clean out the memory cache if needed by moving to a disk cache + (if* (> (queueobj-blocks (pcache-queueobj pcache)) + (pcache-high-water pcache)) + then (flush-memory-cache pcache + (pcache-low-water pcache))) + + ; now rotate caches so they are evenly used + (let ((caches (pcache-disk-caches pcache))) + (if* (cdr caches) + then (let ((new (cdr caches))) + (setf (cdr caches) nil) + (nconc new caches) + (setf (pcache-disk-caches pcache) new))))) + + +(defun flush-disk-cache (pcache pcache-disk goal) + ;; flush entries from the disk cache until the number of blocks + ;; is less than or equal to the goal + (let* ((needed (- (- (pcache-disk-blocks pcache-disk) + (pcache-disk-free-blocks pcache-disk)) + goal)) + (queueobj (pcache-disk-queueobj pcache-disk)) + (mru-head (queueobj-mru queueobj)) + (lru-head (queueobj-lru queueobj))) + (loop + (if* (<= needed 0) + then (return)) + + ; pick off the lru and kill it + (acl-compat.mp::with-process-lock ((pcache-disk-lock pcache-disk)) + (let ((lru (pcache-ent-prev lru-head))) + (if* (not (eq lru mru-head)) + then ; a legit block + (dlogmess (format nil "kill ~s from disk queue" + (pcache-ent-key lru))) + (decf needed (pcache-ent-blocks lru)) + (kill-pcache-ent lru pcache) + (log-proxy (pcache-ent-key lru) 0 :kd nil) + else (return) ; no more left ? shouldn't happen + )))))) + + +(defun flush-memory-cache (pcache goal) + ;; move memory cache items to a disk cache if possible + + (if* (null pcache) + then (setq pcache (wserver-pcache *wserver*))) + + (let* ((needed (- (queueobj-blocks (pcache-queueobj pcache)) + goal)) + (queueobj (pcache-queueobj pcache)) + (mru-head (queueobj-mru queueobj)) + (lru-head (queueobj-lru queueobj)) + (disk-caches (pcache-disk-caches pcache)) + (ent-todo) + ) + + (loop + (if* (<= needed 0) then (return)) + + (block main + (setq ent-todo nil) + + (acl-compat.mp:without-scheduling + ;; find the next ent to process without other processes running + (let ((lru lru-head)) + (loop + (setq lru (pcache-ent-prev lru)) + (if* (eq lru mru-head) + then (setq needed 0) + (return-from main)) + (if* (lock-pcache-ent lru) + then (setq ent-todo lru) + (return-from main)))))) + + (if* ent-todo + then ; move this one to disk or kill it off + (if* (dolist (dc disk-caches t) + (if* (move-ent-to-disk ent-todo dc) + then ; successful move to disk + (decf needed (pcache-ent-blocks ent-todo)) + (unlock-pcache-ent ent-todo) + (return nil))) + then ; can't put on disk. kill it in memory + (decf needed (pcache-ent-blocks ent-todo)) + (kill-pcache-ent ent-todo pcache) + (unlock-pcache-ent ent-todo)))))) + + + +(defun flush-dead-entries (pcache) + ;; flush all the deal items from the cache, returning + ;; their resource + (let (ent) + (acl-compat.excl::atomically + (acl-compat.excl::fast + (setf ent (pcache-dead-ent pcache) + (pcache-dead-ent pcache) nil))) + + ; now we have an exclusive link to the dead entries + ; which we can free at our leisure + (let ((count 0)) + (loop + (if* (null ent) then (return)) + (incf count) + (free-header-blocks (pcache-ent-data ent)) + (let ((diskloc (pcache-ent-disk-location ent))) + ; if stored on the disk, free those blocks + (if* diskloc + then (return-free-blocks (pcache-ent-pcache-disk ent) + diskloc))) + (setq ent (pcache-ent-next ent))) + (acl-compat.excl::atomically + (acl-compat.excl::fast + (decf #-cormanlisp (the fixnum (pcache-dead-items pcache)) #+cormanlisp (pcache-dead-items pcache) + #-cormanlisp (the fixnum count) #+cormanlisp count)))))) + + + + + +(defun empty-all-caches (&key (server *wserver*)) + ;; remove everything from all caches + + (let ((pcache (wserver-pcache server))) + (acl-compat.mp:with-process-lock ((pcache-cleaner-lock pcache)) + (flush-dead-entries pcache) + (flush-memory-cache pcache 0) ; empty memory + (dolist (dcache (pcache-disk-caches pcache)) + (flush-disk-cache pcache dcache 0))))) + + + + + + + + + + + + + + + +;------------ disk cache + +(defun move-ent-to-disk (pcache-ent pcache-disk) + ;; copy the given pcache-ent to the disk + ;; assume that we've locked it at this point + ;; + ;; return t if we suceede and nil if we didn't + ;; + (if* (pcache-ent-disk-location pcache-ent) + then (dlogmess (format nil "cached ~s is already on the disk" + (pcache-ent-key pcache-ent))) + (return-from move-ent-to-disk t)) + + (let ((to-store-list (get-disk-cache-blocks + pcache-disk (pcache-ent-blocks pcache-ent))) + (buffs)) + + (if* to-store-list + then (dlogmess (format nil "store ~s on disk at ~s~%" + (pcache-ent-key pcache-ent) + to-store-list)) + (store-data-on-disk pcache-ent pcache-disk to-store-list) + (log-proxy (pcache-ent-key pcache-ent) 0 :wd nil) + (let ((ans + (acl-compat.mp:without-scheduling + (if* (and (null (pcache-ent-state pcache-ent)) + (eql 1 (pcache-ent-use pcache-ent))) + then ; we are tre sole user of this entry so we cna + ; replace the buffers with the disk location + (setf (pcache-ent-disk-location pcache-ent) + to-store-list + + (pcache-ent-pcache-disk pcache-ent) + pcache-disk + + buffs (pcache-ent-data pcache-ent) + + (pcache-ent-data pcache-ent) nil) + + + ; move to disk's list + (move-pcache-ent pcache-ent + (pcache-ent-queueobj pcache-ent) + (pcache-disk-queueobj + pcache-disk)) + + + + t + + else ; someone started using the entry.. so forget we + ; wrote it + (logmess + (format nil "can't complete store: use ~d, state ~s~%" + (pcache-ent-use pcache-ent) + (pcache-ent-state pcache-ent))) + + (return-free-blocks pcache-disk to-store-list) + + nil)))) + + (free-header-blocks buffs) + ans)))) + +(defun retrieve-pcache-from-disk (pcache-ent) + ;; read the cache entry back in from the disk + + ; ensure the loading flag to true and set flagval + ; to the value before we set the flag. + ; If the value was nil and thus we set it to true, then + ; we are the process responsible for loading in the data + ; + (let ((flagval (acl-compat.excl::atomically + (acl-compat.excl::fast + (let ((val (pcache-ent-loading-flag pcache-ent))) + (if* (null val) + then (setf (pcache-ent-loading-flag pcache-ent) t)) + val))))) + (if* flagval + then (acl-compat.mp:process-wait "cache entry to be loaded" + #'(lambda (pcache-ent) + (null (pcache-ent-loading-flag pcache-ent))) + pcache-ent) + (return-from retrieve-pcache-from-disk)) + + ; it's our job to load in the entry + (let* ((block-list (pcache-ent-disk-location pcache-ent)) + (pcache-disk (pcache-ent-pcache-disk pcache-ent)) + (stream (pcache-disk-stream pcache-disk)) + (bytes (+ (pcache-ent-data-length pcache-ent) + *header-block-size*)) + (res)) + (dlogmess (format nil "retrieve ~s in blocks ~s~%" + (pcache-ent-key pcache-ent) + block-list)) + (log-proxy (pcache-ent-key pcache-ent) 0 :rd nil) + + (acl-compat.mp:with-process-lock ((pcache-disk-lock pcache-disk)) + ; get a lock so we're the only thread doing operations + ; on the stream to the cache + (dolist (ent block-list) + (file-position stream (* (car ent) *header-block-size*)) + (dotimes (i (1+ (- (cdr ent) (car ent)))) + (let ((buff (get-header-block))) + (read-sequence buff stream :end (min *header-block-size* + bytes)) + (decf bytes *header-block-size*) + (push buff res)))) + (setf (pcache-ent-data pcache-ent) (nreverse res)) + + + (return-free-blocks pcache-disk block-list) + + ; insert in the memory ru list + (most-recently-used-ent pcache-ent) + + ; insert in memory + + (acl-compat.excl::atomically + (acl-compat.excl::fast + (setf (pcache-ent-disk-location pcache-ent) nil + (pcache-ent-pcache-disk pcache-ent) nil + (pcache-ent-loading-flag pcache-ent) nil))))))) + + + + + + + + + + +(defun get-disk-cache-blocks (pcache-disk count) + ;; return the location of count cache blocks + + (acl-compat.mp:with-process-lock ((pcache-disk-lock pcache-disk)) + (let ((free (pcache-disk-free-blocks pcache-disk))) + (decf free count) + (if* (>= free 0) + then (setf (pcache-disk-free-blocks pcache-disk) free) + ; now find that many blocks + (let ((free-list (pcache-disk-free-list pcache-disk)) + (toret)) + (loop + (let ((ent (car free-list))) + (if* (null ent) + then ; should not have run out.. this is bad + (return-from get-disk-cache-blocks nil) + else (let ((amt (1+ (- (cdr ent) (car ent))))) + (if* (< amt count) + then ; need this and more + (push ent toret) + (decf count amt) + (pop free-list) + elseif (eql amt count) + ; perfect + then (push ent toret) + (pop free-list) + (return) + else ; too many, take what we need + (push (cons (car ent) + (+ (car ent) + count + -1)) + toret) + (incf (car ent) count) + (return)))))) + (setf (pcache-disk-free-list pcache-disk) free-list) + toret))))) + + + +(defun return-free-blocks (pcache-disk list-of-blocks) + ;; return the given blocks to the free list + ;; list of block is a list of conses (start . end) + ;; and we must insert them in the free list which has the + ;; same form, and we want to merge blocks too. + (acl-compat.mp:with-process-lock ((pcache-disk-lock pcache-disk)) + (let ((giveback 0) + (free-list (pcache-disk-free-list pcache-disk))) + (dolist (ent list-of-blocks) + (incf giveback (1+ (- (cdr ent) (car ent)))) + (do ((prev nil cur) + (cur free-list (cdr cur))) + ((null cur) + ; add at end of the line + (if* prev + then (setf (cdr prev) (list ent)) + else ; only thing + (setq free-list (list ent)))) + (if* (< (cdr ent) (caar cur)) + then ; fit it in between prev and cur + ; we know that it's not adjacent to the previous entry + ; see if adjacent to this cur entry + (if* (eql (1+ (cdr ent)) (caar cur)) + then ; adjacent, just adjust that one + (setf (caar cur) (car ent)) + + else ; not adjacent, link it in + (if* prev + then (setf (cdr prev) (cons ent cur)) + else (setq free-list + (cons ent cur)))) + (return) + elseif (eql (1+ (cdar cur)) (car ent)) + then ; is adjacent at the right end to cur + (setf (cdar cur) (cdr ent)) + ; see if cur now joins with the one after cur + (setq prev cur + cur (cdr prev)) + (if* (and cur (eql (1+ (cdar prev)) (caar cur))) + then ; it does + (setf (cdar prev) (cdar cur)) + (setf (cdr prev) (cdr cur))) + + (return)))) + (setf (pcache-disk-free-list pcache-disk) free-list) + (incf (pcache-disk-free-blocks pcache-disk) giveback)))) + + + +(defun store-data-on-disk (pcache-ent pcache-disk list-of-blocks) + ;; store the data in the pcache-ent to the disk using + ;; the blocks in list-of-blocks (list of cons format) + ;; + (let ((buffers (pcache-ent-data pcache-ent)) + (stream (pcache-disk-stream pcache-disk)) + (bytes (+ *header-block-size* ; for header block + (pcache-ent-data-length pcache-ent)))) + (dlogmess (format nil "writing ~d buffers to list ~d~%" + (length buffers) + list-of-blocks)) + (dolist (ent list-of-blocks) + ; prepare to write + (file-position stream (* (car ent) *header-block-size*)) + + (dotimes (i (1+ (- (cdr ent) (car ent)))) + (if* (null buffers) + then (error "ran out of buffers before blocks")) + (let ((length (min *header-block-size* bytes))) + (if* (> length 0) + then (write-sequence (car buffers) stream :end length))) + (pop buffers) + (decf bytes *header-block-size*))))) + + + + + + + + +;--- end disk cache + +;--- uri transforms + +(defparameter *uri-transforms* + ;; list of functions that take a string and if they make a change + ;; return a string (else they return nil) + nil) + + +(defun transform-uri (string) + ;; transform the string + (let (ans) + (dolist (tr *uri-transforms* string) + (if* (setq ans (funcall tr string)) + then (return ans))))) + + +; define sample transform +(defun add-transform (function) + (pushnew function *uri-transforms*)) + + + +;--- specification of uri handling by proxy +(defun handle-uri (host path + &key (server *wserver*) + (extra-lifetime nil el-p) + (scan-depth nil sd-p) + (exclude nil ex-p) + (scan-function nil sf-p) + (offsite t ofs-p) + ) + + ;; store info about how to handle this uri during the scan + + ;; host can be "foo.com" or "foo.com:8000" + ;; + + (let ((pcache (wserver-pcache server)) + (table) + (uri-info) + (ahost) + (aport) + ) + (if* (null pcache) then (error "proxying isn't enabled")) + (setq table (pcache-uri-info-table pcache)) + + (multiple-value-setq (ahost aport) (get-host-port host)) + (if* (null ahost) + then (error "bad form for the host:port ~s" host)) + + (dolist (ent (gethash ahost table)) + (if* (and (equal path (uri-info-path ent)) + (eql aport (uri-info-port ent))) + then (return (setq uri-info ent)))) + + (if* (null uri-info) + then ; add new one + (setq uri-info (make-uri-info + :host ahost + :port aport + :offsite offsite + :path path + :path-regexp (if* path + then (compile-regexp path)))) + (push uri-info (gethash ahost table))) + + ; set fields + (if* el-p + then (setf (uri-info-extra-lifetime uri-info) extra-lifetime)) + + (if* sd-p + then (setf (uri-info-scan-depth uri-info) scan-depth)) + + (if* ex-p + then (if* (and exclude + (not (consp exclude))) + then (setq exclude (list exclude))) + + (setf (uri-info-exclude uri-info) exclude + (uri-info-exclude-regexp uri-info) (mapcar #'compile-regexp exclude)) + ) + + (if* sf-p + then (setf (uri-info-scan-function uri-info) scan-function)) + + (if* ofs-p + then (setf (uri-info-offsite uri-info) offsite)) + + uri-info)) + + + + +(defmethod find-uri-info ((uri puri:uri)) + ;; locate the uri-info corresponding to this uri, if + ;; there is one + (let ((pcache (wserver-pcache *wserver*)) + (path (puri:uri-path uri)) + (host (puri:uri-host uri)) + (port (or (puri:uri-port uri) 80))) + (if* pcache + then (dolist (ent (gethash host (pcache-uri-info-table pcache))) + (if* (eql port (uri-info-port ent)) + then + (let ((pregexp (uri-info-path-regexp ent))) + (if* (null pregexp) + then ; matches everything + (return ent) + elseif (match-regexp pregexp path :return nil) + then (return ent)))))))) + + + + + + + + + + + + + + + + +;-------- state save/restore + +; items to save +; pcache (wserver-pcache) +; + +; structures needing saving +(defmethod make-load-form ((obj pcache) &optional env) + (make-load-form-saving-slots obj :environment env)) + +(defmethod make-load-form ((obj pcache-disk) &optional env) + (make-load-form-saving-slots obj :environment env)) + +(defmethod make-load-form ((obj pcache-ent) &optional env) + (make-load-form-saving-slots obj :environment env)) + +(defmethod make-load-form ((obj queueobj) &optional env) + (make-load-form-saving-slots obj :environment env)) + +(without-package-locks + #+allegro ;; No class process-lock, at least in acl-mp-cmu.lisp +(defmethod make-load-form ((obj acl-mp:process-lock) &optional env) + (make-load-form-saving-slots obj :environment env)) + +; this is just temporary until we get a patch for this in uri.fasl +(defmethod make-load-form ((self puri:uri) &optional env) + (declare (ignore env)) + `(make-instance ',(class-name (class-of self)) + :scheme ,(uri-scheme self) + :host ,(uri-host self) + :port ,(uri-port self) + :path ',(uri-path self) + :query ,(uri-query self) + :fragment ,(uri-fragment self) + :plist ',(uri-plist self) + :string ,(puri::uri-string self) + ; bug is missing ' in parsed-path value + :parsed-path ',(puri::uri-parsed-path self))) +) + +(defun save-proxy-cache (filename &key (server *wserver*)) + ;; after the server threads have been saved, this function can + ;; be called to save out the state of the proxy cache + + ; prepare to save by removing objects that can't be saved + + (let ((pcache (wserver-pcache server))) + (if* (null pcache) + then (return-from save-proxy-cache nil)) + + (setf (pcache-cleaner pcache) nil) + + ; don't save the hash table since we can recreate it as since + ; saving it is very expensive due to the fasl-circle check + (setf (pcache-table pcache) nil) + + + (dolist (pcache-disk (pcache-disk-caches pcache)) + ; for each disk cache + (ignore-errors (close (pcache-disk-stream pcache-disk))) + (setf (pcache-disk-stream pcache-disk) nil))) + + + (with-open-file (p filename :direction :output :if-exists :supersede) + (fasl-write (wserver-pcache server) p t)) + + (setf (wserver-pcache server) nil)) + + + +(defun restore-proxy-cache (filename &key (server *wserver*)) + (let ((pcache (car (fasl-read filename)))) + (if* (not (typep pcache 'pcache)) + then (error "file didn't contain a saved cache")) + + (dolist (pcache-disk (pcache-disk-caches pcache)) + ; open each cache + (let ((filename (pcache-disk-filename pcache-disk))) + (setf (pcache-disk-stream pcache-disk) + (open filename + :if-exists :overwrite + :if-does-not-exist :error + :direction :io + #-(and allegro (version>= 6)) + :element-type + #-(and allegro (version>= 6)) + '(unsigned-byte 8))))) + + (setf (wserver-pcache server) pcache) + + ; rebuild the hash table + (let ((table (make-hash-table :size 1000 :test #'equal))) + (flet ((process-queue (table queueobj) + ;; add all entries to the hash table + (let ((lru-head (queueobj-lru queueobj)) + (cur (pcache-ent-next (queueobj-mru queueobj)))) + (loop + (if* (eq cur lru-head) then (return)) + + (if* (not (eq :dead (pcache-ent-state cur))) + then (push cur + (gethash (pcache-ent-key cur) + table))) + (setq cur (pcache-ent-next cur)))))) + + (dolist (pcache-disk (pcache-disk-caches pcache)) + (process-queue table (pcache-disk-queueobj pcache-disk))) + (process-queue table (pcache-queueobj pcache)) + + (setf (pcache-table pcache) table) + )) + + + (start-proxy-cache-processes server pcache))) + + +;---- Added: vendor/portableaserve/aserve/publish.cl =================================================================== --- vendor/portableaserve/aserve/publish.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/publish.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2374 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; publish.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2000-2004 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: publish.cl,v 1.19 2005/08/05 09:26:39 melisgl Exp $ + +;; Description: +;; publishing urls + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + +(in-package :net.aserve) + + +(defclass entity () + ;; an object to be published + ;; host and port may be nil, meaning "don't care", or a list of + ;; items or just an item + ((host + :initarg :host + :initform nil + :reader host) + (port :initarg :port + :initform nil + :reader port) + (path :initarg :path + :reader path) + (location :initarg :location + :reader location) + (prefix :initarg :prefix + :initform nil + :reader prefix) + (last-modified :initarg :last-modified + :accessor last-modified + :initform nil ; means always considered new + ) + + ; ut string format for last-modified cached here. + (last-modified-string :initarg :last-modified-string + :accessor last-modified-string + :initform nil) + + (format :initarg :format ;; :text or :binary + :initform :text + :reader entity-format) + + (content-type :initarg :content-type + :reader content-type + :initform nil) + + ; can be a single object or a list of objects + (authorizer :initarg :authorizer + :accessor entity-authorizer + :initform nil) + + ; if not nil then the timeout to be used in a with-http-response + ; for this entity + (timeout :initarg :timeout + :initform nil + :accessor entity-timeout) + + ; property list for storing info on this entity + (plist :initarg :plist + :initform nil + :accessor entity-plist) + + ; function of 3 args (req ent extra) called between + ; with-http-request and with-http-body for entity types + ; where the user has no control (i.e. non function types) + (hook :initarg :hook + :initform nil + :accessor entity-hook) + + ; cons holding extra headers to send with this entity + (headers :initarg :headers + :initform nil + :accessor entity-headers) + + ; extra holds random info we need for a particular entity + (extra :initarg :extra :reader entity-extra) + )) + + +(defclass file-entity (entity) + ;; a file to be published + ( + (file :initarg :file :reader file) + (contents :initarg :contents :accessor contents + :initform nil) + (cache-p + ;; true if the contents should be cached when accessed + :initarg :cache-p + :initform nil + :accessor cache-p) + + )) + + +(defclass computed-entity (entity) + ;; entity computed each time it's called + ((function :initarg :function :reader entity-function))) + +(defvar *dummy-computed-entity* + ;; needed when intercepting and sending a computed entity in place + ;; of the entity being published + (make-instance 'computed-entity)) + + +(defclass access-file-mixin () + ;; slots needed if you want to use access files during + ;; the handling of this entity + ; if non-nil the name of the file to look for in directories to + ; personalize the creation of file entities + ((access-file :initarg :access-file + :initform nil + :accessor directory-entity-access-file) + + ; internal slot used to cache the files we've read + ; is a list of + ; (whole-access-filename last-write-dat cached-value) + ; + (access-file-cache :initform nil + :accessor directory-entity-access-file-cache) + )) + + + +(defclass directory-entity (entity access-file-mixin) + ;; entity that displays the contents of a directory + ((directory :initarg :directory ; directory to display + :reader entity-directory) + (prefix :initarg :prefix ; url prefix pointing to ths dir + :reader prefix + :initform "") + (recurse :initarg :recurse ; t to descend to sub directories + :initform nil + :reader recurse) + + (cache-p + ;; settting for file entities created: + ;; true if the contents should be cached when accessed + :initarg :cache-p + :initform nil + :accessor cache-p) + + ; list of name of files that can be used to index this directory + (indexes :initarg :indexes + :initform nil + :accessor directory-entity-indexes) + + ; filter is nil or a function of req ent filename info + ; which can process the request or return nil + (filter :initarg :filter + :initform nil + :accessor directory-entity-filter) + + + ;: fcn of req ent realname + ; it should create and publish an entity and return it + (publisher :initarg :publisher + :initform nil + :accessor directory-entity-publisher)) + + + ) + + +(defclass special-entity (entity) + ;; used to hold a certain body we want to always return + ;; nil means we'll return no body + ((content :initform nil + :initarg :content + :reader special-entity-content))) + +(setq *not-modified-entity* (make-instance 'special-entity)) + + + +;; the multi-entity contains list of items. the items can be +;; +;; atom - assumed to be a namestring or pathname that can be opened +;; function - function to run to compute a result +;; function takes req ent last-modified-time + +(defclass multi-entity (entity) + ;; handle multiple files and compute entities + + ((items + ;; list of multi-item structs + :initarg :items + :reader items) + (content-length :initform 0 + :accessor multi-entity-content-length)) + ) + + + +(defstruct multi-item + kind ; :file, :function + data ; for :file, the filename for :function the function + cache ; nil or unsigned-byte 8 array + last-modified) + + + +;;-------- locators - objects which find the entity to return + +(defclass locator () + ((name :initform :unnamed + :initarg :name + :reader locator-name) + + ; info is where the locator will likely store data related + ; to mapping + (info :initform nil + :initarg :info + :accessor locator-info) + + ; for random extra info + (extra :initarg :extra :reader locator-extra) + )) + + +(defclass locator-exact (locator) + ;; used to map specific uri paths to entities + ;; the table slot holds the hash table that's used + () + (:default-initargs :info (make-hash-table :test #'equal))) + +;; :default-initargs is broken in CormanLisp 2.0. Workaround here. +#+cormanlisp +(defmethod initialize-instance ((locator locator-exact) &key info &allow-other-keys) + (call-next-method) + (unless info + (setf (locator-info locator) (make-hash-table :test #'equal)))) + + +(defclass locator-prefix (locator) + ;; use to map prefixes to entities + () + ) + + +;; the info slot of a locator-prefix class is a list of +;; prefix-handler objects, sorted by the length of the path +;; (from longest to smallest). +(defstruct (prefix-handler (:type list)) + path ;; string which must be the prefix of the url part to match + host-handlers ;; list of host-handlers + ) + +(defstruct (host-handler (:type list)) + host ;; vhost object to match or :wild meaning match anything + entity ;; entity object to handle this request + ) + + + + + + + + + + + + + + + + + +; we can specify either an exact url or one that handles all +; urls with a common prefix. +;; +;; if the prefix is given as a list: e.g. ("ReadMe") then it says that +;; this mime type applie to file named ReadMe. Note that file types +;; are checked first and if no match then a filename match is done. +; +(defparameter *file-type-to-mime-type* + ;; this list constructed by generate-mime-table in parse.cl + '(("application/EDI-Consent") ("application/EDI-X12") ("application/EDIFACT") + ("application/activemessage") ("application/andrew-inset" "ez") + ("application/applefile") ("application/atomicmail") + ("application/cals-1840") ("application/commonground") + ("application/cybercash") ("application/dca-rft") ("application/dec-dx") + ("application/eshop") ("application/hyperstudio") ("application/iges") + ("application/mac-binhex40" "hqx") ("application/mac-compactpro" "cpt") + ("application/macwriteii") ("application/marc") ("application/mathematica") + ("application/msword" "doc") ("application/news-message-id") + ("application/news-transmission") + ("application/octet-stream" "bin" "dms" "lha" "lzh" "exe" "class") + ("application/oda" "oda") ("application/pdf" "pdf") + ("application/pgp-encrypted") ("application/pgp-keys") + ("application/pgp-signature") ("application/pkcs10") + ("application/pkcs7-mime") ("application/pkcs7-signature") + ("application/postscript" "ai" "eps" "ps") + ("application/prs.alvestrand.titrax-sheet") ("application/prs.cww") + ("application/prs.nprend") ("application/remote-printing") + ("application/riscos") ("application/rtf" "rtf") ("application/set-payment") + ("application/set-payment-initiation") ("application/set-registration") + ("application/set-registration-initiation") ("application/sgml") + ("application/sgml-open-catalog") ("application/slate") + ("application/smil" "smi" "smil") ("application/vemmi") + ("application/vnd.3M.Post-it-Notes") ("application/vnd.FloGraphIt") + ("application/vnd.acucobol") + ("application/vnd.anser-web-certificate-issue-initiation") + ("application/vnd.anser-web-funds-transfer-initiation") + ("application/vnd.audiograph") ("application/vnd.businessobjects") + ("application/vnd.claymore") ("application/vnd.comsocaller") + ("application/vnd.dna") ("application/vnd.dxr") + ("application/vnd.ecdis-update") ("application/vnd.ecowin.chart") + ("application/vnd.ecowin.filerequest") ("application/vnd.ecowin.fileupdate") + ("application/vnd.ecowin.series") ("application/vnd.ecowin.seriesrequest") + ("application/vnd.ecowin.seriesupdate") ("application/vnd.enliven") + ("application/vnd.epson.salt") ("application/vnd.fdf") + ("application/vnd.ffsns") ("application/vnd.framemaker") + ("application/vnd.fujitsu.oasys") ("application/vnd.fujitsu.oasys2") + ("application/vnd.fujitsu.oasys3") ("application/vnd.fujitsu.oasysgp") + ("application/vnd.fujitsu.oasysprs") ("application/vnd.fujixerox.docuworks") + ("application/vnd.hp-HPGL") ("application/vnd.hp-PCL") + ("application/vnd.hp-PCLXL") ("application/vnd.hp-hps") + ("application/vnd.ibm.MiniPay") ("application/vnd.ibm.modcap") + ("application/vnd.intercon.formnet") ("application/vnd.intertrust.digibox") + ("application/vnd.intertrust.nncp") ("application/vnd.is-xpr") + ("application/vnd.japannet-directory-service") + ("application/vnd.japannet-jpnstore-wakeup") + ("application/vnd.japannet-payment-wakeup") + ("application/vnd.japannet-registration") + ("application/vnd.japannet-registration-wakeup") + ("application/vnd.japannet-setstore-wakeup") + ("application/vnd.japannet-verification") + ("application/vnd.japannet-verification-wakeup") ("application/vnd.koan") + ("application/vnd.lotus-1-2-3") ("application/vnd.lotus-approach") + ("application/vnd.lotus-freelance") ("application/vnd.lotus-organizer") + ("application/vnd.lotus-screencam") ("application/vnd.lotus-wordpro") + ("application/vnd.meridian-slingshot") ("application/vnd.mif" "mif") + ("application/vnd.minisoft-hp3000-save") + ("application/vnd.mitsubishi.misty-guard.trustweb") + ("application/vnd.ms-artgalry") ("application/vnd.ms-asf") + ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint" "ppt") + ("application/vnd.ms-project") ("application/vnd.ms-tnef") + ("application/vnd.ms-works") ("application/vnd.music-niff") + ("application/vnd.musician") ("application/vnd.netfpx") + ("application/vnd.noblenet-directory") ("application/vnd.noblenet-sealer") + ("application/vnd.noblenet-web") ("application/vnd.novadigm.EDM") + ("application/vnd.novadigm.EDX") ("application/vnd.novadigm.EXT") + ("application/vnd.osa.netdeploy") ("application/vnd.powerbuilder6") + ("application/vnd.powerbuilder6-s") ("application/vnd.rapid") + ("application/vnd.seemail") ("application/vnd.shana.informed.formtemplate") + ("application/vnd.shana.informed.interchange") + ("application/vnd.shana.informed.package") ("application/vnd.street-stream") + ("application/vnd.svd") ("application/vnd.swiftview-ics") + ("application/vnd.truedoc") ("application/vnd.visio") + ("application/vnd.webturbo") ("application/vnd.wrq-hp3000-labelled") + ("application/vnd.wt.stf") ("application/vnd.xara") + ("application/vnd.yellowriver-custom-menu") ("application/wita") + ("application/wordperfect5.1") ("application/x-bcpio" "bcpio") + ("application/x-cdlink" "vcd") ("application/x-chess-pgn" "pgn") + ("application/x-compress") ("application/x-cpio" "cpio") + ("application/x-csh" "csh") ("application/x-director" "dcr" "dir" "dxr") + ("application/x-dvi" "dvi") ("application/x-futuresplash" "spl") + ("application/x-gtar" "gtar") ("application/x-gzip") + ("application/x-hdf" "hdf") ("application/x-javascript" "js") + ("application/x-koan" "skp" "skd" "skt" "skm") + ("application/x-latex" "latex") ("application/x-netcdf" "nc" "cdf") + ("application/x-rpm" "rpm") ("application/x-sh" "sh") + ("application/x-shar" "shar") ("application/x-shockwave-flash" "swf") + ("application/x-stuffit" "sit") ("application/x-sv4cpio" "sv4cpio") + ("application/x-sv4crc" "sv4crc") ("application/x-tar" "tar") + ("application/x-tcl" "tcl") ("application/x-tex" "tex") + ("application/x-texinfo" "texinfo" "texi") + ("application/x-troff" "t" "tr" "roff") ("application/x-troff-man" "man") + ("application/x-troff-me" "me") ("application/x-troff-ms" "ms") + ("application/x-ustar" "ustar") ("application/x-wais-source" "src") + ("application/x400-bp") ("application/xml") ("application/zip" "zip") + ("audio/32kadpcm") ("audio/basic" "au" "snd") + ("audio/midi" "mid" "midi" "kar") ("audio/mpeg" "mpga" "mp2" "mp3") + ("audio/vnd.qcelp") ("audio/x-aiff" "aif" "aiff" "aifc") + ("audio/x-pn-realaudio" "ram" "rm") ("audio/x-realaudio" "ra") + ("audio/x-wav" "wav") ("chemical/x-pdb" "pdb" "xyz") ("image/cgm") + ("image/g3fax") ("image/gif" "gif") ("image/ief" "ief") + ("image/jpeg" "jpeg" "jpg" "jpe") ("image/naplps") ("image/png" "png") + ("image/prs.btif") ("image/tiff" "tiff" "tif") ("image/vnd.dwg") + ("image/vnd.dxf") ("image/vnd.fpx") ("image/vnd.net-fpx") ("image/vnd.svf") + ("image/vnd.xiff") ("image/x-cmu-raster" "ras") + ("image/x-portable-anymap" "pnm") ("image/x-portable-bitmap" "pbm") + ("image/x-portable-graymap" "pgm") ("image/x-portable-pixmap" "ppm") + ("image/x-rgb" "rgb") ("image/x-xbitmap" "xbm") ("image/x-xpixmap" "xpm") + ("image/x-xwindowdump" "xwd") ("message/delivery-status") + ("message/disposition-notification") ("message/external-body") + ("message/http") ("message/news") ("message/partial") ("message/rfc822") + ("model/iges" "igs" "iges") ("model/mesh" "msh" "mesh" "silo") + ("model/vnd.dwf") ("model/vrml" "wrl" "vrml") ("multipart/alternative") + ("multipart/appledouble") ("multipart/byteranges") ("multipart/digest") + ("multipart/encrypted") ("multipart/form-data") ("multipart/header-set") + ("multipart/mixed") ("multipart/parallel") ("multipart/related") + ("multipart/report") ("multipart/signed") ("multipart/voice-message") + ("text/css" "css") ("text/directory") ("text/enriched") + ("text/plain" "asc" "txt") ("text/prs.lines.tag") ("text/rfc822-headers") + ("text/richtext" "rtx") ("text/rtf" "rtf") ("text/sgml" "sgml" "sgm") + ("text/tab-separated-values" "tsv") ("text/uri-list") ("text/vnd.abc") + ("text/vnd.flatland.3dml") ("text/vnd.fmi.flexstor") ("text/vnd.in3d.3dml") + ("text/vnd.in3d.spot") ("text/vnd.latex-z") ("text/x-setext" "etx") + ("text/xml" "xml") ("video/mpeg" "mpeg" "mpg" "mpe") + ("video/quicktime" "qt" "mov") ("video/vnd.motorola.video") + ("video/vnd.motorola.videop") ("video/vnd.vivo") ("video/x-msvideo" "avi") + ("video/x-sgi-movie" "movie") ("x-conference/x-cooltalk" "ice") + ("text/html" "html" "htm"))) + +(defvar *mime-types* nil) + +(defun build-mime-types-table () + (if* (null *mime-types*) + then (setf *mime-types* (make-hash-table :test #'equalp)) + (dolist (ent *file-type-to-mime-type*) + (dolist (type (cdr ent)) + (setf (gethash type *mime-types*) (car ent)))))) + + +(build-mime-types-table) ;; build the table now + +(defmethod lookup-mime-type (filename) + ;; return mime type if known + (if* (pathnamep filename) + then (setq filename (namestring filename))) + (multiple-value-bind (root tail name type) + (split-namestring filename) + (declare (ignore root name)) + (if* (and type (gethash type *mime-types*)) + thenret + elseif (gethash (list tail) *mime-types*) + thenret))) + + + +(defun unpublish (&key all (server *wserver*)) + (if* all + then (dolist (locator (wserver-locators server)) + (unpublish-locator locator)) + else (error "not done yet"))) + +;; methods on entity objects + +;-- content-length -- how long is the body of the response, if we know + +(defmethod content-length ((ent entity)) + ;; by default we don't know, and that's what nil means + nil) + +(defmethod content-length ((ent file-entity)) + (let ((contents (contents ent))) + (if* contents + then (length contents) + else ; may be a file on the disk, we could + ; compute it.. this is + ;** to be done + nil))) + + +(defmethod content-length ((ent special-entity)) + (let ((body (special-entity-content ent))) + (if* body + then (length body) + else 0))) + +(defmethod content-length ((ent multi-entity)) + (multi-entity-content-length ent)) + +;- transfer-mode - will the body be sent in :text or :binary mode. +; use :binary if you're not sure + +(defmethod transfer-mode ((ent entity)) + (or (entity-format ent) :binary) + ) + + + + + + + + + + + +;; url exporting + + + + + + + + +(defun publish (&key (host nil host-p) port path function class format + content-type + (server *wserver*) + locator + remove + authorizer + timeout + plist + hook + headers + ) + ;; publish the given url + ;; if file is given then it specifies a file to return + ;; + (let (hval) + (if* (null locator) + then (setq locator (find-locator :exact server))) + + (setq hval (convert-to-vhosts (if* (and host (atom host)) + then (list host) + else host) + server)) + + (if* remove + then ; eliminate the entity if it exists + (unpublish-entity locator path hval host-p) + else + + (let ((ent (make-instance (or class 'computed-entity) + :host hval + :port port + :path path + :function function + :format format + :content-type content-type + :authorizer authorizer + :plist plist + :timeout timeout + :hook hook + :headers headers + ))) + (publish-entity ent locator path hval))))) + +(defun publish-prefix (&key (host nil host-p) port prefix + function class format + content-type + (server *wserver*) + locator + remove + authorizer + timeout + plist + headers + ) + ;; publish a handler for all urls with a certain prefix + ;; + (let (hval) + (if* (null locator) + then (setq locator (find-locator :prefix server))) + + (setq hval (convert-to-vhosts (if* (and host (atom host)) + then (list host) + else host) + server)) + + (if* remove + then ; eliminate the entity if it exists + (publish-prefix-entity nil prefix locator hval host-p t) + nil + else + + (let ((ent (make-instance (or class 'computed-entity) + :host hval + :port port + :prefix prefix + :function function + :format format + :content-type content-type + :authorizer authorizer + :plist plist + :timeout timeout + :headers headers + ))) + (publish-prefix-entity ent prefix locator hval + host-p nil) + ent)))) + + + +(defun publish-file (&key (server *wserver*) + locator + (host nil host-p) + port path + file content-type class preload + cache-p + remove + authorizer + plist + (timeout #+io-timeout #.(* 100 24 60 60) + #-io-timeout nil) + hook + headers + ) + + ;; return the given file as the value of the url + ;; for the given host. + ;; If host is nil then return for any host + (let (ent got c-type hval) + (if* (null locator) + then (setq locator (find-locator :exact server))) + + (setq hval (convert-to-vhosts (if* (and host (atom host)) + then (list host) + else host) + server)) + (if* remove + then (unpublish-entity locator path + hval + host-p) + (return-from publish-file nil)) + + + (setq c-type (or content-type + (lookup-mime-type file) + "application/octet-stream")) + + (if* preload + then ; keep the content in core for fast display + (with-open-file (p file :element-type #+cormanlisp 'unsigned-byte #-cormanlisp '(unsigned-byte 8)) + (let ((size (acl-compat.excl::filesys-size (stream-input-fn p))) + (lastmod (acl-compat.excl::filesys-write-date (stream-input-fn p))) + (guts)) + (setq guts (make-array size :element-type '(unsigned-byte 8))) + + (if* (not (eql size (setq got (read-sequence guts p)))) + then (error "~s should have been ~d bytes but was ~d" + file + size + got)) + (setq ent (make-instance (or class 'file-entity) + :host hval + :port port + :path path + :file file + :content-type c-type + + :contents guts + :last-modified lastmod + :last-modified-string (universal-time-to-date lastmod) + + :cache-p cache-p + :authorizer authorizer + :timeout timeout + :plist plist + :hook hook + :headers headers + )))) + else (setq ent (make-instance (or class 'file-entity) + :host hval + :port port + :path path + :file file + :content-type c-type + :cache-p cache-p + :authorizer authorizer + :timeout timeout + :plist plist + :hook hook + :headers headers + ))) + + (publish-entity ent locator path hval))) + + + + + + + +(defun publish-directory (&key prefix + (host nil host-p) + port + destination + (server *wserver*) + locator + remove + authorizer + (indexes '("index.html" "index.htm")) + filter + (timeout #+io-timeout #.(* 100 24 60 60) + #-io-timeout nil) + publisher + access-file + plist + hook + headers + ) + + ;; make a whole directory available + + (if* (null locator) + then (setq locator (find-locator :prefix server))) + + (if* (and host (atom host)) + then (setq host (list host))) + + (setq host (convert-to-vhosts host server)) ; now a list of vhosts + + (if* remove + then (publish-prefix-entity nil prefix locator + host host-p t) + (return-from publish-directory nil)) + + (let ((ent (make-instance 'directory-entity + :directory destination + :prefix prefix + :host host + :port port + :authorizer authorizer + :indexes indexes + :filter filter + :timeout timeout + :publisher publisher + :access-file access-file + :plist plist + :hook hook + :headers headers + ))) + + (publish-prefix-entity ent prefix locator host host-p nil) + + ent + )) + + + +(defun publish-prefix-entity (ent prefix locator host host-p remove) + ;; add or remove an entity ent from the locator + ;; + (dolist (entpair (locator-info locator)) + (if* (equal (prefix-handler-path entpair) prefix) + then ; match, prefix + (if* (and remove (not host-p)) + then ; remove all entries for all hosts + (setf (locator-info locator) + (remove entpair (locator-info locator))) + (return-from publish-prefix-entity nil)) + + + (let ((handlers (prefix-handler-host-handlers entpair))) + (dolist (host host) + (dolist (hostpair handlers + ; not found, add it if we're not removing + (if* (not remove) + then (push (make-host-handler :host host + :entity ent) + handlers))) + (if* (eq host (host-handler-host hostpair)) + then ; a match + (if* remove + then (setq handlers + (remove hostpair handlers :test #'eq)) + else ; change + (setf (host-handler-entity hostpair) ent)) + (return)))) + (setf (prefix-handler-host-handlers entpair) handlers)) + + ; has been processed, time to leave + (return-from publish-prefix-entity ent))) + + ; prefix not present, must add. + ; keep prefixes in order, with max length first, so we match + ; more specific before less specific + + (if* remove + then ; no work to do + (return-from publish-prefix-entity nil)) + + (let ((len (length prefix)) + (list (locator-info locator)) + (new-ent (make-prefix-handler + :path prefix + :host-handlers (mapcar #'(lambda (host) + (make-host-handler + :host host + :entity ent)) + host)))) + (if* (null list) + then ; this is the first + (setf (locator-info locator) (list new-ent)) + elseif (>= len (length (caar list))) + then ; this one should preceed all other ones + (setf (locator-info locator) (cons new-ent list)) + else ; must fit somewhere in the list + (do* ((back list (cdr back)) + (cur (cdr back) (cdr cur))) + ((null cur) + ; put at end + (setf (cdr back) (list new-ent))) + (if* (>= len (length (caar cur))) + then (setf (cdr back) `(,new-ent ,@cur)) + (return)))))) + + + +(defun publish-multi (&key (server *wserver*) + locator + (host nil host-p) + port + path + items + class + content-type + remove + authorizer + timeout + plist + hook + headers) + + (if* (null locator) + then (setq locator (find-locator :exact server))) + + (if* remove + then (unpublish-entity locator path host host-p) + (return-from publish-multi nil)) + + (let* ((hval) + (ent (make-instance (or class 'multi-entity) + :host (setq hval + (convert-to-vhosts + (if* host + then (if* (and host (atom host)) + then (list host) + else host)) + server)) + :port port + :path path + :plist plist + :format :binary ; we send out octets + :items (mapcar #'(lambda (it) + (if* (or (symbolp it) + (functionp it)) + then (make-multi-item + :kind :function + :data it) + elseif (and (consp it) + (eq :string (car it)) + (stringp (cadr it))) + then (make-multi-item + :kind :string + :data (cadr it) + :cache (string-to-octets + (cadr it) + :null-terminate nil)) + elseif (and (consp it) + (eq :binary (car it)) + (typep (cadr it) + '(simple-array (unsigned-byte 8) (*)))) + then (make-multi-item + :kind :binary + :data (cadr it) + :cache (cadr it)) + elseif (or (stringp it) (pathnamep it)) + then (make-multi-item + :kind :file + :data it) + else (error "Illegal item for publish-multi: ~s" it) + )) + items) + :content-type (or content-type "application/octet-stream") + :authorizer authorizer + :timeout timeout + :hook hook + :headers headers + ))) + (publish-entity ent locator path hval))) + + + + + + + + +(defmethod publish-entity ((ent entity) + (locator locator-exact) + path + hosts) + ;; handle putting an entity in hash + ;; table of a locator-exact. + ;; + ;; assert: hosts is a non-null list of vhosts + ;; + (let ((ents (gethash path (locator-info locator)))) + ;; must replace entry with matching host parameter + (dolist (host hosts) + (let ((xent (assoc host ents :test #'eq))) + (if* (null xent) + then ; add new one + (push (cons host ent) ents) + else ; replace + (setf (cdr xent) ent)))) + (setf (gethash path (locator-info locator)) ents) + + ent)) + + + + + +(defmethod unpublish-entity ((locator locator-exact) + path + hosts + host-p) + ;; remove any entities matching the host and path. + ;; if host-p is nil then remove all entities, don't match the host + (let ((ents (gethash path (locator-info locator)))) + (if* ents + then (if* host-p + then ; must patch the hosts + (dolist (host hosts) + (let ((xent (assoc host ents :test #'eq))) + (if* xent + then (setq ents + (delete xent ents :test #'eq))))) + (if* (null ents) + then (remhash path (locator-info locator)) + else (setf (gethash path (locator-info locator)) ents)) + else ; throw away everything + (remhash path (locator-info locator)))))) + + +(defun convert-to-vhosts (hosts server) + ;; host is a list or nil + ;; if an element is a string lookup the virtual host + ;; and create one of none is specified + (if* (null hosts) + then ; specify the wild card host + (list :wild) + else ; convert strings to vhosts + (let (res) + (dolist (host hosts) + (let (vhost) + (if* (stringp host) + then + (if* (null + (setq vhost (gethash host + (wserver-vhosts server)))) + then ; not defined yet, must define + (setq vhost + (setf (gethash host + (wserver-vhosts server)) + (make-instance 'vhost + :log-stream + (wserver-log-stream server) + :error-stream + (wserver-log-stream server) + :names + (list host))))) + else (setq vhost host)) + (pushnew vhost res :test #'eq))) + res))) + + +(defmethod handle-request ((req http-request)) + + + ;; run all filters, starting with vhost filters + ; a return value of :done means don't + ; run any further filters + (dolist (filter (vhost-filters (request-vhost req)) + (dolist (filter (wserver-filters *wserver*)) + (if* (eq :done (funcall filter req)) then (return)))) + (if* (eq :done (funcall filter req)) then (return))) + + + (dolist (locator (wserver-locators *wserver*)) + (let ((ent (standard-locator req locator))) + (if* ent + then ; check if it is authorized + (if* (authorize-and-process req ent) + then (return-from handle-request))))) + + ; no handler + (failed-request req) + + ) + +(defun authorize-and-process (req ent) + ;; check for authorization need and process or send back + ;; a message why it failed + ;; if we actually http responded return true, else return nil + ;; + ;; all authorizers must succeed for it to succeed + + (let ((authorizers (entity-authorizer ent))) + + (if* (and authorizers (atom authorizers)) + then (setq authorizers (list authorizers))) + + (dolist (authorizer authorizers) + (let ((result (authorize authorizer req ent))) + (if* (eq result t) + thenret ; ok so far, but keep checking + elseif (eq result :done) + then ; already responsed + (return-from authorize-and-process t) + elseif (eq result :deny) + then ; indicate denied request + (denied-request req) + (return-from authorize-and-process t) + else ; failed to authorize + (return-from authorize-and-process nil)))) + + ; all authorization ok. try to run it and return the + ; value representing its exit status + (process-entity req ent))) + + + + +(defmethod failed-request ((req http-request)) + ;; generate a response to a request that we can't handle + (let ((entity (wserver-invalid-request *wserver*))) + (if* (null entity) + then (setq entity + (make-instance 'computed-entity + :function #'(lambda (req ent) + (with-http-response + (req ent + :response *response-not-found*) + (with-http-body (req ent) + (html + (:html + (:head (:title "404 - NotFound")) + (:body + (:h1 "Not Found") + "The request for " + (:b + (:princ-safe + (render-uri + (request-uri req) + nil + ))) + " was not found on this server." + :br + :br + :hr + (:i + "AllegroServe " + (:princ-safe *aserve-version-string*)) + )))))) + :content-type "text/html")) + (setf (wserver-invalid-request *wserver*) entity)) + (process-entity req entity))) + +(defmethod denied-request ((req http-request)) + ;; generate a response to a request that we can't handle + (let ((entity (wserver-denied-request *wserver*))) + (if* (null entity) + then (setq entity + (make-instance 'computed-entity + :function #'(lambda (req ent) + (with-http-response + (req ent + :response *response-not-found*) + (with-http-body (req ent) + (html + (:html + (:head (:title "404 - NotFound")) + (:body + (:h1 "Not Found") + "The request for " + (:princ-safe + (render-uri + (request-uri req) + nil + )) + " was denied.")))))) + :content-type "text/html")) + (setf (wserver-denied-request *wserver*) entity)) + (process-entity req entity))) + + +(defmethod standard-locator ((req http-request) + (locator locator-exact)) + ;; standard function for finding an entity in an exact locator + ;; return the entity if one is found, else return nil + + (if* (uri-scheme (request-raw-uri req)) + then ; ignore proxy requests + (return-from standard-locator nil)) + + (let ((ents (gethash (request-decoded-uri-path req) + (locator-info locator)))) + (cdr + (or (assoc (request-vhost req) ents :test #'eq) + (assoc :wild ents :test #'eq))))) + +(defmethod standard-locator ((req http-request) + (locator locator-prefix)) + ;; standard function for finding an entity in an exact locator + ;; return the entity if one is found, else return nil + + (if* (uri-scheme (request-raw-uri req)) + then ; ignore proxy requests + (return-from standard-locator nil)) + + (let* ((url (request-decoded-uri-path req)) + (len-url (length url)) + (vhost (request-vhost req))) + + (dolist (entpair (locator-info locator)) + (if* (and (>= len-url (length (prefix-handler-path entpair))) + (buffer-match url 0 (prefix-handler-path entpair))) + then ; we may already be a wiener + (let ((hh (or (assoc vhost (prefix-handler-host-handlers + entpair) + :test #'eq) + (assoc :wild (prefix-handler-host-handlers + entpair) + :test #'eq)))) + (if* hh + then (return (host-handler-entity hh)))))))) + + + + + +(defun find-locator (name wserver) + ;; give the locator with the given name + (dolist (locator (wserver-locators wserver) + (error "no such locator as ~s" name)) + (if* (eq name (locator-name locator)) + then (return locator)))) + + +(defmethod unpublish-locator ((locator locator-exact)) + (clrhash (locator-info locator))) + +(defmethod unpublish-locator ((locator locator-prefix)) + (setf (locator-info locator) nil)) + + +(defmethod map-entities (function (locator locator)) + ;; do nothing if no mapping function defined + (declare (ignore function)) + nil) + +(defmethod map-entities (function (locator locator-exact)) + ;; map the function over the entities in the locator + (maphash #'(lambda (k v) + (let (remove) + (dolist (pair v) + (if* (eq :remove (funcall function (cdr pair))) + then (push pair remove))) + (if* remove + then (dolist (rem remove) + (setq v (remove rem v :test #'eq))) + (if* (null v) + then (remhash k (locator-info locator)) + else (setf (gethash k (locator-info locator)) + v))))) + (locator-info locator))) + +(defmethod map-entities (function (locator locator-prefix)) + (let (outer-remove) + (dolist (ph (locator-info locator)) + (let (remove) + (dolist (hh (prefix-handler-host-handlers ph)) + (let ((ent (host-handler-entity hh))) + (if* ent + then (if* (eq :remove (funcall function ent)) + then (push hh remove))))) + (if* remove + then (let ((v (prefix-handler-host-handlers ph))) + (dolist (rem remove) + (setq v (remove rem v :test #'eq))) + (if* (null v) + then (push ph outer-remove) ; remove whole thing + else (setf (prefix-handler-host-handlers ph) v)))))) + + (if* outer-remove + then ; remove some whole prefixes + (let ((v (locator-info locator))) + (dolist (rem outer-remove) + (setq v (remove rem v :test #'eq))) + (setf (locator-info locator) v))) + )) + + + + + + + + + + + + + + +(defmethod process-entity ((req http-request) (entity computed-entity)) + ;; + (let ((fcn (entity-function entity))) + (funcall fcn req entity) + t ; processed + )) + + + + + + +(defmethod process-entity ((req http-request) (ent file-entity)) + + (tagbody + retry + (let ((contents (contents ent))) + (if* contents + then ;(preloaded) + ; ensure that the cached file matches the + ; actual file + (if* (not (eql (last-modified ent) + (file-write-date (file ent)))) + then ; uncache it + (setf (contents ent) nil + (last-modified ent) nil) + (go retry)) + + ; set the response code and + ; and header fields then dump the value + + ; * should check for range here + ; for now we'll send it all + (with-http-response (req ent + :content-type (content-type ent) + :format :binary) + (setf (request-reply-content-length req) (length contents)) + (setf (reply-header-slot-value req :last-modified) + (last-modified-string ent)) + + (run-entity-hook req ent nil) + + (with-http-body (req ent) + ;; at this point the header are out and we have a stream + ;; to write to + #-cmu + (write-sequence contents (request-reply-stream req)) + #+cmu + ;; No preemptive multitasking in cmucl, so we yield + ;; manually (otherwise the server blocks on one long + ;; request) + (loop with stream = (request-reply-stream req) + with length = (length contents) + for index from 0 to length by 1024 + do (progn (write-sequence contents stream + :start index + :end (min (+ index 1024) + length)) + (mp:process-yield))) + )) + + + + else ; the non-preloaded case + (let (p range) + + + + + (setf (last-modified ent) nil) ; forget previous cached value + + (if* (null (errorset + (setq p (open (file ent) + :direction :input + :element-type #+cormanlisp 'unsigned-byte #-cormanlisp '(unsigned-byte 8))))) + then ; file not readable + + (return-from process-entity nil)) + + (unwind-protect + (progn + (let ((size (acl-compat.excl::filesys-size (stream-input-fn p))) + (lastmod (acl-compat.excl::filesys-write-date + (stream-input-fn p))) + (buffer (make-array 1024 + :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent buffer)) + + + + + (setf (last-modified ent) lastmod + (last-modified-string ent) + (universal-time-to-date lastmod)) + + (if* (cache-p ent) + then ; we should read and cache the contents + ; and then do the cached thing + (let ((wholebuf + (make-array + size + :element-type '(unsigned-byte 8)))) + (read-sequence wholebuf p) + (setf (contents ent) wholebuf)) + (go retry)) + + + (if* (setq range (header-slot-value req :range)) + then (setq range (parse-range-value range)) + (if* (not (eql (length range) 1)) + then ; ignore multiple ranges + ; since we're not + ; prepared to send back a multipart + ; response yet. + (setq range nil))) + (if* range + then (return-from process-entity + (return-file-range-response + req ent range buffer p size))) + + + (with-http-response (req ent :format :binary) + + ;; control will not reach here if the request + ;; included an if-modified-since line and if + ;; the lastmod value we just calculated shows + ;; that the file hasn't changed since the browser + ;; last grabbed it. + + (setf (request-reply-content-length req) size) + (setf (reply-header-slot-value req :last-modified) + (last-modified-string ent)) + + (run-entity-hook req ent nil) + + (with-http-body (req ent) + (loop + (if* (<= size 0) then (return)) + (let ((got (read-sequence buffer + p :end + (min size 1024)))) + (if* (<= got 0) then (return)) + (write-sequence buffer (request-reply-stream req) + :end got) + (decf size got) + ;; No preemptive multitasking in + ;; cmucl, so we yield manually + ;; (otherwise the server blocks on one + ;; long request) + #+cmu + (mp:process-yield) + )))))) + + + + (close p)))))) + + t ; we've handled it + ) + + +(defun run-entity-hook (req ent extra) + ;; if there is a hook function, call it. + (let ((hook (entity-hook ent))) + (if* hook then (funcall hook req ent extra)))) + + +(defun return-file-range-response (req ent range buffer p size) + ;; read and return just the given range from the file. + ;; assert: range has exactly one range + + (let ((start (caar range)) + (end (cdar range))) + (if* (null start) + then ; suffix range + (setq start (max 0 (- size end))) + (setq end (1- size)) + elseif (null end) + ; extends beyond end + then (setq end (1- size)) + else (setq end (min end (1- size)))) + + ; we allow end to be 1- start to mean 0 bytes to transfer + (if* (> start (1- end)) + then ; bogus range + (with-http-response (req ent + :response + *response-requested-range-not-satisfiable*) + + (run-entity-hook req ent :illegal-range) + (with-http-body (req ent) + (html "416 - Illegal Range Specified"))) + else ; valid range + (with-http-response (req ent + :response *response-partial-content* + :format :binary) + (setf (reply-header-slot-value req :content-range) + (format nil "bytes ~d-~d/~d" start end size)) + (setf (request-reply-content-length req) + (max 0 (1+ (- end start)))) + + (run-entity-hook req ent :in-range) + (with-http-body (req ent) + (file-position p start) + (let ((left (max 0 (1+ (- end start))))) + (loop + (if* (<= left 0) then (return)) + (let ((got (read-sequence buffer p :end + (min left 1024)))) + (if* (<= got 0) then (return)) + (write-sequence buffer *html-stream* + :end got) + (decf left got))))))) + + t ; meaning we sent something + )) + + + + + + + + + + +(defmethod process-entity ((req http-request) (ent directory-entity)) + ;; search for a file in the directory and then create a file + ;; entity for it so we can track last modified. + + ; remove the prefix and tack and append to the given directory + + (let* ((postfix nil) + (realname (concatenate 'string + (entity-directory ent) + (setq postfix (subseq (request-decoded-uri-path req) + (length (prefix ent)))))) + (redir-to) + (info) + (forbidden) + ) + (debug-format :info "directory request for ~s~%" realname) + + ; we can't allow the brower to specify a url with + ; any ..'s in it as that would allow the browser to + ; search outside the tree that's been published + (if* (or #+mswindows (position #\\ postfix) ; don't allow windows dir sep + (match-regexp "\\.\\.[\\/]" postfix)) + then ; contains ../ or ..\ + ; ok, it could be valid, like foo../, but that's unlikely + ; Also on Windows don't allow \ since that's a directory sep + ; and user should be using / in http paths for that. + (return-from process-entity nil)) + + #+allegro + (if* sys:*tilde-expand-namestrings* + then (setq realname (excl::tilde-expand-unix-namestring realname))) + + (multiple-value-setq (info forbidden) + (read-access-files ent realname postfix)) + + (if* forbidden + then ; give up right away. + (return-from process-entity nil)) + + (let ((type (acl-compat.excl::filesys-type realname))) + (if* (null type) + then ; not present + (return-from process-entity nil) + elseif (eq :directory type) + then ; Try the indexes (index.html, index.htm, or user-defined). + ; tack on a trailing slash if there isn't one already. + (if* (not (eq #\/ (schar realname (1- (length realname))))) + then (setq realname (concatenate 'string realname "/"))) + + (setf redir-to + (dolist (index (directory-entity-indexes ent) + ; no match to index file, give up + (return-from process-entity nil)) + (if* (eq :file (acl-compat.excl::filesys-type + (concatenate 'string realname index))) + then (return index)))) + + elseif (not (eq :file type)) + then ; bizarre object + (return-from process-entity nil))) + + (if* redir-to + then ; redirect to an existing index file + (with-http-response (req ent + :response *response-temporary-redirect*) + (let ((path (uri-path (request-uri req)))) + (setf (reply-header-slot-value req :location) + (concatenate 'string path + (if* (and path + (> (length path) 0) + (eq #\/ (aref path + (1- (length path))))) + then "" + else "/") + redir-to)) + + (with-http-body (req ent)))) + elseif (and info (file-should-be-denied-p realname info)) + then ; we should ignore this file + (return-from process-entity nil) + elseif (and (directory-entity-filter ent) + (funcall (directory-entity-filter ent) req ent + realname info)) + thenret ; processed by the filter + else ;; ok realname is a file. + ;; create an entity object for it, publish it, and dispatch on it + (return-from process-entity + (authorize-and-process + req + (funcall + (or (directory-entity-publisher ent) + #'standard-directory-entity-publisher) + + req ent realname info)))) + + t)) + + +(defun standard-directory-entity-publisher (req ent realname info) + ;; the default publisher used when directory entity finds + ;; a file it needs to publish + + (multiple-value-bind (content-type local-authorizer) + (standard-access-file-reader realname info) + + ; now publish a file with all the knowledge + (publish-file :path (request-decoded-uri-path req) + :host (host ent) + :file realname + :authorizer (or local-authorizer + (entity-authorizer ent)) + :content-type content-type + :timeout (entity-timeout ent) + :plist (list :parent ent) ; who spawned us + :hook (entity-hook ent) + :headers (entity-headers ent) + ))) + + +(defun standard-access-file-reader (realname info) + ;; gather the relevant information from the access file + ;; information 'info' and return two values + ;; content-type - if specific content type was specified + ;; authorizers - list of authorization objects + ;; + (let (content-type + local-authorizer + pswd-authorizer + ip-authorizer + ) + + ; look for local mime info that would set the content-type + ; of this file + (block out + (multiple-value-bind (root tail name type) + (split-namestring realname) + (declare (ignore root name)) + (dolist (inf info) + (if* (eq :mime (car inf)) + then ; test this mime info + (dolist (pat (getf (cdr inf) :types)) + (if* (or (and type (member type (cdr pat) :test #'equalp)) + (and tail + (member (list tail) (cdr pat) + :test #'equalp))) + then (setq content-type (car pat)) + (return-from out t))))))) + + + ; look for authorizer + (let ((ip (assoc :ip info :test #'eq))) + (if* ip + then (setq ip-authorizer + (make-instance 'location-authorizer + :patterns (getf (cdr ip) :patterns))))) + + ; only one of ip and pswd allowed + (let ((pswd (assoc :password info :test #'eq))) + (if* pswd + then (setq pswd-authorizer + (make-instance 'password-authorizer + :realm (getf (cdr pswd) :realm) + :allowed (getf (cdr pswd) :allowed))))) + + ; check password second + (if* pswd-authorizer + then (setq local-authorizer (list pswd-authorizer))) + + (if* ip-authorizer + then (push ip-authorizer local-authorizer)) + + (values content-type local-authorizer) + + )) + + +(defun read-access-files (ent realname postfix) + ;; read and cache all access files involved in this access + ; realname is the whole name of the file. Postfix is the part + ; added by the uri and thus represents the part of the uri we + ; need to scan for access files + + (let ((access-file (directory-entity-access-file ent)) + info + pos + opos + file-write-date + root) + + (if* (null access-file) then (return-from read-access-files nil)) + + ; simplify by making '/' the directory separator on windows too + #+mswindows + (if* (position #\\ realname) + then (setq realname (substitute #\/ #\\ realname))) + + ; search for slash ending root dir + (setq pos (position #\/ realname + :from-end t + :end (- (length realname) (length postfix)))) + (loop + (if* (null pos) + then (setq root "./") + (setq pos 1) + else (setq root (subseq realname 0 (1+ pos)))) + + (let ((aname (concatenate 'string root access-file))) + (if* (setq file-write-date (acl-compat.excl::file-write-date aname)) + then ; access file exists + (let ((entry (assoc aname + (directory-entity-access-file-cache ent) + :test #'equal))) + (if* (null entry) + then (setq entry (list aname + 0 + nil)) + (push entry (directory-entity-access-file-cache ent))) + (if* (> file-write-date (cadr entry)) + then ; need to refresh + (setf (caddr entry) (read-access-file-contents aname)) + (setf (cadr entry) file-write-date)) + + ; put new info at the beginning of the info list + (setq info (append (caddr entry) info))))) + + ; see if we have to descend a directory level + (setq opos pos + pos (position #\/ realname :start (1+ pos))) + + (if* pos + then ; we must go down a directory level + + ; see if we can go down into this subdir + (if* info + then (let ((subdirname (subseq realname (1+ opos) + pos))) + (if* (eq :deny + (check-allow-deny-info subdirname + :subdirectories + info)) + then ; give up right away + (return-from read-access-files + (values nil :forbidden))))) + + + ; we can descend.. remove properties that don't get + ; inherited + (let (remove) + (dolist (inf info) + (if* (null (getf (cdr inf) :inherit)) + then (push inf remove))) + (if* remove + then (dolist (rem remove) + (setq info (remove rem info))))) + else ; no more dirs to check + (return-from read-access-files info))))) + + +(defun read-access-file-contents (filename) + ;; read and return the contents of the access file. + ;; + (handler-case + (with-open-file (p filename) + (with-standard-io-syntax + (let ((*read-eval* nil) ; disable #. and #, + (eof (cons nil nil))) + (let (info) + (loop (let ((inf (read p nil eof))) + (if* (eq eof inf) + then (return)) + (push inf info))) + info)))) + (error (c) + (logmess (format nil + "reading access file ~s resulted in error ~a" + filename c)) + nil))) + + + +(defun file-should-be-denied-p (filename info) + ;; given access info check to see if the given filename + ;; should be denied (not allowed to access) + ;; return t to deny access + ;; + (let (tailfilename) + + (let ((pos (position #\/ filename :from-end t))) + (if* (null pos) + then (setq tailfilename filename) + else (setq tailfilename (subseq filename (1+ pos))))) + + ; :deny only if there are access files present which indicate deny + + (eq :deny (check-allow-deny-info tailfilename :files info)) + + )) + +(defun check-allow-deny (name allow deny) + ;; check to see if the name matches the allow/deny list. + ;; possible answers + ;; :allow - on the allow list and not the deny + ;; :deny - on the deny list + ;; nil - not mentioned on the allow or deny lists + ;; + ;; :allow of nil same as ".*" meaning allow all + ;; :deny of nil matches nothing + ;; + + ; clean up common mistakes in access files + (let (state) + (if* (and allow (atom allow)) + then (setq allow (list allow)) + elseif (and (consp allow) + (eq 'quote (car allow))) + then (setq allow (cadr allow))) + + (if* (and deny (atom deny)) + then (setq deny (list deny)) + elseif (and (consp deny) + (eq 'quote (car deny))) + then (setq deny (cadr deny))) + + (if* allow + then ; must check all allows + (dolist (all allow + ; not explicitly allowed + (setq state nil)) + (if* (match-regexp all name :return nil) + then (setq state :allow) + (return))) + else ; no allow's given, same as giving ".*" so matches all + (setq state :allow)) + + (if* deny + then ; must check all denys + (dolist (ign deny) + (if* (match-regexp ign name :return nil) + then ; matches, not allowed + (return-from check-allow-deny :deny)))) + + state)) + + + +(defun check-allow-deny-info (name key info) + ;; search the info under the given key to see if name is allowed + ;; or denyd. + ;; return :allow or :deny if we found access info in the info + ;; else return nil if we didn't find any applicable access info + (do* ((inflist info (cdr inflist)) + (inf (car inflist) (car inflist)) + (seen-inf) + (state nil)) + ((null inf) + (if* seen-inf + then (if* (null state) + then :deny ; not mentioned as allowed + else state))) + (if* (and (consp inf) (eq key (car inf))) + then (setq seen-inf t) ; actually processed some info + (let ((new-state (check-allow-deny name + (getf (cdr inf) :allow) + (getf (cdr inf) :deny)))) + (case new-state + (:allow (setq state :allow)) + ((nil) ; state unchanged + ) + (:deny (return-from check-allow-deny-info :deny))))))) + + + + + + + + + + + + +(defmethod process-entity ((req http-request) (ent multi-entity)) + ;; send out the contents of the multi + ;; + + ; compute the contents of each item + (let ((fwd) (max-fwd 0) (total-size 0)) + ;; we track max file write date (max-fwd) unless we can't compute + ;; it in which case max-fwd is nil. + + (if* (not (member (request-method req) '(:get :head))) + then ; we don't want to specify a last modified time except for + ; these two methods + (setq max-fwd nil)) + + (dolist (item (items ent)) + (ecase (multi-item-kind item) + (:file + (setq fwd (file-write-date (multi-item-data item))) + (if* (or (null (multi-item-last-modified item)) + (null fwd) + (> fwd (multi-item-last-modified item))) + then ; need to read new contents + (if* (null (errorset + (with-open-file (p (multi-item-data item) + :direction :input + :element-type '(unsigned-byte 8)) + (let* ((size (acl-compat.excl::filesys-size + (stream-input-fn p))) + (contents + (make-array size + :element-type + '(unsigned-byte 8)))) + (read-sequence contents p) + (incf total-size size) + (setf (multi-item-cache item) contents) + (setf (multi-item-last-modified item) fwd) + (if* max-fwd + then (setq max-fwd (max max-fwd fwd))))) + t) + ) + then ; failed to read, give up + (return-from process-entity nil)) + else ; don't need to read, but keep running total + (incf total-size (length + (or (multi-item-cache item) ""))) + (if* max-fwd + then (setq max-fwd + (max max-fwd + (or (multi-item-last-modified item) 0)))))) + (:function + (multiple-value-bind (new-value new-modified) + (funcall (multi-item-data item) + req + ent + (multi-item-last-modified item) + (multi-item-cache item)) + (if* (stringp new-value) + then (setq new-value (string-to-octets new-value + :null-terminate nil))) + (setf (multi-item-cache item) new-value) + (setf (multi-item-last-modified item) new-modified) + (if* (null new-modified) then (setq max-fwd nil)) + (if* (and max-fwd (multi-item-last-modified item)) + then (setf max-fwd (max max-fwd (multi-item-last-modified item)))) + (incf total-size (length (or new-value ""))) + )) + ((:string :binary) + ; a constant thing + (incf total-size (length (multi-item-cache item)))) + )) + + (if* (not (eql (last-modified ent) max-fwd)) + then ; last modified has changed + (setf (last-modified ent) max-fwd) + (if* max-fwd + then (setf (last-modified-string ent) + (universal-time-to-date max-fwd)))) + + (setf (multi-entity-content-length ent) total-size) + + ; now we have all the data + (with-http-response (req ent :format :binary) + (setf (request-reply-content-length req) total-size) + (if* max-fwd + then (setf (reply-header-slot-value req :last-modified) + (last-modified-string ent))) + + (run-entity-hook req ent nil) + (with-http-body (req ent) + (dolist (item (items ent)) + (let ((cache (multi-item-cache item))) + ;; TODO: write-all-vector is defined in cgi.cl; reinstate + ;; it here once cgi.cl is integrated into paserve + (#+allegro write-all-vector + #-allegro write-vector + cache *html-stream* + :end (length cache)))))) + + t ; processed + )) + + + + +(defun up-to-date-check (doit req ent) + ;; if doit is true and the request req has an + ;; if-modified-since or if-unmodified-since then + ;; check if it applies and this resuits in a response + ;; we can return right away then do it and + ;; throw to abort the rest of the body being run + + ; to be done + + (if* (not doit) + then ; we dont' even care + (return-from up-to-date-check nil)) + + (let ((if-modified-since (header-slot-value req :if-modified-since))) + (if* if-modified-since + then (setq if-modified-since + (date-to-universal-time if-modified-since))) + + (if* if-modified-since + then ; valid date, do the check + (if* (and (last-modified ent) + (<= (last-modified ent) if-modified-since)) + then ; send back a message that it is already + ; up to date + (let ((nm-ent *not-modified-entity*)) + (debug-format :info "entity is up to date~%") + ; recompute strategy based on simple 0 length + ; thing to return + (compute-strategy req nm-ent nil) + + (setf (request-reply-code req) *response-not-modified*) + (run-entity-hook req ent :not-modified) + (with-http-body (req nm-ent) + ;; force out the header + ) + (throw 'with-http-response nil) ; and quick exit + ))))) + +(defun keep-alive-possible-p (req) + (and (wserver-enable-keep-alive *wserver*) + #-openmcl-native-threads + (>= (wserver-free-workers *wserver*) 2) + (or (and (eq (request-protocol req) :http/1.1) + (not + (header-value-member "close" + (header-slot-value req :connection)))) + (and (eq (request-protocol req) :http/1.0) + (header-value-member "keep-alive" + (header-slot-value req :connection)))))) + +(defmethod compute-strategy ((req http-request) (ent entity) format) + ;; determine how we'll respond to this request + + (let ((strategy nil) + (keep-alive-possible-p (keep-alive-possible-p req))) + (if* (eq (request-method req) :head) + then ; head commands are particularly easy to reply to + (setq strategy '(:use-socket-stream + :omit-body)) + + (if* keep-alive-possible-p + then (push :keep-alive strategy)) + + elseif (and ;; assert: get command + (wserver-enable-chunking *wserver*) + (eq (request-protocol req) :http/1.1) + (null (content-length ent))) + then ;; http/1.1 so we can chunk + (if* keep-alive-possible-p + then (setq strategy '(:keep-alive :chunked :use-socket-stream)) + else (setq strategy '(:chunked :use-socket-stream))) + else ; can't chunk, let's see if keep alive is requested + (if* keep-alive-possible-p + then ; a keep alive is requested.. + ; we may want reject this if we are running + ; short of processes to handle requests. + ; For now we'll accept it if we can. + + (if* (eq (or format (transfer-mode ent)) :binary) + then ; can't create binary stream string + ; see if we know the content length ahead of time + (if* (content-length ent) + then (setq strategy + '(:keep-alive :use-socket-stream)) + else ; must not keep alive + (setq strategy + '(:use-socket-stream + ; no keep alive + ))) + else ; can build string stream + (setq strategy + '(:string-output-stream + :keep-alive + :post-headers))) + else ; keep alive not requested + (setq strategy '(:use-socket-stream + )))) + + ;; save it + + (debug-format :info "strategy is ~s~%" strategy) + (setf (request-reply-strategy req) strategy) + + )) + + +(defmethod compute-strategy ((req http-request) (ent file-entity) format) + ;; for files we can always use the socket stream and keep alive + ;; since we konw the file length ahead of time + (declare (ignore format)) + (let ((keep-alive-possible-p (keep-alive-possible-p req)) + (strategy)) + + (if* (eq (request-method req) :get) + then (setq strategy (if* keep-alive-possible-p + then '(:use-socket-stream :keep-alive) + else '(:use-socket-stream))) + else (setq strategy (call-next-method))) + + (debug-format :info "file strategy is ~s~%" strategy) + (setf (request-reply-strategy req) strategy))) + + + + + + + + + + +(defmethod send-response-headers ((req http-request) (ent entity) time) + ;; + ;; called twice (from with-http-body) in the generation of a response + ;; to an http request + ;; 1. before the body forms are run. in this case time eq :pre + ;; 2. after the body forms are run. in this case time eq :post + ;; + ;; we send the headers out at the time appropriate to the + ;; strategy. We also deal with a body written to a + ;; string output stream + ;; + + (with-timeout-local (60 (logmess "timeout during header send") + ;;(setf (request-reply-keep-alive req) nil) + (throw 'with-http-response nil)) + (with-standard-io-syntax + (let* ((sock (request-socket req)) + (strategy (request-reply-strategy req)) + (extra-headers (request-reply-headers req)) + (post-headers (member :post-headers strategy :test #'eq)) + (content) + (chunked-p (member :chunked strategy :test #'eq)) + (code (request-reply-code req)) + (send-headers + (if* post-headers + then (eq time :post) + else (eq time :pre)) + ) + (sos-ef) ; string output stream external format + ) + + + + (if* send-headers + then (format-dif :xmit sock "~a ~d ~a~a" + (request-reply-protocol-string req) + (response-number code) + (response-desc code) + *crlf*)) + + (if* (and post-headers + (eq time :post) + (member :string-output-stream strategy :test #'eq) + ) + then ; must get data to send from the string output stream + (setq content + (if* (request-reply-stream req) + then (setq sos-ef (stream-external-format + (request-reply-stream req))) + (get-output-stream-string + (request-reply-stream req)) + + else ; no stream created since no body given + "")) + + (if* (and sos-ef (not (eq (stream-external-format sock) sos-ef))) + then ; must do ext format conversion now + ; so we can compute the length + (setq content + (string-to-octets content :external-format sos-ef))) + + (setf (request-reply-content-length req) (length content))) + + (if* (and send-headers + (not (eq (request-protocol req) :http/0.9))) + then ; can put out headers + (format-dif :xmit sock "Date: ~a~a" + (maybe-universal-time-to-date (request-reply-date req)) + *crlf*) + + (if* (member :keep-alive strategy :test #'eq) + then (format-dif :xmit + sock "Connection: Keep-Alive~aKeep-Alive: timeout=~d~a" + *crlf* + *read-request-timeout* + *crlf*) + else (format-dif :xmit sock "Connection: Close~a" *crlf*)) + + (if* (not (assoc :server extra-headers :test #'eq)) + then ; put out default server info + (format-dif :xmit sock "Server: AllegroServe/~a~a" + *aserve-version-string* + *crlf*)) + + (if* (request-reply-content-type req) + then (format-dif :xmit + sock "Content-Type: ~a~a" + (request-reply-content-type req) + *crlf*)) + + (if* chunked-p + then (format-dif :xmit + sock "Transfer-Encoding: chunked~a" + *crlf*)) + + (if* (and (not chunked-p) + (request-reply-content-length req)) + then (format-dif :xmit sock "Content-Length: ~d~a" + (request-reply-content-length req) + *crlf*) + (debug-format :info + "~d ~s - ~d bytes~%" + (response-number code) + (response-desc code) + (request-reply-content-length req)) + elseif chunked-p + then (debug-format :info "~d ~s - chunked~%" + (response-number code) + (response-desc code) + ) + else (debug-format :info + "~d ~s - unknown length~%" + (response-number code) + (response-desc code) + )) + + (dolist (head (request-reply-headers req)) + (format-dif :xmit sock "~a: ~a~a" + (car head) + (cdr head) + *crlf*)) + (format-dif :xmit sock "~a" *crlf*) + + (force-output sock) + ; clear bytes written count so we can count data bytes + ; transferred + #+(and allegro (version>= 6)) + (excl::socket-bytes-written sock 0) + ) + + (if* (and send-headers chunked-p (eq time :pre)) + then (force-output sock) + (acl-compat.socket:socket-control sock :output-chunking t)) + + + ; if we did post-headers then there's a string input + ; stream to dump out. + (if* content + then (write-sequence content sock)) + + ;; if we're chunking then shut that off + (if* (and chunked-p (eq time :post)) + then (acl-compat.socket:socket-control sock :output-chunking-eof t) + ; in acl5.0.1 the output chunking eof didn't send + ; the final crlf, so we do it here + #+(and allegro (not (version>= 6))) + (write-sequence *crlf* sock) + ) + )))) + + + +(defmethod compute-response-stream ((req http-request) (ent file-entity)) + ;; send directly to the socket since we already know the length + ;; + (setf (request-reply-stream req) (request-socket req))) + +(defmethod compute-response-stream ((req http-request) (ent entity)) + ;; may have to build a string-output-stream + (if* (member :string-output-stream (request-reply-strategy req) :test #'eq) + then (setf (request-reply-stream req) (make-string-output-stream)) + else (setf (request-reply-stream req) (request-socket req)))) + +(defmethod compute-response-stream ((req http-request) (ent multi-entity)) + ;; send directly to the socket since we already know the length + ;; + (setf (request-reply-stream req) (request-socket req))) + +(defvar *far-in-the-future* + (encode-universal-time 12 32 12 11 8 2020 0)) + +(defmethod set-cookie-header ((req http-request) + &key name value expires domain + (path "/") + secure + (external-format + *default-aserve-external-format*) + (encode-value t) + ) + ;; put a set cookie header in the list of header to be sent as + ;; a response to this request. + ;; name and value are required, they should be strings + ;; name and value will be urlencoded. + ;; If expires is nil (the default) then this cookie will expire + ;; when the browser exits. + ;; If expires is :never then we'll sent a date so far into the future + ;; that this software is irrelevant + ;; domain and path if given should be strings. + ;; domain must have at least two periods (i.e. us ".franz.com" rather + ;; than "franz.com".... as netscape why this is important + ;; secure is either true or false + ;; + (let (res) + + (setq res + (concatenate 'string + (uriencode-string (string name) :external-format external-format) + "=" + (if* encode-value + then (uriencode-string (string value) + :external-format external-format) + else ; use value unencoded + (string value)))) + + (if* expires + then (if* (eq expires :never) + then (setq expires *far-in-the-future*)) + (if* (integerp expires) + then (setq res (concatenate 'string + res + "; expires=" + (universal-time-to-date expires))) + else (error "bad expiration date: ~s" expires))) + + (if* domain + then (setq res (concatenate 'string + res + "; domain=" + (string domain)))) + + (if* path + then (setq res (concatenate 'string + res + "; path=" + (string path)))) + + (if* secure + then (setq res (concatenate 'string + res + "; secure"))) + + (push `(:set-cookie . ,res) (request-reply-headers req)) + res)) + + +(defun get-cookie-values (req &key (external-format + *default-aserve-external-format*)) + ;; return the set of cookie name value pairs from the current + ;; request as conses (name . value) + ;; + (let ((cookie-string (header-slot-value req :cookie))) + (if* (and cookie-string (not (equal "" cookie-string))) + then ; form is cookie: name=val; name2=val2; name2=val3 + ; which is not exactly the format we want to see it in + ; to parse it. we want + ; cookie: foo; name=val; name=val + ; we we'll dummy up something that we want to see. + ; maybe later we'll have a parser for this form too + ; + (let ((res (parse-header-value + (concatenate 'string "foo; " cookie-string)))) + ; res should be: ((:param "foo" ("baz" . "bof"))) + (if* (and (consp res) + (consp (car res)) + (eq :param (caar res))) + then ; the correct format, must decode pieces + (mapcar #'(lambda (ent) + ; sometimes a param isn't name2=val2; + ; but is simply name2;. pretend it + ; was name2=; + (if* (atom ent) + then (setq ent (cons ent ""))) + (cons + (uridecode-string + (car ent) :external-format external-format) + (uridecode-string + (cdr ent) + :external-format external-format))) + (cddr (car res)))))))) + + +;----------- + +(defmethod timedout-response ((req http-request) (ent entity)) + ;; return a response to a web server indicating that it is taking + ;; too long for us to respond + ;; + (setf (request-reply-code req) *response-internal-server-error*) + (with-http-body (req ent) + (html (:title "Internal Server Error") + (:body "500 - The server has taken too long to respond to the request")))) + + + + + +;;;;;;;;;;;;;;; setup things + +(if* (not (boundp '*wserver*)) + then ; create initial wserver object + (setq *wserver* (make-instance 'wserver))) + + + + + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/test/.csvignore =================================================================== --- vendor/portableaserve/aserve/test/.csvignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/.csvignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,16 @@ +*.wfasl +*.ufsl +*.fasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/test/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,4 @@ +/.csvignore/1.1/Mon Feb 9 14:11:02 2004// +/server.pem/1.1/Thu Aug 30 09:16:05 2001// +/t-aserve.cl/1.8/Tue Feb 17 12:48:44 2004// +D Added: vendor/portableaserve/aserve/test/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/test/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +A D/testdir//// Added: vendor/portableaserve/aserve/test/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test Added: vendor/portableaserve/aserve/test/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/server.pem =================================================================== --- vendor/portableaserve/aserve/test/server.pem 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/server.pem 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,82 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: 2 (0x2) + Signature Algorithm: md5WithRSAEncryption + Issuer: C=US, ST=California, L=Berkeley, O=Franz Inc, CN=Franz Inc CA cert/Email=sa(a)franz.com + Validity + Not Before: Oct 16 21:40:00 2000 GMT + Not After : Oct 16 21:40:00 2001 GMT + Subject: C=US, ST=California, L=Berkeley, O=Franz Inc, OU=Samples, CN=sample.franz.com/Email=info@franz.com + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + RSA Public Key: (1024 bit) + Modulus (1024 bit): + 00:c0:14:51:1f:d5:c4:ab:53:1f:d0:f3:b2:7a:2c: + f6:98:d3:e5:4b:44:21:41:7c:d1:55:af:e7:ff:08: + c2:d4:93:fd:86:5c:87:5d:19:29:37:5b:be:f0:2c: + 96:2b:bf:d6:4f:df:c4:23:d3:5d:02:6d:d1:fd:83: + 7b:36:1b:bb:05:c9:9d:c0:1f:7d:e2:c8:05:33:86: + 7e:47:cb:d1:83:b8:34:06:b6:e8:31:37:7c:23:64: + 06:db:7c:71:98:89:19:d8:de:de:50:83:e6:e9:26: + e1:b4:bb:40:20:26:20:7f:eb:3f:7b:61:9e:06:89: + f7:15:59:1c:84:36:e9:0e:6b + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Basic Constraints: + CA:FALSE + Netscape Comment: + OpenSSL Generated Certificate + X509v3 Subject Key Identifier: + 7B:21:5D:77:D7:77:42:25:1E:8D:47:04:02:89:EA:3C:B6:69:8E:7B + X509v3 Authority Key Identifier: + keyid:DC:24:F0:CB:42:F1:CB:B8:08:72:29:07:75:7F:DD:00:26:76:9E:67 + DirName:/C=US/ST=California/L=Berkeley/O=Franz Inc/CN=Franz Inc CA cert/Email=sa(a)franz.com + serial:00 + + Signature Algorithm: md5WithRSAEncryption + 71:e0:c2:16:0b:4a:85:b3:a3:e5:25:be:0c:6b:47:e2:78:af: + 57:11:33:be:7c:1f:06:96:c1:5c:4e:3d:29:25:a2:cb:23:af: + 4b:94:ad:1a:b5:56:a6:48:d8:3d:79:99:30:25:57:cd:63:e7: + f9:da:32:85:20:9c:0b:e6:9d:bf:16:ce:02:d2:94:6f:93:d8: + 62:25:37:61:ea:ba:ca:6c:19:10:29:b6:22:7a:32:ce:f8:ea: + 8d:14:af:61:6f:f0:cf:af:32:9c:be:6b:e1:89:87:fb:dc:2b: + ad:2d:6b:e9:4f:a5:5a:d9:24:43:31:e1:1b:53:fa:e2:f9:3a: + c4:b3 +-----BEGIN CERTIFICATE----- +MIIDnzCCAwigAwIBAgIBAjANBgkqhkiG9w0BAQQFADCBgjELMAkGA1UEBhMCVVMx +EzARBgNVBAgTCkNhbGlmb3JuaWExETAPBgNVBAcTCEJlcmtlbGV5MRIwEAYDVQQK +EwlGcmFueiBJbmMxGjAYBgNVBAMTEUZyYW56IEluYyBDQSBjZXJ0MRswGQYJKoZI +hvcNAQkBFgxzYUBmcmFuei5jb20wHhcNMDAxMDE2MjE0MDAwWhcNMDExMDE2MjE0 +MDAwWjCBlTELMAkGA1UEBhMCVVMxEzARBgNVBAgTCkNhbGlmb3JuaWExETAPBgNV +BAcTCEJlcmtlbGV5MRIwEAYDVQQKEwlGcmFueiBJbmMxEDAOBgNVBAsTB1NhbXBs +ZXMxGTAXBgNVBAMTEHNhbXBsZS5mcmFuei5jb20xHTAbBgkqhkiG9w0BCQEWDmlu +Zm9AZnJhbnouY29tMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDAFFEf1cSr +Ux/Q87J6LPaY0+VLRCFBfNFVr+f/CMLUk/2GXIddGSk3W77wLJYrv9ZP38Qj010C +bdH9g3s2G7sFyZ3AH33iyAUzhn5Hy9GDuDQGtugxN3wjZAbbfHGYiRnY3t5Qg+bp +JuG0u0AgJiB/6z97YZ4GifcVWRyENukOawIDAQABo4IBDjCCAQowCQYDVR0TBAIw +ADAsBglghkgBhvhCAQ0EHxYdT3BlblNTTCBHZW5lcmF0ZWQgQ2VydGlmaWNhdGUw +HQYDVR0OBBYEFHshXXfXd0IlHo1HBAKJ6jy2aY57MIGvBgNVHSMEgacwgaSAFNwk +8MtC8cu4CHIpB3V/3QAmdp5noYGIpIGFMIGCMQswCQYDVQQGEwJVUzETMBEGA1UE +CBMKQ2FsaWZvcm5pYTERMA8GA1UEBxMIQmVya2VsZXkxEjAQBgNVBAoTCUZyYW56 +IEluYzEaMBgGA1UEAxMRRnJhbnogSW5jIENBIGNlcnQxGzAZBgkqhkiG9w0BCQEW +DHNhQGZyYW56LmNvbYIBADANBgkqhkiG9w0BAQQFAAOBgQBx4MIWC0qFs6PlJb4M +a0fieK9XETO+fB8GlsFcTj0pJaLLI69LlK0atVamSNg9eZkwJVfNY+f52jKFIJwL +5p2/Fs4C0pRvk9hiJTdh6rrKbBkQKbYiejLO+OqNFK9hb/DPrzKcvmvhiYf73Cut +LWvpT6Va2SRDMeEbU/ri+TrEsw== +-----END CERTIFICATE----- +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQDAFFEf1cSrUx/Q87J6LPaY0+VLRCFBfNFVr+f/CMLUk/2GXIdd +GSk3W77wLJYrv9ZP38Qj010CbdH9g3s2G7sFyZ3AH33iyAUzhn5Hy9GDuDQGtugx +N3wjZAbbfHGYiRnY3t5Qg+bpJuG0u0AgJiB/6z97YZ4GifcVWRyENukOawIDAQAB +AoGAGIB++LikJdassFLl6X/i1Qvyq+887sWlTnDp/zZ24/cc2A7llZKoF0+0w55s +aZhHFllNA+TqcGzh5JzpErXm3VUE5BBYRp2o7z9BvGsnwbZcEB+JXuQxiMWb5eZ+ +TvledVJeCMZeMchY6a6ROjiPuQ1OVW5Ep1VmD5Q0fm8qsQECQQD+p+6HHhDIvEM9 +LJA1UiI+rTJH3ziOB7jTfXU+CC9M3Cvxk+KQKPZfeScQEK48BVG0t8d0mI6MPnfa +htl2qYkRAkEAwRfWVZugVIzkRtbfH80iVB0L7t3nV91b5GumWrM59v3G3n1JzkrO +E8InCiWfLiZmZ0yUbZHp15WtGoJ6YOr/uwJAbdYq2JaMMLia28jbzlPFt3jmhf9u +mjwUaQvkxMOs+x6/yWu6vekdEuLjiVdYf0TgD+1wlwax/SV4doXRSBApsQJAW6a3 +2myC/n7df25P++U/TRN4bYmwXDk6e8JI9LYrZjvwn/xyAtPo2uIF68ANvTcG1jM4 +JIXkq6pkvrd95PDGLwJBAJZNLyK4IQ4uTAegAAjGd5eQr1rpPT5k3kw6lBOyUJgw +u0h5fqY84KtggD544uScxEeWZZe/VlYsYVAS64HHB+s= +-----END RSA PRIVATE KEY----- Added: vendor/portableaserve/aserve/test/t-aserve.cl =================================================================== --- vendor/portableaserve/aserve/test/t-aserve.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/t-aserve.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1792 @@ +;; -*- mode: common-lisp; package: net.aserve.test -*- +;; +;; t-aserve.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: t-aserve.cl,v 1.8 2004/02/17 12:48:44 rudi Exp $ + +;; Description: +;; test iserve + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +#+allegro +(eval-when (compile load eval) + (require :tester)) + +;;; Get Kevin Rosenberg's port of Franz tester at +;;; http://files.b9.com/ptester/ +#-allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:oos 'asdf:load-op :ptester) + (rename-package (find-package :ptester) :ptester '(:util.test))) + +(defpackage :net.aserve.test + (:use :common-lisp :acl-compat.excl :net.html.generator :net.aserve + :net.aserve.client + :util.test) + ) + +(in-package :net.aserve.test) + +; set to nil before loading the test to prevent the test from auto-running +(defvar common-lisp-user::*do-aserve-test* t) +(defvar *x-proxy* nil) ; when true x-do-http-request will go through a proxy +(defvar *x-ssl* nil) ; true when we want to do ssl client calls +(defvar *proxy-wserver* nil) + +; if true run timeout test +(defvar *test-timeouts* nil) + +; stack of old values +(defvar *save-x-proxy* nil) +(defvar *save-proxy-wserver* nil) + +; remember where we were loaded from so we can run manually +(defparameter *aserve-load-truename* *load-truename*) + +(defun test-aserve (test-timeouts) + ;; run the allegroserve tests three ways: + ;; 1. normally + ; 2. through an allegroserve proxy to test the proxy + ;; 3. through ssl (if ssl module present) + ;; + ;; tests are run on a variety of threads, so we have to + ;; account for those other thread errors separately. + (setq util.test::*test-errors* 0 + util.test::*test-successes* 0 + util.test::*test-unexpected-failures* 0) + (with-tests (:name "aserve") + (let* ((*wserver* *wserver*) + (port (start-aserve-running))) + (format t "server started on port ~d~%" port) + (unwind-protect + (flet ((do-tests () + (test-publish-file port) + (test-publish-directory port) + (test-publish-computed port) + (test-publish-multi port) + (test-publish-prefix port) + (test-authorization port) + (test-encoding) + (test-forms port) + (test-client port) + (test-cgi port) + (if* (member :ics *features*) + then (test-international port) + (test-spr27296)) + (if* test-timeouts + then (test-timeouts port)) + )) + (format t "~%~%===== test direct ~%~%") + (do-tests) + + (format t "~%~%===== test through proxy ~%~%") + (start-proxy-running) + (do-tests) + + (format t "~%~%===== test through proxy to proxy~%~%") + (start-proxy-running) + (do-tests) + + (format t "~%>> checking to see if ssl is present~%~%") + (if* (errorset (require :ssl)) + then ; we have ssl capability, run tests through ssl + (stop-proxy-running) + (stop-proxy-running) + (stop-aserve-running) + (format t "~%~%===== test through ssl ~%~%") + (setq port (start-aserve-running + (merge-pathnames + "server.pem" *aserve-load-truename*))) + (do-tests) + else (format t "~%>> it isn't so ssl tests skipped~%~%"))) + ; cleanup forms: + (stop-aserve-running) + (stop-proxy-running) + (stop-proxy-running) + ))) + (if* (or (> util.test::*test-errors* 0) + (> util.test::*test-successes* 0) + (> util.test::*test-unexpected-failures* 0)) + then (format t "~%Test information from other threads:~%") + (format t "Errors: ~d~%" util.test::*test-errors*) + (format t "Successes: ~d~%~%" util.test::*test-successes*) + (format t "Unexpected failures: ~d~%" + util.test::*test-unexpected-failures*))) + + + +(defun start-aserve-running (&optional ssl) + ;; start aserve, return the port on which we've started aserve + (let ((wserver (start :port nil :server :new :ssl ssl))); let the system pick a port + (setq *wserver* wserver) + (unpublish :all t) ; flush anything published + (setq *x-ssl* ssl) + (socket::local-port (net.aserve::wserver-socket wserver)) + )) + +(defun stop-aserve-running () + (shutdown)) + + +(defun start-proxy-running () + ;; start another web server to be the proxy + (push *proxy-wserver* *save-proxy-wserver*) + + (setq *proxy-wserver* (start :server :new + :port nil + :proxy t + :proxy-proxy *x-proxy*)) + + (push *x-proxy* *save-x-proxy*) + (setq *x-proxy* (format nil "localhost:~d" + (socket:local-port + (wserver-socket *proxy-wserver*)))) + ) + + +(defun stop-proxy-running () + (if* *proxy-wserver* + then (shutdown :server *proxy-wserver*) + (setq *proxy-wserver* (pop *save-proxy-wserver*))) + (setq *x-proxy* (pop *save-x-proxy*))) + + + + + + +(defun x-do-http-request (uri &rest args) + ;; add a proxy arg + (apply #'do-http-request uri :proxy *x-proxy* :ssl *x-ssl* args)) + + + +(defmacro values2 (form) + ;; return the second value + (let ((v1 (gensym)) + (v2 (gensym))) + `(multiple-value-bind (,v1 ,v2) ,form + (declare (ignore ,v1)) + ,v2))) + +;-------- publish-file tests + +(defvar *dummy-file-value* nil) +(defvar *dummy-file-name* "aservetest.xx") + +(defun build-dummy-file (length line-length name) + ;; write a dummy file named name (if name isn't nil) + ;; of a given length with spaces every line-length characters + ;; Return the string holding the contents of the file. + (let ((strp (make-string-output-stream)) + (result)) + (dotimes (i length) + (write-char (code-char (+ #.(char-code #\a) (mod i 26))) strp) + (if* (zerop (mod (1+ i) line-length)) + then ; newlines cause a problem due to dos/unix differences. + ; so let's just use space + (write-char #\space strp))) + (setq result (get-output-stream-string strp)) + (if* name + then (with-open-file (p name :direction :output + :if-exists :supersede) + (write-sequence result p))) + + result)) + + +(defun test-publish-file (port) + (let (dummy-1-contents + (dummy-1-name "xxaservetest.txt") + dummy-2-contents + (dummy-2-name "xx2aservetest.txt") + (prefix-local (format nil "http://localhost:~a" port)) + (prefix-dns + ;; KLUDGE: Don't assume that long-site-name returns a valid + ;; hostname -- punt instead. + #-allegro + (format nil "http://localhost:~a" port) + #+allegro + (format nil "http://~a:~a" + (long-site-name) + port)) + (reps 0) + (got-reps nil)) + + (setq dummy-1-contents (build-dummy-file 8055 70 dummy-1-name)) + + + ;; basic publish file test + ;; + ;; publish a file and retrieve it. + ;; the result will be the same since given that we know the + ;; length of the file, chunking won't be needed + ;; + (let ((ent (publish-file :path "/frob" :file dummy-1-name + :content-type "text/plain" + :cache-p t + :hook #'(lambda (req ent extra) + (declare (ignore req ent extra)) + (setq got-reps (or got-reps 0)) + (incf got-reps)) + :headers '((:testhead . "testval")) + ))) + (test nil (net.aserve::contents ent)) ; nothing cached yet + + ;; + (dolist (cur-prefix (list prefix-local prefix-dns)) + (dolist (keep-alive '(nil t)) + (dolist (protocol '(:http/1.0 :http/1.1)) + (format t "test 1 - ~s~%" (list keep-alive protocol)) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/frob" cur-prefix) + :protocol protocol + :keep-alive keep-alive) + (incf reps) + (test 200 code) + (test (format nil "text/plain") + (cdr (assoc :content-type headers :test #'eq)) + :test #'equal) + + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) + + #+ignore (if* (eq protocol :http/1.1) + then (test "chunked" + (cdr (assoc :transfer-encoding headers + :test #'eq)) + :test #'equalp)) + (test dummy-1-contents body :test #'equal))))) + + ;; stuff should be cached by now + (test t (not (null (net.aserve::contents ent)))) + ) + + (test reps got-reps) ; verify hook function worked + + (setq dummy-2-contents (build-dummy-file 8055 65 dummy-2-name)) + + + ;; preload publish file test + ;; + ;; publish a file and retrieve it. + ;; ** Preload this time ** + ;; + ;; the result will be the same since given that we know the + ;; length of the file, chunking won't be needed + ;; + (publish-file :path "/frob2" :file dummy-2-name + :content-type "text/plain" + :preload t + :headers '((:testhead . "testval")) + ) + + ;; publish with no preload and no cache + (publish-file :path "/frob2-npl" :file dummy-2-name + :content-type "text/plain" + :preload nil) + + + ;; + (dolist (cur-prefix (list prefix-local prefix-dns)) + (dolist (keep-alive '(nil t)) + (dolist (protocol '(:http/1.0 :http/1.1)) + (format t "test 2 - ~s~%" (list keep-alive protocol)) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/frob2" cur-prefix) + :protocol protocol + :keep-alive keep-alive) + (test 200 code) + (test (format nil "text/plain") + (cdr (assoc :content-type headers :test #'eq)) + :test #'equal) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) + #+ignore (if* (eq protocol :http/1.1) + then (test "chunked" + (cdr (assoc :transfer-encoding headers + :test #'eq)) + :test #'equalp)) + (test dummy-2-contents body :test #'equal)) + + ; try partial gets + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/frob2-npl" cur-prefix) + :protocol protocol + :keep-alive keep-alive + :headers '((:range . "bytes=100-400")) + ) + (test 206 code) + (test "text/plain" + (cdr (assoc :content-type headers :test #'eq)) + :test #'equal) + (test (subseq dummy-2-contents 100 401) + body :test #'equal) + + (test "bytes 100-400/8178" + (cdr (assoc :content-range headers :test #'eq)) + :test #'equal) + + ) + ))) + + + ;;;; remove published file test + ;; + ; verify it's still there + (test 200 (values2 (x-do-http-request (format nil "~a/frob" prefix-local)))) + (test 200 (values2 (x-do-http-request (format nil "~a/frob" prefix-dns)))) + + ; check that skip-body works + (test nil (values (x-do-http-request (format nil "~a/frob" prefix-local) + :skip-body t))) + + ; remove it + (publish-file :path "/frob" :remove t) + + ; verify that it's not there: + (test 404 (values2 (x-do-http-request (format nil "~a/frob" prefix-local)))) + (test 404 (values2 (x-do-http-request (format nil "~a/frob" prefix-dns)))) + + ;; likewise for frob2 + + ; verify it's still there + (test 200 (values2 (x-do-http-request (format nil "~a/frob2" prefix-local)))) + (test 200 (values2 (x-do-http-request (format nil "~a/frob2" prefix-dns)))) + + ; remove it + (publish-file :path "/frob2" :remove t) + + ; verify that it's not there: + (test 404 (values2 (x-do-http-request (format nil "~a/frob2" prefix-local)))) + (test 404 (values2 (x-do-http-request (format nil "~a/frob2" prefix-dns)))) + + + + + ;; now add different files for localhost and the dns names + ;; and verify that we get served different files based on + ;; the virtual host we choose + (publish-file :path "/checkit" + :host "localhost" + :file dummy-1-name + :content-type "text/plain") + + (publish-file :path "/checkit" + :host (long-site-name) + :file dummy-2-name + :content-type "text/plain") + + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/checkit" prefix-local)) + (declare (ignore headers)) + (test 200 (and :df-test code)) + (test dummy-1-contents body :test #'equal)) + + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/checkit" prefix-dns)) + (declare (ignore headers)) + (test 200 (and :df-test code)) + (test dummy-2-contents body :test #'equal)) + + ;; remove the localhost one + (publish-file :path "/checkit" + :host "localhost" + :remove t) + ; verify it's gone: + (test 404 (values2 (x-do-http-request (format nil "~a/checkit" + prefix-local)))) + ; but the the dns one is still there + (test 200 (values2 (x-do-http-request (format nil "~a/checkit" prefix-dns)))) + + ; remove the dns one + (publish-file :path "/checkit" + :host (long-site-name) + :remove t) + + ; verify it's gone too + (test 404 (values2 (x-do-http-request (format nil "~a/checkit" + prefix-dns)))) + + + + + (setq dummy-1-contents (build-dummy-file 432 23 dummy-1-name)) + + ; test caching and auto uncaching and recaching + (let ((ent (publish-file :path "/check-uncache" + :file dummy-1-name + :cache-p t))) + + ; verify nothing cached right now + (test nil (and :second (net.aserve::contents ent))) + + (let ((body2 (x-do-http-request (format nil "~a/check-uncache" + prefix-local)))) + + ; verify result was correct + (test dummy-1-contents body2 :test #'equal) + + ; verify that something's cached. + (test t (not (null (and :second (net.aserve::contents ent))))) + + ; overwrite dummy file with new contents + (sleep 2) ; pause to get file write date to noticably advance + (setq dummy-1-contents (build-dummy-file 555 44 dummy-1-name)) + + ; verify that the contents are in fact different + (test nil (equal dummy-1-contents body2)) + + ; now do the same request.. but we should get new things back + ; since the last modified time of the file + (setq body2 + (x-do-http-request (format nil "~a/check-uncache" prefix-local))) + ; verify that we did get the new stuff back. + + (test t (equal dummy-1-contents body2)))) + + ; rewrite file with different contents + + + + + ; cleanup + (delete-file dummy-1-name) + (delete-file dummy-2-name) + )) + + + + +(defun test-publish-computed (port) + ;; test publishing computed entities + (let ((dummy-1-content (build-dummy-file 0 50 nil)) + (dummy-2-content (build-dummy-file 1 50 nil)) + (dummy-3-content (build-dummy-file 100 50 nil)) + (dummy-4-content (build-dummy-file 1000 50 nil)) + (dummy-5-content (build-dummy-file 10000 50 nil)) + (dummy-6-content (build-dummy-file 100000 50 nil)) + + (prefix-local (format nil "http://localhost:~a" port)) + ) + + ;; + ;; publish strings of various sizes using various protocols + ;; verify that chunking is turned on when we select http/1.1 + ;; + (dolist (pair `(("/dum1" ,dummy-1-content) + ("/dum2" ,dummy-2-content) + ("/dum3" ,dummy-3-content) + ("/dum4" ,dummy-4-content) + ("/dum5" ,dummy-5-content) + ("/dum6" ,dummy-6-content))) + + (let ((this (cadr pair))) + ;; to make a separate binding for each function + (publish :path (car pair) + :content-type "text/plain" + :headers '((:testhead . "testval")) + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (write-sequence this *html-stream*)))))) + (dolist (keep-alive '(nil t)) + (dolist (protocol '(:http/1.0 :http/1.1)) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a~a" prefix-local (car pair)) + :protocol protocol + :keep-alive keep-alive) + (test 200 code) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) + (test (format nil "text/plain" port) + (cdr (assoc :content-type headers :test #'eq)) + :test #'equal) + (if* (and (eq protocol :http/1.1) + (null *x-proxy*) + (null *x-ssl*) + ) + then (test "chunked" + (cdr (assoc :transfer-encoding headers + :test #'eq)) + :test #'equalp)) + (test (cadr pair) body :test #'equal))))) + + + ;; test whether we can read urls with space in them + (publish :path "/foo bar baz" + :content-type "text/plain" + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (write-sequence "foo" *html-stream*))))) + (multiple-value-bind (body code) + (x-do-http-request (format nil "~a/foo%20bar%20baz" prefix-local)) + (test 200 code) + (test "foo" body :test #'equal)) + + + ;; test we can send non-standard headers back and forth + + (publish :path "/unusual-headers" + :content-type "text/plain" + :function + #'(lambda (req ent) + + (test "booboo" (header-slot-value req :frobfrob) + :test #'equal) + (with-http-response (req ent) + (setf (reply-header-slot-value req :snortsnort) + "zipzip") + (with-http-body (req ent) + (html "foo the bar"))))) + + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/unusual-headers" prefix-local) + :headers '(("frobfrob" . "booboo"))) + (declare (ignore body)) + + (test 200 code) + (test "zipzip" (cdr (assoc "snortsnort" headers :test #'equalp)) + :test #'equal)) + + + )) + + +(defun test-authorization (port) + (let ((prefix-local (format nil "http://localhost:~a" port)) + (prefix-dns (format nil "http://~a:~a" + (long-site-name) port))) + + ;; manual authorization testing + ;; basic authorization + ;; + (publish :path "/secret" + :content-type "text/html" + :function + #'(lambda (req ent) + (multiple-value-bind (name password) (get-basic-authorization req) + (if* (and (equal name "foo") (equal password "bar")) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))) + else + (with-http-response (req ent :response + *response-unauthorized*) + (set-basic-authorization req + "secretserver") + (with-http-body (req ent))))))) + + ; no dice with no password + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/secret" prefix-local)) + (declare (ignore body)) + (test 401 code) + ; verify that we are asking for the right realm + (test "Basic realm=\"secretserver\"" + (cdr (assoc :www-authenticate headers :test #'eq)) + :test #'equal)) + + + ; good password + (test 200 + (values2 (x-do-http-request (format nil "~a/secret" prefix-local) + :basic-authorization '("foo" . "bar")))) + + ; bad password + (test 401 + (values2 (x-do-http-request (format nil "~a/secret" prefix-local) + :basic-authorization '("xxfoo" . "bar")))) + + + + + ;; manual authorization testing, testing via ip address + + (publish :path "/local-secret" + ;; this only "works" if we reference via localhost + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((net-address (ash (socket:remote-host + (request-socket req)) + -24))) + (if* (equal net-address 127) + then (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body (:b "Congratulations. ") + "You are on the local network")))) + else (failed-request req))))) + + (test 200 + (values2 (x-do-http-request (format nil "~a/local-secret" + prefix-local)))) + + (test 404 + (values2 (x-do-http-request (format nil "~a/local-secret" + prefix-dns)))) + + + ;; + ;; password authorizer class + ;; + (publish :path "/secret-auth" + :content-type "text/html" + :authorizer (make-instance 'password-authorizer + :allowed '(("foo2" . "bar2") + ("foo3" . "bar3") + ) + :realm "SecretAuth") + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))))) + + (multiple-value-bind (body ccode headers) + (x-do-http-request (format nil "~a/secret-auth" prefix-local)) + (declare (ignore body)) + (test 401 ccode) + (test "Basic realm=\"SecretAuth\"" + (cdr (assoc :www-authenticate headers :test #'eq)) + :test #'equal)) + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-auth" prefix-local) + :basic-authorization '("foo2" . "bar2")))) + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-auth" prefix-local) + :basic-authorization '("foo3" . "bar3")))) + + (test 401 + (values2 (x-do-http-request (format nil "~a/secret-auth" prefix-local) + :basic-authorization '("foo4" . "bar4")))) + + + ;; + ;; location authorizers + ;; + (let ((loca (make-instance 'location-authorizer + :patterns nil))) + (publish :path "/secret-loc-auth" + :content-type "text/html" + :authorizer loca + :function + #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Secret page")) + (:body "You made it to the secret page")))))) + + ;; with a nil pattern list this should accept connections + ;; from anywhere + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + ; now deny all + (setf (location-authorizer-patterns loca) '(:deny)) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + + ;; accept from localhost only + (setf (location-authorizer-patterns loca) + '((:accept "127.0" 8) + :deny)) + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + ;; accept from dns name only + + (setf (location-authorizer-patterns loca) + `((:accept ,(long-site-name)) + :deny)) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + + ;; deny dns and accept all others + (setf (location-authorizer-patterns loca) + `((:deny ,(long-site-name)) + :accept)) + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + + ;; deny localhost and accept all others + (setf (location-authorizer-patterns loca) + '((:deny "127.0" 8) + :accept)) + + (test 404 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-local)))) + + (test 200 + (values2 (x-do-http-request (format nil "~a/secret-loc-auth" + prefix-dns)))) + + + + ;; function authorizer + (let ((funa (make-instance 'function-authorizer + :function #'(lambda (req ent auth) + (declare (ignore ent auth)) + ;; authorized if the uri + ;; has a 'foo' in it + (if* (search "foo" + (puri:uri-path + (request-uri req))) + then t + else :deny))))) + (publish :path "/func-auth-foo" + :content-type "text/html" + :authorizer funa + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "foo"))))) + (publish :path "/func-auth-foo" + :content-type "text/html" + :authorizer funa + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "foo"))))) + + (test 200 (values2 + (x-do-http-request (format nil "~a/func-auth-foo" + prefix-local)))) + (test 404 (values2 + (x-do-http-request (format nil "~a/func-auth-bar" + prefix-local)))) + + )))) + + +(defun test-encoding () + ;; test the encoding and decoding + (let ((str1 (make-string 256)) + (str2 (make-string 256))) + (dotimes (i 256) + (setf (schar str1 i) (code-char i)) + (setf (schar str2 i) (code-char (mod (+ i 10) 256)))) + + (let ((query `(("foo bar" . "baz") + (,str1 . "a b c d") + ("efffg" . ,str2)))) + (test (form-urlencoded-to-query + (query-to-form-urlencoded query :external-format :latin1-base) + :external-format :latin1-base) + query + :test #'equal))) + #+(and allegro ics (version>= 6 0)) + (let* ((str1 (coerce '(#\hiragana_letter_a #\hiragana_letter_i + #\hiragana_letter_u) + 'string)) + (str2 (coerce '(#\katakana_letter_a #\katakana_letter_i + #\katakana_letter_u) + 'string)) + (query `(("bazzer" . ,str1) + (,str2 . "berry")))) + (dolist (ef (list (find-external-format :utf8) + (find-external-format :shiftjis) + ;; 6.0 beta didn't have an ef for unicode. + (if* (find-external-format :unicode :errorp nil) + thenret + else (find-external-format :utf8)) + (find-external-format :euc))) + (test (form-urlencoded-to-query + (query-to-form-urlencoded query :external-format ef) + :external-format ef) + query + :test #'equal) + (test str1 + (uridecode-string (uriencode-string str1 :external-format ef) + :external-format ef) + :test #'string=)))) + + +(defun test-forms (port) + ;; test encoding and decoding info + ;; + ;; we can send the info as a uri query or as the body of a post + ;; + (let ((prefix-local (format nil "http://localhost:~a" port)) + (uri-var-vals '(("marketing" . "sammy c") + ("sales" . "masako o") + ("tech group" . "A Whole Big <Group> of Folks?"))) + (post-var-vals + '(("cessna" . "good#") + ("piper" . "better###") + ("grumman" . "best<>###"))) + (req-query-res) + ) + + + ;;------------------------- + + (publish :path "/form-tester-both" + :content-type "text/html" + :function + #'(lambda (req ent) + ;; get both uri and post + (if* (eql (request-method req) :post) + then (test "application/x-www-form-urlencoded" + (header-slot-value req :content-type) + :test #'equal)) + (setq req-query-res (request-query req)) + + ;; also test here the setf'ing of query values + (test nil (request-query-value "flurber" req)) + (setf (request-query-value "flurber" req) "ziftp") + (test "ziftp" (request-query-value "flurber" req) + :test #'equal) + + + (with-http-response (req ent) + (with-http-body (req ent) + (html "hi"))))) + + + ;; send query only on uri + (x-do-http-request (format nil "~a/form-tester-both?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals))) + + (test nil (set-difference uri-var-vals req-query-res + :test #'equal)) + + + ; - use query arg + (x-do-http-request (format nil "~a/form-tester-both" prefix-local) + :query uri-var-vals) + + (test nil (set-difference uri-var-vals req-query-res + :test #'equal)) + + + + + ;; send query only on post + (x-do-http-request (format nil "~a/form-tester-both" + prefix-local) + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil (set-difference post-var-vals req-query-res + :test #'equal)) + + + (x-do-http-request (format nil "~a/form-tester-both" + prefix-local) + :method :post + :query post-var-vals) + + (test nil (set-difference post-var-vals req-query-res + :test #'equal)) + + + ;; send query on both uri and post + (x-do-http-request (format nil "~a/form-tester-both?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals)) + + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil (set-difference (append post-var-vals + uri-var-vals) + req-query-res + :test #'equal)) + + + ;;------------------------------------ + + ;; only check uri + + (publish :path "/form-tester-uri" + :content-type "text/html" + :function + #'(lambda (req ent) + ;; get both uri and post + (setq req-query-res (request-query req :post nil)) + (with-http-response (req ent) + (with-http-body (req ent) + (html "hi"))))) + + + (x-do-http-request (format nil "~a/form-tester-uri?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals))) + + (test nil (set-difference uri-var-vals req-query-res + :test #'equal)) + + + + ;; send query only on post + (x-do-http-request (format nil "~a/form-tester-uri" + prefix-local) + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil req-query-res) + + + ;; send query on both uri and post + (x-do-http-request (format nil "~a/form-tester-uri?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals)) + + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil (set-difference uri-var-vals + req-query-res + :test #'equal)) + + ;;------------------------- + + ; only check post + + (publish :path "/form-tester-post" + :content-type "text/html" + :function + #'(lambda (req ent) + ;; get both uri and post + (setq req-query-res (request-query req :uri nil)) + (with-http-response (req ent) + (with-http-body (req ent) + (html "hi"))))) + + + (x-do-http-request (format nil "~a/form-tester-post?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals))) + + (test nil req-query-res) + + + + ;; send query only on post + (x-do-http-request (format nil "~a/form-tester-post" + prefix-local) + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil (set-difference req-query-res post-var-vals :test #'equal)) + + + ;; send query on both uri and post + (x-do-http-request (format nil "~a/form-tester-post?~a" + prefix-local + (query-to-form-urlencoded uri-var-vals)) + + :method :post + :content (query-to-form-urlencoded post-var-vals) + :content-type "application/x-www-form-urlencoded" + ) + + (test nil (set-difference post-var-vals req-query-res :test #'equal)) + + ; + ; test that we can do get-request-body more than once + ; + (publish :path "/get-request-body-tester" + :content-type "text/plain" + :function + #'(lambda (req ent) + + (with-http-response (req ent) + (test t + (equal (get-request-body req) + "foo and bar")) + (test t + (equal (get-request-body req) + "foo and bar")) + (with-http-body (req ent))))) + (x-do-http-request (format nil "~a/get-request-body-tester" + prefix-local) + :method :post + :content "foo and bar" + :content-type "text/plain") + + )) + + + +(defun test-client (port) + (let ((prefix-local (format nil "http://localhost:~a" port))) + + ;; test redirection + (publish :path "/redir-target" + :content-type "text/plain" + :function #'(lambda (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (html "foo"))))) + + (publish :path "/redir-to" + :function #'(lambda (req ent) + (with-http-response (req ent + :response *response-found*) + (setf (reply-header-slot-value req :location) + "redir-target") + (with-http-body (req ent))))) + + ; redirect to itself... danger danger! + (publish :path "/redir-inf" + :function #'(lambda (req ent) + (with-http-response (req ent + :response *response-found*) + (setf (reply-header-slot-value req :location) + "redir-inf") + (with-http-body (req ent))))) + + + ; first test target + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/redir-target" prefix-local)) + (declare (ignore body headers)) + (test 200 code)) + + ; now test through redirect + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/redir-to" prefix-local)) + (declare (ignore body headers)) + (test 200 (and :second code))) + + ; now turn off redirect and test + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/redir-to" prefix-local) :redirect nil) + (declare (ignore body headers)) + (test 302 (and :third code))) + + ; turn off with a zero repeat count + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/redir-to" prefix-local) :redirect 0) + (declare (ignore body headers)) + (test 302 (and :fourth code))) + + + ; self redirect, we test that we eventually give up + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/redir-inf" prefix-local)) + (declare (ignore body headers)) + (test 302 (and :fifth code))) + )) + + + + +;; proxy cache tests +;; (net.aserve.test::test-proxy-cache) +;; +(defun test-proxy-cache () + (let* ((*wserver* (start :port nil :server :new)) + (proxy-wserver (start :port nil :server :new :proxy t :cache t)) + (proxy-host) + (origin-server) + (pcache (net.aserve::wserver-pcache proxy-wserver)) + (*print-level* 4) ; in case we see some errors + ) + + (macrolet ((test-2 (res1 res2 form &key (test #'eql)) + `(multiple-value-bind (v1 v2) ,form + (test ,res1 (and '(:first ,form) v1) :test ,test) + (test ,res2 (and '(:second ,form) v2) :test ,test)))) + + + + + (setq proxy-host (format nil "localhost:~d" + (socket:local-port + (net.aserve::wserver-socket proxy-wserver)))) + + (setq origin-server + (format nil "http://localhost:~d" (socket:local-port + (net.aserve::wserver-socket *wserver*)))) + + (format t "server on port ~d, proxy server on port ~d~%" + (socket:local-port + (net.aserve::wserver-socket *wserver*)) + (socket:local-port + (net.aserve::wserver-socket proxy-wserver))) + + (with-open-file (p "aservetest.xx" :direction :output + :if-exists :supersede) + (format p "foo")) + + (with-tests (:name "aserve-proxy-cache") + (unwind-protect + (progn + (publish-file :path "/foo" :file "aservetest.xx" :cache-p t) + + ; a miss + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + + (test 1 (net.aserve::pcache-r-miss pcache)) + + ; a fast hit + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + (test 1 (net.aserve::pcache-r-fast-hit pcache)) + + ; another fast hit + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + (test 2 (net.aserve::pcache-r-fast-hit pcache)) + + + (format t "sleeping for 10 secs.....~%")(force-output) + (sleep 10) + + ; entry no longer fresh so get a slow hit + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + (test 1 (net.aserve::pcache-r-slow-hit pcache)) + + ; entry now updated so we get a fast hit + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + + (test 3 (net.aserve::pcache-r-fast-hit pcache)) + + ; try flushing all to disk + (net.aserve::flush-memory-cache pcache 0) + + ; and retrieve from the disk + (test-2 "foo" 200 + (do-http-request + (format nil "~a/foo" origin-server) + :proxy proxy-host) + :test #'equal) + (test 4 (net.aserve::pcache-r-fast-hit pcache)) + + ) + + + + + (ignore-errors (delete-file "aservetest.xx")) + (shutdown :server proxy-wserver) + (shutdown :server *wserver*)))))) + + + +; publish-directory tests + +(defun test-publish-directory (port) + (let ((prefix-local (format nil "http://localhost:~a" port)) + (prefix-dns (format nil "http://~a:~a" + (long-site-name) + port)) + (test-dir) + (step 0) + (got-reps nil)) + + (multiple-value-bind (ok whole dir) + ;; A slight, unfortunate incompatibility between cl-ppcre and + ;; ACL regexps ... + (match-regexp #+allegro "\$.*[/\\]\$.*" #-allegro "\$.*[/\\\\]\$.*" (namestring *aserve-load-truename*)) + (declare (ignore whole)) + (if* (not ok) + then (error "can't find the server.pem directory")) + + (setq test-dir dir)) + + + (publish-directory :prefix "/test-pd/" + :destination test-dir + :hook #'(lambda (req ent extra) + (declare (ignore req ent extra)) + (setq got-reps (or got-reps 0)) + (incf got-reps)) + :headers '(("testvdir" . "testvval")) + :filter #'(lambda (req ent filename info) + (declare (ignore ent info)) + (test t + (values + (match-regexp "server.pem" + filename)) + :test #'equal) + (case step + (0 (failed-request req) + t) + (1 nil)))) + + ; in step 0 we have the filter return a 404 code + (test 404 (values2 + (x-do-http-request (format nil "~a/test-pd/server.pem" + prefix-local)))) + + (test nil got-reps) ; hook didn't fire + + ; in step 1 we have it return the actual file + (setq step 1) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/test-pd/server.pem" + prefix-local)) + (declare (ignore body)) + (test 200 code) + (test "testvval" + (cdr (assoc "testvdir" headers :test #'equal)) + :test #'equal)) + + (test 1 got-reps) ; hook fired + + ; remove entry so subsequent tests won't see it + (publish-file :path "/test-pd/server.pem" :remove t) + + ; remove directory publish and see if that worked + (publish-directory :prefix "/test-pd/" :remove t) + + ; now it shouldn't exist + (test 404 (values2 + (x-do-http-request (format nil "~a/test-pd/server.pem" + prefix-local)))) + + ; test publish directory with virtual hosts + (publish-directory :prefix "/test-foo/" + :destination test-dir + :host "localhost") + ; so it will work with localhost + (test 200 (values2 + (x-do-http-request (format nil "~a/test-foo/server.pem" + prefix-local)))) + + ; but not the dns name + (test 404 (values2 + (x-do-http-request (format nil "~a/test-foo/server.pem" + prefix-dns)))) + ; remove all refs + (publish-directory :prefix "/test-foo/" + :host "localhost" + :remove t) + (publish-file :path "/test-foo/server.pem" + :host "localhost" + :remove t) + + ; now doesn't exist + (test 404 (values2 + (x-do-http-request (format nil "~a/test-foo/server.pem" + prefix-local)))) + + ;; now try using the access control + (publish-directory :prefix "/acc-test/" + :destination (concatenate 'string test-dir "testdir/") + :access-file "access.cl") + + + ; forbidden to access this file + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/access.cl" + prefix-local + )))) + + ; and this file + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/bbb.ign" + prefix-local)))) + + ; and any CVS file in this dir and those below + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/CVS/Root" + prefix-local)))) + + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/subc/ccc.html" + prefix-local)))) + + ; subdir subd can't be accessed from this or any subdir + ; due to :inherit in the access file + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/subd/ddee.html" + prefix-local)))) + (test 404 + (values2 (x-do-http-request (format nil "~a/acc-test/suba/subd/ddd.html" + prefix-local)))) + + ; but this one is ok, and has content type specified by access file + (multiple-value-bind (res code headers) + (x-do-http-request (format nil "~a/acc-test/aaa.foo" + prefix-local)) + (declare (ignore res)) + (test 200 code) + (test "foo/bar" (cdr (assoc :content-type headers :test #'eq)) + :test #'equal)) + + ; test getting mime type from the standard place since it isn't + ; specified + (multiple-value-bind (res code headers) + (x-do-http-request (format nil "~a/acc-test/ccc.html" + prefix-local)) + (declare (ignore res)) + (test 200 code) + (test "text/html" (cdr (assoc :content-type headers :test #'eq)) + :test #'equal)) + + ; now try full name mime type + (multiple-value-bind (res code headers) + (x-do-http-request (format nil "~a/acc-test/readme" + prefix-local)) + (declare (ignore res)) + (test 200 code) + (test "frob/frib" (cdr (assoc :content-type headers :test #'eq)) + :test #'equal)) + + ; test blocking via ip address, can't access if not using localhost + (test 404 (values2 (x-do-http-request (format nil "~a/acc-test/ccc.html" + prefix-dns)))) + + + ; now down a directory the ip restriction isn't inherited + (test 200 (values2 (x-do-http-request + (format nil "~a/acc-test/suba/foo.html" prefix-dns)))) + (test 200 (values2 (x-do-http-request + (format nil "~a/acc-test/suba/foo.html" prefix-local)))) + ; this is blocked since we only match files named 'foo' + (test 404 (values2 (x-do-http-request + (format nil "~a/acc-test/suba/access.cl" prefix-local)))) + + ; and we can't go down another directory level since that's blocked + (test 404 (values2 (x-do-http-request + (format nil "~a/acc-test/suba/subsuba/foo.html" prefix-local)))) + + ;; now try password and ip authorized + ; no password + (test 401 (values2 (x-do-http-request + (format nil "~a/acc-test/subb/foo.html" + prefix-local)))) + + ; wrong ip but password ok + (test 404 (values2 (x-do-http-request + (format nil "~a/acc-test/subb/foo.html" + prefix-dns) + :basic-authorization '("joe" . "eoj") + ))) + + ; good password and ip + (test 200 (values2 (x-do-http-request + (format nil "~a/acc-test/subb/foo.html" + prefix-local) + :basic-authorization '("joe" . "eoj") + ))) + + + )) + + +;; publish-multi tests +(defun test-publish-multi (port) + (let ((prefix-local (format nil "http://localhost:~a" port))) + (with-open-file (p "aservemulti.xx" + :direction :output + :if-exists :supersede) + (write-sequence "bar" p)) + (publish-multi :path "/multi-test" + :items (list '(:string "foo") + "aservemulti.xx" ; file + #'(lambda (req ent time value) + (declare (ignore req ent time value)) + "baz") + #'(lambda (req ent time value) + (declare (ignore req ent time value)) + (string-to-octets "bof" + :null-terminate nil)))) + + + (test "foobarbazbof" + (values (x-do-http-request (format nil "~a/multi-test" prefix-local))) + :test #'equal) + + (ignore-errors (delete-file "aservemulti.xx")) + )) + + + +;; publish-prefix tests +;; +(defun test-publish-prefix (port) + (let ((prefix-local (format nil "http://localhost:~a" port)) + (prefix-dns (format nil "http://~a:~a" + (long-site-name) + port)) + (got-here)) + (publish-prefix :prefix "/pptest" + :function + #'(lambda (req ent) + (incf got-here) + (with-http-response (req ent) + (with-http-body (req ent) + (html "foo")))) + :headers '((:testhead . "testval")) + ) + (dolist (prefix (list prefix-local prefix-dns)) + (setq got-here 0) + (test 200 (values2 + (x-do-http-request (format nil "~a/pptest" + prefix)))) + (test 1 got-here) + (test 200 (values2 + (x-do-http-request (format nil "~a/pptest/fred" + prefix)))) + (test 2 got-here) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/pptest#asdfasdf" + prefix)) + (declare (ignore body)) + (test 200 code) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal)) + + (test 3 got-here) + (test 200 (values2 + (x-do-http-request (format nil "~a/pptestasdfasdf#asdfasdf" + prefix)))) + + (test 4 got-here) + (test 404 (values2 + (x-do-http-request (format nil "~a/pptes" + prefix)))) + (test 4 got-here)))) + + + + + + + + + + +(defun test-cgi (port) + ;; currently we only have a test program on unix since + ;; that where our shell script works + ;; + (declare (ignorable port)) + #+(and unix (and allegro (version>= 6 1))) + (let ((prefix-local (format nil "http://localhost:~a" port)) + (error-buffer)) + (publish :path "/cgi-0" + :function #'(lambda (req ent) + (net.aserve:run-cgi-program + req ent "sh aserve/examples/cgitest.sh"))) + (publish :path "/cgi-1" + :function #'(lambda (req ent) + (net.aserve:run-cgi-program + req ent "sh aserve/examples/cgitest.sh 1"))) + (publish :path "/cgi-2" + :function #'(lambda (req ent) + (net.aserve:run-cgi-program + req ent "sh aserve/examples/cgitest.sh 2"))) + (publish :path "/cgi-3" + :function #'(lambda (req ent) + (net.aserve:run-cgi-program + req ent "sh aserve/examples/cgitest.sh 3"))) + + ;; verify that the various headers work + (test 200 (values2 + (x-do-http-request (format nil "~a/cgi-0" + prefix-local)))) + + (test 200 (values2 + (x-do-http-request (format nil "~a/cgi-1" + prefix-local)))) + + ; verify that a redirect is requested + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/cgi-2" + prefix-local) + :redirect nil) + (test "go to franz" body :test #'equal) + (test 301 code) + (test "http://www.franz.com" (cdr (assoc :location headers)) + :test #'equal) + (test "123hellomac" (cdr (assoc :etag headers)) + :test #'equal) + ) + + ; verify that the unauthorized response is made + (test 401 (values2 + (x-do-http-request (format nil "~a/cgi-3" + prefix-local)))) + + ; test error output processing + (publish :path "/cgi-4" + :function #'(lambda (req ent) + (net.aserve:run-cgi-program + req ent "sh aserve/examples/cgitest.sh 4" + :error-output + #'(lambda (req ent stream) + (declare (ignore req ent)) + (let (eof) + (loop + (let ((ch (read-char-no-hang stream + nil :eof))) + + (if* (null ch) then (return)) + + (if* (eq :eof ch) + then (setq eof t) + (return)) + + (vector-push-extend ch error-buffer))) + eof + ))))) + (setq error-buffer (make-array 10 + :element-type 'character + :adjustable t + :fill-pointer 0)) + + (multiple-value-bind (body rescode) + (x-do-http-request (format nil "~a/cgi-4" prefix-local)) + (test "okay +" body :test #'equal) + (test 200 rescode) + (test "stuff-on-error-stream +" error-buffer :test #'equal)) + )) + + + +(defun test-timeouts (port) + ;; test aserve timing out when the client is non responsive + (let (#+ignore (prefix-local (format nil "http://localhost:~a" port))) + + (if* *x-ssl* + then ; we don't get the same timeout behavior since we're + ; not directly connected to the server socket, so + ; don't try the tests + (return-from test-timeouts nil)) + + (format t "timeout tests.. expect pauses~%")(force-output) + + ;; try making a connection and not sending any headers. + ;; we should timeout + (let ((sock (socket:make-socket :remote-host "localhost" + :remote-port port))) + (unwind-protect + (progn + (format sock "GET /timeouttest HTTP/1.0~c~cfoo: bar~c~c" + #\return #\newline #\return #\newline) + (force-output sock) + + ; try sending data periodically but in enough time to + ; bypass the timeout. This only works in the io-timeout + ; situation. + #+io-timeout + (dotimes (i 3) + (sleep (max 1 (- net.aserve:*http-io-timeout* 10))) + (format t "send packet~%")(force-output) + (format sock "brap: brop~c~c" #\return #\newline) + (force-output sock) + ) + + ; now sleep for longer than it should take for the timeout to occur + (sleep (+ 3 (max *http-response-timeout* *http-io-timeout*))) + (test-error + ;; now we should get a connection reset by peer + (progn (format sock "brap: brop~c~c" #\return #\newline) + (force-output sock) + (format sock "brap: brop~c~c" #\return #\newline) + (force-output sock)) + :condition-type 'errno-stream-error + )) + (ignore-errors (close sock :abort t)))))) + + +(defun test-international (port) + (declare (ignorable port)) + #+(and allegro ics (version>= 6 1)) + (let ((prefix-local (format nil "http://localhost:~a" port)) + (Privyet! (coerce '(#\cyrillic_capital_letter_pe + #\cyrillic_small_letter_er + #\cyrillic_small_letter_i + #\cyrillic_small_letter_ve + #\cyrillic_small_letter_ie + #\cyrillic_small_letter_te + #\!) + 'string))) + (publish + :path "/simple-form-itest" + :function + #'(lambda (req ent) + ; simulate starting aserve with :external-format :koi8-r arg + (let ((*default-aserve-external-format* :koi8-r)) + (with-http-response (req ent) + (with-http-body (req ent :external-format :koi8-r) + (let ((text (request-query-value "text" req))) + (if* text + then (html + (:html + (:head (:title "result")) + (test Privyet! text :test #'string=) + (:body "test text: {" (:princ text) "}"))) + else ;; filler -- test normally doesn't go here + (html + (:html + (:head (:title "foobar")) + (:body)))))))))) + + (let* ((result + (x-do-http-request + (format nil "~a/simple-form-itest?text=%F0%D2%C9%D7%C5%D4%21" + prefix-local) + :external-format :octets)) + (begin (position #\{ result)) + (end (position #\} result)) + (test-string + (if* begin + then (octets-to-string + (string-to-octets (subseq result (1+ begin) end) + :external-format :octets) + :external-format :koi8-r)))) + (test t (not (null begin))) ; verify we found begin + (test t (not (null end))) ; and end markers + (test Privyet! test-string :test #'string=)))) + + + +(defun test-spr27296 () + #+(and allegro ics) + (let ((server (start :port nil :server :new + :external-format (crlf-base-ef :utf8))) + (string (concatenate 'string + "<Name>B" + '(#\latin_small_letter_o_with_diaeresis + #\r + #\latin_small_letter_o_with_diaeresis) + "cz P" + '(#\latin_small_letter_e_with_acute) + "ter</Name>"))) + (publish :path "/spr27296" + :content-type "text/xml" + :server server + :function #'(lambda (req ent) + (test string + (get-request-body + req + :external-format (crlf-base-ef :utf8)) + :test #'string=) + (with-http-response (req ent) + (with-http-body (req ent))))) + (do-http-request (format nil "http://localhost:~d/spr27296" + (socket:local-port + (net.aserve::wserver-socket server))) + :method :post + :content string + :external-format (crlf-base-ef :utf8)) + (shutdown :server server))) + + + + +(if* common-lisp-user::*do-aserve-test* + then (test-aserve *test-timeouts*) + else (format t + " (net.aserve.test::test-aserve) will run the aserve test~%")) + + + + + + + + + + + + + + + Added: vendor/portableaserve/aserve/test/testdir/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/aaa.foo/1.1/Sun Jun 9 11:34:59 2002// +/access.cl/1.1/Sun Jun 9 11:34:59 2002// +/bbb.ign/1.1/Sun Jun 9 11:34:59 2002// +/ccc.html/1.1/Sun Jun 9 11:34:59 2002// +/readme/1.1/Sun Jun 9 11:34:59 2002// +D Added: vendor/portableaserve/aserve/test/testdir/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/test/testdir/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,4 @@ +A D/suba//// +A D/subb//// +A D/subc//// +A D/subd//// Added: vendor/portableaserve/aserve/test/testdir/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir Added: vendor/portableaserve/aserve/test/testdir/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/aaa.foo =================================================================== --- vendor/portableaserve/aserve/test/testdir/aaa.foo 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/aaa.foo 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +this file should be mime type foo/bar + Added: vendor/portableaserve/aserve/test/testdir/access.cl =================================================================== --- vendor/portableaserve/aserve/test/testdir/access.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/access.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,21 @@ +;; access file +(:subdirectories :deny "subc") +(:subdirectories :deny "subd" :inherit t) + +(:mime :types (("foo/bar" "foo" "foo2") ("foo/baz" "baz"))) +(:mime :types (("frob/frib" ("readme")))) ; use whole file name mime type +(:files :deny ("^access\\.cl$")) ; ignore exactly access.cl +(:files :deny "\\.ign$") ; ignore all files ending in .ign + +; allow from localhost only and don't inherit this rule +(:ip :patterns ((:accept "127.1") + :deny) + :inherit nil) + + + + + + + + Added: vendor/portableaserve/aserve/test/testdir/bbb.ign =================================================================== --- vendor/portableaserve/aserve/test/testdir/bbb.ign 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/bbb.ign 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +this file will not be accessible Added: vendor/portableaserve/aserve/test/testdir/ccc.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/ccc.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/ccc.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +this file will be accessible. Added: vendor/portableaserve/aserve/test/testdir/readme =================================================================== --- vendor/portableaserve/aserve/test/testdir/readme 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/readme 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +sorry, I meant to say "don't read me" Added: vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +/access.cl/1.1/Sun Jun 9 11:34:58 2002// +/foo.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +A D/subd//// +A D/subsuba//// Added: vendor/portableaserve/aserve/test/testdir/suba/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/suba Added: vendor/portableaserve/aserve/test/testdir/suba/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/suba/access.cl =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/access.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/access.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +; subdir access file + +(:files :allow ("foo")) ; only files with aaa in their name + +(:subdirectories :deny "subsuba") ; block this subdir + Added: vendor/portableaserve/aserve/test/testdir/suba/foo.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/foo.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/foo.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +this should be readable by all Added: vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/ddd.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/suba/subd Added: vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subd/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/suba/subd/ddd.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subd/ddd.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subd/ddd.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +foo Added: vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/foo.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/suba/subsuba Added: vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subsuba/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/suba/subsuba/foo.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/suba/subsuba/foo.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/suba/subsuba/foo.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +this will not be reachable Added: vendor/portableaserve/aserve/test/testdir/subb/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/subb/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subb/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +/access.cl/1.1/Sun Jun 9 11:34:58 2002// +/foo.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/subb/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/subb/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subb/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/subb Added: vendor/portableaserve/aserve/test/testdir/subb/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/subb/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subb/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/subb/access.cl =================================================================== --- vendor/portableaserve/aserve/test/testdir/subb/access.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subb/access.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +;; need to be local and password approved + +(:password :realm "foorealm" + :allowed (("joe" . "eoj") + ("fred" . "derf"))) +(:ip :patterns ((:accept "127.1") :deny)) Added: vendor/portableaserve/aserve/test/testdir/subb/foo.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/subb/foo.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subb/foo.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +secret page Added: vendor/portableaserve/aserve/test/testdir/subc/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/subc/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subc/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/ccc.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/subc/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/subc/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subc/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/subc Added: vendor/portableaserve/aserve/test/testdir/subc/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/subc/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subc/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/subc/ccc.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/subc/ccc.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subc/ccc.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +fooo Added: vendor/portableaserve/aserve/test/testdir/subd/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/test/testdir/subd/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subd/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +/ddee.html/1.1/Sun Jun 9 11:34:58 2002// +D Added: vendor/portableaserve/aserve/test/testdir/subd/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/test/testdir/subd/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subd/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/test/testdir/subd Added: vendor/portableaserve/aserve/test/testdir/subd/CVS/Root =================================================================== --- vendor/portableaserve/aserve/test/testdir/subd/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subd/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/test/testdir/subd/ddee.html =================================================================== --- vendor/portableaserve/aserve/test/testdir/subd/ddee.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/test/testdir/subd/ddee.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +foo Added: vendor/portableaserve/aserve/webactions/.cvsignore =================================================================== --- vendor/portableaserve/aserve/webactions/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/webactions/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/webactions/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,8 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/ChangeLog/1.1/Tue Dec 2 14:36:33 2003// +/clpage.cl/1.9/Tue Aug 31 03:49:36 2004// +/load.cl/1.2/Mon Apr 26 18:18:37 2004// +/webact.cl/1.11/Tue Aug 31 03:49:36 2004// +/webactions.asd/1.2/Sat Mar 13 17:46:08 2004// +/websession.cl/1.3/Mon Mar 1 18:25:31 2004// +D Added: vendor/portableaserve/aserve/webactions/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/webactions/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +A D/clpcode//// +A D/doc//// +A D/test//// Added: vendor/portableaserve/aserve/webactions/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/webactions/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/webactions Added: vendor/portableaserve/aserve/webactions/CVS/Root =================================================================== --- vendor/portableaserve/aserve/webactions/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/webactions/ChangeLog =================================================================== --- vendor/portableaserve/aserve/webactions/ChangeLog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/ChangeLog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,55 @@ +2003-10-22 John Foderaro <jkf(a)tiger.franz.com> +1.4 + * webact.cl - add :content-type flag and :redirect flag + to map entry. Add tests. + Update document + +2003-10-09 <jkf(a)main.verada.com> +1.3 + * webact.cl - add :prefix flag to map entry + webaction.html - more documentation + +2003-10-07 John Foderaro <jkf(a)tiger.franz.com> + + * webact.cl - fix :prefix sym name processing so that an existing + file takes precedence over a prefix name. + +2003-09-22 <jkf(a)main.verada.com> + + * webact.cl - add :clp-content-type argument to webaction-project + to control the content-type returned by clp pages + - add (:prefix t) support in maps to say that + the given symbolic page name matches any sym page name + that extends that given name. + * clpage.cl - support clp-content-type declaration + +2003-09-18 Colin Meldrum <colin@cobweb> + + * clpage.cl + - whenever opening a .clp file use the external-format of + the associated clp-entity + - fixed a couple of places in the code to parse clp files + which made the assumption that 1 character = 1 file-position. + + * webact.cl + - added :host argument to webaction-project + +2003-09-03 <jkf(a)main.verada.com> +1.2 + * webact.cl: add :authorizer argument to webaction-project + +2003-08-13 <jkf(a)main.verada.com> +1.1 + * add 'extended maps' where you can specify more + than one handler for each symbolic page. + update webactions document + +2003-07-07 <jkf(a)tiger.franz.com> +<noversion> + * add clp_select funtion + +2003-05-16 John Foderaro <jkf(a)tiger.franz.com> + + * add external-format support to clp pages + + Added: vendor/portableaserve/aserve/webactions/clpage.cl =================================================================== --- vendor/portableaserve/aserve/webactions/clpage.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpage.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,761 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; clpage.cl +;; common lisp server pages +;; +;; copyright (c) 2003 Franz Inc, Oakland, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; $Id: clpage.cl,v 1.9 2004/08/31 03:49:36 kevinrosenberg Exp $ + + +(eval-when (compile load eval) (require :aserve)) + +(in-package :net.aserve) + +(export '(clp-directory-entity-processor + clp-entity + def-clp-function + emit-clp-entity + find-clp-module + find-clp-module-function + publish-clp + request-variable-value + )) + +(defclass clp-entity (entity) + ;; a clp file + ((file :initarg :file :accessor file) + (file-write-date :initarg :file-write-date + :accessor clp-entity-file-write-date + :initform nil) + (objects :initarg :objects + :accessor clp-entity-objects) + + ; list of (filename . last-write-date) for included files + (dependencies :initform nil + :accessor clp-entity-dependencies) + + (external-format :initform nil + :initarg :external-format + :accessor clp-entity-external-format) + )) + + +(defun publish-clp (&key (host nil host-p) port path class + (server *wserver*) + locator + remove + authorizer + filename + (timeout #+io-timeout #.(* 100 24 60 60) + #-io-timeout nil) + (content-type "text/html") + plist + external-format + ) + + ;; publish a templated page, one that is created by a combination + ;; of an html file and a lisp file + + (if* (null locator) + then (setq locator (find-locator :exact server))) + + (if* remove + then (unpublish-entity locator path + host + host-p) + (return-from publish-clp nil)) + + + (let* ((hval (convert-to-vhosts (if* (and host (atom host)) + then (list host) + else host) + server)) + (ent (make-instance (or class 'clp-entity) + :host hval + :port port + :path path + :authorizer authorizer + :file filename + :content-type content-type + :timeout timeout + :plist plist + :external-format external-format + ))) + (publish-entity ent locator path hval) + + ent) + + ) + + +(defun clp-directory-entity-publisher (req ent realname info suffixes + external-format clp-content-type) + ;; publish all files ending in .clp as clp files + ;; otherwise do the standard-directory-entity-publisher thing + ;; + (multiple-value-bind (root tail name type) + (split-namestring realname) + (declare (ignore root tail name)) + (if* (member type suffixes :test #'equalp) + then + + (multiple-value-bind (content-type local-authorizer) + (standard-access-file-reader realname info) + + (publish-clp :path (request-decoded-uri-path req) + :host (host ent) + :filename realname + :authorizer (or local-authorizer + (entity-authorizer ent)) + :content-type (or content-type + clp-content-type + "text/html") + :timeout (entity-timeout ent) + :plist (list :parent ent) ; who spawned us + :external-format external-format + )) + else + (standard-directory-entity-publisher req ent realname info)))) + + + + + + + + + +(defmethod process-entity ((req http-request) (ent clp-entity)) + ;; emit a clp file + ;; + (let ((websession (getf (request-reply-plist req) 'websession)) + (wa) + (sm)) + + (if* (and (null websession) + (setq wa (getf (entity-plist ent) 'webaction)) + (setq sm (webaction-websession-master wa))) + then ; try to find session via cookie and if that fails, + ; make up a session + (let ((csessid (cdr (assoc (sm-cookie-name sm) + + (get-cookie-values req) + :test #'equal)))) + (if* (setq websession + (gethash csessid (sm-websessions sm))) + then ; cookie worked + (if* (eq :try-cookie (websession-method websession)) + then (setf (websession-method websession) + :cookie)) + else ; no session found via cookie + (setq websession + (if (webaction-cookie-domain wa) + (make-instance 'websession + :key (next-websession-id sm) + :domain (webaction-cookie-domain wa) + :method :cookie) + (make-instance 'websession + :key (next-websession-id sm) + :method :cookie))) + (setf (gethash (websession-key websession) + (sm-websessions sm)) + websession))) + + (if* websession + then + (setf (getf (request-reply-plist req) 'websession) + websession))) + + + (if* websession then (note-websession-referenced websession)) + + (if* (or (null (clp-entity-file-write-date ent)) + (not (eql (clp-entity-file-write-date ent) + (file-write-date (file ent)))) + (dolist (dep (clp-entity-dependencies ent)) + (if* (not (eql (cdr dep) + (file-write-date (car dep)))) + then (return t))) + + + ) + then (parse-clp-file ent)) + + (with-http-response (req ent + :content-type (content-type ent)) + (if* (and websession + (eq :try-cookie (websession-method websession)) + (or sm ; sm already known, otherwise compute it + (and (setq wa (getf (entity-plist ent) 'webaction)) + (setq sm (webaction-websession-master wa))))) + then (if (webaction-cookie-domain wa) + (set-cookie-header req + :name (sm-cookie-name sm) + :value (websession-key websession) + :path (webaction-project-prefix wa) + :domain (webaction-cookie-domain wa)) + (set-cookie-header req + :name (sm-cookie-name sm) + :value (websession-key websession) + :path (webaction-project-prefix wa)))) + (setf (reply-header-slot-value req :cache-control) "no-cache") + (setf (reply-header-slot-value req :pragma) "no-cache") + + (with-http-body (req ent + :external-format + (or (clp-entity-external-format ent) + *default-aserve-external-format*) + ) + (emit-clp-entity req ent (clp-entity-objects ent)))) + t)) + + +(defun parse-clp-file (ent) + ;; parse the clp file + ;; + + (handler-case + (with-open-file (p (file ent) + :direction :input + #+allegro :external-format + #+allegro (clp-entity-external-format ent)) + (setf (clp-entity-file-write-date ent) + (file-write-date (file ent))) + (let* ((objects (parse-clp-guts p (file ent))) + (dependencies (expand-clp-includes objects (file ent) + (clp-entity-external-format ent)))) + (if* dependencies + then (setf (clp-entity-dependencies ent) + (mapcar #'(lambda (filename) + (cons filename (file-write-date filename))) + dependencies))) + (setf (clp-entity-objects ent) objects))) + + (error (c) + (logmess (format nil "processing clp file ~s got error ~a" + (file ent) + c))))) + + + +(defun parse-clp-filename (filename external-format) + ;; parse the clp file + ;; + + (handler-case + (with-open-file (p filename + :direction :input + ;; KLUDGE: (rudi 2004-05-31): revisit this when + ;; other Lisps support external format + #+allegro :external-format #+allegro external-format) + (parse-clp-guts p filename)) + + (error (c) + (logmess (format nil "processing clp file ~s got error ~a" + filename + c))))) + + +(defun expand-clp-includes (objects filename + &optional (external-format *default-aserve-external-format*)) + ;; expand all the includes in the file + ;; destructively modify the objects list to replace the + ;; include directives with what they include + (do ((oo objects (cdr oo)) + (deps) + (obj) + (fname)) + ((null oo) + deps) + + (setq obj (car oo)) + + (if* (and (consp obj) + (eq :clp (nth 0 obj)) + (equal "clp" (nth 1 obj)) + (equal "include" (nth 2 obj)) + (setq fname (cdr (assoc "name" (nth 3 obj) :test #'equal)))) + then (let ((newname (merge-pathnames fname filename))) + (pushnew newname deps :test #'equal) + + (let* ((newobjs (parse-clp-filename newname external-format)) + (newdeps (expand-clp-includes newobjs newname external-format))) + (dolist (dep newdeps) + (pushnew dep deps :test #'equal)) + + (if* newobjs + then ; splice it in in place of the clp + (setf (cdr (last newobjs)) (cdr oo) + (cdr oo) (cdr newobjs) + (car oo) (car newobjs)))))) + + ; expand the body (if any) + (dolist (subdep (expand-clp-includes (nth 4 obj) filename external-format)) + (pushnew subdep deps :test #'equal)))) + + + + + + + +(defun tparse (filename) + (with-open-file (p filename) + (let ((res (parse-clp-guts p filename))) + (expand-clp-includes res filename) + res))) + + + + + +(defun parse-clp-guts (p filename) + (let ((result) + (pos-start 0) + (chstart 0) + (chcount 0) + (ch) + (res) + (backbuffer (make-array 10 :element-type 'character + :initial-element #\space)) + (backindex 0)) + + (flet ((savestring (p pos chars) + (if* (> chars 0) + then (let ((ans (make-array chars + :element-type 'character)) + (savepos (file-position p))) + (file-position p pos) + (dotimes (i chars) + (setf (aref ans i) (read-char p))) + (file-position p savepos) + + (push `(:text ,ans) result)))) + (wa-cvt (dest) + ;; convert dest to the appropriate wa_link command + ;; + (let ((xpos (min (or (position #\? dest) most-positive-fixnum) + (or (position #\# dest) most-positive-fixnum))) + (extra)) + (if* (< xpos most-positive-fixnum) + then ; tag as ? or # in it, remove that and make it extra + (setq extra (subseq dest xpos) + dest (subseq dest 0 xpos))) + + `(:clp "wa" "link" + (("name" . ,dest) + ,@(if* extra then + `(("extra" . ,extra)))) + nil)))) + (block outer + (loop + (if* (null (setq ch (read-char p nil nil))) + then (savestring p pos-start (- chcount chstart)) + (return)) + (incf chcount) + (if* (eq ch #\<) + then + (setq res (parse-clp-tag p filename)) + ;(format t "res is ~s~%" res) + (if* res + then (savestring p pos-start + (- chcount chstart 1)) + (push res result) + (setq pos-start (file-position p) + chstart chcount)) + elseif (eq ch #\") + then (if* (or (match-buffer backbuffer backindex "=ferh") + (match-buffer backbuffer backindex "=noitca")) + then (savestring p pos-start (- chcount chstart)) + ; scan for tag name + (let ((savepos (file-position p))) + (setq chstart chcount) + (loop + (let ((lastpos (file-position p)) + (ch (read-char p nil nil))) + (if* (null ch) + then ; no " seen to end tag + (savestring p + pos-start + (- chcount chstart)) + (return-from outer nil)) + (incf chcount) + (if* (eq ch #\") + then ; end of tag, collect + (savestring p savepos + (- chcount chstart 1)) + (let ((res (car result))) + (if* (and (> (length (cadr res)) 0) + (or (member + (aref (cadr res) 0) + '(#\/ #\# #\?)) + (match-regexp + "^[A-Za-z]+:" ;eg: http: + (cadr res))) + ) + thenret ; absolute pathname, ok + else (pop result) + (push (wa-cvt (cadr res)) + result))) + (setq pos-start lastpos + chstart (1- chcount)) + (return)))))) + else (setq backindex (mod (1+ backindex) (length backbuffer))) + (setf (aref backbuffer backindex) ch))))) + + ;; return + (nreverse result))) + + +(defun match-buffer (buffer index string) + ;; see if string matches what's in the buffer, case insensitive + (dotimes (i (length string) t) + (if* (not (char-equal (schar string i) + (schar buffer index))) + then (return nil)) + (if* (< (decf index) 0) then (setq index (1- (length buffer)))))) + + +(eval-when (compile load eval) + (defparameter *clp-white-space* '(#\space #\tab #\return #\linefeed)) + (defparameter *clp-end-tagname* '(#\space #\tab #\return #\linefeed + #\/ #\>)) +) + +(defun parse-clp-tag (p filename) + ;; just read a <.. now see if there's a clp tag to read + ;; + (macrolet ((no-tag-found () + `(progn (file-position p start-pos) ; restore position + (return-from parse-clp-tag nil)))) + + (let ((start-pos (file-position p)) + (chars)) + (loop + (let ((ch (read-char p nil nil))) + (if* (null ch) + then (no-tag-found)) + + (if* (member ch *clp-end-tagname*) + then ; seen end of tag + (unread-char ch p) + (let ((tag (make-array (length chars) + :element-type 'character + :initial-contents (nreverse chars)))) + ;(format t "tag is ~s~%" tag) + (if* (equal tag "!--") + then (return-from parse-clp-tag + (collect-comment p))) + + (let ((pos (position #\_ tag))) + (if* pos + then ; possible clp tag + (let ((module (subseq tag 0 pos)) + (fcn (subseq tag (1+ pos)))) + (if* (or (equal module "clp") ; built-in + (find-clp-module module)) + then ; ok a valid module + (let ((clptag (process-clp-tag + p + module + fcn + filename))) + (if* clptag + then + (return-from parse-clp-tag + clptag)))))) + (no-tag-found))) + else (push ch chars))))))) + + + +(defun process-clp-tag (p module fcn filename) + ;; we've found a valid clp tag. + ;; now parse the arguments and the body + ;; and recusively parse the guts + (let (arg-values namechars valuechars seendq) + (flet ((finish-attribute () + ;; build the attribute name,values + (let ((name (make-array (length namechars) + :element-type 'character + :initial-contents (nreverse + namechars))) + (value (and valuechars + (make-array (length valuechars) + :element-type 'character + :initial-contents + (nreverse valuechars))))) + (push (cons name + (or value "")) + arg-values) + ))) + (let ((state 0)) + + (loop + (let ((ch (read-char p nil nil))) + (if* (null ch) + then ; eof before end of tag seen, give up + (return-from process-clp-tag nil)) + (case state + (0 ; looking for next interesting thing + (case ch + (#\/ (setq state 1)) + (#\> (setq state 2)) ; end of tag, look for body + (#.*clp-white-space* + nil ; do nothing + ) + (t (setq namechars (list ch) + valuechars nil) + (setq state 3)))) + + ; seen /, expect > next + (1 (if* (eq ch #\>) + then ; body-free clp tag + (return-from process-clp-tag + `(:clp ,module ,fcn ,(nreverse arg-values) nil)) + else ; not a valid tag + (return-from process-clp-tag nil))) + + ; seen end of tag, scan until </tag> seen + (2 (unread-char ch p) + (let ((body-start (file-position p))) + (let ((length (scan-for-end-tag p module fcn))) + (if* length + then ; found end tag, now parse the + ; body + + (let ((body (make-array length + :element-type + 'character)) + (curpos (file-position p))) + (file-position p body-start) + (read-sequence body p) + (file-position p curpos) + + (return-from process-clp-tag + `(:clp ,module ,fcn + ,(nreverse arg-values) + ,(parse-clp-guts + (make-string-input-stream body) + filename + )))) + else ; no end tag, bogus! + (return-from process-clp-tag nil))))) + + ; collecting the attribute name + (3 (case ch + (#\= ; end of name, time for value + (setq valuechars nil) + (setq state 4)) + (#.*clp-white-space* + (finish-attribute) + (setq state 0)) + (#\/ + (finish-attribute) + (setq state 1)) + (#\> + (finish-attribute) + (setq state 2)) + (t (push ch namechars)))) + + ; start collecting the attribute value + + (4 (case ch + (#.*clp-white-space* + (finish-attribute) + (setq state 0)) + (#\/ (finish-attribute) + (setq state 1)) + (#\> (finish-attribute) + (setq state 2)) + (#\" (setq seendq t + state 5)) + (t (push ch valuechars) + (setq state 5) + ))) + + ; in the middle of collecting an attribute value + (5 + (if* seendq + then (if* (eq ch #\") + then (finish-attribute) + (setq state 0) + else (push ch valuechars)) + else (case ch + (#.*clp-white-space* + (finish-attribute) + (setq state 0)) + (#\/ (finish-attribute) + (setq state 1)) + (#\> (finish-attribute) + (setq state 2)) + (t (push ch valuechars)))))))))))) + + + + +(defun scan-for-end-tag (p module fcn) + ;; look for </module_fcn> + ;; leave the file position after the tag + ;; + ;; return the number of characters read not including + ;; the end tag + ;; + ;; return nil if the end tag wasn't found + ;; + (let ((searchfor (format nil "</~a_~a>" module fcn)) + (chcount 0)) + + (loop + (dotimes (i (length searchfor) + ; matched + (return-from scan-for-end-tag + (- chcount (length searchfor)))) + (let ((ch (read-char p nil nil))) + (incf chcount) + (if* (null ch) then (return-from scan-for-end-tag nil)) ; eof + (if* (not (eq ch (aref searchfor i))) + then ;(format t "ch: ~s~%" ch) + (return))))))) + + +(defun collect-comment (p) + ;; return a text object holding a whole comment + (let ((state 0) + (start-pos (file-position p)) + (chcount 0)) + (flet ((makestr () + (let ((retstr (make-array (+ 5 chcount) + :element-type 'character))) + (setf (aref retstr 0) #\<) + (setf (aref retstr 1) #\!) + (setf (aref retstr 2) #\-) + (setf (aref retstr 3) #\-) + (setf (aref retstr 4) #\space) + (file-position p start-pos) + (dotimes (i chcount) + (setf (aref retstr (+ i 5)) (read-char p))) + `(:text ,retstr)))) + + (loop + (let ((ch (read-char p nil nil))) + (if* (null ch) then (return (makestr))) + (incf chcount) + (case state + (0 (if* (eql #\- ch) then (setq state 1))) + (1 (if* (eql #\- ch) + then (setq state 2) + else (setq state 0))) + (2 (case ch + (#\> (return (makestr))) + (#\- nil) ; still in state 2 + (t (setq state 0)))))))))) + + + + + +(defun emit-clp-entity (req ent objects) + ;; send objects in the clp to the output stream + (dolist (obj objects) + ;(format t "process ~s~%" obj) + (if* (consp obj) + then (case (car obj) + (:text (write-sequence (cadr obj) *html-stream*)) + (:clp + (destructuring-bind (mod fcn args body) (cdr obj) + (let ((func (find-clp-module-function mod fcn))) + (if* func + then (funcall func req ent args body))))))))) + + + + + +(defvar *clp-modules* (make-hash-table :test #'equal)) + +(defun find-clp-module (modname &key create) + (let ((mod (gethash modname *clp-modules*))) + (or mod + (if* create + then (setf (gethash modname *clp-modules*) + (make-hash-table :test #'equal)))))) + +(defun find-clp-module-function (module function) + ;; get the specified function in the specified module + (let ((mod (find-clp-module module))) + (and mod (gethash function mod)))) + + + + + +;; define a clp handler +; args to lambda are req ent args body +;; +(defmacro def-clp-function (fcn args &rest body) + (let ((name (if* (symbolp fcn) + then (string-downcase (symbol-name fcn)) + elseif (stringp fcn) + then fcn + else (error "The first argument to def-clp-function should be a string or a symbol, not ~s" fcn))) + (module) + (function) + (pos)) + + (setq pos (position #\_ name)) + (if* (null pos) + then (error "def-clp-function names must have an underscore in them ~ +to separate the module part from the function name part, ~s doesn't" name)) + (setq module (subseq name 0 pos) + function (subseq name (1+ pos))) + + `(setf (gethash ,function + (find-clp-module ,module :create t)) + #'(lambda ,args ,@body)))) + + + + +;;------- support for storing variables in the request object + +(defun request-variable-value (req name) + ;; get the value of the named variable in the request variable list + ;; + (cdr (assoc name (getf (request-reply-plist req) 'variables) + :test #'equal))) + +(defsetf request-variable-value .inv-request-variable-value) + +(defun .inv-request-variable-value (req name newvalue) + (let ((ent (assoc name (getf (request-reply-plist req) 'variables) + :test #'equal))) + (if* ent + then (setf (cdr ent) newvalue) + else ; must add an ent + (push (cons name newvalue) + (getf (request-reply-plist req) 'variables)) + newvalue))) + + +(provide :webactions) Added: vendor/portableaserve/aserve/webactions/clpcode/.cvsignore =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/webactions/clpcode/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,6 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/clp.cl/1.4/Tue Aug 31 02:53:17 2004// +/http.cl/1.1/Tue Dec 2 14:36:33 2003// +/time.cl/1.1/Tue Dec 2 14:36:33 2003// +/wa.cl/1.1/Tue Dec 2 14:36:33 2003// +D Added: vendor/portableaserve/aserve/webactions/clpcode/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/webactions/clpcode Added: vendor/portableaserve/aserve/webactions/clpcode/CVS/Root =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/webactions/clpcode/clp.cl =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/clp.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/clp.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,307 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; clp.cl +;; clp functions named clp_xxx +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: clp.cl,v 1.4 2004/08/31 02:53:17 kevinrosenberg Exp $ + + +(in-package :net.aserve) + +(def-clp-function clp_base (req ent args body) + ;; put out a base tag for this page. + ;; use this in the head section so that relative links to images + ;; and such are properly handled + ;; + (declare (ignore args body)) + (write-string "<base href=\"" *html-stream*) + (render-uri (copy-uri (request-uri req) :path (path ent)) + *html-stream*) + (write-string "\">" *html-stream*)) + + + +(defun locate-any-value (req args name) + ;; find the value with the given name looking in one of three + ;; places: + ;; the request object's list of variable [the default] + ;; the query + ;; the session + ;; + (let ((location :request)) + (if* (assoc "query" args :test 'equal) + then (setq location :query) + elseif (assoc "session" args :test 'equal) + then (setq location :session)) + + (case location + (:request + (request-variable-value req name)) + (:query + (request-query-value name req)) + (:session + (websession-variable (websession-from-req req) name))))) + +;; NDL 2004-06-04 -- LispWorks needs the eval-when in order to use this form further down +;; the same file. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defsetf locate-any-value .inv-locate-any-value)) + +(defun .inv-locate-any-value (req args name value) + (let ((location :request)) + (if* (assoc "query" args :test 'equal) + then (setq location :query) + elseif (assoc "session" args :test 'equal) + then (setq location :session)) + + (case location + (:request + (setf (request-variable-value req name) value)) + (:query + (setf (request-query-value name req) value)) + (:session + (setf (websession-variable (websession-from-req req) name) value))))) + +(defun cvt-to-integer (value) + ;; convert value to an integer if possible + (if* (integerp value) + then value + elseif (stringp value) + then (parse-integer value :junk-allowed t))) + + +;; NDL 2004-06-04 -- I don't think LispWorks can change a socket's external-format. +(def-clp-function clp_value (req ent args body) + ;; name=xxxx + ;; safe + ;; external-format=fmt + ;; + ;; print the value of the variable + (declare (ignore ent body)) + (let* ((name (cdr (assoc "name" args :test #'equal))) + + (value (and name + (locate-any-value req args name))) + (safe (assoc "safe" args :test #'equalp)) + #-lispworks + (external-format + (cdr (assoc "external-format" args :test #'equalp)))) + #-lispworks + (if* external-format + then (setq external-format (find-external-format external-format))) + + (if* value + then (cond + ;; NDL - breaking with tradition heere and using cond, so I can comment + ;; out one clause without getting ugly. + #-lispworks + (external-format + (let ((old-ef (stream-external-format *html-stream*))) + (force-output *html-stream*) + (setf (stream-external-format *html-stream*) + (find-external-format :octets)) + (if* safe + then (html (:princ-safe value)) + else (html (:princ value))) + (force-output *html-stream*) + (setf (stream-external-format *html-stream*) old-ef))) + (t (if* safe + then (html (:princ-safe value)) + else (html (:princ value)))))))) + + +(def-clp-function clp_set (req ent args body) + ;; name=xxxx + ;; value=yyyy + ;; set the value of var xxxx to yyyy + (declare (ignore ent body)) + (let* ((name (cdr (assoc "name" args :test #'equal))) + (value (cdr (assoc "value" args :test #'equal)))) + (if* name + then (setf (locate-any-value req args name) value)) + value)) + + +(def-clp-function clp_ifgt (req ent args body) + ;; name=varname + ;; value=val + ;; + ;; compare the value of varname against the value. If it's + ;; greater than then process the body. + ;; + ;; if name or value cannot be turned into an integer value then + ;; it's assume to not be greater than. + ;; + (let ((name (cdr (assoc "name" args :test #'equal))) + (value (cdr (assoc "value" args :test #'equal)))) + (setq name (if* name + then (cvt-to-integer + (locate-any-value req args name))) + value (cvt-to-integer value)) + ;(format t "name ~s ... value ~s~%" name value) + (if* (and name value + (> name value)) + then ; process the body + (emit-clp-entity req ent body)))) + +(def-clp-function clp_iflt (req ent args body) + ;; name=varname + ;; value=val + ;; + ;; compare the value of varname against the value. If it's + ;; greater than then process the body. + ;; + ;; if name or value cannot be turned into an integer value then + ;; it's assume to not be greater than. + ;; + (let ((name (cdr (assoc "name" args :test #'equal))) + (value (cdr (assoc "value" args :test #'equal)))) + (setq name (if* name + then (cvt-to-integer + (locate-any-value req args name))) + value (cvt-to-integer value)) + ;(format t "name ~s ... value ~s~%" name value) + (if* (and name value + (< name value)) + then ; process the body + (emit-clp-entity req ent body)))) + +(def-clp-function clp_ifeq (req ent args body) + ;; name=varname + ;; value=val + ;; + ;; compare the value of varname against the value. If it's + ;; greater than then process the body. + ;; + ;; if name or value cannot be turned into an integer value then + ;; it's assume to not be greater than. + ;; + (let ((name (cdr (assoc "name" args :test #'equal))) + (value (cdr (assoc "value" args :test #'equal)))) + (setq name (if* name + then (cvt-to-integer + (locate-any-value req args name))) + value (cvt-to-integer value)) + ;(format t "name ~s ... value ~s~%" name value) + (if* (and name value + (eql name value)) + then ; process the body + (emit-clp-entity req ent body)))) + + + +(def-clp-function clp_ifdef (req ent args body) + ;; name=varname + ;; + ;; if name has a non-nil value then emit body + ;; + (let ((name (cdr (assoc "name" args :test #'equal)))) + (if* (and name (locate-any-value req args name)) + then ; process the body + (net.aserve::emit-clp-entity req ent body)))) + +(def-clp-function clp_ifndef (req ent args body) + ;; name=varname + ;; + ;; if name is not defined or has nil value then emit body + ;; + (let ((name (cdr (assoc "name" args :test #'equal)))) + (if* (not (and name (locate-any-value req args name))) + then ; process the body + (net.aserve::emit-clp-entity req ent body)))) + + + +(def-clp-function clp_ifequal (req ent args body) + ;; name=varname + ;; value=val + ;; + ;; compare the value of varname against the value, which + ;; are both strings + ;; + ;; + (let ((name (cdr (assoc "name" args :test #'equal))) + (value (cdr (assoc "value" args :test #'equal)))) + (setq name (if* name + then (locate-any-value req args name))) + ;(format t "name ~s ... value ~s~%" name value) + (if* (equal name value) + then ; process the body + (emit-clp-entity req ent body)))) + + +(def-clp-function clp_options (req ent args body) + ;; if body contains a zero or more text elements then convert to + ;; a list of option strings and change to (:options ..) + ;; args contains a "name" tag which says which request query + ;; value contains the default value + (declare (ignore ent)) + (let ((val (locate-any-value + req args (or (cdr (assoc "name" args :test #'equal)) ""))) + (firstselect) + (options)) + (if* (dolist (form body t) + (if* (not (eq :text (car form))) + then (return nil))) + then ; all :text forms + (let (res (s (make-string-input-stream + (apply #'concatenate 'string + (mapcar #'second body))))) + (loop + (let ((ent (read s nil s))) + (if* (eq s ent) then (return)) + (push ent res))) + (setf (car body) `(:options ,(nreverse res))))) + (if* (zerop (length val)) then (setq firstselect t)) + + (setq options (if* (and (consp body) + (consp (car body)) + (eq :options (caar body))) + then (cadr (car body)))) + (dolist (opt options) + (if* (or firstselect + (equal val opt)) + then (format *html-stream* + "<option selected>~a</option>~%" opt) + (setq firstselect nil) + + else (format *html-stream* + "<option>~a</option>~%" opt))))) + +(def-clp-function clp_select (req ent args body) + ;; this just does a <select> ... </select> + ;; but is useful in cases where clp_options is used and + ;; you're using an html editor that gets confused by + ;; <select><clp_options ...> </select> + ;; + (format *html-stream* + "<select") + (dolist (arg args) + (format *html-stream* " ~a=~s" (car arg) (cdr arg))) + (write-char #\> *html-stream*) + (emit-clp-entity req ent body) + + (write-string "</select>" *html-stream*)) + + Added: vendor/portableaserve/aserve/webactions/clpcode/http.cl =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/http.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/http.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,42 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; http.cl +;; clp functions named http_xxx +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; $Id: http.cl,v 1.1 2003/12/02 14:36:33 rudi Exp $ + +(in-package :net.aserve) + + +(def-clp-function http_header-value (req ent args body) + (declare (ignore ent body)) + (let ((header-name (cdr (assoc "name" args :test #'equal)))) + (if* header-name + then (let ((value + (header-slot-value req + (read-from-string + (format nil ":~a" + (string-downcase header-name)))))) + (html (:princ-safe value)))))) + + Added: vendor/portableaserve/aserve/webactions/clpcode/time.cl =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/time.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/time.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,39 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; time.cl +;; clp functions named time_xxx +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: time.cl,v 1.1 2003/12/02 14:36:33 rudi Exp $ + +(in-package :net.aserve) + + +(net.aserve:def-clp-function time_universal-time + (req ent args body) + (declare (ignore req ent args body)) + (net.html.generator:html (:princ-safe (get-universal-time)))) + + + + Added: vendor/portableaserve/aserve/webactions/clpcode/wa.cl =================================================================== --- vendor/portableaserve/aserve/webactions/clpcode/wa.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/clpcode/wa.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,84 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; wa.cl +;; clp functions named wa_xxx +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: wa.cl,v 1.1 2003/12/02 14:36:33 rudi Exp $ + + +(in-package :net.aserve) + + +(def-clp-function wa_link (req ent args body) + (declare (ignore body)) + (let ((wa (getf (entity-plist ent) 'webaction)) + (session (getf (request-reply-plist req) 'websession))) + (and wa + (let ((name (locate-action-path + wa + (cdr (assoc "name" args :test #'equal)) + session))) + (html (:princ name)) + (let ((extra (cdr (assoc "extra" args :test #'equal)))) + (if* extra + then (html (:princ extra)))) + + )))) + + + + + +(def-clp-function wa_showerrors (req ent args body) + (declare (ignore ent body)) + (let* ((name (cdr (assoc "name" args :test #'equal))) + (clear (cdr (assoc "clear" args :test #'equal))) + (errs (locate-any-value req args (or name "")))) + + (if* clear + then (setf (locate-any-value req args (or name "")) + nil)) + + (if* errs + then (if* (atom errs) + then (setq errs (list errs))) + (html ((:font :color "red") + :br + (dolist (err errs) + (html (:princ-safe err) :br)) + :br + ))) + )) + + + + + + + + + + + + Added: vendor/portableaserve/aserve/webactions/doc/.cvsignore =================================================================== --- vendor/portableaserve/aserve/webactions/doc/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +{arch} +.arch-ids Added: vendor/portableaserve/aserve/webactions/doc/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/webactions/doc/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,4 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/using-webactions.html/1.1/Tue Dec 2 14:36:33 2003// +/webactions.html/1.2/Tue Feb 17 12:48:43 2004// +D Added: vendor/portableaserve/aserve/webactions/doc/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/webactions/doc/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/webactions/doc Added: vendor/portableaserve/aserve/webactions/doc/CVS/Root =================================================================== --- vendor/portableaserve/aserve/webactions/doc/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/webactions/doc/using-webactions.html =================================================================== --- vendor/portableaserve/aserve/webactions/doc/using-webactions.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/using-webactions.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,596 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"><html><head><title>Using webactions</title></head><body> +<h1 style="text-align: center;">Using Allegro Webactions +</h1> +<h2>Introduction</h2> +The web sites of the past began as a way to display static data. +Today's web sites, +however are graphical user interfaces to services or collections of data.  They +are no longer simply web sites, but rather web applications.  +From banking +tasks to airline reservations to news sites, consumers are accessing +content-specific data +via an internet browser.  +Creating a web application is, in many ways, more difficult than +creating a standalone +application -- and it will become even more so as users demand +increasingly customized +features/services.  This paper will discuss some of the key +challenges web +application developers face, and how Allegro Webactions +solves these problems.   Allegro Webactions sits on top of +AllegroServe (Franz Inc.'s +Lisp-based web server) and  provides a framework for +building  web applications +that are easy to maintain and update.     + + +<h2>Skyscrapers can't be built on the foundation of a Log Cabin</h2> +Customers are continuously demanding more, better, and faster services +from web +applications. Unfortunately, many developers are still attempting to +layer dynamic +features on top of a static structure.  In order to successfully +cater to user +demands, we must change the paradigm of how web sites are built and +structured.  What +worked for a 10 page web site two years ago, will not work for a 100 +page site that +includes numerous databases and an e-commerce application.  Some +key challenges that +need to be addressed include the following: + +<h3>SessionControl</h3> +The web server must track individual visitors as they navigate +through the web site. +  The first time a visitor comes to the web site the server +assigns that visitor a session object. +  Subsequent requests by the same visitor must be assigned the +same session object so that the code processing the request does +work for that specific visitor.  For example a  visitor +entering a shopping site is +assigned a virtual shopping cart.  As the visitor adds items to +the cart he expects to +see previously added items still in the cart.   Without a session +object the visitor +would find that his shopping cart was always empty which, needless to +say, would destroy +the concept of online shopping. +The http protocol on which +the web is built is +a connectionless protocol.   A visitor does not connect to a web +site and stay connected +until moving to another web site.   Thus there needs to be some +means for each +request to identify the visitor behind the request.   Cookies +were designed for this purpose.  A web server can ask a web +browser to store a value +on the visitor's machine that will be returned to the web server on +subsequent requests. +  +Cookies are a great tool for tracking sessions however some visitors +disable cookies due +to privacy concerns.  Therefore, a web application must be +prepared to fall back on +other methods for tracking sessions.     + +<h3>Web Designer vs. Programmer</h3> +Building a web application requires two types of talent: a web page +designer and a +programmer.    Once the web site is up and running the daily +maintenance can be +done by the web page designer.   If significant new functionality +is needed the +programmer may have to return to write new code. +A successful web application framework should allow +for the web site to be modified by either the designer or the +programmer, depending on the +task.  Requiring a programmer to be involved every time a product +or text change +occurs is inefficient and expensive.  + +<h3>Dynamic Site Enhancement</h3> +Web sites evolve constantly -- some even need to be updated hourly. +  And, if a +site is being accessed many times a second, the site can't go down +while these +modifications are made.  A site's framework must support changing +the static content +and the dynamic content generation functions.     + +<h3>Dealing With Complexity</h3> +A web application usually consists of a large set of pages with +various links between +them.   When new features are added, new pages are also added, +which cause links to +be added or modified.  Plus, there are often several paths through +the web site that +must yield equivalent results.  For example, in a shopping site a +visitor can just start +adding items to the shopping cart, and then identify himself at +check-out. + Alternatively, a visitor can first identify himself and then +start adding items to his cart.  In either case, the same products +are ordered..    + +Many web sites are like unstructured programs with "goto's" all over +the place. As +more products and features are added, the complexity can become +overwhelming -- the site +becomes slower, more brittle, and less robust with each change.  +Something has to be +done to organize and simplify the process. + +<h2> +</h2> +<h2> +</h2> +<h2>Model View Controller</h2> +Suppose a web site is selling clothing.    A user sees a +nice sweater and +clicks on the button to add that sweater to his cart.  The +webserver gets the +request.  How should it handle it? + +One way would be to write a function that identifies the user sending +the request, adds +the sweater to that user's shopping cart, and then writes out a page +showing the current +contents of the cart.   This type of monolithic +function approach works, but is not very flexible.  +Perhaps a change +needs to be made that requires an inventory check first, and then +displays a different +message if the item is not in inventory.  That would make the +programmer have to +rewrite the monolithic function.   Maybe the cart contents need to +be displayed from +a link on every store page.  Since the cart displayer code is in +the handler function +we just described, the code must be duplicated or pulled out to be a +separate routine. +   In the monolithic function approach, the logic to choose +what to display next +is intermixed with the code to manipulate the store database and to +display store items. +  This makes it very hard to figure out all the links through the +web site. + +A better way to design a web application is to separate out these three +types of code: +<ul> + <li>Model - this is code to manipulate the data of the website. +  If the web site is a store then this category includes the code +to create carts and orders, compute shipping costs and charge credit +cards.   </li> + <li>View - this is the code to display the data of the web site on a +web page.   The data is not modified by the code that causes it to +be displayed. </li> + <li>Controller - when a link or button is clicked on a web page this +causes the action (if any) to be performed and then causes something to +be sent back to the browser.   The action is performed by calling +on Model functions.  The browser received data due to  a call +on a View function.    The controller  is the manager of +the web site, it directs requests to model functions and to view +functions. </li> +</ul> +Using the MVC paradigm when the user asks to add a sweater to his +cart  a Model +function is called.   The Model function manipulates the store's +databases to add the +sweater to the user's cart.    The View function then +displays the cart. +  +<h2>A Flexible Foundation</h2> +The paradigm described above, can easily be executed using Allegro +WebActions and +AllegroServe.  Although there exist a number of web application +frameworks, +Webactions' simplicity, transparency and power distinguish it from +other tools.   +Allegro WebActions uses Lisp as the web extension language.   Lisp +is not a simple +scripting language (like Perl or PHP) or a byte interpreted +strongly-typed language (like +Java).   Lisp is a flexible runtime-typed language that compiles +down to machine +code.   As a result, code written in the Lisp extension language +runs at machine +speed with no interpreter overhead. +Webactions borrows ideas from the <a href="http://jakarta.apache.org/struts/index.html">Struts</a> +web application framework for Java.    Struts has good ideas +for mapping web +applications into the Model-View-Controller paradigm (more on this +below).     +Due to the more static design of the Java language, Struts is not as +easy to use as +Webactions. + +<h2>Webactions components</h2> +Unlike many other tools, which were cobbled together as web site +requirements +increased, Allegro WebActions was designed specifically to support +complex web +applications.  It can easily support the key challenges outlined +in this paper: +<h3>Session Control</h3> +Webactions supports  url +rewriting in +addition to Cookies.  In url rewriting the links to +other pages in the site +are modified to include a session identifier.    Webactions +automatically does +the check for disabled cookies and then switches to url rewriting, if +necessary. +Webactions is also careful to create session identifiers that are +unique and virtually +impossible to guess.  This prevents a malicious user from +guessing a valid session +identifier and hijacking another user's session.   +<h3>Separation of Text and Code</h3> +Webactions provides a clear distinction between web design and +programming, allowing +web designers to work independently with their choice of tools.   +Webactions +introduces  a  syntax of special tags that display dynamic +content in static +pages.   This syntax was designed specifically so that  +existing "What you +see is what you get" (WYSIWYG) html editors  such as FrontPage and +Mozilla will +accept them.     Webactions does not permit programming +constructs to appear in +html pages, so web designers won't see code they don't understand. +   This is +not to say that Webactions forbids other scripting languages (such as +javascript) from +appearing in web pages.  Webactions simply does not add its own set of programming constructs +to html (as Java +Server Pages do for example). +<h3>Dynamic Updates</h3> +Webactions automatically notices when static pages are updated on +the disk and begins +serving them immediately.    One can load in new definitions +of dynamic +functions and have them in use right away (this is a benefit of all +Lisp programs). +<h3>Complexity</h3> +Webactions adds a layer of abstraction which greatly simplifies the +code.   Web +pages are denoted by symbolic names.   Links from one web page to +another are made +using the symbolic name, as well.    There is a single +project description that +lists all symbolic page names and describes how each is rendered. +    This +project description allows a programmer to see a complete overview of +the web site.   +Also, symbolic page names can be changed without having to edit any +file that refers to +it.  +<h2> +Components of an Allegro WebActions Web Site +</h2> +<ol> + <li>Project Description - Describes the pages in the +project and where static pages are found and gives some parameters +values.  The project description can be modified and loaded in +while the web site is running, thus allowing the site to change dynamically +(in true Lisp fashion). </li> + <li>Static Pages -Created by the web designer, they +can be changed at any time.  The next time an updated or new page +is referenced, the new value will be used. </li> + <li>clp-functions - these are Lisp functions that +display html (generally these are used to show the dynamic parts of +pages). </li> + <li>Action functions - these are Lisp functions that +interact with the application behind the web site (e.g. the store). </li> +</ol> +In MVC terms, the project description is input to the Controller. + Items 2 and 3 +are View components.  The Model functions are item 4. + Allegro Webactions itself +implements the Controller. + +<h2>Simple Example</h2> +Let's examine a very simple Webactions web site.   The project +description is: +<pre>(webaction-project "simpleproject" :destination "site/" :index "home" :map '(("home" "pageone.clp") ("second" "pagetwo.clp"))) </pre> +Let's skip right to the :map argument.   Its value is a list of +the pages that +make up this project.   Each page is described by its symbolic +page name followed by +an object  which describes how the  page is to be rendered. + In this example +we have two pages, one named "home" and the other "second".   +  The render value for each of these pages is a string which in +Webactions means that +each is rendered by serving a file on disk with the given name. + +There are two files that accompany this project description: + +site/pageone.clp: + + +<pre><html> <body> This is page one. Go to <a href="second">page two<a> </body> </html> </pre> + +site/pagetwo.clp: + + +<pre><html> <body> This is page two. Go to <a href="home">page one<a> </body> </html> </pre> + + +You'll note that the clp +files look just like html +files.  This is intentional.   A clp file +is just an html file that is processed by Webactions before being sent +to the browser. Two +types of  processing are done by Webactions.  First all +symbolic page references +are replaced by page references that work in the current context. +  Symbolic page +references are found in two places:  href="xxx" inside an <a> element and  +action="xxx" inside +a <form> element.   +Second if there are +references in the clp file to special clp Lisp functions, then those +functions are called at the +appropriate time when the page is being sent to the browser. + +In our example above each clp page has one symbolic page reference. +  Suppose we load +Webactions and this project definition into Lisp and start the server +on port 8000. + We go to a web browser and ask for http://localhost:8000/. +What happens is the url in the web browser changes to http://localhost:8000/home +and we see: + + +<div style="margin-left: 80px;"> +This is page one. +Go to page two. + +</div> + +The reason the url changed to "/home" is that in the project definition +we +specified "home" as the index page for this project.  Thus +accessing the +project without specifying a particular page resulted in the request +being redirected to +the index page. + +We click on the "page two" link and the browser now shows a url like: + +<div style="margin-left: 40px;"> +http://localhost:8000/~159c546f07540c5a9ee4155d~/pagetwo.clp + + +</div> +and we see in the main frame of the web browser: + + +<div style="margin-left: 80px;"> +This is page two. +Go to page one. + +</div> + + +Why does the url look so strange?  The reason is that when the +first page (the +page named "home") was processed by Webactions and sent back to the +browser, +Webactions didn't know if the browser would accept a cookie.   +What Webactions did +was send a cookie back with the page and at the same time it put the +session identifier in +the url for all symbolic page references.   The number +159c546f07540c5a9ee4155d is +the session id chosen by Webactions.    When you clicked on page two +this caused the +web browser to send a request for that page to Webactions.   That +request either +arrived at the web server with cookie value or it did not.   If +the request came with +the cookie value then Webactions notes that for this session Webactions +can depend on the +cookie value being sent with each request and thus Webactions will not +put the session id +in any more urls.  If the cookie value wasn't sent then Webactions +notes that it will +have to alter urls for this session and Webactions no longer tries to +send cookies for +this session. +If you run this simple example twice, once with your browser set to +accept cookies and +once with it set to  not accept cookies you can see how Webactions +adapts to your +browser setting and still maintains session identity. +This simple two web page example doesn't do anything that couldn't +have been done with +two static html pages.    Even though this example doesn't +make use of it, +Webactions is maintaining session information while the pages of this +example are +accessed.   We'll extend the example to make use of session +tracking by counting the +number of times pages in this session were accessed.   + + + +<h2>Adding a clp function +</h2> +We'll change the two clp files to add a line showing the hit count: + +site/pageone.clp + +<pre><html> <body> This is page one. Go to <a href="second">page two<a> session hits: <sample_hitcount/> </body> </html> </pre> + +site/pagetwo.clp + + +<pre><html> <body> This is page two. Go to <a href="home">page one<a> session hits: <sample_hitcount/> </body> </html> </pre> +and then we define  a clp function in this way and load it into +the Lisp running +the web server: + + +<pre>(def-clp-function sample_hitcount (req ent args body) (let ((session (websession-from-req req))) (net.html.generator:html (:princ (setf (websession-variable session "hitcount") (1+ (or (websession-variable session "hitcount") 0))))))) </pre> +Now we again go to a browser and view the pages.   Now we see +pages like this: +<div style="margin-left: 80px;"> +This is page one. +Go to page two. +session hits: 9 + +</div> +What is happening now is that when Webactions returns pageone.clp it +sends all of the +page up to but not including <sample_hitcount/> to the browser, +then it runs the sample_hitcount +clp function, and then it sends the +contents of  pageone.clp after <sample_hitcount/> to the +browser.   + The sample_hitcount +function retrieves the +session object associated with this request (using websession-from-req) +and uses this session object to increment the session variable named +"hitcount". +  You're free to define as many session variables as you wish. + If you access a +session variable that hasn't been set, the value nil +is returned.   sample_hitcount +increments the +"hitcount" variable for this session and then prints it to the html +stream. +  + +You may have noticed in the clp files that we used an xhtml syntax +when we wrote html +code to invoke sample_hitcount: + +<div style="margin-left: 40px;"> +<sample_hitcount/> + +</div> +We could have written the equivalent + +<div style="margin-left: 40px;"> +<sample_hitcount></sample_hitcount> + +</div> +instead but the former is easier to type.   While some html +elements don't have a +body (e.g. <img>) all +clp elements we add to +html have a body and the end of the body must be +denoted in one of the two above ways. + + +<h2>Actions</h2> +The previous examples show the use of static clp pages and the +introduction of dynamic +content via clp functions.   There is one important part of +Webactions left to +describe and that is Actions.    When a web page is +referenced symbolically it +can invoke a lisp function to perform some action.  Usually that +action affects the +data object behind the web site or the current session object.   +After the action is +performed an invisible redirect is done to another page on the web site +which is then +handled either by another action or by displaying a web page. +Actions should never send anything to the web browser.  The sole +function of an +action is to affect the state of the Model behind the web site for this +particular +session. + +Our example for the use of actions is something found in most +dynamic web sites these +days:  the login page.  In our sample web site we want to +know the name of the +person visiting our site so we can personalize the page.   + The user enters the +web site at the main entry point  and we check to see if he has +logged on yet. + If so we go right to the home page of the site.   If he +hasn't then we ask him +to identify himself and once that's done we go to the home page of the +site. + +We begin with the project description and the two actions referenced: + +<pre>(webaction-project "simpleproject" :destination "site/" :index "home" :map '(("home" action-check-login) ("login" "login.clp") ("gotlogin" action-got-login) ("realhome" "home.clp"))) (defun action-check-login (req ent) (let ((session (websession-from-req req))) (let ((user (websession-variable session "username"))) (if* user then ; already logged in ; just go to the real home "realhome" else ; must login "login")))) (defun action-got-login (req ent) (let ((username (request-query-value "username" req))) (if* (and username (> (length username) 0)) then (setf (websession-variable (websession-from-req req) "username") username) "realhome" else "login"))) </pre> + +We have four symbolic pages named in this project.   Two of them +refer to clp files +we'll show below.   Two others refer to lisp functions that we +call action functions.   + Users coming to the site +are redirected to the page with symbolic name "home".  That causes +action-check-login to be +called.  The action-check-login +function checks to see if this session +has a non-nil value for the session variable "user".  If so the +user has +already logged in.    Action functions never send anything +back to the browser. + They simply return a string which is the symbolic name of the +page in the project +that should be processed next.    This action function +returns either +"realhome" or "login".     Both of those symbolic page names +refer to clp files in the project description. +site/login.clp + +<pre><html> <body> What is your name: <form action="gotlogin"> <input type="text" name="username"> <input type="submit"> </form> </body> </html> </pre> +site/home.clp + +<pre><html> <body> Welcome to my page, <clp_value name="user" session/>. </body> </html> </pre> +The login.clp file puts up a form that asks the visitor to enter his +name.   When +the submit button is pressed control goes to symbolic page name +"gotlogin". +  In our project,  symbolic page name "gotlogin" is handled +by action +function  action-got-login +shown above.   + This action function reads the user name from the form and if +it's non-empty it +stores  the user name in the session variable named "user".   +  action-got-login +returns either symbolic page name +"realhome" (if a valid user name was given) or "login" if a name +wasn't given and if the visitor must try again to identify himself. +The symbolic page "realhome" is connected to the file home.clp. + This is a +very simple home page that simply welcomes the user by name.  The +clp_value function +is part of the built-in Webactions library.  It retrieves and +prints the value of a +variable.   Here the variable name is "user" and the context is +"session".   + +<h2>Further Information</h2>The <a href="webactions.html">Allegro Webactions</a> document is a reference manual for clp pages and Webactions. +<h2>Summary</h2> + +Allegro WebActions is a dynamic framework for building a web +application. + Webactions does the work necessary to track sessions whether or +not the browser +accepts cookies and allows the visual part of the website to be +designed by html +programmers using tools they are accustomed to using.  The dynamic +part of the web +site is clearly partitioned from the static part so that the +programming behind the web +site will not interfere with the visual part. Allegro WebActions makes +it easier to +structure and update any web application in a cleaner, simpler way than +with other current +web application building tools.  + + +</body></html> \ No newline at end of file Added: vendor/portableaserve/aserve/webactions/doc/webactions.html =================================================================== --- vendor/portableaserve/aserve/webactions/doc/webactions.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/doc/webactions.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1239 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> +<html> +<head> + <title>Allegro Webactions</title> +</head> +<body> +<h1 style="text-align: center;">Allegro Webactions +v1.4 +</h1> +<h4>copyright(c) 2003. Franz Inc</h4> +<h1>Table of Contents</h1> +<a href="#introduction">Introduction +</a><a href="#Loading_Webactions">Loading Webactions</a> +<a href="#Common_Lisp_Server_Pages_">Common Lisp Server Pages</a> +  <a href="#Processing_a_clp_file">Processing a clp file</a> +  <a href="#clp_elements_with_bodies">clp elements with bodies</a> +  <a href="#parsing_clp_files">parsing clp files</a> +  <a href="#clp_tag_and_function_names">clp tag and function names</a> +  <a href="#The_Lisp_side_of_clp">The Lisp side of clp</a> +<a href="#Webactions">Webactions</a> +  <a href="#Webaction_project">Webaction project</a> +   <a href="#Classes_used_in_webactions">classes used in +Webactions</a> +   <a href="#Lisp_functions_for_webactions">Lisp functions +for Webactions</a> +  <a href="#Library_of_clp_functions"> Library of clp +functions</a> +    +<h1><a name="introduction"></a>Introduction</h1> + Most of the web sites people visit again and again are dynamic. +These pages range from pages containing static data and a dynamically +selected banner ad to pages full of personalized content, such as a +search page returned by Google.  AllegroServe offers two different +ways of creating dynamic pages. The most general is the publish +function which allows the programmer to completely generate the +response +to an http request.  Also the publish-multi function +creates +pages that are a mixture of static data and data generated by a lisp +function. It's possible to build a large dynamic web site using just +these functions but it does require that you have a lot of programming +talent at your disposal. It's far easier to find html designers than +Lisp programmers and so we designed a method of building large dynamic +web sites in AllegroServe that uses mainly html designers with some +support from Lisp programmers. This is the purpose of Common Lisp Server Pages (or clp) and Webactions. + +Webactions is the framework used to describe the whole site and to +control access to pages in the site.    clp files provide a +way of mixing static and dynamic html that works well with the +webaction +framework.   We'll describe clp pages first and then the webaction +framework. + +Please see the document <a href="using-webactions.html">Using +Webactions</a> for further background information on webactions. + +<h2> +</h2> +<h1><a name="Loading_Webactions"></a>Loading Webactions</h1> +In order to load in Webactions you should (require +:webactions).   +This will load in AllegroServe if it isn't already loaded.  The +functions in Webactions are exported from the net.aserve package. + +<h1><a name="Common_Lisp_Server_Pages_"></a>Common Lisp Server Pages +</h1> + Common Lisp Server Pages is modeled after similar designs for +other +languages: Java Server Pages, Active Server Pages, Personal Home Pages +(PHP) and others. + A Common Lisp Server Page file looks just like an html file.  +In fact the format is the same as html.  We've extended html by +allowing new tags which cause extended functionality to be invoked. + +The key features of clp are: +<ul> + <li>A clp file can be edited with an html editor (such as FrontPage +or Mozilla's built-in html editor named Composer). </li> + <li>clp files can contain javascript or other scripting code. </li> + <li>a clp file can contain illegal html. The clp file processor does +not attempt to verify that the file contains valid html syntax. + While we don't recommend that you use illegal html we do know +that +some people do and that won't prevent you from using clp files. </li> + <li>A clp file does not contain any lisp code. A clp file may +contain tags that cause Lisp code to be run to render html, but it does +not contain Lisp code. The html designers  editing the clp files +will likely not know Lisp. The presence of code in the file that they +don't understand would confuse them and they may inadvertently modify +the Lisp code and cause it to fail. </li> + <li>The clp file processor, when used with the webactions framework, +supports the notion of sessions which are automatically maintained by +cookies (preferably) and by url rewriting otherwise. </li> +</ul> +<h2><a name="Processing_a_clp_file"></a>Processing a clp file</h2> +This is a sample clp file: + +<pre><html> <body> You are using this browser: <http_header-value name="User-Agent"/> How do you like it? </body> </html></pre> +You'll notice two unusual things in the file.  One is the tag http_header-value, which you've +never seen before.  The other is that tag ends in "/>", which is the xml and xhtml +way of specifying that this html element has no body.   It's +equivalent to writing the pure html: +<div style="text-align: center;"> +<pre><http_header-value name="User-Agent"></http_header-value></pre> +</div> +The tag http_header-value +names + a clp function.   A clp function is +written in Lisp and is run during the time this page is sent back to +the +browser.   Thus when this page is retrieved by a browser, the +result  is that all the text in the file up to the +http_header-value tag would be sent directly to the browser.  Next +the http_header-value function would be run and it will emit html which +will be sent back to the browser.  Finally the text after the +http_header-value tag will be sent to the browser. + +The clp function http_header-value is supplied with AllegroServe. + As its name suggests it retrieves the value from an http header +in +the request and then emits the value as html.   In our sample file +we're retrieving the value of the User-Agent header which describes +which http client is making the request. + +A user accessing this page would see something like this in his browser: + +<pre>You are using this browser: Netscape 4.01 How do you like it?</pre> + + +<h2><a name="clp_elements_with_bodies"></a>clp elements with bodies</h2> +The example above uses a clp element with no body.  This is what +you'll typically find in use.   However there are situations +where you want to give the element a body, the most notable one being +when you want a clp function to determine which parts of a clp file are +sent back to the browser.   For example + +<pre><clp_ifdef name="winner" session> You are the Winner! </clp_ifdef> <clp_ifndef name="winner" session > Sorry, you lost </clp_ifndef></pre> + +This clp file fragment checks to see if the session state has a +variable +named winner defined and if it does it includes the appropriate text. + If winner is not defined then +it includes the loser message.    The clp_ifdef and +clp_ifndef +functions are supplied with AllegroServe. + +One problem with using conditional inclusion of text is that an html +editor's view of the clp file will include both versions of the text +since it ignores unknown tags like clp_ifdef.   Thus you'll have +to +balance the power of using conditional text inclusion against the +problems it creates in that your html  editor can't display the +final product. + +<h2><a name="parsing_clp_files"></a>parsing clp files</h2> + +Before a clp file can be used to generate a response to an http request +it must be parsed.   The parsing function is very simple and  +is in fact more like pattern matching than traditional parsing. + The parser +simply locates all calls to clp functions in the file and +separates them from the text that is sent back verbatim as part of the +response.    A clp file is parsed when it's first referenced +in an http request and the results  of the parse are cached   +The clp file is not parsed again unless the file is updated on disk. + +<h2><a name="clp_tag_and_function_names"></a>clp tag and function names</h2> + +The clp parser has to be able to distinguish clp  tags from html +tags and from tags that are neither clp tags nor valid html tags. +  +The parser may encounter a clp tag referencing a clp function that's +not +yet defined (in Lisp we don't require that function be defined before +we'll recognize a call to that function).   The problem then is +determining whether a given tag in the file is a call to a clp function +or +a name that could be used as a clp function in the future.   The +strategy employed is the following:  A clp function name has two +parts: a module name and the name of the function within the module. + These names are separated by an underscore.  Thus http_header-value is the header-value function in the http module.   The clp parser +only has to look closely at tags with an underscore in them.   In +order to tell if such a tag is a clp function name the parser looks +only +at the module name.   If the module name is of a currently known +module then that  name is considered to be a clp function name. +Thus before you start running your web site you should define at least +one clp function in each module you intend to use.    You can +define the other functions later (and you likely will if you are +building your site and testing it incrementally). + + +<h2><a name="The_Lisp_side_of_clp"></a>The Lisp side of clp</h2> + +(def-clp-function +name (req ent args body) &rest function-body) + +This macro defines a clp function with the given name.   Name can be a string or a symbol (in +which case the downcased version of the symbol-name is used).  The +name must include an underscore between two of the characters (this +separates the module name from the function-with-the-module name). +   When called the function takes four arguments and we've +shown above the names we suggest be used for those four arguments. +  req and ent are the familiar  request +and +entity values passed to all http response functions.    Args +is an alist of attribute names and values found in the start tag that +invoked this function.  For example given the tag +<pre><mod_sample name="foo" value="24"></pre> +the value of args would be +<pre>(("name" . "foo") ("value" . "24"))</pre> +The fourth argument, body, is +passed the parsed version of the of the body of the element, that is +the +text that appears between the start and end tags in the clp file. +  + A clp function is not supposed to examine the value of body.  It should do one of two +things with body.  It can +just ignore the value in which case the text and calls to clp +functions  between the start and end tags is ignored and not sent +as part of the response to the web browser.   Alternatively it can +cause the body to be sent back +as part of the response by calling (emit-clp-entity +req ent body). + +The function-body is the code +that's run when the clp function is called.   It should emit html +just like the code in a normal http response function.  Often this +is done with the html macro. +  The value returned by this function is unimportant. + + + +(emit-clp-entity +req ent body) + +This is used inside a clp function to cause the contents of  body to be processed as a parsed clp +file.    This will result in strings being sent to the html +stream (and thus back to the browser) and it will cause clp functions +to +be run.     The only place this function should be used is +inside a clp function. + + + +<h1><a name="Webactions"></a>Webactions</h1> +Webactions is a framework for building dynamic web sites.   +Dynamic webs sites are difficult to build as they require more than +html +can provide, such as +<ol> + <li>sessions - the web site must follow each user as they move around +the site, perhaps picking up products and placing them in their virtual +shopping cart.   This is accomplished by associating a session +object in the web server with each distinct user.</li> + <li>database backed - the dynamic web site is often just a user +interface to a database.     Shopping sites display products +found in the store's database and add orders to the store's database. + It's useful to separate out the code that operates on the +database +and the code that displays the current state of the database.</li> + <li>complex linking - there are many paths through an online store as +goods are selected and finally an order is made.   Keeping track +of +these links is very hard as the site gets large. You need some way of +keeping track of the layout of the whole site. + </li> +</ol> +The webactions framework supports a programming methodology called +Model View Controller (or MVC).   In a dynamic web application the +pieces are these: +<ol> + <li>Model - this is the  code that implements the data objects +being manipulated by users of the web site.  In a online store the +model includes the notions of a shopping cart and orders and so on. +   This is the code that must be written specifically for the +objects being modeled.</li> + <li>View - the html pages that show the user a view of the model. + These pages are usually clp pages in the webaction framework. +  There will be some clp functions to implement the dynamic parts +of the pages.</li> + <li>Controller - the code that accepts user input and passes control +to the model to process the input and finally selects a  view to +send back to the user.   This code is supplied with the webaction +framework. + </li> +</ol> +A designer of a webactions-based web site will write or reuse Lisp code +to implement the Model.   For the View he'll write clp functions +in +Lisp  to support the clp pages written in html.   He'll +use the the Controller code supplied with Webactions. + + +<h2><a name="Webaction_project"></a> Webaction project</h2> + +A Webaction based web site is defined by a call to the +webaction-project macro.   + + +(webaction-project name &key project-prefix clp-suffixes map +destination index +                  + sessions session-lifetime reap-interval reap-hook-function server +authorizer +                   +host access-file clp-content-type external-format) + +webaction-project creates +project data structures and executes calls to publish to make the project exist on +the server.   + +The arguments are +name - a string naming the +project.   The name is used to ensure that if webaction-project is called again +with the same name,   the project by that name is redefined rather +than +creating a new project.   Also the name is used as the name of the +cookie that's used to track sessions in this project.   Since this +is a cookie name too the name should use just alphabetic and numeric +characters. +project-prefix - a string which +specifies the  prefix of all urls in the project.   The +prefix +should be a string beginning and  ending in the forward-slash +character, such as  "/myproject/" .  It's legal to use the +one +character string "/".    What this means is that all url's +beginning with this prefix are assumed to be part of this project and +are treated specially. +clp-suffixes -  a list of +strings naming the suffixes of files, which if found inside the +project, +are assume to be clp files.   By default the value of clp-suffixes +is a list of the string "clp".   You may wish to add "htm" or +"html" to this list if you want those files to be parsed as clp files +when referenced inside this project. +map - an assoc list of the +symbolic page name and how that page is generated.  This will be +described in detail below. +destination - the location on +the filesystem where the files that make up this project are to be +found.    This can be the empty string "" or the name of + a directory on the machine.  If you name a directory be sure +that the name ends in "/". +index -  the symbolic page +name of the main page of this project (also known as the index or root +page).   webaction-project will redirect to this page if a request +comes in for a url which is just the project-prefix.    If +the +project-prefix is  "/foo/" and the index is "home" then a request +for  "/foo" or "/foo/" will be redirected to "/foo/home" +sessions - if true (which is +the +default value) then track access to the pages of the project so that +all +accesses from a given web browser are assigned a unique websession +object. +session-lifetime - if the +session hasn't been accessed in this many seconds, remove the session +object from the internal table of sessions, allowing it to be garbage +collected.  The default session lifetime is 18000 seconds (i.e. +five hours). +reap-interval - the number of +seconds between checks to see if any sessions have expired and should +be +removed.   Specifying this variable sets a global variable (since +all webaction projects share the same session reaping process).   +The default value is  300 seconds (i.e. five minutes). +reap-hook-function - a function +of one argument, a websession object.  This is called when a +session is about to be destroyed due to no reference to this session +for the session-lifetime.   If this function returns a +non-nil value then the session will not +be reaped and instead the session will be treated as if it was just +reference and thus it wil be kept alive for another +session-lifetime.   One common use for this function is to +deallocate objects associated with the session that won't be recovered +by the Lisp garbage collector when the session is garbage collected. +server - this is the wserver +object into which this project will be published.   It defaults to +the value of *wserver*. +authorizer - an authorizer +object that will be associated with all entities created in this +project. +host - the value for the host +argument to the publish function used to establish the project +access-file - the filename of +the access file(s) found in the project's directory.   See +the documentation for AllegroServe's publish-directory for details on +access-files. +clp-content-type - a string +holding the content type for all clp files published in this +project.  The default is "text/html". +external-format - the external +format used when sending data back to the browser.   The +default is the value of *default-aserve-external-format* + + +A web site is  a collection of pages and images,  each page +with references to images and with links to other pages.   The +pages may be static or may be generated by programs.   The links + and image references may be within the web site or to other web +sites.   In a webaction web site we further distinguish managed pages +from unmanaged pages. + Session information is maintained as long as the user visits a +sequence of managed pages.  If a user visits an unmanaged page and +then follows a link to a managed page, the user may end up in a new +session.     Thus when designing a webaction web site it's +important to keep the user on managed pages until the session +information is no longer important. + +A clp file is a managed page.   An html file that's not a clp +file is an unmanaged page.   A page generated by a Lisp function + is a managed page if it uses the locate-action-path +function to +compute the url's for href and action attributes in the page it +generates.  Otherwise it's an unmanaged page. + +The reason that there's a distinction between managed and unmanaged +pages is that if the browser doesn't accept cookies then the only way +that session information can be maintained is through url rewriting, +and +only managed pages have the support for url rewriting. + +Every managed page is named by a distinct Lisp string we call the symbolic name of the page.   + All references to pages in clp files and in clp functions is to +the symbolic name of the page rather than the url of the page.   +The map argument to +webaction-project +associates the symbolic name of a page with the steps needed to render +the page. + +A symbolic page name can refer to a managed page, an unmanaged page or +an action.   An action is a Lisp function which performs some +operation and returns a symbolic page name.   Earlier we talked +about the Model View Controller methodology.   In MVC terms, the +action functions are operations on the Model.    An action +function should not generate any html, that's the responsibility of the +View code. + +<h3>Maps</h3> +The map argument +specifies +what steps are taken to process a request for  a symbolic +page.   In this section we'll describe the complete syntax of +the map value.  If you're just learning Webactions you'll probably +want to skip to the Simple  Maps section and then come back to +this section when you're done reading the rest of the +document.   + + +The value of the map argument is  a list of map entries: + +( map-entry1 +map-entry2  map-entry3 ....) + +Each map entry is  a list beginning with a symbolic page name and +followed by items which specify which actions to run, which view to +render and a set of flag values that apply to this entry.   +In pseudo-bnf the form of a map entry is: + +("symbolic page +name"  item* [ (:flag1 value1  ... ...) +] ) + +In our psuedo-bnf, the '*' means zero or more occurances.  The +square brackets mean +zero or one occurance. + +An item can be a symbol or a string.   If an item is a symbol +it names a lisp function which is either an action function or a view +function.  If the item is a string then it either names a file to +send back to the browser or a symbolic page name. + +An action function may modify the Model behind the website and then it +returns either  a string naming a symbolic page name, as string +naming a file to send back to the browser,  or the keyword symbol :continue meaning go on to the next +item in the map entry. +A view function will generate a response to the http request (which +usually means sending html  to the browser).  A view function +returns nil meaning that this +request has been processed and there's nothing more for webactions to +do. + +These are some typical map entries + +("home" +"homepage.clp") +("login" action-do-login "home") +("letter" +action-check-login  get-named-letter (:prefix t)) + +As noted above a string can represent either a file to send back to the +browser or a symbolic page name.    If a given string is +equal to the first value in a map entry then it is  symblic page +name, otherwise it's a file to send back to the browser.  There is +one exception: if a map entry doesn't have any items in it then the +string that's the first value of that map entry is the name of  a +file to return.   This special form is used when you wish to +add flags to the processing of a file.   This is an example: + +<big>("myletter.clp" +(:content-type "text/plain")) +</big> + +You need not understand the complete map entry syntax in order to use +Webactions.    In fact you can build useful web sites +using only a fraction of the features of map entries.   Next +we'll gradually introduce you to maps and show when you would want to +use the advanced features. +<h3> +</h3> +<h3>Simple Maps</h3> + +In its simplest form,  the +map is  a list of two element +lists.  Each two element list begins with the symbolic name of the +page.  This is followed by either the location of the page or a +function name.   A function name can either name a function that +will generate  a managed or unmanaged page, or it will be the name +of an action function.    Usually a function name will +not  +name a page generating function, instead clp files will be used for +each page, however in some situations it may prove useful  to have +totally dynamic pages generated by a lisp function. + +Here's an example of a map argument value + +<pre>(("home" "home.clp")   ("signin" "signin.clp")   ("newuser" action-new-user)   ("existinguser" action-existing-user)   ("failedlogin"  user-failed-login)   ("storefront"   "storefront.clp")) </pre> + +In the example we have three symbolic pages that refer to clp files. + These are thus managed pages.  Two symbolic pages refer to +functions whose names suggest they are action functions.   One +symbolic +page refers to a function user-failed-login which is a function to +dynamically create a page describing the failed login attempt. + +You can't distinguish an action function from a dynamic page generation +function based on what's in the map argument.   If you're wise +you'll use a naming convention such as used above to make the +distinction clear.    The way that webactions determines +which +is which when running the function is that an action function will +return a string and a dynamic html generation function will return nil. + +In a clp file relative urls that follow "href=" or "action=" are +considered to be the logical names of pages.  Thus you can write +<pre><a href="home"> blah blah </a></pre> +and that href will be transformed into the appropriate url such that +the link will be directed to the page associated with the page with the +logical name "home". +It's still possible to reference pages outside the project using +absolute paths in url, such as + + +<a href="/othersite/index.html>check this out too</a> + or <a href="http://www.cnn.com"> read the latest +news</a> + +Now we have the background to describe exactly what webaction-project +does.    webaction-project does a publish-prefix for the path +that's the value of project-prefix.  This means that any url in +that url-space will be processed as a reference to an object in this +project.   + +Let's create an example of a simple site that asks you to sign in and +once that's successful it lets you vote for your favorite food.   +The sign in process ensures that at most one vote is recorded for each +user. + +<pre>(webaction-project "sample" :project-prefix "/mysamp/" :destination "/usr/proj/sample/" :index "main" :map '(("main" "main.clp") ("signin" action-sign-in) ("choice"   choice.clp") ("vote"      action-vote) ("thanks"  "thanks.clp")))</pre> +              +The first page of the site has the logical name "main" and that causes +the file "main.clp" to be returned to the browser.  Here is +main.clp: +<pre><html> <body> <h1>Sign In Please</h1> <mysamp_showerrors/> <form action="signin" method="POST"> name: <input type="text" name="name" value="<clp_value name=name session/>"> password <input type="password" name="password"> <input type="submit"> </form> </body> </html> </pre> +There are just a few items to note in this page, and we've shown them +in bold.   The first is the element <mysamp_showerrors/>. +  This will cause a clp function to be invoked, which we'll +describe below.  The next item to note is that the value of action=  is a symbolic page +named +"signin".   The clp processor will transform "signin"  to the +appropriate value that depends on whether your browser is accepting +cookies. +  The final item to note is that the default value of the text +field for "name" is given by a clp_value +tag.   This clp_value retrieves the value of the session variable +"name", if +it has a value.   We'll see later how this session variable is +set. + The idea is that if the user typed in his name but failed to type +in the correct password, we'll prompt him again for his password and +will fill in the name field for him.   Note how the clp_value +element can be placed inside an html string value.   This is +because the clp file parser doesn't parse the html, it just looks for +clp element tags. + +The clp function mysamp_showerrors is this: +<pre>(def-clp-function mysamp_showerrors (req ent args body) (declare (ignore ent args body)) (let ((error (request-variable-value req "error"))) (if* error then (html :br ((:font :color "red") (:princ-safe error)) :br :br)))) </pre> +This function looks on the request object for a variable named "error" +and if found prints that value of that variable in red.   This is +used to communicate to the users problems found by the code that checks +the name and password for validity.   We'll next see how that +"error" variable is set. +  + +When the user enters his name and password and clicks on the submit +button control is passed to the logical page "signin".   Looking +at +the map above you'll see that this causes the function  action-sign-in to be called.   +Here is that function: + +<pre>(defun action-sign-in (req ent) (declare (ignore ent)) (let ((name (request-query-value "name" req)) (password (request-query-value "password" req)) (websession (websession-from-req req)) ) (setf (websession-variable websession "name") name) (if* (equal password (cdr (assoc name '(("joe" . "eoj") ("fred" . "derf")) :test #'equal))) then ; success! (setf (websession-variable websession "signed-in") t) "choice" ; show choice else ; failure (setf (request-variable-value req "error") "name and password are invalid") "main" ; go back and try again ))) </pre> +This function retrieves the values of the "name" and "password" values +from the set of form values.  It retrieves the current session +object which is stored on the request object by the webaction framework +code.   Next it stores the name given as the value of session +variable "name".    This means that the clp_value form shown +in main.clp will be able to retrieve it should we get to that page +again.    Next it checks if the password is valid.  We +have a very simple test in our example, a real web site would use some +kind of database to store the password information.    If the +password matches we set the session variable "signed-in" to true + and return the string "choice".  The webaction framework +then +consults the map for a page named "choice" and finds that choice.clp +should be returned.   If the name and password are not valid then +action-sign-in  returns the string "main" causing main.clp to be +returned and the user prompted again for a name and password. + Before returning "main" this function sets the request variable +"error" to a string to print when main.clp is sent back to the browser. + +This is choice.clp: + +<pre><html> <body> <h1>Vote</h1> Ok <clp_value name="name" session/>, what do you like? <form action="vote" method="POST"> favorite food: <input type="text" name="food"> </form> </body> </html> </pre> +Here we ask the user for their favorite food.  We personalize the +page by displaying the user's name on the page using clp_value.   +When the user types in the food and presses enter the logical page +"vote" is invoked.  From the map we see that that causes the +function action-vote to be invoked. + +<pre>(defvar *votes* nil) (defun action-vote (req ent) (declare (ignore ent)) (let* ((food (request-query-value "food" req)) (websession (websession-from-req req)) (name (websession-variable websession "name"))) (if* (websession-variable websession "signed-in") then (let ((ent (assoc name *votes* :test #'equal))) (if* ent then (setf (cdr ent) food) else (push (cons name food) *votes*))) "thanks" else ; not signed in, can't vote "main"))) </pre> +The vote action checks to see if the user is logged in in which case it +stores the last value the user voted for in an assoc list in the +variable +*votes*.    The logged in test is important since a user may +try to bypass the signing-in process by just directing his web browser +to  /mysamp/vote which would run this action function as well. + +If the vote was recorded this function returns "thanks" which the map +causes thanks.clp to be returned: + +<pre><html> <body> <h2>Thanks for voting</h2> </body> </html </pre> +<h3> +</h3> +<h3>Extended Maps</h3> +When designing a web application you usually want to force the user to +login first and then you open up the site to him.   When a +user enters the correct name and password you modify the current +session object to include an object that identifies the user so that +subsequent visits to this site during the same session will be +associated with the user who just logged in.   What if a new user +doesn't +come to the 'front door' of the web site but instead jumps right into +the middle of it?    How can you protect the site so that a +non-logged-in user is forced to start at the login page before visiting +any other page of the site?   The answer is using extended maps.    Let's +look at the map from the project mentioned above: +<pre> (("main" "main.clp") ("signin" action-sign-in) ("choice"   choice.clp") ("vote"     action-vote) ("thanks"  "thanks.clp")))</pre> +In this map we would like the symbolic pages "choice", "vote" and +"thanks" to  be reachable only +if the current session has a logged in +user. +We can accomplish this with +<pre> (("main" "main.clp") ("signin" action-sign-in) ("choice"   action-check-login choice.clp") ("vote"     action-check-login action-vote) ("thanks"   action-check-login "thanks.clp")))</pre> +Where we define action-check-login as: +<pre>(defun action-check-login (req ent) (declare (ignore ent)) (if* (websession-variable (websession-from-req req) "signed-in") then ; logged in :continue else ; not logged in "main")) </pre> +As you can see, a symbolic page name has a sequence of function names +or strings associated with it.    The rule for +processing a symbolic page name is to process the list of items after +the symbolic page name in this way: +<ol> + <li>if the first item is a string then consider it to be a symbolic +page name and start processing from the top. + </li> + <li>if +the first item is a symbol then run the function value of that +symbol.   The return value from that function will be either + <ul> + <li>string - consider this to be a symbolic page name to render +and start the processing from the beginning with this symbolic name</li> + <li>nil - assume that the function called has already done the +html response for this request so do nothing further.</li> + <li>:continue - if this particular keyword is returned then pop +the list of items specified to process this symbolic page and go back +to step 1.</li> + </ul> + </li> +</ol> +If the map doesn't contain an entry for the symbolic page name then +assume that the symbolic page name is the actual name of a page on the +site and return that. + +In our example the function action-check-login tests to see if the user +is logged in and if he is returns :continue so that the next item in +the list will be used to process the symbolic page request.   +If the user is not logged in then the string "main" is returned which +causes the login page to be displayed (and subsequent items in the list +to handle the symbolic page request are ignored). + +<h3>Prefix Maps</h3> +It is possible to have one map entry specify how to handle a whole set +of symbolic page names.   The syntax is this + +("name" action-or-view .... +(:prefix t)) + +What distinguishes this syntax is that the last item is a list.  +That list contain a sequence of flag names and values, in a property +list format.  . + +The meaning of :prefix t is +that this map entry applies to all symbolic pages name beginning with +the string "name".    For example if the project has a +prefix of "/foo/" then the following urls will be handled by this map +entry: + +http://localhost/foo/name +http://www.foo.com/foo/named +http://www.bar.com/foo/namexxx/yyyy/zzz + +Prefix map entries are the last ones considered when Webactions looks +for a map entry to handle a symbolic page name.  Webactions first +looks for a specific symbolic page name entry.    Then +Webactions see if the symbolic page name names an actual file in the +project directory.  And finally if those first two searches fail +to find a map entry, Webactions looks for a prefix entry. + +The precedence of the prefix entries search is "last mentioned +first".  That is the last prefix map value in the map argument to +webaction-project is tested first, and then the second to last, and so +on. + +To continue our example above if there were also a map entry + +("name" action-do-name) + +then this this url + +http://localhost/foo/name + +would be handled by the single symbolic name map entry rather than the +prefix entry. + +Also if there were a file "name.clp" in the directory of files for this +project then the url + +http://localhost/foo/name.clp + +would return this file rather than invoke the "name" as a prefix map +entry. + +We'll show two important uses for prefix map entries.  The first +is that you can catch references to non-existent symbolic pages names +and return a nicer error message than the standard one AllegroServe +returns.   The map entry + +("" handle-undefined-page +(:prefix t)) + +will catch all symbolic pages references that don't have a +handler.  You'll want to list this entry before any other prefix +entry in the map since you want this entry to be checked last. + +The second important use for prefix map entries arises when you wish to +send a file to the browser and you would like to suggest the filename +for the file.  Browers usually use the name that appears after the +last "/" in a url as the default name of the file to store. + +Thus if this url + +http://www.foo.com/myproj/sendfile/mypic.jpg + +resulted in an "image/jpeg" being returned then the browser would +prompt to store this as "mypic.jpg".     In a  +webaction project (with the project  prefix of "/myproj/") you +would have a map entry such as this + +    +("sendfile/"  return-filecontents (:prefix t)) + + +<h3>Redirection Maps</h3> + +Suppose you click on the submit button in a form, and the method for +that form is "POST".    The webserver will respond with +another page.  Now you click on a link on that page to go to a new +page.  Now suppose you click on the Back button on the web +browser, which should take you to the page that was the result of +submitting the form.    The browser should just show you +the previous page from its cache.   Most browsers will do +this except that Internet Explorer will often tell you that the page +has expired and it refuses to show you the page. + +This is counterintuitive and user-unfriendly behavior on IE's part but +still you must handle it in some way. + +One way to handle this is that whenever a POST is done the webserver +processes the posted data and then return a Redirect response to the +browser which then does a GET of the page that's the target of the +redirect.   Thus the user ends up looking at a page that was +fetched with a GET, and thus IE will have no problem returning to this +page if the Back button is clicked. + +You can specify this behavior in a map entry in this way + +("getdata" action-do-getdata "showresult.clp" (:redirect t)) + +The redirect flag say that rather than simply return the contents of +showresult.clp to the browser, instead Webactions will return a +Redirect response to the browser which will then fetch "showresult.clp". +The consequence of this redirect is that clp functions invoked by +showresult.clp will not have access to the query values from the first +request to "getdata" and they will not have access to the +request-variables that may have been set by +action-do-getdata.   This +feature is still under development -- we may change this in the future +to allow query and request variables to survive the redirect. + +If you're concerned about making your site work in IE you'll likely +want to do this redirect for all symbolic pages that are reached by a +POST to a form. + +<h3>Content-Type maps</h3> + +You can specify the content type of a file return by Webactions by +adding a map entry of the following form + +<big>("myfile.clp" (:content-type +"text/plain")) +</big> +By default clp files are given the "text/html" +content-type.   You can override this for all clp files using +the clp-content-type argument +to webaction-project.   +Specifying the content type in a map entry overrides all other +specifications. + +Specifying the content-type in this way only works in this case where +there are no actions or views following the name of the file. + +<h2><a name="Classes_used_in_webactions"></a>Classes used in webactions</h2> +These classes are used by the webaction framework.   Except as +noted the classes should be considered opaque.   Use only the +documented functions to operate on instances of these classes. + +clp-entity - when clp files are +"discovered" in a webaction  by being referenced from a request +url,  a clp-entity instance is created to describe the page. + This entity is then published so that the discovery process +doesn't have to happen again.   When the clp-entity is created a +pointer to the webaction object is placed in the entity so that clp +functions run during the processing of the clp file can find the +webaction project they are running inside. + +webaction-entity - there is one +entity of this class for each webaction project.   This entity is +published to capture all urls that begin with the project prefix (if no +other more specific entity captures them).   The webaction entity +holds a pointer to a webaction object. + + +webaction - An instance of this +class contains the information on a webaction project.  It +contains +the information passed as arguments to webaction-project as well as a a +websession-master instance if sessions are to be maintained. + +websession-master -  An +instance of this object is associated with a webaction object if that +project wants session support.  The webaction-master object +contains the information for creating session ids and for automatically +deleting unused sessions.  It also contains a map from cookie +value +to websession object. + +websession - An instance of +this +class denotes a single session for a site denoted by a webaction. +  +The websession contains a "last used" time and will be automatically +removed after a certain amount of time without being used. + + +<h2><a name="Lisp_functions_for_webactions"></a>Lisp functions for +webactions</h2> + +These functions are useful inside clp functions and webactions action +functions. + +(locate-action-path +webaction action-name websession)    + +Returns a url path to the action named action-name +in the given webaction + and websession.   +This is used in a +clp function when you wish to provide a value for a  href or action attribute that should be +directed to an action in the current project.   + +<pre> (html "go to " ((:a href (locate-action-path wa "signup" session)) "here")  " to sign up.")</pre> + +You can find the current webaction object using webaction-from-ent and the current +session object using websession-from-req. + + +(webaction-from-ent +ent)   + +Returns the webaction object associated with this entity.  This +function will return the webaction object for clp-entity and +webaction-entity objects.    This function is rarely used +since there is little that can be done by user code with a webaction +object. + + +(websession-from-req  req) + +Returns the websession object associated with this request (which is an +http-request object). +<h2> +</h2> +(websession-data +websession) + +Returns whatever data was stored in the session object by the user. +  Use (setf (websession-data websession) xxxxx) to store data in +the +websession object.    See websession-variable for a way of +storing data using a name as a key. + + +(websession-key websession) + +returns the key for this session.  This key is used in cookies and +in the url itself if cookies are not supported. + + +(websession-variable websession name) + +returns the value of the session variable with the given name. + The name can be a string or symbol.  It's compared against +existing keys using the equal +function.  Use setf to +store the value of variables. +<h2> +</h2> +<h2><a name="Library_of_clp_functions"></a>Library of clp functions</h2> + +The following clp functions are supplied with AllegroServe. + +<clp_include +name="filename"/> + +insert the contents of the given file at this point.   A relative +filename will be relative to the location of the file containing this +clp_include element. + + + +<clp_base/> + +This emits  a <base href="xxx"> tag into the html stream. +  xxx is the location of the clp page being emitted.   Due to +the automatic internal redirecting done by the webaction processor the +initial url can be much different than the url which describes the page +being sent to the browser.  If the page contains relative +references to images then the base tag will allow the browser to turn +those relative references into the correct absolute references. +This tag must be within the <head> .... </head> part of the +page. + + +<clp_value +name="xxx" [safe] [query | request | session]/> + +Retrieve the value of the variable named xxx from the location +specified and emit it to the html stream.   If location is query +then the value is retrieved from the query string of a  GET or the +body and query string of the POST.    If the location is +request then the value is retrieved from the request variables. + If +the location is session then the values are retrieved from the session +variables.    If safe +is given then the value will be printed in such a way to escape any +characters that would be interpreted as html  (e.g as (html (:princ-safe xxx)) would +print the value). +Example: +<pre>  The value of query variable foo is <clp_value name="foo" safe query/>.</pre> + + +<clp_set +name="xxx" value="yyy" [query | request | session]/> + +Sets the value of variable xxx to yyy in the given location.   + If you want to pass values from one clp function to another +storing them in the request location is best as the value will be +isolated to this one http request. + + +<clp_ifgt +name="xxx" value="yyy" [query | request | session]>body</clp_ifgt> + +If the value of the variable xxx found at the given location is +greater than the value yyy then the body will be emitted to the html +stream.    The value yyy should be an integer value. + + +<clp_iflt +name="xxx" value="yyy" [query | request | session]>body</clp_iflt> + +If the value of the variable xxx found at the given location is +less than the value yyy then the body will be emitted to the html +stream.    The value yyy should be an integer value. + + +<clp_ifeq name="xxx" value="yyy" [query | request | session]>body</clp_ifeq> + +If the value of the variable xxx found at the given location is +equal to the value yyy then the body will be emitted to the html +stream. +   The value yyy should be an integer value. + + +<clp_ifdef name="xxx" [query | request | session]>body</clp_ifdef> + +If the value of the variable xxx found at the given location is + not nil then the body will be emitted to the html stream.   + + +<clp_ifndef +name="xxx" [query | request | session]>body</clp_ifdef> + +If the value of the variable xxx found at the given location +is  nil then the body will be emitted to the html stream.   +If +the variable xxx has never been set then this is the same as it having +a +value of nil. + + +<clp_ifequal name="xxx" value="yyy" [query | request | session]>body</clp_ifequal> + +If the value of the variable xxx found at the given location is +equal to the value yyy then the body will be emitted to the html +stream. +   The value yyy can be any value, but is likely to be a +string. + +<clp_options +name="xxx" [query | request | session]> +      "opt1" "opt2" +..."optn"</clp_options><big> +</big> +This function helps build a dynamically defaulted option list for the +html <select> element. +   Inside a <select> element are a sequence of +<option> elements with the default value denoted <option +selected>.   When generating an option list the default value +may not be known when the author writes the page.   The default +can +be based on some other value entered in the session.   Thus this +form allows the default to be computed where the default value is found +at runtime from the value of the variable whose name is given as the +value of the name attribute. +   In the form shown above the variable name is xxx. +Between <clp_options> and </clp_options> are a sequence of +lisp strings.   When this is processed the lisp strings are read +with the lisp reader in order to create a list of option values.   + +If a name= attribute isn't present then the first lisp string is made +the default +Example: +<pre><select name="color"> <clp_options name="defcolor" session> "blue" "green" "yellow" "red" "purple" "gold" </clp_options> </select> </pre> +<clp_select +args>body</clp_select> +This  function simply emits a select form: <select args>body</select>.     +The reason for using clp_select +instead of select is that some +html editors get confused by items inside the body of a select that aren't option elements   In a clp file +you might want to put clp_options +or clp_include inside a select tag.  If you use clp_select you can put whatever you +want in the body and most html editors will not object. + + + + +<http_header-value name="xxx"/> + +print the value of the given http header to the html stream.   The +name (here xxx) is treated +case-insensitively. +Example: +<pre>You are using browser <http_header-value name="User-Agent"/>.</pre> + +<pre> </pre> +<pre> </pre> + +<wa_link name="xxx" extra="yyy"/> + +This function is rarely if ever explicitly found in a clp file however +this function is implicitly called whenever the clp parser encounters +an +href= or action= in a clp file.   The result of a call to wa_link +is to take a url (here xxx) and transform it into the appropriate url +given whether the url is relative or absolute and whether cookies are +being accepted in the current session.   Extra is optional and if +given specifies what string should be added to the end of the resulting +url.  This is where a query string is usually placed +Example: +<pre>   <wa_link href="main" extra="?user=joe&password=123"/> </pre> + +<wa_showerrors +name="xxx" [query | request | session]  [clear]/> + +If the the variable named xxx +in the location specified (query, +request or session) has a value then display +that value in red in the html being returned as part of the +request.   If clear +is +given then set the valueof variable xxx  +to nil.   This is commonly used to display error messages on a +page, such as when a form wasn't filled out correctly and you're +redisplaying the page and asking the user to try again.   The +default location is request. + + + + + +</body> +</html> Added: vendor/portableaserve/aserve/webactions/load.cl =================================================================== --- vendor/portableaserve/aserve/webactions/load.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/load.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,68 @@ +;; +;; load up the webaction code. +;; + +(require :aserve) + + +(defvar *loadswitch* :compile-if-needed) +(defparameter *webactions-root* (directory-namestring *load-pathname*)) + +(defparameter *webactions-files* + '("clpage" + "webact" + "websession" + + "clpcode/clp" + "clpcode/wa" + "clpcode/http" + "clpcode/time")) + +(defvar +fasl-type+ (pathname-type (compile-file-pathname "foo.lisp"))) + +(with-compilation-unit nil + (dolist (file *webactions-files*) + (case *loadswitch* + (:compile-if-needed (compile-file-if-needed + (format nil "~a~a.cl" *webactions-root* file))) + (:compile (compile-file + (merge-pathnames (format nil "~a~a.cl" + *webactions-root* file)))) + (:load nil)) + (load (format nil "~a~a.~a" *webactions-root* file +fasl-type+)))) + + +(defun make-webactions.fasl () + (wa-copy-files-to *webactions-files* + (concatenate 'string "webactions." +fasl-type+) + :root *webactions-root*) + ; in place for require + (sys:copy-file (concatenate 'string + *webactions-root* "webactions." + +fasl-type+) + "code/webactions.fasl" + :overwrite t) + + ) + + + +(defun wa-copy-files-to (files dest &key (root "")) + ;; copy the contents of all files to the file named dest. + ;; append .fasl to the filenames (if no type is present) + + (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (p (concatenate 'string root dest) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (dolist (file files) + (setq file (concatenate 'string root file)) + (if* (and (null (pathname-type file)) + (not (probe-file file))) + then (setq file (concatenate 'string file "." +fasl-type+))) + (with-open-file (in file :element-type '(unsigned-byte 8)) + (loop + (let ((count (read-sequence buffer in))) + (if* (<= count 0) then (return)) + (write-sequence buffer p :end count)))))))) Added: vendor/portableaserve/aserve/webactions/test/.cvsignore =================================================================== --- vendor/portableaserve/aserve/webactions/test/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/aserve/webactions/test/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/webactions/test/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/t-webactions.cl/1.2/Mon Apr 26 18:18:38 2004// +D Added: vendor/portableaserve/aserve/webactions/test/CVS/Entries.Log =================================================================== --- vendor/portableaserve/aserve/webactions/test/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +A D/sitea//// Added: vendor/portableaserve/aserve/webactions/test/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/webactions/test/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/webactions/test Added: vendor/portableaserve/aserve/webactions/test/CVS/Root =================================================================== --- vendor/portableaserve/aserve/webactions/test/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/webactions/test/sitea/CVS/Entries =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +/file1.clp/1.1/Tue Dec 2 14:36:33 2003// +/file2.clp/1.1/Tue Dec 2 14:36:33 2003// +/file3.clp/1.1/Tue Dec 2 14:36:33 2003// +/project.cl/1.1/Tue Dec 2 14:36:33 2003// +D Added: vendor/portableaserve/aserve/webactions/test/sitea/CVS/Repository =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/aserve/webactions/test/sitea Added: vendor/portableaserve/aserve/webactions/test/sitea/CVS/Root =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/aserve/webactions/test/sitea/file1.clp =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/file1.clp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/file1.clp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +test Added: vendor/portableaserve/aserve/webactions/test/sitea/file2.clp =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/file2.clp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/file2.clp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +the second test file: file2 Added: vendor/portableaserve/aserve/webactions/test/sitea/file3.clp =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/file3.clp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/file3.clp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +This is a plain text file Added: vendor/portableaserve/aserve/webactions/test/sitea/project.cl =================================================================== --- vendor/portableaserve/aserve/webactions/test/sitea/project.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/sitea/project.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,40 @@ +(in-package :net.aserve.testwa) + +(webaction-project "sitea" + :project-prefix "/sitea/" + :destination (directory-namestring *load-pathname*) + :map '(("pagea" "file1.clp") + ("action" + action-sitea-pushit + action-sitea-pushit + action-sitea-pushit + "file1.clp") + + ("action2" + action-retname-two) + + ("action3" + action-retname-three) + + ("action4" + action-retname-four) + + ("act" action-sitea-pushit "file1.clp" + (:prefix t)) + + ; push once and then redir to "action" + ("redirtry" action-sitea-pushit "action") + + ; test that the existing file file1.clp has + ; precedence over the prefix fil + ("fil" action-sitea-pushit action-sitea-pushit + "file2.clp" + (:prefix t)) + + ("testctype" "file3.clp") + ("file3.clp" (:content-type "text/plain")) + )) + + + + Added: vendor/portableaserve/aserve/webactions/test/t-webactions.cl =================================================================== --- vendor/portableaserve/aserve/webactions/test/t-webactions.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/test/t-webactions.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,297 @@ +;; -*- mode: common-lisp; package: net.aserve.test -*- +;; +;; t-webactions.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation; +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: t-webactions.cl,v 1.2 2004/04/26 18:18:38 kevinrosenberg Exp $ + +;; Description: +;; test webactions in aserve + +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + +#+allegro +(eval-when (compile load eval) + (require :tester)) + +;;; Get Kevin Rosenberg's port of Franz tester at +;;; http://files.b9.com/ptester/ +#-allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:oos 'asdf:load-op :ptester) + (rename-package (find-package :ptester) :ptester '(:util.test))) + +(defpackage :net.aserve.testwa + (:use :common-lisp :acl-compat.excl :net.html.generator :net.aserve + :net.aserve.client + :util.test) + ) + +(in-package :net.aserve.testwa) + +(defvar *x-ssl*) + +(defvar *test-dir* (directory-namestring *load-pathname*)) + +(defun test-webactions () + ;; run the allegroserve tests three ways: + ;; 1. normally + ; 2. through an allegroserve proxy to test the proxy + ;; 3. through ssl (if ssl module present) + ;; + ;; tests are run on a variety of threads, so we have to + ;; account for those other thread errors separately. + (setq util.test::*test-errors* 0 + util.test::*test-successes* 0 + util.test::*test-unexpected-failures* 0) + (with-tests (:name "aserve") + (let* ((*wserver* *wserver*) + (port (start-aserve-running))) + (format t "server started on port ~d~%" port) + (unwind-protect + (flet ((do-tests () + (sitea-tests port) + )) + (format t "~%~%===== test direct ~%~%") + (do-tests) + + )) + ; cleanup forms: + (stop-aserve-running))) + (if* (or (> util.test::*test-errors* 0) + (> util.test::*test-successes* 0) + (> util.test::*test-unexpected-failures* 0)) + then (format t "~%Test information from other threads:~%") + (format t "Errors: ~d~%" util.test::*test-errors*) + (format t "Successes: ~d~%~%" util.test::*test-successes*) + (format t "Unexpected failures: ~d~%" + util.test::*test-unexpected-failures*))) + +(defun x-do-http-request (uri &rest args) + ;; add a proxy arg + (apply #'do-http-request uri :ssl *x-ssl* args)) + +(defmacro values2 (form) + ;; return the second value + (let ((v1 (gensym)) + (v2 (gensym))) + `(multiple-value-bind (,v1 ,v2) ,form + (declare (ignore ,v1)) + ,v2))) + +(defun start-aserve-running (&optional ssl) + ;; start aserve, return the port on which we've started aserve + (let ((wserver (start :port nil :server :new :ssl ssl))); let the system pick a port + (setq *wserver* wserver) + (unpublish :all t) ; flush anything published + (setq *x-ssl* ssl) + (socket::local-port (net.aserve::wserver-socket wserver)) + )) + + +(defun stop-aserve-running () + (shutdown)) + + + + +;;--------- the tests ------------ + +(defvar *sitea-vara* nil) + + +(defun sitea-tests (port) + ; load in project + (let ((prefix-local (format nil "http://localhost:~a" port))) + (load (concatenate 'string *test-dir* "sitea/project.cl")) + + + ; test a sample symbolic page + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/pagea" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode)) + + + ; test a non existant one + + (test 404 (values2 (x-do-http-request (format nil "~a/sitea/notthere" + prefix-local)))) + + + + ;; test extended maps... with multiple actions firing + (setq *sitea-vara* nil) + + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/action" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode) + (test '(:foo :foo :foo) *sitea-vara* :test #'equal)) + + + ;; test redir to previous page preceeded by one push + (setq *sitea-vara* nil) + + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/redirtry" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode) + (test '(:foo :foo :foo :foo) *sitea-vara* :test #'equal)) + + + + ;; test an action returning a clp name + ;; it's not clear we should support this. it does seem more + ;; regular to allow it... but then we can't as easy detect + ;; mistyped symbolic page names returned by action functions + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/action2" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode)) + + + ;; test an action returning a symbolic page name which then + ;; points at a clp file + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/action3" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode)) + + + ;; bogus sym page name returned by action + (test 404 (values2 (x-do-http-request (format nil "~a/sitea/action4" + prefix-local)))) + + ;; test with prefix + + ; smallest prefix + (setq *sitea-vara* nil) + + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/act" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode) + (test '(:foo) *sitea-vara* :test #'equal)) + + + ; bigger suffix + (setq *sitea-vara* nil) + + (multiple-value-bind (data retcode) + (x-do-http-request (format nil "~a/sitea/act234234/asd/asd/ad" prefix-local)) + + (test "test +" data :test #'equal) + (test 200 retcode) + (test '(:foo) *sitea-vara* :test #'equal)) + + + + ;; verify that the fil prefix works too + (setq *sitea-vara* nil) + + (multiple-value-bind (data retcode headers) + (x-do-http-request (format nil "~a/sitea/filesss/act234234/asd/asd/ad" prefix-local)) + + (test "the second test file: file2 +" data :test #'equal) + (test 200 retcode) + (test "text/html" (cdr (assoc :content-type headers)) + :test #'equal) + (test '(:foo :foo) *sitea-vara* :test #'equal)) + + + ; check to see if we can change the content-type of a + ; single file + + (multiple-value-bind (data retcode headers) + (x-do-http-request (format nil "~a/sitea/testctype" prefix-local)) + + (test "This is a plain text file +" data :test #'equal) + (test 200 retcode) + (test "text/plain" (cdr (assoc :content-type headers)) + :test #'equal)) + + + + + )) + + +(defun action-sitea-pushit (req ent) + (declare (ignore req ent)) + (push :foo *sitea-vara*) + :continue + ) + +(defun action-retname-two (req ent) + ;; return actual name to run + (declare (ignore req ent)) + "file1.clp") + + +(defun action-retname-three (req ent) + ;; return another symbolic page name + (declare (ignore req ent)) + "pagea") + + +(defun action-retname-four (req ent) + ;; return a bogus symbolic page name + (declare (ignore req ent)) + "thisdoesntexist") + + + + + + + + + + + + + + + + + + + +(test-webactions) Added: vendor/portableaserve/aserve/webactions/webact.cl =================================================================== --- vendor/portableaserve/aserve/webactions/webact.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/webact.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,648 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; webaction.cl +;; framework for building dynamic web sites +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; + +;; $Id: webact.cl,v 1.11 2004/08/31 03:49:36 kevinrosenberg Exp $ + + +(in-package :net.aserve) +(export + '(initialize-websession-master + locate-action-path + webaction + webaction-entity + webaction-from-ent + webaction-project + websession + websession-data + websession-key + websession-from-req + websession-master + websession-variable + )) + +(defclass webaction-entity (computed-entity access-file-mixin) + ((webaction ;; holds webaction object + :initarg :webaction + :initform nil + :accessor webaction-webaction))) + + +(defclass webaction () + ;; a request handled as a action + ((name :initarg name + :initform "unnamed" + :accessor webaction-name + ) + (project-prefix :initarg :project-prefix + :initform "" + :accessor webaction-project-prefix + ) + + + ; prefix of where regular files are found + (destination :initarg :destination + :initform "" + :accessor webaction-destination) + + (clp-suffixes :initarg :clp-suffixes + :initform '("clp") + :accessor webaction-clp-suffixes) + + (map :initarg :map + :initform nil + :accessor webaction-map) + + (hash :initform (make-hash-table :test #'equal) + :reader webaction-hash) + + ; list of actions triggered by a prefix + (prefixes :initform nil + :accessor webaction-prefixes) + + (websession-master :initarg :websession-master + :initform nil + :accessor webaction-websession-master) + + (external-format :initarg :external-format + :accessor webaction-external-format) + + ; content-type for clp files + (clp-content-type :accessor webaction-clp-content-type + :initform nil) + + (cookie-domain :accessor webaction-cookie-domain + :initarg :cookie-domain) + + )) + +(defparameter *webactions-version* "1.5") + +(defvar *name-to-webaction* (make-hash-table :test #'equal)) + +(defparameter *session-reap-interval* (* 5 60)) ; 5 minutse + +(defun webaction-project (name &key (project-prefix "/") + (clp-suffixes '("clp")) + map + (destination "") + index + (server *wserver*) + host + session-lifetime + (sessions t) + reap-interval + reap-hook-function + access-file + authorizer + clp-content-type + (external-format + *default-aserve-external-format*) + cookie-domain + ) + ;; create a webaction project + ;; and publish all prefixes + ;; + + (if* (not (and (stringp project-prefix) + (> (length project-prefix) 0) + (eql #\/ (aref project-prefix (1- (length project-prefix)))))) + then (error "project-prefix should be a string ending in /, not ~s" + project-prefix)) + + + ; publish the webactions + (let ((ent (publish-prefix :prefix project-prefix + :function 'webaction-entity + :class 'webaction-entity + :server server + :host host + :authorizer authorizer + )) + (wa (or (gethash name *name-to-webaction*) + (make-instance 'webaction)))) + + (setf (directory-entity-access-file ent) access-file) + + (setf (webaction-name wa) name) + (setf (webaction-project-prefix wa) project-prefix) + (setf (webaction-map wa) map) + (setf (webaction-clp-suffixes wa) clp-suffixes) + (setf (webaction-destination wa) destination) + (setf (webaction-external-format wa) external-format) + (setf (webaction-clp-content-type wa) clp-content-type) + (setf (webaction-cookie-domain wa) cookie-domain) + + (if* (and reap-interval (integerp reap-interval) (> reap-interval 0)) + then (setq *session-reap-interval* reap-interval)) + + + ; put stuff in the table + (clrhash (webaction-hash wa)) + (let ((hash (webaction-hash wa))) + (dolist (ent map) + (let ((lastval (car (last ent)))) + (if* (and (consp lastval) (getf lastval :prefix)) + then ; this is a prefix entry, not a fixed entry + (push ent (webaction-prefixes wa)) + else (setf (gethash (car ent) hash) (cdr ent)))))) + + (setf (webaction-webaction ent) wa) + + ; store the webaction object here too so that + ; webaction-from-req will work in action functions too + (setf (getf (entity-plist ent) 'webaction) wa) + + (if* (and (null (webaction-websession-master wa)) + sessions) + then (initialize-websession-master + (setf (webaction-websession-master wa) + (make-instance 'websession-master + :cookie-name name + :reap-hook-function reap-hook-function + )))) + + (if* (null sessions) + then ; no sessions for this project + (setf (webaction-websession-master wa) nil)) + + (if* (and session-lifetime (webaction-websession-master wa)) + then (setf (sm-lifetime (webaction-websession-master wa)) + session-lifetime)) + + + (setf (gethash name *name-to-webaction*) wa) + + + ;; if we have an index page for the site, then redirect + ;; the project-prefix to it + (if* index + then (publish :path project-prefix + :function #'(lambda (req ent) + (redirect-to req ent + (concatenate + 'string project-prefix + index))) + :authorizer authorizer + :server server + :host host) + (if* (> (length project-prefix) 1) + then ; also do it with the slash missing at the end + (publish :path (subseq project-prefix 0 + (1- (length project-prefix))) + :function #'(lambda (req ent) + (redirect-to req ent + (concatenate + 'string project-prefix + index))) + :authorizer authorizer + :server server + :host host))) + + + ent)) + + +(defun redirect-to (req ent dest) + (with-http-response (req ent + :response *response-moved-permanently*) + (setf (reply-header-slot-value req :location) dest) + (with-http-body (req ent)))) + +;; the current websession is placed in the req object by +;; the action code that first gets the request. + +(defun websession-from-req (req) + (getf (request-reply-plist req) 'websession)) + +(defsetf websession-from-req .inv-websession-from-req) + +(defun .inv-websession-from-req (req websession) + (setf (getf (request-reply-plist req) 'websession) websession)) + + + +(defun webaction-from-ent (ent) + (getf (entity-plist ent) 'webaction)) + + + +(defun webaction-entity (req ent) + ;; handle a request in the uri-space of this project + + ; determine if it's in the action space, if so, find the action + ; the map, run it, and then handle what it returns + (let ((path (uri-path (request-uri req))) + (wa (webaction-webaction ent)) + (newfollowing) + (websession (websession-from-req req)) + (failed-following) + (final-flags) + (sm)) + + + ; look for session info based on cookie + ; and remember it on the request + + + (let (csessid) + (if* (and (null websession) + (setq sm (webaction-websession-master wa)) + (setq csessid + (cdr (assoc (sm-cookie-name sm) + (get-cookie-values req) + :test #'equal)))) + then + (if* (setq websession + (gethash csessid (sm-websessions sm))) + then (if* (eq :try-cookie (websession-method websession)) + then (setf (websession-method websession) :cookie)) + elseif (> (length csessid) 10) + then ; no session found, but this session id looks good + ; and was probably created by another web server. + ; so create a session object + (setq websession (make-instance 'websession + :key csessid + :method :cookie)) + (setf (gethash csessid (sm-websessions sm)) websession))) + (if* websession + then (setf (websession-from-req req) websession))) + + + + #+ignore + (if* websession + then (format t "in action key ~s data ~s~%" + (websession-key websession) + (websession-data websession))) + + ;; strip sessionid off either of the possible prefixes + (let* ((prefix (webaction-project-prefix wa)) + (following (match-prefix + prefix + path))) + + (if* (and following (setq newfollowing + (strip-websessionid + req wa following websession))) + then ; found session id + (modify-request-path req + prefix + newfollowing) + (return-from webaction-entity + (handle-request req)))) + + + (if* (and (null websession) + (or sm (setq sm (webaction-websession-master wa)))) + + then ; we haven't got a session yet for this session. + ; create one, and remeber it for this requst + (let ((key (next-websession-id sm))) + + (setf (websession-from-req req) + (setf (gethash key (sm-websessions sm)) + (setq websession (make-instance 'websession + :key key + :method :try-cookie)))))) + + + + (if* websession then (note-websession-referenced websession)) + + (let* ((following (match-prefix (webaction-project-prefix wa) + path)) + (initial-following following)) + (if* following + then ; this is a call on a webaction and no session id + ; was found in the url + ; try to locate the session via a cookie + + (let* ((actions (locate-actions req ent wa following)) + (redirect)) + + ; there may be a list of flags at the end of + ; the map entry + (setq final-flags (let ((last (last actions))) + (if* (consp (car last)) + then (car last)))) + + + (if* (and actions + (not (listp (car actions)))) + then ; this isn't the case of an entry followed + ; right by flags + (setq redirect (getf final-flags :redirect)) + + (loop + (if* (stringp (car actions)) + then (modify-request-path req + (webaction-project-prefix wa) + (car actions)) + (return) + + elseif (symbolp (car actions)) + then + (setq following (funcall (car actions) + req ent)) + #+ignore + (format t "following is ~s, actions is ~s~%" + following actions) + (if* (null following) + then ; must have done html output + (return-from webaction-entity nil) + elseif (eq following :continue) + then (if* (null (cdr actions)) + then (logmess (format + nil + "action ~s return nil with no subsequent actions" + (car actions))) + (return-from webaction-entity + nil)) + + (pop actions) + elseif (stringp following) + then (modify-request-path + req (webaction-project-prefix wa) + following) + (return) + + else ; bogus ret from action fcn + (logmess (format nil "action function ~s returns illegal value: ~s" + (car actions) + following)) + (return-from webaction-entity nil)) + else (logmess (format nil + "reached end of map entries for ~s" + initial-following)) + (return-from webaction-entity nil))) + + ; out of the procesing loop. the request + ; has been modified and may now refer to + ; an already published file, so start through + ; the handle-request logic again to find + ; an existing entity before creating one. + (return-from webaction-entity + (if* redirect + then (redirect-to req ent + (puri:uri-path + (request-uri req))) + else (handle-request req))) + else (setq failed-following following))))) + + ; must be a file then.. + (multiple-value-bind (realname postfix) + (compute-symname-as-filename req ent wa) + (let ((info) + (forbidden)) + + ; this is like what publish-directory does now + (if* (null realname) + then ; contains ../ or ..\ + ; ok, it could be valid, like foo../, but that's unlikely + ; Also on Windows don't allow \ since that's a directory sep + ; and user should be using / in http paths for that. + (return-from webaction-entity + (failed-request req))) + + + (multiple-value-setq (info forbidden) + (read-access-files ent realname postfix)) + + (if* forbidden + then ; give up right away. + (return-from webaction-entity (failed-request req))) + + (let ((type (acl-compat.excl::filesys-type realname))) + (if* (not (eq :file type)) + then (if* failed-following + then (logmess (format nil "no map for webaction ~s" + failed-following))) + (return-from webaction-entity (failed-request req))) + + (let ((new-ent (clp-directory-entity-publisher + req ent realname info + (webaction-clp-suffixes wa) + (webaction-external-format wa) + (or (getf final-flags :content-type) + (webaction-clp-content-type wa)) + ))) + ; put the webaction in the entity so it can be used + ; when the clp file (if this is clp entity) is used + (setf (getf (entity-plist new-ent) 'webaction) + (webaction-webaction ent)) + (authorize-and-process req new-ent))))))) + +(defun compute-symname-as-filename (req ent wa) + ;; compute the filename that the symbolic name denotes. + ;; return nil if the filename is illegal (since it contains + ;; upward directory movement characters). + (let* ((postfix (subseq (request-decoded-uri-path req) (length (prefix ent)))) + ;; NDL 2004-06-04 -- concatenate a pathname? this is portable? + #+ignore (realname (concatenate 'string (webaction-destination wa) postfix)) + (realname (namestring (merge-pathnames postfix (webaction-destination wa))))) + (if* (or #+mswindows (position #\\ postfix) ; don't allow windows dir sep + (match-regexp "\\.\\.[\\/]" postfix)) + then ; contains ../ or ..\ + ; ok, it could be valid, like foo../, but that's unlikely + ; Also on Windows don't allow \ since that's a directory sep + ; and user should be using / in http paths for that. + (return-from compute-symname-as-filename nil)) + + #+allegro + (if* sys:*tilde-expand-namestrings* + then (setq realname (excl::tilde-expand-unix-namestring realname))) + + (values realname postfix))) + + + + +(defun strip-websessionid (req wa following websession) + ;; strip leading session id if any + ;; setup the current session on the request object + ;; /prefix/~24234344234234242342342234~/realname/whatever + ;; + ;; return what follows the session id. If no session id + ;; as found, return nil + ;; + ;; we assume that before this function is called we check for + ;; a cookie indicated session and if that found something then + ;; websession is non-nil. + ;; + (let (pos sessid sm) + (if* (and (eq #\~ (aref following 0)) + (setq pos (position #\~ following :start 1)) + (> (length following) (1+ pos)) + (eql #\/ (aref following (1+ pos))) + ) + then (setq sessid (subseq following 1 pos) + following (subseq following (+ 2 pos))) + + (if* (null websession) + then ; cookie didn't work to locate a websession + ; it could be that it wasn't even tried though... + (setq sm (webaction-websession-master wa) + websession + (and sm (gethash sessid (sm-websessions sm)))) + + ; possibilities + ; session found + ; check mode. if we're in try-cookie mode then + ; check to see if the cookie was passed + + (if* websession + then (setf (websession-from-req req) websession) + (case (websession-method websession) + (:try-cookie + ;; cookie didn't work so use url for now on + (setf (websession-method websession) + :url))) + elseif sm + then ; add new session + (setf (websession-from-req req) + (setf (gethash sessid (sm-websessions sm)) + (make-instance 'websession + :key sessid + :method :try-cookie))) + + )) + + following))) + + + + +(defun locate-actions (req ent wa action-name) + ;; retrieve a list of actions for the symbolic page name + ;; + (or (gethash action-name (webaction-hash wa)) + ; only do prefixes if there's no existing filename + ; mentioned + (let ((realname (compute-symname-as-filename req ent wa))) + (if* (and realname + (probe-file realname)) + then nil ; means no actions + else ; look for prefixes + + (dolist (pp (webaction-prefixes wa)) + (if* (and (consp pp) + (stringp (car pp)) + (match-prefix (car pp) action-name)) + then (return (cdr pp)))))))) + + +(defun locate-action-path (wa action-name websession) + ;; return the full uri path for what action points to + ;; if the action points to a page, otherwise return a pointer + ;; to the action itself + ;;** change -- always return a pointer to the action since + ;; that will allow the project to be redefined and not have + ;; the clp files reparsed. + (let* ((relative-path action-name) + (prefix (webaction-project-prefix wa))) + + (relative-to-absolute-path + (if* (and websession (member (websession-method websession) + '(:try-cookie :url))) + then ; add session id to url + (concatenate 'string + prefix + "~" + (websession-key websession) + "~/") + else prefix) + relative-path))) + + +(defun relative-to-absolute-path (prefix relative-path) + ;; add on the project prefix so that the resulting path + ;; is reachable via a browser + (if* (not (eq #\/ (aref relative-path 0))) + then ; relative path + (concatenate 'string prefix relative-path) + else relative-path)) + + +(defun match-prefix (prefix full) + ;; if prefix is a prefix of full then return what follows + ;; prefix + (and (<= (length prefix) (length full)) + (dotimes (i (length prefix) + (subseq full (length prefix))) + (if* (not (eq (aref prefix i) (aref full i))) then (return nil))))) + + + +(defun modify-request-path (req prefix newpath) + ;; modify the http request with the new path + ;; the new path can be relative or absolute + (setq newpath + (relative-to-absolute-path prefix + newpath)) + + (setf (request-decoded-uri-path req) newpath) + (setf (request-uri req) + (puri:copy-uri (request-uri req) + :path newpath)) + + (setf (request-raw-uri req) + (puri:copy-uri (request-raw-uri req) + :path newpath))) + + + +(defun webaction-cleanup-process () + ;; clean up all old sessions in all active webactions + (loop + ;;(format t "~%Reap Check~%")(force-output) + (maphash #'(lambda (name webaction) + (declare (ignore name)) + (let ((websession-master (webaction-websession-master + webaction))) + (if* websession-master + then (reap-unused-sessions websession-master)))) + *name-to-webaction*) + + (sleep *session-reap-interval*))) + +(defvar *webaction-cleanup-lock* (acl-compat.mp:make-process-lock)) + +(defvar *webaction-cleanup-process* nil) + +(defun ensure-webaction-cleanup-process () + (acl-compat.mp:with-process-lock (*webaction-cleanup-lock*) + (if* (not (and *webaction-cleanup-process* + (acl-compat.mp:process-active-p *webaction-cleanup-process*))) + then ; must restart it + (setq *webaction-cleanup-process* + (acl-compat.mp:process-run-function "session reaper" + #'webaction-cleanup-process))))) + + + + + + Added: vendor/portableaserve/aserve/webactions/webactions.asd =================================================================== --- vendor/portableaserve/aserve/webactions/webactions.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/webactions.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,25 @@ +;;; -*- lisp -*- + +(defpackage #:webactions-system + (:use #:cl #:asdf)) +(in-package #:webactions-system) + +(defclass acl-file (cl-source-file) ()) +(defmethod asdf:source-file-type ((c acl-file) (s module)) "cl") + +(defsystem webactions + :author "John K. Foderaro" + :licence "LLGPL" + :default-component-class acl-file + :components + ((:file "websession") + (:file "webact" :depends-on ("websession")) + (:file "clpage" :depends-on ("webact")) + (:module :clpcode + :components + ((:file "clp") + (:file "http") + (:file "time") + (:file "wa")) + :depends-on ("clpage"))) + :depends-on (aserve #-allegro acl-compat htmlgen)) Added: vendor/portableaserve/aserve/webactions/websession.cl =================================================================== --- vendor/portableaserve/aserve/webactions/websession.cl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/aserve/webactions/websession.cl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,203 @@ +;; -*- mode: common-lisp; package: net.aserve -*- +;; +;; websession.cl +;; session support for webactions +;; +;; copyright (c) 2003 Franz Inc, Oakland CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code is distributed in the hope that it will be useful, +;; but without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; $Id: websession.cl,v 1.3 2004/03/01 18:25:31 kevinrosenberg Exp $ + +(in-package :net.aserve) + + + +(defclass websession-master () + ;; describes how a set of sessions is managed + ((prefix :initarg :prefix + ;; string that preceeds all keys + :initform "" + :accessor sm-prefix) + + (suffix :initarg :suffix + ;; number against which the counter will be xored + :initform "" + :accessor sm-suffix) + + (counter :initarg :counter + :initform nil + :accessor sm-counter) + + ;; how long a session will last if no reference made to it + (lifetime :initarg :lifetime + :accessor sm-lifetime + :initform #.(* 5 60 60) ; five hours + ) + + (reap-hook-function :initarg :reap-hook-function + :accessor sm-reap-hook-function + :initform nil) + + (cookie-name :initarg :cookie-name + :initform "webaction" + :reader sm-cookie-name) + + (websessions :initform (make-hash-table :test #'equal) + :reader sm-websessions))) + + +(defclass websession () + ;; individual sessions + ( + (key :initarg :key + ;; the session key + :reader websession-key) + + (lastref :initform (acl-compat.excl::cl-internal-real-time) + :accessor websession-lastref) + + ; how we pass the session information + ; :try-cookie - send via cookie and url rewiting + ; :cookie - passwed as a cookie + ; :url - pass in url + (method :initarg :method + :initform nil + :accessor websession-method) + + ; a place for users to hang information onto the session object. + (data :initarg :data + :initform nil + :accessor websession-data) + + (variables :initform nil + :accessor websession-variables))) + + + + +(defmethod initialize-websession-master ((sm websession-master)) + ;; we no longer do this here.. we wait until we start to use + ;; the keys that way a saved image will get new info when + ;; it starts + nil + + ) + +(defun compute-prefix-suffix (sm) + ;; compute the prefix string and suffix value + ; randomize the random number generator + (dotimes (i (logand (get-universal-time) #xfff)) (random 256)) + + #+unix + (dotimes (i (logand (acl-compat.excl::filesys-inode ".") #xfff)) (random 256)) + (dotimes (i (logand (get-universal-time) #xff)) (random 256)) + + (let ((val 1)) + (dotimes (i 4) + (setq val (+ (ash val 8) (random 255)))) + (setf (sm-prefix sm) (format nil "~x" val)) + + (setq val 0) + (dotimes (i 4) + (setq val (+ (ash val 8) (random 255)))) + (setf (sm-suffix sm) val)) +) + + + +(defvar *websession-counter-lock* (acl-compat.mp:make-process-lock)) + +(defmethod next-websession-id ((sm websession-master)) + (acl-compat.mp:with-process-lock (*websession-counter-lock*) + + (let ((counterval (sm-counter sm))) + + (if* (null counterval) + then (compute-prefix-suffix sm) + (setq counterval (random 255))) + + (setf (sm-counter sm) (1+ counterval)) + + (concatenate 'string (sm-prefix sm) + (format nil "~x" (random #xfffffff)) + (format nil "~x" (logxor (sm-suffix sm) counterval)))))) + + + + +(defvar *verify-reaper-started* 0) + +(defmethod note-websession-referenced ((sess websession)) + (setf (websession-lastref sess) (acl-compat.excl::cl-internal-real-time)) + + ; make sure we've got the reaper process running, but don't + ; check too often since it's not necessary + (if* (< (decf *verify-reaper-started*) 0) + then (setq *verify-reaper-started* 30) + (ensure-webaction-cleanup-process))) + + + +(defun websession-variable (websession name) + (and websession + (cdr (assoc name (websession-variables websession) :test #'equal)))) + +(defsetf websession-variable .inv-websession-variable) + +(defun .inv-websession-variable (websession name newvalue) + (if* (null websession) + then ; do nothing since there is no session + newvalue + else + (let ((ent (assoc name (websession-variables websession) + :test #'equal))) + (if* ent + then (setf (cdr ent) newvalue) + else (setq ent (cons name newvalue)) + (push ent (websession-variables websession))) + newvalue))) + + + +(defun reap-unused-sessions (sm) + (let ((now (acl-compat.excl::cl-internal-real-time)) + (lifetime (sm-lifetime sm)) + (reap-fcn (sm-reap-hook-function sm)) + (toreap)) + (maphash #'(lambda (id websession) + (declare (ignore id)) + (if* (> now + (+ (websession-lastref websession) lifetime)) + then (if* (and reap-fcn + (funcall reap-fcn websession)) + then ; keep around this session longer + (setf (websession-lastref websession) now) + else (push websession toreap)))) + (sm-websessions sm)) + + (dolist (websession toreap) + (format t " flush session ~s~%" (websession-key websession)) + (force-output) + (remhash (websession-key websession) (sm-websessions sm))))) + + + + + Added: vendor/portableaserve/build-aserve-lw.lisp =================================================================== --- vendor/portableaserve/build-aserve-lw.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/build-aserve-lw.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: CL-USER; Base: 10 -*- +;;; +;;; Builds a LispWorks image of paserve. + +(in-package :cl-user) + +#-lispworks +(error "This only works with Lispworks.") + +(load (merge-pathnames "compile-aserve-lw.lisp" *load-truename*)) + +(deliver #'net.aserve::start-cmd + (merge-pathnames "aserve-lw" *load-truename*) + 0 + :multiprocessing t + :keep-pretty-printer t + :keep-clos t + )) Added: vendor/portableaserve/clean.sh =================================================================== --- vendor/portableaserve/clean.sh 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/clean.sh 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +#!/bin/sh + +for i in `cat acl-compat/.cvsignore` ; + do find . -name $i -type f -delete +done Added: vendor/portableaserve/compile-aserve-lw.lisp =================================================================== --- vendor/portableaserve/compile-aserve-lw.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/compile-aserve-lw.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: CL-USER; Base: 10 -*- +;;; +;;; Compiles paserve for LispWorks + +(in-package :cl-user) + +#-lispworks +(error "This only works with Lispworks.") + +(load (merge-pathnames "logical-hostnames.lisp" *load-truename*)) + +(load "acl-compat:defsys.lisp") +(let ((lw:*handle-warn-on-redefinition* :warn)) + (scm:compile-system 'acl-compat :load t)) +(load "aserve:defsys.lisp") +(let ((lw:*handle-warn-on-redefinition* :warn)) + (scm:compile-system 'aserve :load t)) Added: vendor/portableaserve/contrib/.cvsignore =================================================================== --- vendor/portableaserve/contrib/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/contrib/CVS/Entries =================================================================== --- vendor/portableaserve/contrib/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/example.lsp/1.1/Fri Jul 19 09:35:33 2002// +/lsp.lisp/1.1/Fri Jul 19 09:35:33 2002// +/session.lisp/1.1/Fri Jul 19 09:23:33 2002// +D Added: vendor/portableaserve/contrib/CVS/Repository =================================================================== --- vendor/portableaserve/contrib/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/contrib Added: vendor/portableaserve/contrib/CVS/Root =================================================================== --- vendor/portableaserve/contrib/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/contrib/example.lsp =================================================================== --- vendor/portableaserve/contrib/example.lsp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/example.lsp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,46 @@ +<html> +<head> +<title> +</title> +</head> +<body> + +<h1>LSP Example</h1> + +<h2>User Agent</h2> +<%= + (:princ-safe (or (net.aserve:header-slot-value com.lemonodor.lsp:request + :user-agent) + "None.")) +%> + +<h2>Referrer</h2> +<%= + (:princ-safe (or (net.aserve:header-slot-value com.lemonodor.lsp:request + :referer) + "None.")) +%> + +<h2>Query Variables</h2> +<table> +<% +(let ((queries (net.aserve:request-query com.lemonodor.lsp:request))) + (if (null queries) + (net.html.generator:html (:tr (:td "None."))) + (dolist (query queries) + (net.html.generator:html + (:tr (:td (:princ-safe (car query))) + (:td (:princ-safe (cdr query)))))))) +%> +</table> + +<h2>Loop Of Dynamism</h2> + +<% (dotimes (i (+ (random 10) 1)) %> + Hi! +<% ) %> + + +</body> + +</html> Added: vendor/portableaserve/contrib/lsp.lisp =================================================================== --- vendor/portableaserve/contrib/lsp.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/lsp.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,240 @@ +;;; -------------------------------------------------------------------- +;;; Lisp Server Pages (LSP) -- Implements something like Java Server +;;; Pages (JSP), but for Lisp. +;;; +;;; Copyright 2001, 2002 I/NET Inc. (http://www.inetmi.com/) +;;; John Wiseman (jjwiseman(a)yahoo.com) +;;; 2002-06-10 +;;; Licensed under the MIT license: +#|| +Copyright (c) 2001, 2002 I/NET Inc. + +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. +||# +;;; +;;; +;;; * Introduction +;;; +;;; Java Server Pages are a way to make web pages that are dynamic, by +;;; embedding Java code in HTML. Similarly, Lisp Server Pages allow +;;; you to make dynamic web pages that contain Lisp code. +;;; +;;; To publish an LSP page, call the PUBLISH-LSP function: +;;; +;;; PUBLISH-LSP (&key path file server) [function] +;;; Publishes the LSP file FILE at the URL prefix PATH, on SERVER +;;; (defaults to the default AllegroServe server, *wserver*). Example: +;;; (publish-lsp :path "/temp.html" :file "/Users/wiseman/src/temperature.lsp") +;;; +;;; An LSP file looks just like an HTML file, except for two new tags: +;;; <% ... %> and <%= ... %>. +;;; +;;; <% ... %> is a scriptlet tag (to use the JSP terminology), and +;;; wraps lisp code. For example, <% (dotimes (i 10) (beep)) %>. The +;;; code inside the tag is executed each time the page is requested. +;;; +;;; <%= ... %> is an expression tag, and the effect of this tag is to +;;; evaluate the contents as if they were wrapped with the Franz +;;; net.html.generator:html macro. For example, +;;; +;;; <%= (:h1 "header") "hi" (:princ-safe (generate-footer)) %> +;;; +;;; is equivalent to +;;; +;;; (net.html.generator:html +;;; (:h1 "header") +;;; "hi" +;;; (:princ-safe (generate-footer))) +;;; +;;; which will output something like the following HTML: +;;; +;;; <h1>header</h1>hi<hr>2002-06-09 +;;; +;;; During execution of LSP code, the following two variables will be +;;; bound: +;;; +;;; request -- The HTTP request object containing all the +;;; information about the request. +;;; entity -- The information passed to the publish-lsp function. +;;; +;;; (See the AllegroServe documentation for more information on these +;;; objects.) +;;; +;;; +;;; * Tips +;;; +;;; Expressions can be used inside HTML attributes, e.g., +;;; +;;; <img src="<%= (img-title request) %>"> +;;; +;;; Scriptlets do not need to be complete lisp forms, as long as the +;;; page as a whole is syntactically valid, e.g., +;;; +;;; <% (dotimes (i 10) %> +;;; <img src="mr-yuck.jpg"> +;;; <% ) %> +;;; +;;; +;;; * Implementation Notes and Caveats +;;; +;;; LSP pages are converted to strings containing lisp code, which are +;;; then compiled and cached. If the source file containing the lsp +;;; code is modified, the next time a request is made for that page +;;; the code will be recompiled and recached. +;;; +;;; In my first attempt to do this, I tried to construct forms instead +;;; of strings. That just made it trickier to separate forms across +;;; <% ... %> tags (see the dotimes example above). Just because it's +;;; bad that other languages are often *limited* to manipulating code +;;; as strings doesn't mean there aren't times where it's appropriate. +;;; +;;; There's nothing like JSP's directives or declarations. +;;; +;;; LSP Requires Franz' AllegroServe +;;; (http://allegroserve.sourceforge.net/) or Portable AllegroServe +;;; (http://portableaserve.sourceforge.net/) +;;; +;;; See http://sourceforge.net/projects/lsp for a more serious attempt +;;; at doing this right, by Sunil Mishra and Tim Bradshaw. + +(require :aserve) + + +(defpackage :com.lemonodor.lsp + (:use #:common-lisp) + (:export #:publish-lsp #:request #:entity)) + +(in-package :com.lemonodor.lsp) + + +(defun publish-lsp (&key path file (server net.aserve:*wserver*)) + "Publishes an LSP file. PATH is a string containing the name part + of the URL at which to publish the file, e.g. \"/math/sum.lsp\"; + FILE is a pathname that specifies the file containing the page + to publish." + (net.aserve:publish :path path + :server server + :function #'(lambda (request entity) + (do-lsp-request request entity file)))) + +(defun do-lsp-request (request entity file) + "Handles the request for an LSP URL." + (funcall (get-lsp-function file) request entity)) + + +(defvar *lsp-functions* (make-hash-table :test #'equal) + "The table mapping LSP filespecs to function-time pairs.") + +(defun get-lsp-function (file) + "Returns the function implementing a given LSP file. Builds and + compiles the function the first time it's requested, or if the file + has been modified." + (let ((func.time (gethash file *lsp-functions*))) + (if (or (null func.time) + (> (file-write-date file) (cdr func.time))) + (register-lsp-function file + (construct-lsp-function (contents-of-file file))) + (car func.time)))) + +(defun register-lsp-function (file function) + (setf (gethash file *lsp-functions*) (cons function (get-universal-time))) + function) + + +(defun construct-lsp-function (lsp-string) + "Builds and compiles the request-handling LSP function for the page + whose contents are in LSP-STRING." + (let ((form + `(lambda (request entity) + (net.aserve:with-http-response (request entity) + (net.aserve:with-http-body (request entity) + ;; We punt hard on the issue of package. + ,(read-from-string + (format nil "(progn ~A)" + (construct-lsp-body-string lsp-string)))))))) + (compile nil form))) + + +(defun contents-of-file (pathname) + "Returns a string with the entire contents of the specified file." + ;; This is excl:file-contents in ACL. + (with-output-to-string (contents) + (with-open-file (in pathname :direction :input) + (let* ((buffer-size 4096) + (buffer (make-string buffer-size))) + (labels ((read-chunks () + (let ((size (read-sequence buffer in))) + (if (< size buffer-size) + (princ (subseq buffer 0 size) contents) + (progn + (princ buffer contents) + (read-chunks)))))) + (read-chunks)))))) + + +;; (i) Converts text outside <% ... %> tags (straight HTML) into calls +;; to net.html.generator.html, (ii) Text inside <% ... %> +;; ("scriptlets") is straight lisp code, (iii) Text inside <%= ... %> +;; ("expressions") becomes the body of the net.html.generator:html +;; macro. + +(defun construct-lsp-body-string (lsp-string &optional (start 0)) + "Takes a string containing an LSP page and returns a string + containing the lisp code that implements that page." + (multiple-value-bind (start-tag start-code tag-type) + (next-code lsp-string start) + (if (not start-tag) + (format nil "(net.html.generator:html ~S)" (subseq lsp-string start)) + (let ((end-code (search "%>" lsp-string :start2 start-code))) + (if (not end-code) + (error "EOF reached in LSP inside open '<%' tag.") + (format nil "(net.html.generator:html ~S) ~A ~A" + (subseq lsp-string start start-tag) + (format nil (tag-template tag-type) + (subseq lsp-string start-code end-code)) + (construct-lsp-body-string lsp-string (+ end-code 2)))))))) + + +;; Finds the next scriptlet or expression tag in LSP source. Returns +;; nil if none are found, otherwise returns 3 values: +;; 1. The position of the opening bracket (<) of the tag. +;; 2. The position of the contents of the tag. +;; 3. The type of tag (:scriptlet or :expression). + +(defun next-code (string start) + (let ((start-tag (search "<%" string :start2 start))) + (if (not start-tag) + nil + (if (and (> (length string) (+ start-tag 2)) + (eql (char string (+ start-tag 2)) #\=)) + (values start-tag (+ start-tag 3) :expression) + (values start-tag (+ start-tag 2) :scriptlet))))) + + +;; Given a tag type (:scriptlet or :expression), returns a format +;; string to be used to generate source code from the contents of the +;; tag. + +(defun tag-template (tag-type) + (ecase tag-type + ((:scriptlet) "~A") + ((:expression) "(net.html.generator:html ~A)"))) + + Added: vendor/portableaserve/contrib/session.lisp =================================================================== --- vendor/portableaserve/contrib/session.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/contrib/session.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,188 @@ + +#|| +Subject: Session Support in aserve +Date: 18 Jul 2002 16:22:38 -0400 +From: Brendan Burns <bburns(a)genet.cs.umass.edu> +To: opensource(a)franz.com + + + +Hey folks, I've implemented persistent session support for +AllegroServe. For every user who connects to AllegroServe, the server +maintains a global hash-table until the user has been inactive for a +specified period of time and then the session is removed. This is +similar to session support in Java Servlets and PHP. The code is +attached including several samples (look at "with-session-test" for a +nice starter) + +This code is released under the GPL and Franz should feel free to +incorporate it into future versions of allegro serve. + +??/Bugs -> Me + +- --brendan +||# + +(in-package :net.aserve) +(defvar *global-sessions* (make-hash-table :test #'equal)) +(defvar *session-reaper-thread* nil) + +(defparameter *session-life* 3600) + +(defun set-session-limit (time) + (setf *session-life* time)) + +(defun get-session-limit () + *session-life*) + +(defun session-reaper () + (loop while (> (hash-table-size *global-sessions*) 0) + do (let ((test-time (get-universal-time))) + (maphash #'(lambda (key val) + (when (> (- test-time (car val)) *session-life*) + (remhash key *global-sessions*))) + *global-sessions*)) + do (sleep 30)) + (setf *session-reaper-thread* nil)) + + +(defun reset-sessions () + (setf *global-sessions* (make-hash-table :test #'equal))) + +(defun make-session () + (if (not *session-reaper-thread*) + (setf *session-reaper-thread* + (mp::process-run-function "session-reaper" #'session-reaper))) + (list (get-universal-time) (make-hash-table))) + +(defun get-session (req &key (create t)) + (let ((session-id (get-cookie-value req "aserve_session")) + (session nil)) + (if session-id + (if (gethash session-id *global-sessions*) + (setf session (gethash session-id *global-sessions*)) + (if create + (setf session + (setf (gethash session-id *global-sessions*) + (make-session))))) + (if create + (let ((new-id (string (gensym)))) + (setf session (make-session)) + (setf (gethash new-id *global-sessions*) session) + (set-cookie-header req :name "aserve_session" + :value new-id)))) + (if session (setf (car session) (get-universal-time))) + (cadr session))) + +(defmacro with-session (req session-name &body body) + `(let ((,session-name (get-session ,req))) + (unwind-protect + (progn ,@body)))) + +(defun get-cookie-hash-table (req &optional (external-format *default-aserve-external-format*)) + (let ((result (make-hash-table))) + (mapc (lambda (name-value-pair) + (setf (gethash (car name-value-pair) result) + (cdr name-value-pair)) + (print (gethash (car name-value-pair) result))) + (get-cookie-values req external-format)) + result)) + +(defmacro with-cookie-hash (req hash-name &body body) + `(let ((,hash-name (get-cookie-hash-table ,req))) + (unwind-protect + (progn ,@body)))) + +(defun get-cookie-value (req name) + (let ((result nil)) + (mapc (lambda (name-value-pair) + (if (equal name (car name-value-pair)) + (setf result (cdr name-value-pair)))) + (get-cookie-values req)) + result)) + +(defmacro with-cookie-value (req value name &body body) + `(let ((,value (get-cookie-value ,req ,name))) + (unwind-protect + (progn ,@body)))) + + +#+TEST +(defun with-hash-test (req ent) + (with-http-response (req ent) + (with-cookie-hash req hash + (with-http-body + (req ent) + (html + (:html + (:body (:princ (gethash "counter" hash))))))))) + +#+TEST +(defun cookie-test (req ent) + (with-http-response + (req ent) + (with-cookie-value req counter "counter" + (with-http-body + (req ent) + (html + (:html + (:body + ((:font :color "red") (:princ counter))))))))) + +#+TEST +(defun cookie-counter (req ent) + (with-http-response + (req ent) + (let ((val 0)) + (with-cookie-value + req counter "counter" + (if counter (setf val (parse-integer counter))) + (set-cookie-header req :name "counter" + :value (format nil "~A" (1+ val))) + (with-http-body + (req ent) + (html + (:html (:head (:title "Counter Tester")) + (:body + ((:font :color "red") "The value is: " (:princ val)))))))))) + + +#+TEST +(defun session-test (req ent) + (with-http-response (req ent) + (let ((session (get-session req))) + (with-http-body (req ent) + (html + (:html (:head (:title "Session Test")) + (:body + ((:font :color "blue") "Your session " + (:princ (if (gethash 'val session) "is present" + (progn + (setf (gethash 'val session) t) + "has been started"))))))))))) + +#+TEST +(defun with-session-test (req ent) + (with-http-response (req ent) + (with-session req session + (with-http-body (req ent) + (html + (:html (:head (:title "Session Test")) + (:body + ((:font :color "blue") "Your session " + (:princ (if (gethash 'val session) "is present" + (progn + (setf (gethash 'val session) t) + "has been started"))))))))))) + +(defun session-reset (req ent) + (with-http-response (req ent) + (with-http-body (req ent) + (reset-sessions) + (html + (:html (:head (:title "Session Reset")) + (:body "All sessions have been cleared")))))) + +#+YOU-OUGHT-TO-DO-THIS +(publish :path "/admin/reset-sessions" :function #'session-reset) + Added: vendor/portableaserve/debian/.cvsignore =================================================================== --- vendor/portableaserve/debian/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,7 @@ +tmp +*.debhelper +cl-acl-compat +files +*substvars +{arch} +.arch-ids Added: vendor/portableaserve/debian/CVS/Entries =================================================================== --- vendor/portableaserve/debian/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,20 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:01 2004// +/README.Debian/1.9/Sat Aug 21 17:54:35 2004// +/changelog/1.57/Thu Mar 3 09:37:30 2005// +/cl-acl-compat.README.Debian/1.1/Sat Oct 13 10:57:07 2001// +/cl-acl-compat.postinst/1.6/Wed Aug 4 02:41:53 2004// +/cl-acl-compat.preinst/1.1/Thu Oct 10 15:29:12 2002// +/cl-acl-compat.prerm/1.3/Wed Aug 4 02:41:53 2004// +/cl-aserve.doc-base/1.2/Sat Dec 21 16:53:38 2002// +/cl-aserve.docs/1.3/Wed Dec 18 06:09:04 2002// +/cl-aserve.postinst/1.4/Wed Aug 4 02:41:53 2004// +/cl-aserve.preinst/1.1/Thu Oct 10 15:29:12 2002// +/cl-aserve.prerm/1.2/Wed Aug 4 02:41:53 2004// +/cl-htmlgen.docs/1.1/Wed Dec 18 06:09:04 2002// +/cl-htmlgen.postinst/1.4/Wed Aug 4 02:41:53 2004// +/cl-htmlgen.preinst/1.1/Thu Oct 10 15:29:12 2002// +/cl-htmlgen.prerm/1.2/Wed Aug 4 02:41:53 2004// +/control/1.25/Thu Mar 3 09:37:30 2005// +/copyright/1.4/Mon Sep 30 12:01:24 2002// +/rules/1.12/Fri Dec 5 22:36:32 2003// +D Added: vendor/portableaserve/debian/CVS/Repository =================================================================== --- vendor/portableaserve/debian/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/debian Added: vendor/portableaserve/debian/CVS/Root =================================================================== --- vendor/portableaserve/debian/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/debian/README.Debian =================================================================== --- vendor/portableaserve/debian/README.Debian 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/README.Debian 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,21 @@ +The Debian Package cl-portable-aserve +------------------------------------- + +Note: On CMUCL, this package also requires the Debian package +cmucl-source. However, cmucl-source package is not included as a +dependency for cl-portable-aserve since cl-portable-aserve can be used +with other CL implementations which would not require cmucl-source. + +Example files may be found in: +/usr/share/doc/cl-aserve/examples/ + +More info about Portable Aserve may be found on +http://www.sourceforge.net/projects/portableaserve/ + +*** INCOMPATIBILITY NOTICE *** + +The webactions module is not yet completely portable. Currently, it +compiles only on Lispworks and Allegro. Patches will be welcomed +upstream. + + -- Kevin M. Rosenberg <kmr(a)debian.org>, Sat Aug 21 11:53:11 2004 Added: vendor/portableaserve/debian/changelog =================================================================== --- vendor/portableaserve/debian/changelog 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/changelog 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,320 @@ +cl-portable-aserve (1.2.42+cvs.2005.02.21) unstable; urgency=low + + * New maintainer. (Closes: #297380: O: cl-portable-aserve -- + Compatibility layer for Allegro Common Lisp) + * / 297381 Adopted by Peter Van Eynde + + -- Peter Van Eynde <pvaneynd(a)debian.org> Tue, 1 Mar 2005 10:18:57 +0100 + +cl-portable-aserve (1.2.42+cvs.2005.02.20) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 20 Feb 2005 13:33:23 -0700 + +cl-portable-aserve (1.2.35+cvs.2004.09.24) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 24 Sep 2004 10:59:00 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.31) unstable; urgency=high + + * New upstream with important SBCL changes + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 31 Aug 2004 14:35:27 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.21) unstable; urgency=low + + * Update README.Debian (closes:267234) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 21 Aug 2004 11:53:38 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.11) unstable; urgency=low + + * Add acl-compat function for lispworks (closes:265041) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 11 Aug 2004 13:03:20 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.04) unstable; urgency=low + + * Fix compilation on Allegro (closes:248033) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 4 Aug 2004 22:23:58 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.03) unstable; urgency=low + + * Convert to CLC 4 (closes:263378) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 3 Aug 2004 20:41:32 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.08.02) unstable; urgency=low + + * README.Debian: Add note about incompatibilities for webactions + (closes:260199) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 2 Aug 2004 21:41:06 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.07.08) unstable; urgency=low + + * New upstream (closes:258127) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 8 Jul 2004 11:54:41 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.06.09) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 9 Jun 2004 21:49:44 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.04.26) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 26 Apr 2004 12:18:16 -0600 + +cl-portable-aserve (1.2.35+cvs.2004.03.16b) unstable; urgency=low + + * New upstream + * Now compiles webactions on cmucl/sbcl (closes:231151) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 16 Mar 2004 13:41:41 -0700 + +cl-portable-aserve (1.2.35+cvs.2004.03.16) unstable; urgency=low + + * New upstream (closes:238258) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 16 Mar 2004 09:26:22 -0700 + +cl-portable-aserve (1.2.35+cvs.2004.03.15) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 15 Mar 2004 19:53:00 -0700 + +cl-portable-aserve (1.2.35+cvs.2004.03.05) unstable; urgency=low + + * Add dependencies on cl-ppcre and cl-puri (closes:236283) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 5 Mar 2004 19:55:59 -0700 + +cl-portable-aserve (1.2.35+cvs.2004.03.01) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 1 Mar 2004 10:04:49 -0700 + +cl-portable-aserve (1.2.33+cvs2003.12.05) unstable; urgency=low + + * Add cl-webactions binary package + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 5 Dec 2003 14:47:40 -0700 + +cl-portable-aserve (1.2.33+cvs2003.12.02) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 2 Dec 2003 09:47:07 -0700 + +cl-portable-aserve (1.2.27+cvs2003.11.15b) unstable; urgency=low + + * Add notice to README.Debian about dependencies when compiling + on CMUCL (closes:220765) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 15 Nov 2003 20:31:55 -0700 + +cl-portable-aserve (1.2.27+cvs2003.11.15) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 15 Nov 2003 20:19:28 -0700 + +cl-portable-aserve (1.2.27+cvs2003.09.19) unstable; urgency=low + + * New upstream, fix clisp compilation (closes:210759) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 19 Sep 2003 09:41:22 -0600 + +cl-portable-aserve (1.2.27+cvs2003.09.13) unstable; urgency=low + + * Add depends for cl-htmlgen (closes:210756) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 13 Sep 2003 11:31:17 -0600 + +cl-portable-aserve (1.2.27+cvs2003.09.10) unstable; urgency=low + + * Update description for cl-htmlgen (closes: 209449) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 10 Sep 2003 00:13:27 -0600 + +cl-portable-aserve (1.2.27+cvs2003.08.29) unstable; urgency=low + + * New upstream + * Patched to allegroserver 1.2.27 version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 24 Aug 2003 12:18:25 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.08.17) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 17 Aug 2003 23:45:03 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.08.09) unstable; urgency=low + + * Use CMUCL graystream (closes:203860) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 9 Aug 2003 19:08:51 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.07.29) unstable; urgency=low + + * Update dependencies to move package into testing + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 29 Jul 2003 13:32:29 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.07.06) unstable; urgency=low + + * Update for cmucl-18e + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 5 Jul 2003 21:48:33 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.06.12) unstable; urgency=low + + * Add version dependency for cmucl 18e (closes: 197564) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 15 Jun 2003 19:53:43 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.06.11) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 28 May 2003 15:07:49 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.05.11) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 11 May 2003 16:02:05 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.04.15) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 15 Apr 2003 13:45:49 -0600 + +cl-portable-aserve (1.2.12c+cvs2003.01.11) unstable; urgency=low + + * Add information to README.Debian about the need to install + the Debian package cmucl-graystream (closes: 175898) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 11 Jan 2003 14:41:48 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.12.27) unstable; urgency=low + + * Add ACL compatibility + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 26 Dec 2002 16:17:14 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.12.26) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 17 Dec 2002 23:02:12 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.12.11) unstable; urgency=low + + * Move htmlgen.html to cl-htmlgen package + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 11 Dec 2002 06:36:04 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.12.05) unstable; urgency=low + + * Fix loading of gray streams during compile-op + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 5 Dec 2002 09:23:20 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.12.02) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 2 Dec 2002 09:57:40 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.11.07) unstable; urgency=low + + * Adds clisp support + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 8 Nov 2002 08:49:25 -0700 + +cl-portable-aserve (1.2.12c+cvs2002.10.20) unstable; urgency=low + + * acl-compat.asd: to improve graystream handling with Common Lisp + Controller. Merge acl-compat-mcl.system. + * control: Add explanation for the requirement of cmucl-graystream. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 20 Oct 2002 13:36:18 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.10.16) unstable; urgency=low + + * Add reader conditional on .asd files so that defsystem is only read + for compatible implementations. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 16 Oct 2002 01:42:32 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.10.15) unstable; urgency=low + + * Add cl-htmlgen to Depends: for cl-aserve + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 15 Oct 2002 16:55:57 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.10.10) unstable; urgency=low + + * Test and remove any old symlinks by pre-offical versions of this package + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 10 Oct 2002 09:27:42 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.10.09) unstable; urgency=low + + * Push package name onto features after .asd load-op + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 9 Oct 2002 11:47:11 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.10.06) unstable; urgency=low + + * Expand package descriptions (closes: 163598) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 6 Oct 2002 20:07:13 -0600 + +cl-portable-aserve (1.2.12c+cvs2002.09.22) unstable; urgency=low + + * New upstream release + * Initial Debian Release (closes: 162213) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 23 Sep 2002 07:38:34 -0600 + +cl-portable-aserve (1.2.5b-4) unstable; urgency=low + + * Fixing lintian bugs + + -- Stig E Sandoe <stig(a)users.sourceforge.net> Sat, 13 Oct 2001 15:11:03 +0200 + +cl-portable-aserve (1.2.5b-3) unstable; urgency=low + + * Minor fix on debian-package type. + + -- Stig E Sandoe <stig(a)users.sourceforge.net> Sat, 13 Oct 2001 14:09:41 +0200 + +cl-portable-aserve (1.2.5b-2) unstable; urgency=low + + * Added some files from original CVS. + * Changed doc-category to Lisp/Net + * Added improved thread-handling for CMU + + -- Stig E Sandoe <stig(a)users.sourceforge.net> Sat, 13 Oct 2001 12:22:51 +0200 + +cl-portable-aserve (1.2.5b-1) unstable; urgency=low + + * Initial Release. + + -- Stig E Sandoe <stig(a)users.sourceforge.net> Fri, 12 Oct 2001 20:49:30 +0200 + + Added: vendor/portableaserve/debian/cl-acl-compat.README.Debian =================================================================== --- vendor/portableaserve/debian/cl-acl-compat.README.Debian 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-acl-compat.README.Debian 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,14 @@ +Package cl-acl-compat +--------------------- + +ACL-COMPAT is a thin wrapper for ACL-functionality. + +You can use it: +$ lisp +* (require :acl-compat) + +More info about Portable Aserve, where acl-compat also resides, may be found on +http://www.sourceforge.net/projects/portableaserve/ + +Package maintainer: +Stig E Sandoe <stig(a)users.sourceforge.net> Added: vendor/portableaserve/debian/cl-acl-compat.postinst =================================================================== --- vendor/portableaserve/debian/cl-acl-compat.postinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-acl-compat.postinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,39 @@ +#! /bin/sh +set -e + +# summary of how this script can be called: +# * <postinst> `configure' <most-recently-configured-version> +# * <old-postinst> `abort-upgrade' <new version> +# * <conflictor's-postinst> `abort-remove' `in-favour' <package> +# <new-version> +# * <deconfigured's-postinst> `abort-deconfigure' `in-favour' +# <failed-install-package> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +PKG=acl-compat + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source $PKG + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/cl-acl-compat.preinst =================================================================== --- vendor/portableaserve/debian/cl-acl-compat.preinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-acl-compat.preinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +#!/bin/bash + +pkg=acl-compat +dir=/usr/share/common-lisp/source/$pkg + +case "$1" in + install|upgrade|abort-upgrade) + # Remove any old symlinks + test -h $dir && rm $dir + ;; + *) + echo "preinst called with unknown argument '$1'" >&2 + ;; +esac + +#DEBHELPER# + +exit 0 Property changes on: vendor/portableaserve/debian/cl-acl-compat.preinst ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/debian/cl-acl-compat.prerm =================================================================== --- vendor/portableaserve/debian/cl-acl-compat.prerm 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-acl-compat.prerm 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,32 @@ +#! /bin/sh +set -e + +# summary of how this script can be called: +# * <prerm> `remove' +# * <old-prerm> `upgrade' <new-version> +# * <new-prerm> `failed-upgrade' <old-version> +# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version> +# * <deconfigured's-prerm> `deconfigure' `in-favour' +# <package-being-installed> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ + +THE_PACKAGE_NAME=acl-compat + +case "$1" in + remove|upgrade|deconfigure) + unregister-common-lisp-source ${THE_PACKAGE_NAME} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/cl-aserve.doc-base =================================================================== --- vendor/portableaserve/debian/cl-aserve.doc-base 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-aserve.doc-base 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,9 @@ +Document: cl-aserve +Title: Aserve documentation +Author: Franz, Inc +Abstract: Documentation for the webserver Aserve +Section: Lisp/Net + +Format: HTML +Index: /usr/share/doc/cl-aserve/aserve.html +Files: /usr/share/doc/cl-aserve/*.html Added: vendor/portableaserve/debian/cl-aserve.docs =================================================================== --- vendor/portableaserve/debian/cl-aserve.docs 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-aserve.docs 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,5 @@ +README +aserve/doc/aserve.html +aserve/doc/cvs.html +aserve/doc/rfc2396.txt +aserve/doc/tutorial.html Added: vendor/portableaserve/debian/cl-aserve.postinst =================================================================== --- vendor/portableaserve/debian/cl-aserve.postinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-aserve.postinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,39 @@ +#! /bin/sh +set -e + +# summary of how this script can be called: +# * <postinst> `configure' <most-recently-configured-version> +# * <old-postinst> `abort-upgrade' <new version> +# * <conflictor's-postinst> `abort-remove' `in-favour' <package> +# <new-version> +# * <deconfigured's-postinst> `abort-deconfigure' `in-favour' +# <failed-install-package> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +PKG=aserve + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source $PKG + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/cl-aserve.preinst =================================================================== --- vendor/portableaserve/debian/cl-aserve.preinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-aserve.preinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +#!/bin/bash + +pkg=aserve +dir=/usr/share/common-lisp/source/$pkg + +case "$1" in + install|upgrade|abort-upgrade) + # Remove any old symlinks + test -h $dir && rm $dir + ;; + *) + echo "preinst called with unknown argument '$1'" >&2 + ;; +esac + +#DEBHELPER# + +exit 0 Property changes on: vendor/portableaserve/debian/cl-aserve.preinst ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/debian/cl-aserve.prerm =================================================================== --- vendor/portableaserve/debian/cl-aserve.prerm 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-aserve.prerm 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,33 @@ +#! /bin/sh +set -e + +# summary of how this script can be called: +# * <prerm> `remove' +# * <old-prerm> `upgrade' <new-version> +# * <new-prerm> `failed-upgrade' <old-version> +# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version> +# * <deconfigured's-prerm> `deconfigure' `in-favour' +# <package-being-installed> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ + +THE_PACKAGE_NAME=aserve + +case "$1" in + remove|upgrade|deconfigure) +# install-info --quiet --remove /usr/info/#PACKAGE#.info.gz + /usr/sbin/unregister-common-lisp-source ${THE_PACKAGE_NAME} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/cl-htmlgen.docs =================================================================== --- vendor/portableaserve/debian/cl-htmlgen.docs 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-htmlgen.docs 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +aserve/doc/htmlgen.html Added: vendor/portableaserve/debian/cl-htmlgen.postinst =================================================================== --- vendor/portableaserve/debian/cl-htmlgen.postinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-htmlgen.postinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,43 @@ +#! /bin/sh +# postinst script for series +# +# see: dh_installdeb(1) + +set -e + +# summary of how this script can be called: +# * <postinst> `configure' <most-recently-configured-version> +# * <old-postinst> `abort-upgrade' <new version> +# * <conflictor's-postinst> `abort-remove' `in-favour' <package> +# <new-version> +# * <deconfigured's-postinst> `abort-deconfigure' `in-favour' +# <failed-install-package> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +PKG=htmlgen + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source $PKG + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/cl-htmlgen.preinst =================================================================== --- vendor/portableaserve/debian/cl-htmlgen.preinst 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-htmlgen.preinst 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,18 @@ +#!/bin/bash + +pkg=htmlgen +dir=/usr/share/common-lisp/source/$pkg + +case "$1" in + install|upgrade|abort-upgrade) + # Remove any old symlinks + test -h $dir && rm $dir + ;; + *) + echo "preinst called with unknown argument '$1'" >&2 + ;; +esac + +#DEBHELPER# + +exit 0 Property changes on: vendor/portableaserve/debian/cl-htmlgen.preinst ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/debian/cl-htmlgen.prerm =================================================================== --- vendor/portableaserve/debian/cl-htmlgen.prerm 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/cl-htmlgen.prerm 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,33 @@ +#! /bin/sh + +set -e + +# summary of how this script can be called: +# * <prerm> `remove' +# * <old-prerm> `upgrade' <new-version> +# * <new-prerm> `failed-upgrade' <old-version> +# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version> +# * <deconfigured's-prerm> `deconfigure' `in-favour' +# <package-being-installed> <version> `removing' +# <conflicting-package> <version> +# for details, see /usr/share/doc/packaging-manual/ + +THE_PACKAGE_NAME=htmlgen + +case "$1" in + remove|upgrade|deconfigure) + unregister-common-lisp-source ${THE_PACKAGE_NAME} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: vendor/portableaserve/debian/control =================================================================== --- vendor/portableaserve/debian/control 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/control 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,39 @@ +Source: cl-portable-aserve +Section: web +Priority: optional +Maintainer: Peter Van Eynde <pvaneynd(a)debian.org> +Standards-Version: 3.6.1.1 +Build-Depends-Indep: debhelper (>= 4.0.0) + +Package: cl-aserve +Architecture: all +Depends: common-lisp-controller (>= 3.56), cl-acl-compat, cl-htmlgen +Suggests: cl-webactions +Description: Portable Aserve + A portable version of AllegroServe which is a web application server + for Common Lisp programs. It also includes an HTTP client function + for accessing web sites and retrieving data. + +Package: cl-acl-compat +Architecture: all +Depends: common-lisp-controller (>= 3.56), cl-ppcre, cl-puri +Description: Compatibility layer for Allegro Common Lisp + A thin compatibility-layer that emulates library functions provided + by Allegro Common Lisp. It is used + to support a number of Franz's open-source packages which depend upon + such library functions. + +Package: cl-htmlgen +Architecture: all +Depends: common-lisp-controller (>= 3.56), cl-acl-compat +Description: HTML generation library for Common Lisp programs + cl-htmlgen is Franz's library for generating HTML from Common Lisp programs. + It is limited to generating HTML code, so you may want to use the cl-lml2 + Debian package for generating XHTML code. + +Package: cl-webactions +Architecture: all +Depends: common-lisp-controller (>= 3.56), cl-aserve +Description: HTTP dispatch library for cl-aserve + Webactions is Franz's library for dispatching HTTP requests as well as + processing HTML templates. It uses the cl-aserve package. Added: vendor/portableaserve/debian/copyright =================================================================== --- vendor/portableaserve/debian/copyright 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/copyright 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,93 @@ +This package was initially Debianized by Stig E Sandoe +<stig(a)users.sourceforge.net>. Packaging was updated and Common Lisp +Controller compatibility was added by Kevin Rosenberg <kmr(a)debian.org> +who is the Debian package maintainer. + +The original Aserve is written by Franz Inc, and Portable +Aserve is maintained by a small team on Sourceforge. +Prominent team-members: + Jochen Schmidt + Vebj�rn Ljos� + Rudolf Schlatte + +Changes compared to upstream: This is a native Debian packages so +there are no differences betweeh the upstream and the Debian package. + +Copyright (c) 2000 Franz Inc., Berkeley, CA 94704 + +This code is free software; you can redistribute it and/or modify it +under the terms of the version 2.1 of the GNU Lesser General Public +License as published by the Free Software Foundation, as clarified by +the Franz preamble to the LGPL found in +http://opensource.franz.com/preamble.html. The preambled is copied below. + +This code is distributed in the hope that it will be useful, +but without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. See the GNU +Lesser General Public License for more details. + +The GNU Lessor General Public License can be found in your Debian file +system in /usr/share/common-licenses/LGPL. + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. Added: vendor/portableaserve/debian/rules =================================================================== --- vendor/portableaserve/debian/rules 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/debian/rules 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,95 @@ +#!/usr/bin/make -f + +pkg-compat := cl-acl-compat +pkg-aserve := cl-aserve +pkg-webact := cl-webactions +pkg-html := cl-htmlgen + +name-compat := acl-compat +name-aserve := aserve +name-webact := webactions +name-html := htmlgen + +clc-base := usr/share/common-lisp +clc-systems := $(clc-base)/systems +clc-source := $(clc-base)/source +clc-aserve := $(clc-source)/$(name-aserve) +clc-html := $(clc-source)/$(name-html) +clc-compat := $(clc-source)/$(name-compat) +clc-webact := $(clc-source)/$(name-webact) + +src-aserve := aserve/*.cl aserve/*.asd +src-webact := aserve/webactions/*.cl aserve/webactions/*.asd aserve/webactions/clpcode +src-html := aserve/htmlgen/*.cl aserve/htmlgen/*.asd +src-compat := acl-compat/*.lisp acl-compat/*.asd acl-compat/allegro acl-compat/clisp acl-compat/cmucl acl-compat/lispworks acl-compat/mcl acl-compat/sbcl + +doc-base := usr/share/doc + +examples := aserve/examples/*.cl aserve/examples/*.jpg \ + aserve/examples/*.gif aserve/examples/*.txt + +build: + dh_testdir +# make + touch build + +clean: + dh_testdir + rm -f build + # Add here commands to clean up after the build process. +# -$(MAKE) clean + dh_clean + +# Build architecture-independent files here. +binary-indep: build +# We have nothing to do by default. + +# Build architecture-dependent files here. +binary-arch: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + dh_installdirs -p $(pkg-aserve) $(clc-aserve) $(clc-systems) + dh_installdirs -p $(pkg-compat) $(clc-compat) $(clc-systems) + dh_installdirs -p $(pkg-html) $(clc-html) $(clc-systems) + + dh_install -p $(pkg-aserve) $(src-aserve) $(clc-aserve) + dh_install -p $(pkg-webact) $(src-webact) $(clc-webact) + dh_install -p $(pkg-html) $(src-html) $(clc-html) + dh_install -p $(pkg-compat) $(src-compat) $(clc-compat) + + dh_link -p $(pkg-aserve) $(clc-aserve)/$(name-aserve).asd $(clc-systems)/$(name-aserve).asd + dh_link -p $(pkg-webact) $(clc-webact)/$(name-webact).asd $(clc-systems)/$(name-webact).asd + dh_link -p $(pkg-compat) $(clc-compat)/$(name-compat).asd $(clc-systems)/$(name-compat).asd + dh_link -p $(pkg-html) $(clc-html)/$(name-html).asd $(clc-systems)/$(name-html).asd + + dh_installdocs + gzip --best aserve/ChangeLog + mv aserve/ChangeLog.gz aserve/changelog.gz + dh_installdocs -p $(pkg-aserve) aserve/changelog.gz + gzip --best aserve/htmlgen/ChangeLog + mv aserve/htmlgen/ChangeLog.gz aserve/htmlgen/changelog.gz + dh_installdocs -p $(pkg-aserve) aserve/htmlgen/changelog.gz + gzip --best aserve/webactions/ChangeLog + mv aserve/webactions/ChangeLog.gz aserve/webactions/changelog.gz + dh_installdocs -p $(pkg-webact) aserve/webactions/changelog.gz + dh_installexamples -p $(pkg-aserve) $(examples) + dh_installchangelogs + dh_link + dh_strip + dh_compress + dh_fixperms + dh_installdeb + dh_shlibdeps + dh_gencontrol + dh_makeshlibs + dh_md5sums + dh_builddeb + +source diff: + @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary + Property changes on: vendor/portableaserve/debian/rules ___________________________________________________________________ Name: svn:executable + Added: vendor/portableaserve/libs/.cvsignore =================================================================== --- vendor/portableaserve/libs/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/libs/CVS/Entries =================================================================== --- vendor/portableaserve/libs/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,4 @@ +/.cvsignore/1.1/Mon Feb 9 14:11:01 2004// +/README/1.1/Sun Feb 8 15:43:10 2004// +/asdf.lisp/1.1/Sun Feb 8 15:42:38 2004// +D Added: vendor/portableaserve/libs/CVS/Entries.Log =================================================================== --- vendor/portableaserve/libs/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,2 @@ +A D/cl-ppcre//// +A D/puri-1.3.1//// Added: vendor/portableaserve/libs/CVS/Repository =================================================================== --- vendor/portableaserve/libs/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/libs Added: vendor/portableaserve/libs/CVS/Root =================================================================== --- vendor/portableaserve/libs/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/libs/README =================================================================== --- vendor/portableaserve/libs/README 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/README 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,26 @@ +-*- text -*- + +This directory contains source that is needed to run Portable +AllegroServe but is maintained elsewhere. This code is included in +CVS so that portableaserve can be run without the usual hunt for a +gazillion libraries. + +A reasonable effort is made to provide current upstream versions of +these libraries here; reports of outdated libraries are welcome +(report to portableaserve-discuss(a)lists.sourceforge.net; thanks!). +If one or more of these libraries are already installed on the +system, the existing ones are used (thanks to asdf). + +What do we need? + +- asdf + + Daniel Barlow's defsystem utility ("Another System Definition + Facility"). In an ideal world, this would be included with the + Lisp system. For Debian, sbcl and OpenMCL version > 0.14, the + world is already ideal :) + +- puri + + Franz Inc. released their uri library under the same license as + AllegroServe, and Kevin Rosenberg made a portable version. Added: vendor/portableaserve/libs/asdf.lisp =================================================================== --- vendor/portableaserve/libs/asdf.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/asdf.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1104 @@ +;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; +;;; Feedback, bug reports, and patches are all welcome: please mail to +;;; <cclan-list(a)lists.sf.net>. But note first that the canonical +;;; source for asdf is presently the cCLan CVS repository at +;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/> +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; is the latest development version, whereas the revision tagged +;;; RELEASE may be slightly older but is considered `stable' + +;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; +;;; 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. + +;;; the problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file + +(defpackage #:asdf + (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:hyperdocumentation #:hyperdoc + + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + + #:retry + #:accept ; restarts + + ) + (:use :cl)) + +#+nil +(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") + + +(in-package #:asdf) + +(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) + +(defvar *compile-file-warnings-behaviour* :warn) +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) + +(defvar *verbose-out* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utility stuff + +(defmacro aif (test then &optional else) + `(let ((it ,test)) (if it ,then ,else))) + +(defun pathname-sans-name+type (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME and TYPE components" + (make-pathname :name nil :type nil :defaults pathname)) + +(define-modify-macro appendf (&rest args) + append "Append onto list") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; classes, condiitons + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply #'format s (format-control c) (format-arguments c))))) + +(define-condition circular-dependency (system-definition-error) + ((components :initarg :components :reader circular-dependency-components))) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (version :initform nil :reader missing-version :initarg :version) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(define-condition operation-error (error) + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (formatter "~@<erred while invoking ~A on ~A~@:>") + (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(defclass component () + ((name :accessor component-name :initarg :name :documentation + "Component name: designator for a string composed of portable pathname characters") + (version :accessor component-version :initarg :version) + (in-order-to :initform nil :initarg :in-order-to) + ;;; XXX crap name + (do-first :initform nil :initarg :do-first) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + (operation-times :initform (make-hash-table ) + :accessor component-operation-times) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties + :initform nil))) + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (format s (formatter "~@<~A, required by ~A~@:>") + (call-next-method c nil) + (missing-required-by c))) + +(defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) + +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s (formatter "~@<component ~S not found~ + ~@[ or does not match version ~A~]~ + ~@[ in ~A~]~@:>") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) + +(defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (component-system it) + component)) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity t) + (ignore-errors + (prin1 (component-name c) stream)))) + +(defclass module (component) + ((components :initform nil :accessor module-components :initarg :components) + ;; what to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing + (if-component-dep-fails :initform :fail + :accessor module-if-component-dep-fails + :initarg :if-component-dep-fails) + (default-component-class :accessor module-default-component-class + :initform 'cl-source-file :initarg :default-component-class))) + +(defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) + +(defgeneric component-relative-pathname (component) + (:documentation "Extracts the relative pathname applicable for a particular component.")) + +(defmethod component-relative-pathname ((component module)) + (or (slot-value component 'relative-pathname) + (make-pathname + :directory `(:relative ,(component-name component)) + :host (pathname-host (component-parent-pathname component))))) + +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) + +(defgeneric component-property (component property)) + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defgeneric (setf component-property) (new-value component property)) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) + +(defclass system (module) + ((description :accessor system-description :initarg :description) + (long-description + :accessor system-long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence))) + +;;; version-satisfies + +;;; with apologies to christophe rhodes ... +(defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) + +(defgeneric version-satisfies (component version)) + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (return-from version-satisfies t)) + (let ((x (mapcar #'parse-integer + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding systems + +(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error (formatter "~@<invalid component designator ~A~@:>") + name)))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* + '(sysdef-central-registry-search)) + +(defun system-definition-pathname (system) + (some (lambda (x) (funcall x system)) + *system-definition-search-functions*)) + +(defvar *central-registry* + '(*default-pathname-defaults* + #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + +(defun sysdef-central-registry-search (system) + (let ((name (coerce-name system))) + (block nil + (dolist (dir *central-registry*) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) + + +(defun find-system (name &optional (error-p t)) + (let* ((name (coerce-name name)) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) + (let ((*package* (make-package (gensym (package-name #.*package*)) + :use '(:cl :asdf)))) + (format *verbose-out* + (formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%") + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. + on-disk + *package*) + (load on-disk))) + (let ((in-memory (gethash name *defined-systems*))) + (if in-memory + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) + +(defun register-system (name system) + (format *verbose-out* + (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding components + +(defgeneric find-component (module name &optional version) + (:documentation "Finds the component with name NAME present in the +MODULE module; if MODULE is nil, then the component is assumed to be a +system.")) + +(defmethod find-component ((module module) name &optional version) + (if (slot-boundp module 'components) + (let ((m (find name (module-components module) + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + + +;;; a component with no parent is a system +(defmethod find-component ((module (eql nil)) name &optional version) + (let ((m (find-system name nil))) + (if (and m (version-satisfies m version)) m))) + +;;; component subclasses + +(defclass source-file (component) ()) + +(defclass cl-source-file (source-file) ()) +(defclass c-source-file (source-file) ()) +(defclass java-source-file (source-file) ()) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) ()) + +(defgeneric source-file-type (component system)) +(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") +(defmethod source-file-type ((c c-source-file) (s module)) "c") +(defmethod source-file-type ((c java-source-file) (s module)) "java") +(defmethod source-file-type ((c html-file) (s module)) "html") +(defmethod source-file-type ((c static-file) (s module)) nil) + +(defmethod component-relative-pathname ((component source-file)) + (let* ((*default-pathname-defaults* (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + (if (slot-value component 'relative-pathname) + (merge-pathnames + (slot-value component 'relative-pathname) + name-type) + name-type))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; operations + +;;; one of these is instantiated whenever (operate ) is called + +(defclass operation () + ((forced :initform nil :initarg :force :accessor operation-forced) + (original-initargs :initform nil :initarg :original-initargs + :accessor operation-original-initargs) + (visited-nodes :initform nil :accessor operation-visited-nodes) + (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (parent :initform nil :initarg :parent :accessor operation-parent))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + +(defmethod shared-initialize :after ((operation operation) slot-names + &key force + &allow-other-keys) + (declare (ignore slot-names force)) + ;; empty method to disable initarg validity checking + ) + +(defgeneric perform (operation component)) +(defgeneric operation-done-p (operation component)) +(defgeneric explain (operation component)) +(defgeneric output-files (operation component)) +(defgeneric input-files (operation component)) + +(defun node-for (o c) + (cons (class-name (class-of o)) c)) + +(defgeneric operation-ancestor (operation) + (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + +(defmethod operation-ancestor ((operation operation)) + (aif (operation-parent operation) + (operation-ancestor it) + operation)) + + +(defun make-sub-operation (c o dep-c dep-o) + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) + + +(defgeneric visit-component (operation component data)) + +(defmethod visit-component ((o operation) (c component) data) + (unless (component-visited-p o c) + (push (cons (node-for o c) data) + (operation-visited-nodes (operation-ancestor o))))) + +(defgeneric component-visited-p (operation component)) + +(defmethod component-visited-p ((o operation) (c component)) + (assoc (node-for o c) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) + +(defgeneric (setf visiting-component) (new-value operation component)) + +(defmethod (setf visiting-component) (new-value operation component) + ;; MCL complains about unused lexical variables + (declare (ignorable new-value operation component))) + +(defmethod (setf visiting-component) (new-value (o operation) (c component)) + (let ((node (node-for o c)) + (a (operation-ancestor o))) + (if new-value + (pushnew node (operation-visiting-nodes a) :test 'equal) + (setf (operation-visiting-nodes a) + (remove node (operation-visiting-nodes a) :test 'equal))))) + +(defgeneric component-visiting-p (operation component)) + +(defmethod component-visiting-p ((o operation) (c component)) + (let ((node (cons o c))) + (member node (operation-visiting-nodes (operation-ancestor o)) + :test 'equal))) + +(defgeneric component-depends-on (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (class-name (class-of o)) + (slot-value c 'in-order-to)))) + +(defgeneric component-self-dependencies (operation component)) + +(defmethod component-self-dependencies ((o operation) (c component)) + (let ((all-deps (component-depends-on o c))) + (remove-if-not (lambda (x) + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) nil) + +(defmethod operation-done-p ((o operation) (c component)) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (or (apply #'max + (mapcar #'file-write-date in-files)) 0))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'file-write-date in-files)) )))))) + +;;; So you look at this code and think "why isn't it a bunch of +;;; methods". And the answer is, because standard method combination +;;; runs :before methods most->least-specific, which is back to front +;;; for our purposes. And CLISP doesn't have non-standard method +;;; combinations, so let's keep it simple and aspire to portability + +(defgeneric traverse (operation component)) +(defmethod traverse ((operation operation) (c component)) + (let ((forced nil)) + (labels ((do-one-dep (required-op required-c required-v) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (t + (dolist (d dep) + (cond ((consp d) + (assert (string-equal + (symbol-name (first d)) + "VERSION")) + (appendf forced + (do-one-dep op (second d) (third d)))) + (t + (appendf forced (do-one-dep op d nil))))))))) + (aif (component-visited-p operation c) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) + ;; dependencies + (if (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) + (setf (visiting-component operation c) t) + (loop for (required-op . deps) in (component-depends-on operation c) + do (do-dep required-op deps)) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c)))))) + (setf (visiting-component operation c) nil) + (visit-component operation c (and forced t)) + forced))) + + +(defmethod perform ((operation operation) (c source-file)) + (sysdef-error + (formatter "~@<required method PERFORM not implemented~ + for operation ~A, component ~A~@:>") + (class-of operation) (class-of c))) + +(defmethod perform ((operation operation) (c module)) + nil) + +(defmethod explain ((operation operation) (component component)) + (format *verbose-out* "~&;;; ~A on ~A~%" + operation component)) + +;;; compile-op + +(defclass compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*))) + +(defmethod perform :before ((operation compile-op) (c source-file)) + (map nil #'ensure-directories-exist (output-files operation c))) + +(defmethod perform :after ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (get-universal-time))) + +;;; perform is required to check output-files to find out where to put +;;; its answers, in case it has been overridden for site policy +(defmethod perform ((operation compile-op) (c cl-source-file)) + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file + :output-file output-file) + ;(declare (ignore output)) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (formatter "~@<COMPILE-FILE warned while ~ + performing ~A on ~A.~@:>") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn + (formatter "~@<COMPILE-FILE failed while ~ + performing ~A on ~A.~@:>") + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation))))) + +(defmethod output-files ((operation compile-op) (c cl-source-file)) + (list (compile-file-pathname (component-pathname c)))) + +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + +;;; load-op + +(defclass load-op (operation) ()) + +(defmethod perform ((o load-op) (c cl-source-file)) + (mapcar #'load (input-files o c))) + +(defmethod perform ((operation load-op) (c static-file)) + nil) +(defmethod operation-done-p ((operation load-op) (c static-file)) + t) + +(defmethod output-files ((o operation) (c component)) + nil) + +(defmethod component-depends-on ((operation load-op) (c component)) + (cons (list 'compile-op (component-name c)) + (call-next-method))) + +;;; load-source-op + +(defclass load-source-op (operation) ()) + +(defmethod perform ((o load-source-op) (c cl-source-file)) + (let ((source (component-pathname c))) + (setf (component-property c 'last-loaded-as-source) + (and (load source) + (get-universal-time))))) + +(defmethod perform ((operation load-source-op) (c static-file)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + nil) + +;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (let ((what-would-load-op-do (cdr (assoc 'load-op + (slot-value c 'in-order-to))))) + (mapcar (lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) + what-would-load-op-do))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; invoking operations + +(defun operate (operation-class system &rest args) + (let* ((op (apply #'make-instance operation-class + :original-initargs args args)) + (*verbose-out* + (if (getf args :verbose t) + *trace-output* + (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system))) + (steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s + (formatter "~@<Retry performing ~S on ~S.~@:>") + op component))) + (accept () + :report + (lambda (s) + (format s + (formatter "~@<Continue, treating ~S on ~S as ~ + having been successful.~@:>") + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))))) + +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; syntax + +(defun remove-keyword (key arglist) + (labels ((aux (key arglist) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) + (aux key arglist))) + +(defmacro defsystem (name &body options) + (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (let ((component-options (remove-keyword :class options))) + `(progn + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type + (resolve-symlinks *load-truename*)) + *default-pathname-defaults*) + ',component-options)))))) + + +(defun class-for-type (parent type) + (let ((class (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.*package*)) nil))) + (or class + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error (formatter "~@<don't recognize component type ~A~@:>") + type)))) + +(defun maybe-add-tree (tree op1 op2 c) + "Add the node C at /OP1/OP2 in TREE, unless it's there already. +Returns the new tree (which probably shares structure with the old one)" + (let ((first-op-tree (assoc op1 tree))) + (if first-op-tree + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun union-of-dependencies (&rest deps) + (let ((new-tree nil)) + (dolist (dep deps) + (dolist (op-tree dep) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + new-tree)) + + +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defvar *serial-depends-on*) + +(defun parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (check-component-input type name depends-on components in-order-to) + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when (boundp '*serial-depends-on*) + (setf depends-on + (concatenate 'list *serial-depends-on* depends-on))) + (apply #'reinitialize-instance + ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*))))) + + (setf (slot-value ret 'in-order-to) + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) + + (loop for (n v) in `((perform ,perform) (explain ,explain) + (output-files ,output-files) + (operation-done-p ,operation-done-p)) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) (remove-method (symbol-function n) m)) + (component-inline-methods ret)) + when v + do (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret)))) + ret))) + +(defun check-component-input (type name depends-on components in-order-to) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) + +(defun resolve-symlinks (path) + #-allegro (truename path) + #+allegro (excl:pathname-resolve-symbolic-links path) + ) + +;;; optional extras + +;;; run-shell-command functions for other lisp implementations will be +;;; gratefully accepted, if they do the same thing. If the docstring +;;; is ambiguous, send a bug report + +(defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *verbose-out*. Returns the shell's exit code." + (let ((command (apply #'format nil control-string args))) + (format *verbose-out* "; $ ~A~%" command) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+allegro + (excl:run-shell-command command :input nil :output *verbose-out*) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream *verbose-out*) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + )) + + +(defgeneric hyperdocumentation (package name doc-type)) +(defmethod hyperdocumentation ((package symbol) name doc-type) + (hyperdocumentation (find-package package) name doc-type)) + +(defun hyperdoc (name doc-type) + (hyperdocumentation (symbol-package name) name doc-type)) + + +(pushnew :asdf *features*) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") + (pushnew :sbcl-hooks-require *features*))) + +#+(and sbcl sbcl-hooks-require) +(progn + (defun module-provide-asdf (name) + (handler-bind ((style-warning #'muffle-warning)) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) + + (pushnew + '(merge-pathnames "systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) + + (pushnew + '(merge-pathnames "site-systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) + + (pushnew + '(merge-pathnames ".sbcl/systems/" + (user-homedir-pathname)) + *central-registry*) + + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) + +(provide 'asdf) Added: vendor/portableaserve/libs/cl-ppcre/CHANGELOG =================================================================== --- vendor/portableaserve/libs/cl-ppcre/CHANGELOG 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/CHANGELOG 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,150 @@ +Version 0.7.3 +2004-01-28 +Fixed bug in CURRENT-MIN-REST for lookaheads (reported by Thomas-Paz Hartman) +Added tests for this bug + +Version 0.7.2 +2004-01-27 +Fixed typo (SUBSEQ/NSUBSEQ) in SPLIT (thanks to Alan Ruttenberg) +Updated docs with respect to ECL (thanks to Alex Mizrahi) +Mention FreeBSD port in docs + +Version 0.7.1 +2003-10-24 +Fixed version numbers in docs (thanks to S�bastien Saint-Sevin) + +Version 0.7.0 +2003-10-23 +New macros REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS +Added SHAREP keyword argument to most API functions and macros +Mention CL-INTERPOL in docs +Partial code cleanup (using WITH-UNIQUE-NAMES and REBINDING) + +Version 0.6.1 +2003-10-11 +Added EXTERNAL-FORMAT keyword args to CL-PPCRE-TEST:TEST for some CLs (thanks to JP Massar and Scott D. Kalter) +Fixed bug with REGEX-REPLACE and REGEX-REPLACE-ALL when (= START END) was true +Added doc sections for quoting problems and backslash confusions (thanks to conversations with Peter Seibel) +Disable quoting in definition of QUOTE-SECTIONS so you can always safely rebuild CL-PPCRE + +Version 0.6.0 +2003-10-07 +CL-PPCRE now has its own condition types +Added support for Perl's \Q and \E (Peter Seibel convinced me to do it) - see QUOTE-META-CHARS and *ALLOW-QUOTING* +Added tests for this new feature +Threaded tests are more verbose now and use only keyword args + +Version 0.5.9 +2003-10-03 +Changed "^" optimizations with respect to constant end strings with offsets (bug caught by Yexuan Gui) +Added tests for this bug +Removed *.dos files from CL-PPCRE-TEST tests (thanks to JP Massar) +Added threaded tests for SBCL (thanks to Christophe Rhodes) + +Version 0.5.8 +2003-09-17 +Optimizations for ".*" were too optimistic when look-behinds were involved +Added tests for this bug +Removed *.dos files + +Version 0.5.7 +2003-08-20 +Fixed (CL-PPCRE:SCAN "(.)X$" "ABCX" :START 4) bug (spotted by Tibor Simko) +Forgot to export *REGEX-CHAR-CODE-LIMIT* in Corman version of DEFPACKAGE +Removed Emacs local variables from source code (finally...) +Mention Gentoo in docs + +Version 0.5.6 +2003-06-30 +Replaced wrong COPY-REGEX code for WORD-BOUNDARY objects (detected by Max Goldberg) +Added info about possible TRUENAME problems with ACL in README (thanks to Kevin Layer for providing a patch for this) + +Version 0.5.5 +2003-06-09 +Patch for SBCL/Debian compatibility by Kevin Rosenberg +Simpler version of compiler macro +Availability through asdf-install + +Version 0.5.4 +2003-04-09 +Added DESTRUCTIVE keyword to CREATE-SCANNER + +Version 0.5.3 +2003-03-31 +Fixed bug in REGEX-REPLACE (replacement string couldn't contain literal backslash) +Fixed bug in definition of CHAR-CLASS (since 0.5.0 the hash slot may be NIL - CMUCL's new PCL detects this) +Micro-optimization in INSERT-CHAR-CLASS-TESTER: CHAR-NOT-GREATERP instead of CHAR-DOWNCASE + +Version 0.5.2 +2003-03-28 +Better compiler macro (thanks to Kent M. Pitman) + +Version 0.5.1 +2003-03-27 +Removed compiler macro + +Version 0.5.0 +2003-03-27 +Lexer, parser, and converter mostly re-written to reduce consing and increase speed +Get rid of FIX-POS in lexer and parser, "ism" flags are handled after parsing now +Smaller test suite (again) due to literal embedding of line breaks +Seperate test files for DOS line endings +Replaced constant +REGEX-CHAR-CODE-LIMIT+ with special variable *REGEX-CHAR-CODE-LIMIT* + +Version 0.4.1 +2003-03-19 +Added compiler macro for SCAN +Changed test suite to be nicer to Corman Lisp and ECL (see docs for new syntax) +Incorporated visual feedback (dots) in test suite (thanks to JP Massar) +Added README file +Replaced STRING-LIST-TO-SIMPLE-STRING with a much improved version by JP Massar + +Version 0.4.0 +2003-02-27 +Added *USE-BMH-MATCHER* + +Version 0.3.2 +2003-02-21 +Added load.lisp +Various minor changes for Corman Lisp compatibility (thanks to Karsten Poeck and JP Massar) + +Version 0.3.1 +2003-01-18 +Bugfix in CREATE-SCANNER (didn't work if flags were given and arg was a parse-tree) + +Version 0.3.0 +2003-01-12 +Added new features to REGEX-REPLACE and REGEX-REPLACE-ALL + +Version 0.2.0 +2003-01-11 +Make SPLIT more Perl-compatible, including new keyword parameters + +Version 0.1.4 +2003-01-10 +Don't move "^" and "\A" while iterating with DO-SCANS +Added link to Debian package + +Version 0.1.3 +2002-12-25 +More usable MK:DEFSYSTEM files (courtesy of Hannu Koivisto) +Fixed typo in documentation + +Version 0.1.2 +2002-12-22 +Added version numbers for Debian packaging +Be friendly to case-sensitive ACL images (courtesy of Kevin Rosenberg and Douglas Crosher) +"Fixed" two cases where declarations came after docstrings (because of bugs in Corman Lisp and older CMUCL versions) +Added #-cormanlisp to hide (INCF (THE FIXNUM POS)) from Corman Lisp +Added file doc/benchmarks.2002-12-22.txt + +Version 0.1.1 +2002-12-21 +Added asdf system definitions by Marco Baringer +Small additions to documentation +Correct (Emacs) local variables list in closures.lisp and api.lisp +Added this CHANGELOG + +Version 0.1.0 +2002-12-20 +Initial release Added: vendor/portableaserve/libs/cl-ppcre/CVS/Entries =================================================================== --- vendor/portableaserve/libs/cl-ppcre/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,25 @@ +/CHANGELOG/1.1/Mon Feb 16 19:37:18 2004// +/README/1.1/Mon Feb 16 19:37:18 2004// +/api.lisp/1.1/Mon Feb 16 19:37:18 2004// +/cl-ppcre-test.asd/1.1/Mon Feb 16 19:37:18 2004// +/cl-ppcre-test.system/1.1/Mon Feb 16 19:37:18 2004// +/cl-ppcre.asd/1.1/Mon Feb 16 19:37:18 2004// +/cl-ppcre.system/1.1/Mon Feb 16 19:37:18 2004// +/closures.lisp/1.1/Mon Feb 16 19:37:18 2004// +/convert.lisp/1.1/Mon Feb 16 19:37:18 2004// +/errors.lisp/1.1/Mon Feb 16 19:37:17 2004// +/lexer.lisp/1.1/Mon Feb 16 19:37:17 2004// +/load.lisp/1.1/Mon Feb 16 19:37:17 2004// +/optimize.lisp/1.1/Mon Feb 16 19:37:17 2004// +/packages.lisp/1.1/Mon Feb 16 19:37:17 2004// +/parser.lisp/1.1/Mon Feb 16 19:37:17 2004// +/perltest.pl/1.1/Mon Feb 16 19:37:17 2004// +/ppcre-tests.lisp/1.1/Mon Feb 16 19:37:17 2004// +/regex-class.lisp/1.1/Mon Feb 16 19:37:17 2004// +/repetition-closures.lisp/1.1/Mon Feb 16 19:37:17 2004// +/scanner.lisp/1.1/Mon Feb 16 19:37:17 2004// +/specials.lisp/1.1/Mon Feb 16 19:37:17 2004// +/testdata/1.1/Mon Feb 16 19:37:17 2004// +/testinput/1.1/Mon Feb 16 19:37:17 2004// +/util.lisp/1.1/Mon Feb 16 19:37:17 2004// +D Added: vendor/portableaserve/libs/cl-ppcre/CVS/Entries.Log =================================================================== --- vendor/portableaserve/libs/cl-ppcre/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/CVS/Entries.Log 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +A D/doc//// Added: vendor/portableaserve/libs/cl-ppcre/CVS/Repository =================================================================== --- vendor/portableaserve/libs/cl-ppcre/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/libs/cl-ppcre Added: vendor/portableaserve/libs/cl-ppcre/CVS/Root =================================================================== --- vendor/portableaserve/libs/cl-ppcre/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/libs/cl-ppcre/README =================================================================== --- vendor/portableaserve/libs/cl-ppcre/README 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/README 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,51 @@ +Complete documentation for CL-PPCRE can be found in the 'doc' +directory. + +1. Installation + +1.1. Probably the easiest way is + + (load "/path/to/cl-ppcre/load.lisp") + + This should compile and load CL-PPCRE on most Common Lisp + implementations. + +1.2. With MK:DEFSYSTEM you can make a symbolic link from + 'cl-ppcre.system' and 'cl-ppcre-test.system' to your central registry + (which by default is in '/usr/local/lisp/Registry/') and then issue + the command + + (mk:compile-system "cl-ppcre") + + 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-PPCRE comes with a test suite that can be used to check its +compatibility with Perl's regex syntax. See the documentation on how +to use this test suite for benchmarks and on how to write your own +tests. + +2.1. If you've used 'load.lisp' to load CL-PPCRE you already have the + test suite loaded and can start the default tests with + + (cl-ppcre-test:test) + +2.2. With MK:DEFSYSTEM you need to compile the 'cl-ppcre-test' system + as well before you can proceed as in 2.1. + +2.3. Same for ASDF. + +Depending on your machine and your CL implementation the default test +will take between a few seconds and a couple of minutes. (It will +print a dot for every tenth test case while it proceeds to give some +visual feedback.) It should exactly report three 'errors' (662, 790, +and 1439) which are explained in the documentation. + +MCL might report an error for the ninth test case which is also +explained in the docs. \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/api.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/api.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/api.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1163 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/api.lisp,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; The external API for creating and using scanners. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defgeneric create-scanner (regex &key case-insensitive-mode + multi-line-mode + single-line-mode + extended-mode + destructive) + (:documentation "Accepts a regular expression - either as a +parse-tree or as a string - and returns a scan closure which will scan +strings for this regular expression. The \"mode\" keyboard arguments +are equivalent to the imsx modifiers in Perl. If DESTRUCTIVE is not +NIL the function is allowed to destructively modify its first argument +\(but only if it's a parse tree).")) + +(defmethod create-scanner ((regex-string string) &key case-insensitive-mode + multi-line-mode + single-line-mode + extended-mode + destructive) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (ignore destructive)) + ;; parse the string into a parse-tree and then call CREATE-SCANNER + ;; again + (let* ((*extended-mode-p* extended-mode) + (quoted-regex-string (if *allow-quoting* + (quote-sections (clean-comments regex-string extended-mode)) + regex-string)) + (*syntax-error-string* (copy-seq quoted-regex-string))) + ;; wrap the result with :GROUP to avoid infinite loops for + ;; constant strings + (create-scanner (cons :group (list (parse-string quoted-regex-string))) + :case-insensitive-mode case-insensitive-mode + :multi-line-mode multi-line-mode + :single-line-mode single-line-mode + :destructive t))) + +(defmethod create-scanner ((scanner function) &key case-insensitive-mode + multi-line-mode + single-line-mode + extended-mode + destructive) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (ignore destructive)) + (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode) + (signal-ppcre-invocation-error + "You can't use the keyword arguments to modify an existing scanner.")) + scanner) + +(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode + multi-line-mode + single-line-mode + extended-mode + destructive) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (when extended-mode + (signal-ppcre-invocation-error + "Extended mode doesn't make sense in parse trees.")) + ;; convert parse-tree into internal representation REGEX and at the + ;; same time compute the number of registers and the constant string + ;; (or anchor) the regex starts with (if any) + (unless destructive + (setq parse-tree (copy-tree parse-tree))) + (let (flags) + (if single-line-mode + (push :single-line-mode-p flags)) + (if multi-line-mode + (push :multi-line-mode-p flags)) + (if case-insensitive-mode + (push :case-insensitive-p flags)) + (when flags + (setq parse-tree (list :group (cons :flags flags) parse-tree)))) + (let ((*syntax-error-string* nil)) + (multiple-value-bind (regex reg-num starts-with) + (convert parse-tree) + ;; simplify REGEX by flattening nested SEQ and ALTERNATION + ;; constructs and gathering STR objects + (let ((regex (gather-strings (flatten regex)))) + ;; set the MIN-REST slots of the REPETITION objects + (compute-min-rest regex 0) + ;; set the OFFSET slots of the STR objects + (compute-offsets regex 0) + (let* (end-string-offset + end-anchored-p + ;; compute the constant string the regex ends with (if + ;; any) and at the same time set the special variables + ;; END-STRING-OFFSET and END-ANCHORED-P + (end-string (end-string regex)) + ;; if we found a non-zero-length end-string we create an + ;; efficient search function for it + (end-string-test (and end-string + (plusp (len end-string)) + (if (= 1 (len end-string)) + (create-char-searcher + (schar (str end-string) 0) + (case-insensitive-p end-string)) + (create-bmh-matcher + (str end-string) + (case-insensitive-p end-string))))) + ;; initialize the counters for CREATE-MATCHER-AUX + (*rep-num* 0) + (*zero-length-num* 0) + ;; create the actual matcher function (which does all the + ;; work of matching the regular expression) corresponding + ;; to REGEX and at the same time set the special + ;; variables *REP-NUM* and *ZERO-LENGTH-NUM* + (match-fn (create-matcher-aux regex #'identity)) + ;; if the regex starts with a string we create an + ;; efficient search function for it + (start-string-test (and (typep starts-with 'str) + (plusp (len starts-with)) + (if (= 1 (len starts-with)) + (create-char-searcher + (schar (str starts-with) 0) + (case-insensitive-p starts-with)) + (create-bmh-matcher + (str starts-with) + (case-insensitive-p starts-with)))))) + (declare (special end-string-offset end-anchored-p end-string)) + ;; now create the scanner and return it + (create-scanner-aux match-fn + (regex-min-length regex) + (or (start-anchored-p regex) + ;; a dot in single-line-mode also + ;; implicitely anchors the regex at + ;; the start, i.e. if we can't match + ;; from the first position we won't + ;; match at all + (and (typep starts-with 'everything) + (single-line-p starts-with))) + starts-with + start-string-test + ;; only mark regex as end-anchored if we + ;; found a non-zero-length string before + ;; the anchor + (and end-string-test end-anchored-p) + end-string-test + (if end-string-test + (len end-string) + nil) + end-string-offset + *rep-num* + *zero-length-num* + reg-num)))))) + +(defgeneric scan (regex target-string &key start end) + (:documentation "Searches TARGET-STRING from START to END and tries +to match REGEX. On success returns four values - the start of the +match, the end of the match, and two arrays denoting the beginnings +and ends of register matches. On failure returns NIL. REGEX can be a +string which will be parsed according to Perl syntax, a parse tree, or +a pre-compiled scanner created by CREATE-SCANNER. TARGET-STRING will +be coerced to a simple string if it isn't one already.")) + +(defmethod scan ((regex-string string) target-string + &key (start 0) + (end (length target-string))) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + ;; note that the scanners are optimized for simple strings so we + ;; have to coerce TARGET-STRING into one if it isn't already + (funcall (create-scanner regex-string) + (maybe-coerce-to-simple-string target-string) + start end)) + +(defmethod scan ((scanner function) target-string + &key (start 0) + (end (length target-string))) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (funcall scanner + (maybe-coerce-to-simple-string target-string) + start end)) + +(defmethod scan ((parse-tree t) target-string + &key (start 0) + (end (length target-string))) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (funcall (create-scanner parse-tree) + (maybe-coerce-to-simple-string target-string) + start end)) + +(define-compiler-macro scan (&whole form regex target-string &rest rest) + "Make sure that constant forms are compiled into scanners at compile time." + (cond ((constantp regex) + `(scan (load-time-value + (create-scanner ,regex)) + ,target-string ,@rest)) + (t form))) + +(defun scan-to-strings (regex target-string &key (start 0) + (end (length target-string)) + sharedp) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Like SCAN but returns substrings of TARGET-STRING instead of +positions, i.e. this function returns two values on success: the whole +match as a string plus an array of substrings (or NILs) corresponding +to the matched registers. If SHAREDP is true, the substrings may share +structure with TARGET-STRING." + (multiple-value-bind (match-start match-end reg-starts reg-ends) + (scan regex target-string :start start :end end) + (unless match-start + (return-from scan-to-strings nil)) + (let ((substr-fn (if sharedp #'nsubseq #'subseq))) + (values (funcall substr-fn + target-string match-start match-end) + (map 'vector + (lambda (reg-start reg-end) + (if reg-start + (funcall substr-fn + target-string reg-start reg-end) + nil)) + reg-starts + reg-ends))))) + +(defmacro register-groups-bind (var-list (regex target-string + &key start end sharedp) + &body body) + "Executes BODY with the variables in VAR-LIST bound to the +corresponding register groups after TARGET-STRING has been matched +against REGEX, i.e. each variable is either bound to a string or to +NIL. If there is no match, BODY is _not_ executed. For each element of +VAR-LIST which is NIL there's no binding to the corresponding register +group. The number of variables in VAR-LIST must not be greater than +the number of register groups. If SHAREDP is true, the substrings may +share structure with TARGET-STRING." + (rebinding (target-string) + (with-unique-names (match-start match-end reg-starts reg-ends + start-index substr-fn) + `(multiple-value-bind (,match-start ,match-end ,reg-starts ,reg-ends) + (scan ,regex ,target-string :start (or ,start 0) + :end (or ,end (length ,target-string))) + (declare (ignore ,match-end)) + (when ,match-start + (let* ,(cons + `(,substr-fn (if ,sharedp + #'nsubseq + #'subseq)) + (loop for var in var-list + for counter from 0 + when var + collect `(,var (let ((,start-index + (aref ,reg-starts ,counter))) + (if ,start-index + (funcall ,substr-fn + ,target-string + ,start-index + (aref ,reg-ends ,counter)) + nil))))) + ,@body)))))) + +(defmacro do-scans ((match-start match-end reg-starts reg-ends regex + target-string + &optional result-form + &key start end) + &body body) + "Iterates over TARGET-STRING and tries to match REGEX as often as +possible evaluating BODY with MATCH-START, MATCH-END, REG-STARTS, and +REG-ENDS bound to the four return values of each match in turn. After +the last match, returns RESULT-FORM if provided or NIL otherwise. An +implicit block named NIL surrounds DO-SCANS; RETURN may be used to +terminate the loop immediately. If REGEX matches an empty string the +scan is continued one position behind this match. BODY may start with +declarations." + (rebinding (target-string regex) + (with-unique-names (%start %end scanner loop-tag block-name) + ;; the NIL BLOCK to enable exits via (RETURN ...) + `(block nil + (let* ((,%start (or ,start 0)) + (*real-start-pos* ,%start) + (,%end (or ,end (length ,target-string))) + ;; create a scanner unless the regex is already a + ;; function (otherwise SCAN will do this on each + ;; iteration) + (,scanner (typecase ,regex + (function ,regex) + (t (create-scanner ,regex))))) + ;; coerce TARGET-STRING to a simple string unless it is one + ;; already (otherwise SCAN will do this on each iteration) + (setq ,target-string + (maybe-coerce-to-simple-string ,target-string)) + ;; a named BLOCK so we can exit the TAGBODY + (block ,block-name + (tagbody + ,loop-tag + ;; invoke SCAN and bind the returned values to the + ;; provided variables + (multiple-value-bind + (,match-start ,match-end ,reg-starts ,reg-ends) + (scan ,scanner ,target-string :start ,%start :end ,%end) + ;; declare the variables to be IGNORABLE to prevent the + ;; compiler from issuing warnings + (declare + (ignorable ,match-start ,match-end ,reg-starts ,reg-ends)) + (unless ,match-start + ;; stop iteration on first failure + (return-from ,block-name ,result-form)) + ;; execute BODY (wrapped in LOCALLY so it can start with + ;; declarations) + (locally + ,@body) + ;; advance by one position if we had a zero-length match + (setq ,%start (if (= ,%start ,match-end) + (1+ ,match-end) + ,match-end))) + (go ,loop-tag)))))))) + +(defmacro do-matches ((match-start match-end regex + target-string + &optional result-form + &key start end) + &body body) + "Iterates over TARGET-STRING and tries to match REGEX as often as +possible evaluating BODY with MATCH-START and MATCH-END bound to the +start/end positions of each match in turn. After the last match, +returns RESULT-FORM if provided or NIL otherwise. An implicit block +named NIL surrounds DO-MATCHES; RETURN may be used to terminate the +loop immediately. If REGEX matches an empty string the scan is +continued one position behind this match. BODY may start with +declarations." + ;; this is a simplified form of DO-SCANS - we just provide two dummy + ;; vars and ignore them + (with-unique-names (reg-starts reg-ends) + `(do-scans (,match-start ,match-end + ,reg-starts ,reg-ends + ,regex ,target-string + ,result-form + :start ,start :end ,end) + ,@body))) + +(defmacro do-matches-as-strings ((match-var regex + target-string + &optional result-form + &key start end sharedp) + &body body) + "Iterates over TARGET-STRING and tries to match REGEX as often as +possible evaluating BODY with MATCH-VAR bound to the substring of +TARGET-STRING corresponding to each match in turn. After the last +match, returns RESULT-FORM if provided or NIL otherwise. An implicit +block named NIL surrounds DO-MATCHES-AS-STRINGS; RETURN may be used to +terminate the loop immediately. If REGEX matches an empty string the +scan is continued one position behind this match. If SHAREDP is true, +the substrings may share structure with TARGET-STRING. BODY may start +with declarations." + (rebinding (target-string) + (with-unique-names (match-start match-end substr-fn) + `(let ((,substr-fn (if ,sharedp #'nsubseq #'subseq))) + ;; simple use DO-MATCHES to extract the substrings + (do-matches (,match-start ,match-end ,regex ,target-string + ,result-form :start ,start :end ,end) + (let ((,match-var + (funcall ,substr-fn + ,target-string ,match-start ,match-end))) + ,@body)))))) + +(defmacro do-register-groups (var-list (regex target-string + &optional result-form + &key start end sharedp) + &body body) + "Iterates over TARGET-STRING and tries to match REGEX as often as +possible evaluating BODY with the variables in VAR-LIST bound to the +corresponding register groups for each match in turn, i.e. each +variable is either bound to a string or to NIL. For each element of +VAR-LIST which is NIL there's no binding to the corresponding register +group. The number of variables in VAR-LIST must not be greater than +the number of register groups. After the last match, returns +RESULT-FORM if provided or NIL otherwise. An implicit block named NIL +surrounds DO-REGISTER-GROUPS; RETURN may be used to terminate the loop +immediately. If REGEX matches an empty string the scan is continued +one position behind this match. If SHAREDP is true, the substrings may +share structure with TARGET-STRING. BODY may start with declarations." + (rebinding (target-string) + (with-unique-names (substr-fn match-start match-end + reg-starts reg-ends start-index) + `(let ((,substr-fn (if ,sharedp + #'nsubseq + #'subseq))) + (do-scans (,match-start ,match-end ,reg-starts ,reg-ends + ,regex ,target-string + ,result-form :start ,start :end ,end) + (let ,(loop for var in var-list + for counter from 0 + collect `(,var (let ((,start-index + (aref ,reg-starts ,counter))) + (if ,start-index + (funcall ,substr-fn + ,target-string + ,start-index + (aref ,reg-ends ,counter)) + nil)))) + ,@body)))))) + +(defun all-matches (regex target-string + &key (start 0) + (end (length target-string))) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns a list containing the start and end positions of all +matches of REGEX against TARGET-STRING, i.e. if there are N matches +the list contains (* 2 N) elements. If REGEX matches an empty string +the scan is continued one position behind this match." + (let (result-list) + (do-matches (match-start match-end + regex target-string + (nreverse result-list) + :start start :end end) + (push match-start result-list) + (push match-end result-list)))) + +(defun all-matches-as-strings (regex target-string + &key (start 0) + (end (length target-string)) + sharedp) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns a list containing all substrings of TARGET-STRING which +match REGEX. If REGEX matches an empty string the scan is continued +one position behind this match. If SHAREDP is true, the substrings may +share structure with TARGET-STRING." + (let (result-list) + (do-matches-as-strings (match regex target-string (nreverse result-list) + :start start :end end :sharedp sharedp) + (push match result-list)))) + +(defun split (regex target-string + &key (start 0) + (end (length target-string)) + limit + with-registers-p + omit-unmatched-p + sharedp) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Matches REGEX against TARGET-STRING as often as possible and +returns a list of the substrings between the matches. If +WITH-REGISTERS-P is true, substrings corresponding to matched +registers are inserted into the list as well. If OMIT-UNMATCHED-P is +true, unmatched registers will simply be left out, otherwise they will +show up as NIL. LIMIT limits the number of elements returned - +registers aren't counted. If LIMIT is NIL (or 0 which is equivalent), +trailing empty strings are removed from the result list. If REGEX +matches an empty string the scan is continued one position behind this +match. If SHAREDP is true, the substrings may share structure with +TARGET-STRING." + ;; initialize list of positions POS-LIST to extract substrings with + ;; START so that the start of the next match will mark the end of + ;; the first substring + (let ((pos-list (list start)) + (counter 0)) + ;; how would Larry Wall do it? + (when (eql limit 0) + (setq limit nil)) + (do-scans (match-start match-end + reg-starts reg-ends + regex target-string nil + :start start :end end) + (unless (and (= match-start match-end) + (= match-start (car pos-list))) + ;; push start of match on list unless this would be an empty + ;; string adjacent to the last element pushed onto the list + (when (and limit + (>= (incf counter) limit)) + (return)) + (push match-start pos-list) + (when with-registers-p + ;; optionally insert matched registers + (loop for reg-start across reg-starts + for reg-end across reg-ends + if reg-start + ;; but only if they've matched + do (push reg-start pos-list) + (push reg-end pos-list) + else unless omit-unmatched-p + ;; or if we're allowed to insert NIL instead + do (push nil pos-list) + (push nil pos-list))) + ;; now end of match + (push match-end pos-list))) + ;; end of whole string + (push end pos-list) + ;; now collect substrings + (nreverse + (loop with substr-fn = (if sharedp #'nsubseq #'subseq) + with string-seen = nil + for (this-end this-start) on pos-list by #'cddr + ;; skip empty strings from end of list + if (or limit + (setq string-seen + (or string-seen + (and this-start + (> this-end this-start))))) + collect (if this-start + (funcall substr-fn + target-string this-start this-end) + nil))))) + +(defun string-case-modifier (str from to start end) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum from to start end)) + "Checks whether all words in STR between FROM and TO are upcased, +downcased or capitalized and returns a function which applies a +corresponding case modification to strings. Returns #'IDENTITY +otherwise, especially if words in the target area extend beyond FROM +or TO. STR is supposed to be bounded by START and END. It is assumed +that (<= START FROM TO END)." + (case + (if (or (<= to from) + (and (< start from) + (alphanumericp (char str (1- from))) + (alphanumericp (char str from))) + (and (< to end) + (alphanumericp (char str to)) + (alphanumericp (char str (1- to))))) + ;; if it's a zero-length string or if words extend beyond FROM + ;; or TO we return NIL, i.e. #'IDENTITY + nil + ;; otherwise we loop through STR from FROM to TO + (loop with last-char-both-case + with current-result + for index of-type fixnum from from below to + for chr = (char str index) + do (cond ((not #-:cormanlisp (both-case-p chr) + #+:cormanlisp (or (upper-case-p chr) + (lower-case-p chr))) + ;; this character doesn't have a case so we + ;; consider it as a word boundary (note that + ;; this differs from how \b works in Perl) + (setq last-char-both-case nil)) + ((upper-case-p chr) + ;; an uppercase character + (setq current-result + (if last-char-both-case + ;; not the first character in a + (case current-result + ((:undecided) :upcase) + ((:downcase :capitalize) (return nil)) + ((:upcase) current-result)) + (case current-result + ((nil) :undecided) + ((:downcase) (return nil)) + ((:capitalize :upcase) current-result))) + last-char-both-case t)) + (t + ;; a lowercase character + (setq current-result + (case current-result + ((nil) :downcase) + ((:undecided) :capitalize) + ((:downcase) current-result) + ((:capitalize) (if last-char-both-case + current-result + (return nil))) + ((:upcase) (return nil))) + last-char-both-case t))) + finally (return current-result))) + ((nil) #'identity) + ((:undecided :upcase) #'string-upcase) + ((:downcase) #'string-downcase) + ((:capitalize) #'string-capitalize))) + +;; first create a scanner to identify the special parts of the +;; replacement string (eat your own dog food...) +#-:cormanlisp +(let* ((*use-bmh-matchers* nil) + (reg-scanner (create-scanner "\\\\(?:\\\\|{\\d+}|\\d+|&|`|')"))) + (defmethod build-replacement-template ((replacement-string string)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Converts a replacement string for REGEX-REPLACE or +REGEX-REPLACE-ALL into a replacement template which is an +S-expression." + (let ((from 0) + ;; COLLECTOR will hold the (reversed) template + (collector '())) + ;; scan through all special parts of the replacement string + (do-matches (match-start match-end reg-scanner replacement-string) + (when (< from match-start) + ;; strings between matches are copied verbatim + (push (subseq replacement-string from match-start) collector)) + ;; PARSE-START is true if the pattern matched a number which + ;; refers to a register + (let* ((parse-start (position-if #'digit-char-p + replacement-string + :start match-start + :end match-end)) + (token (if parse-start + (1- (parse-integer replacement-string + :start parse-start + :junk-allowed t)) + ;; if we didn't match a number we convert the + ;; character to a symbol + (case (char replacement-string (1+ match-start)) + ((#\&) :match) + ((#\`) :before-match) + ((#\') :after-match) + ((#\\) :backslash))))) + (when (and (numberp token) (< token 0)) + ;; make sure we don't accept something like "\\0" + (signal-ppcre-invocation-error + "Illegal substring ~S in replacement string" + (subseq replacement-string match-start match-end))) + (push token collector)) + ;; remember where the match ended + (setq from match-end)) + (when (< from (length replacement-string)) + ;; push the rest of the replacement string onto the list + (push (subseq replacement-string from) collector)) + (nreverse collector)))) + +#-:cormanlisp +(defmethod build-replacement-template ((replacement-function function)) + (list replacement-function)) + +#-:cormanlisp +(defmethod build-replacement-template ((replacement-function-symbol symbol)) + (list replacement-function-symbol)) + +#-:cormanlisp +(defmethod build-replacement-template ((replacement-list list)) + replacement-list) + +;;; Corman Lisp's methods can't be closures... :( +#+:cormanlisp +(let* ((*use-bmh-matchers* nil) + (reg-scanner (create-scanner "\\\\(?:\\\\|{\\d+}|\\d+|&|`|')"))) + (defun build-replacement-template (replacement) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (typecase replacement + (string + (let ((from 0) + ;; COLLECTOR will hold the (reversed) template + (collector '())) + ;; scan through all special parts of the replacement string + (do-matches (match-start match-end reg-scanner replacement) + (when (< from match-start) + ;; strings between matches are copied verbatim + (push (subseq replacement from match-start) collector)) + ;; PARSE-START is true if the pattern matched a number which + ;; refers to a register + (let* ((parse-start (position-if #'digit-char-p + replacement + :start match-start + :end match-end)) + (token (if parse-start + (1- (parse-integer replacement + :start parse-start + :junk-allowed t)) + ;; if we didn't match a number we convert the + ;; character to a symbol + (case (char replacement (1+ match-start)) + ((#\&) :match) + ((#\`) :before-match) + ((#\') :after-match) + ((#\\) :backslash))))) + (when (and (numberp token) (< token 0)) + ;; make sure we don't accept something like "\\0" + (signal-ppcre-invocation-error + "Illegal substring ~S in replacement string" + (subseq replacement match-start match-end))) + (push token collector)) + ;; remember where the match ended + (setq from match-end)) + (when (< from (length replacement)) + ;; push the rest of the replacement string onto the list + (push (nsubseq replacement from) collector)) + (nreverse collector))) + (list + replacement) + (t + (list replacement))))) + +(defun build-replacement (replacement-template + target-string + start end + match-start match-end + reg-starts reg-ends) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Accepts a replacement template and the current values from the +matching process in REGEX-REPLACE or REGEX-REPLACE-ALL and returns the +corresponding template." + ;; the upper exclusive bound of the register numbers in the regular + ;; expression + (let ((reg-bound (if reg-starts + (array-dimension reg-starts 0) + 0))) + (with-output-to-string (s) + (loop for token in replacement-template + do (typecase token + (string + ;; transfer string parts verbatim + (write-string token s)) + (integer + ;; replace numbers with the corresponding registers + (when (>= token reg-bound) + ;; but only if the register was referenced in the + ;; regular expression + (signal-ppcre-invocation-error + "Reference to non-existent register ~A in replacement string" + (1+ token))) + (when (svref reg-starts token) + ;; and only if it matched, i.e. no match results + ;; in an empty string + (write-string target-string s + :start (svref reg-starts token) + :end (svref reg-ends token)))) + (function + (write-string (funcall token + target-string + start end + match-start match-end + reg-starts reg-ends) + s)) + (symbol + (case token + ((:backslash) + ;; just a backslash + (write-char #\\ s)) + ((:match) + ;; the whole match + (write-string target-string s + :start match-start + :end match-end)) + ((:before-match) + ;; the part of the target string before the match + (write-string target-string s + :start start + :end match-start)) + ((:after-match) + ;; the part of the target string after the match + (write-string target-string s + :start match-end + :end end)) + (otherwise + (write-string (funcall token + target-string + start end + match-start match-end + reg-starts reg-ends) + s))))))))) + +(defun replace-aux (target-string replacement pos-list reg-list start end preserve-case) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Auxiliary function used by REGEX-REPLACE and +REGEX-REPLACE-ALL. POS-LIST contains a list with the start and end +positions of all matches while REG-LIST contains a list of arrays +representing the corresponding register start and end positions." + ;; build the template once before we start the loop + (let ((replacement-template (build-replacement-template replacement))) + (with-output-to-string (s) + ;; loop through all matches and take the start and end of the + ;; whole string into account + (loop for (from to) on (append (list start) pos-list (list end)) + ;; alternate between replacement and no replacement + for replace = nil then (and (not replace) to) + for reg-starts = (if replace (pop reg-list) nil) + for reg-ends = (if replace (pop reg-list) nil) + for curr-replacement = (if replace + ;; build the replacement string + (build-replacement replacement-template + target-string + start end + from to + reg-starts reg-ends) + nil) + while to + if replace + do (write-string (if preserve-case + ;; modify the case of the replacement + ;; string if necessary + (funcall (string-case-modifier target-string + from to + start end) + curr-replacement) + curr-replacement) + s) + else + ;; no replacement + do (write-string target-string s :start from :end to))))) + +(defun regex-replace (regex target-string replacement + &key (start 0) + (end (length target-string)) + preserve-case) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Try to match TARGET-STRING between START and END against REGEX and +replace the first match with REPLACEMENT. + + REPLACEMENT can be a string which may contain the special substrings +\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING +before the match, \"\\'\" for the part of TARGET-STRING after the +match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive +integer. + + REPLACEMENT can also be a function designator in which case the +match will be replaced with the result of calling the function +designated by REPLACEMENT with the arguments TARGET-STRING, START, +END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and +REG-ENDS are arrays holding the start and end positions of matched +registers or NIL - the meaning of the other arguments should be +obvious.) + + Finally, REPLACEMENT can be a list where each element is a string, +one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH - +corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N - +representing register (1+ N) -, or a function designator. + + If PRESERVE-CASE is true, the replacement will try to preserve the +case (all upper case, all lower case, or capitalized) of the +match. The result will always be a fresh string, even if REGEX doesn't +match." + (multiple-value-bind (match-start match-end reg-starts reg-ends) + (scan regex target-string :start start :end end) + (if match-start + (replace-aux target-string replacement + (list match-start match-end) + (list reg-starts reg-ends) + start end preserve-case) + (subseq target-string start end)))) + +(defun regex-replace-all (regex target-string replacement + &key (start 0) + (end (length target-string)) + preserve-case) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Try to match TARGET-STRING between START and END against REGEX and +replace all matches with REPLACEMENT. + + REPLACEMENT can be a string which may contain the special substrings +\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING +before the match, \"\\'\" for the part of TARGET-STRING after the +match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive +integer. + + REPLACEMENT can also be a function designator in which case the +match will be replaced with the result of calling the function +designated by REPLACEMENT with the arguments TARGET-STRING, START, +END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and +REG-ENDS are arrays holding the start and end positions of matched +registers or NIL - the meaning of the other arguments should be +obvious.) + + Finally, REPLACEMENT can be a list where each element is a string, +one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH - +corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N - +representing register (1+ N) -, or a function designator. + + If PRESERVE-CASE is true, the replacement will try to preserve the +case (all upper case, all lower case, or capitalized) of the +match. The result will always be a fresh string, even if REGEX doesn't +match." + (let ((pos-list '()) + (reg-list '())) + (do-scans (match-start match-end reg-starts reg-ends regex target-string + nil + :start start :end end) + (push match-start pos-list) + (push match-end pos-list) + (push reg-starts reg-list) + (push reg-ends reg-list)) + (if pos-list + (replace-aux target-string replacement + (nreverse pos-list) + (nreverse reg-list) + start end preserve-case) + (subseq target-string start end)))) + +#-:cormanlisp +(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form) + &body body) + "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST. Loops +through PACKAGES and executes BODY with SYMBOL bound to each symbol +which matches REGEX. Optionally evaluates and returns RETURN-FORM at +the end. If CASE-INSENSITIVE is true and REGEX isn't already a +scanner, a case-insensitive scanner is used." + (rebinding (regex) + (with-unique-names (scanner %packages next morep) + `(let* ((,scanner (create-scanner ,regex + :case-insensitive-mode + (and ,case-insensitive + (not (functionp ,regex))))) + (,%packages (or ,packages + (list-all-packages)))) + (with-package-iterator (,next ,%packages :external :internal) + (loop + (multiple-value-bind (,morep symbol) + (,next) + (unless ,morep + (return ,return-form)) + (when (scan ,scanner (symbol-name symbol)) + ,@body)))))))) + +;;; The following two functions were provided by Karsten Poeck + +#+:cormanlisp +(defmacro do-with-all-symbols ((variable package-packagelist) &body body) + (with-unique-names (pack-var iter-sym) + `(if (listp ,package-packagelist) + (dolist (,pack-var ,package-packagelist) + (do-symbols (,iter-sym ,pack-var) + ,@body)) + (do-symbols (,iter-sym ,package-packagelist) + ,@body)))) + +#+:cormanlisp +(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form) + &body body) + "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST. Loops +through PACKAGES and executes BODY with SYMBOL bound to each symbol +which matches REGEX. Optionally evaluates and returns RETURN-FORM at +the end. If CASE-INSENSITIVE is true and REGEX isn't already a +scanner, a case-insensitive scanner is used." + (rebinding (regex) + (with-unique-names (scanner %packages) + `(let* ((,scanner (create-scanner ,regex + :case-insensitive-mode + (and ,case-insensitive + (not (functionp ,regex))))) + (,%packages (or ,packages + (list-all-packages)))) + (do-with-all-symbols (symbol ,%packages) + (when (scan ,scanner (symbol-name symbol)) + ,@body)) + ,return-form)))) + +(defun regex-apropos-list (regex &optional packages &key (case-insensitive t)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Similar to the standard function APROPOS-LIST but returns a list of +all symbols which match the regular expression REGEX. If +CASE-INSENSITIVE is true and REGEX isn't already a scanner, a +case-insensitive scanner is used." + (let ((collector '())) + (regex-apropos-aux (regex packages case-insensitive collector) + (push symbol collector)))) + +(defun print-symbol-info (symbol) + "Auxiliary function used by REGEX-APROPOS. Tries to print some +meaningful information about a symbol." + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (handler-case + (let ((output-list '())) + (cond ((special-operator-p symbol) + (push "[special operator]" output-list)) + ((macro-function symbol) + (push "[macro]" output-list)) + ((fboundp symbol) + (let* ((function (symbol-function symbol)) + (compiledp (compiled-function-p function))) + (multiple-value-bind (lambda-expr closurep) + (function-lambda-expression function) + (push + (format nil + "[~:[~;compiled ~]~:[function~;closure~]]~:[~; ~A~]" + compiledp closurep lambda-expr (cadr lambda-expr)) + output-list))))) + (let ((class (find-class symbol nil))) + (when class + (push (format nil "[class] ~S" class) output-list))) + (cond ((keywordp symbol) + (push "[keyword]" output-list)) + ((constantp symbol) + (push (format nil "[constant]~:[~; value: ~S~]" + (boundp symbol) (symbol-value symbol)) output-list)) + ((boundp symbol) + (push #+(or LispWorks CLISP) "[variable]" + #-(or LispWorks CLISP) (format nil "[variable] value: ~S" + (symbol-value symbol)) + output-list))) + #-(or :cormanlisp :clisp) + (format t "~&~S ~<~;~^~A~@{~:@_~A~}~;~:>" symbol output-list) + #+(or :cormanlisp :clisp) + (loop for line in output-list + do (format t "~&~S ~A" symbol line))) + (condition () + ;; this seems to be necessary due to some errors I encountered + ;; with LispWorks + (format t "~&~S [an error occured while trying to print more info]" symbol)))) + +(defun regex-apropos (regex &optional packages &key (case-insensitive t)) + "Similar to the standard function APROPOS but returns a list of all +symbols which match the regular expression REGEX. If CASE-INSENSITIVE +is true and REGEX isn't already a scanner, a case-insensitive scanner +is used." + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (regex-apropos-aux (regex packages case-insensitive) + (print-symbol-info symbol)) + (values)) + +(let* ((*use-bmh-matchers* nil) + (non-word-char-scanner (create-scanner "[^a-zA-Z_0-9]"))) + (defun quote-meta-chars (string &key (start 0) (end (length string))) + "Quote, i.e. prefix with #\\\\, all non-word characters in STRING." + (regex-replace-all non-word-char-scanner string "\\\\\\&" + :start start :end end))) + +(let* ((*use-bmh-matchers* nil) + (*allow-quoting* nil) + (quote-char-scanner (create-scanner "\\\\Q")) + (section-scanner (create-scanner "\\\\Q((?:[^\\\\]|\\\$?!Q))*?)(?:\\\\E|$)"))) + (defun quote-sections (string) + "Replace sections inside of STRING which are enclosed by \\Q and +\\E with the quoted equivalent of these sections \(see +QUOTE-META-CHARS). Repeat this as long as there are such +sections. These sections may nest." + (flet ((quote-substring (target-string start end match-start + match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (quote-meta-chars target-string + :start (svref reg-starts 0) + :end (svref reg-ends 0)))) + (loop for result = string then (regex-replace-all section-scanner + result + #'quote-substring) + while (scan quote-char-scanner result) + finally (return result))))) + +(let* ((*use-bmh-matchers* nil) + (comment-scanner (create-scanner "(?s)\\(\\?#.*?\$")) + (extended-comment-scanner (create-scanner "(?m:#.*?$)|(?s:\$\\?#.*?\$)")) + (quote-token-scanner "\\\\[QE]") + (quote-token-replace-scanner "\\\\([QE])")) + (defun clean-comments (string &optional extended-mode) + "Clean \(?#...) comments within STRING for quoting, i.e. convert +\\Q to Q and \\E to E. If EXTENDED-MODE is true, also clean +end-of-line comments, i.e. those starting with #\\# and ending with +#\\Newline." + (flet ((remove-tokens (target-string start end match-start + match-end reg-starts reg-ends) + (declare (ignore start end reg-starts reg-ends)) + (loop for result = (nsubseq target-string match-start match-end) + then (regex-replace-all quote-token-replace-scanner result "\\1") + ;; we must probably repeat this because the comment + ;; can contain substrings like \\Q + while (scan quote-token-scanner result) + finally (return result)))) + (regex-replace-all (if extended-mode + extended-comment-scanner + comment-scanner) + string + #'remove-tokens)))) Added: vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.asd =================================================================== --- vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,40 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/cl-ppcre-test.asd,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; This ASDF system definition was kindly provided by Marco Baringer. + +;;; Copyright (c) 2002-2003, 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. + +(defpackage #:cl-ppcre-test.system + (:use #:cl + #:asdf)) + +(in-package #:cl-ppcre-test.system) + +(defsystem #:cl-ppcre-test + :depends-on (#:cl-ppcre) + :components ((:file "ppcre-tests"))) Added: vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.system =================================================================== --- vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.system 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/cl-ppcre-test.system 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,40 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/cl-ppcre-test.system,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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-ppcre-test-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(mk:defsystem #:cl-ppcre-test + :source-pathname *cl-ppcre-test-base-directory* + :source-extension "lisp" + :depends-on (#:cl-ppcre) + :components ((:file "ppcre-tests"))) Added: vendor/portableaserve/libs/cl-ppcre/cl-ppcre.asd =================================================================== --- vendor/portableaserve/libs/cl-ppcre/cl-ppcre.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/cl-ppcre.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/cl-ppcre.asd,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; This ASDF system definition was kindly provided by Marco Baringer. + +;;; Copyright (c) 2002-2003, 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. + +(defpackage #:cl-ppcre.system + (:use #:cl + #:asdf)) + +(in-package #:cl-ppcre.system) + +(defsystem #:cl-ppcre + :components ((:file "packages") + (:file "specials" :depends-on ("packages")) + (:file "util" :depends-on ("packages")) + (:file "errors" :depends-on ("util")) + (:file "lexer" :depends-on ("errors" "specials")) + (:file "parser" :depends-on ("lexer")) + (:file "regex-class" :depends-on ("parser")) + (:file "convert" :depends-on ("regex-class")) + (:file "optimize" :depends-on ("convert")) + (:file "closures" :depends-on ("optimize" "specials")) + (:file "repetition-closures" :depends-on ("closures")) + (:file "scanner" :depends-on ("repetition-closures")) + (:file "api" :depends-on ("scanner")))) Added: vendor/portableaserve/libs/cl-ppcre/cl-ppcre.system =================================================================== --- vendor/portableaserve/libs/cl-ppcre/cl-ppcre.system 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/cl-ppcre.system 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/cl-ppcre.system,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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-ppcre-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(mk:defsystem #:cl-ppcre + :source-pathname *cl-ppcre-base-directory* + :source-extension "lisp" + :components ((:file "packages") + (:file "specials" :depends-on ("packages")) + (:file "util" :depends-on ("packages")) + (:file "errors" :depends-on ("util")) + (:file "lexer" :depends-on ("errors" "specials")) + (:file "parser" :depends-on ("lexer")) + (:file "regex-class" :depends-on ("parser")) + (:file "convert" :depends-on ("regex-class")) + (:file "optimize" :depends-on ("convert")) + (:file "closures" :depends-on ("optimize" "specials")) + (:file "repetition-closures" :depends-on ("closures")) + (:file "scanner" :depends-on ("repetition-closures")) + (:file "api" :depends-on ("scanner")))) Added: vendor/portableaserve/libs/cl-ppcre/closures.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/closures.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/closures.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,576 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/closures.lisp,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; Here we create the closures which together build the final +;;; scanner. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(declaim (inline *string*= *string*-equal)) + +(defun *string*= (string2 start1 end1 start2 end2) + "Like STRING=, i.e. compares the special string *STRING* from START1 +to END1 with STRING2 from START2 to END2. Note that there's no +boundary check - this has to be implemented by the caller." + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum start1 end1 start2 end2)) + (loop for string1-idx of-type fixnum from start1 below end1 + for string2-idx of-type fixnum from start2 below end2 + always (char= (schar *string* string1-idx) + (schar string2 string2-idx)))) + +(defun *string*-equal (string2 start1 end1 start2 end2) + "Like STRING-EQUAL, i.e. compares the special string *STRING* from +START1 to END1 with STRING2 from START2 to END2. Note that there's no +boundary check - this has to be implemented by the caller." + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum start1 end1 start2 end2)) + (loop for string1-idx of-type fixnum from start1 below end1 + for string2-idx of-type fixnum from start2 below end2 + always (char-equal (schar *string* string1-idx) + (schar string2 string2-idx)))) + +(defgeneric create-matcher-aux (regex next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Creates a closure which takes one parameter, +START-POS, and tests whether REGEX can match *STRING* at START-POS +such that the call to NEXT-FN after the match would succeed.")) + +(defmethod create-matcher-aux ((seq seq) next-fn) + ;; the closure for a SEQ is a chain of closures for the elements of + ;; this sequence which call each other in turn; the last closure + ;; calls NEXT-FN + (loop for element in (reverse (elements seq)) + for curr-matcher = next-fn then next-matcher + for next-matcher = (create-matcher-aux element curr-matcher) + finally (return next-matcher))) + +(defmethod create-matcher-aux ((alternation alternation) next-fn) + ;; first create closures for all alternations of ALTERNATION + (let ((all-matchers (mapcar #'(lambda (choice) + (create-matcher-aux choice next-fn)) + (choices alternation)))) + ;; now create a closure which checks if one of the closures + ;; created above can succeed + (lambda (start-pos) + (declare (type fixnum start-pos)) + (loop for matcher in all-matchers + thereis (funcall (the function matcher) start-pos))))) + +(defmethod create-matcher-aux ((register register) next-fn) + ;; the position of this REGISTER within the whole regex; we start to + ;; count at 0 + (let ((num (num register))) + (declare (type fixnum num)) + ;; STORE-END-OF-REG is a thin wrapper around NEXT-FN which will + ;; update the corresponding values of *REGS-START* and *REGS-END* + ;; after the inner matcher has succeeded + (flet ((store-end-of-reg (start-pos) + (declare (type fixnum start-pos) + (type function next-fn)) + (setf (svref *reg-starts* num) (svref *regs-maybe-start* num) + (svref *reg-ends* num) start-pos) + (funcall next-fn start-pos))) + ;; the inner matcher is a closure corresponding to the regex + ;; wrapped by this REGISTER + (let ((inner-matcher (create-matcher-aux (regex register) + #'store-end-of-reg))) + (declare (type function inner-matcher)) + ;; here comes the actual closure for REGISTER + (lambda (start-pos) + (declare (type fixnum start-pos)) + ;; remember the old values of *REGS-START* and friends in + ;; case we cannot match + (let ((old-*reg-starts* (svref *reg-starts* num)) + (old-*regs-maybe-start* (svref *regs-maybe-start* num)) + (old-*reg-ends* (svref *reg-ends* num))) + ;; we cannot use *REGS-START* here because Perl allows + ;; regular expressions like /(a|\1x)*/ + (setf (svref *regs-maybe-start* num) start-pos) + (let ((next-pos (funcall inner-matcher start-pos))) + (unless next-pos + ;; restore old values on failure + (setf (svref *reg-starts* num) old-*reg-starts* + (svref *regs-maybe-start* num) old-*regs-maybe-start* + (svref *reg-ends* num) old-*reg-ends*)) + next-pos))))))) + +(defmethod create-matcher-aux ((lookahead lookahead) next-fn) + ;; create a closure which just checks for the inner regex and + ;; doesn't care about NEXT-FN + (let ((test-matcher (create-matcher-aux (regex lookahead) #'identity))) + (declare (type function next-fn test-matcher)) + (if (positivep lookahead) + ;; positive look-ahead: check success of inner regex, then call + ;; NEXT-FN + (lambda (start-pos) + (and (funcall test-matcher start-pos) + (funcall next-fn start-pos))) + ;; negative look-ahead: check failure of inner regex, then call + ;; NEXT-FN + (lambda (start-pos) + (and (not (funcall test-matcher start-pos)) + (funcall next-fn start-pos)))))) + +(defmethod create-matcher-aux ((lookbehind lookbehind) next-fn) + (let ((len (len lookbehind)) + ;; create a closure which just checks for the inner regex and + ;; doesn't care about NEXT-FN + (test-matcher (create-matcher-aux (regex lookbehind) #'identity))) + (declare (type function next-fn test-matcher) + (type fixnum len)) + (if (positivep lookbehind) + ;; positive look-behind: check success of inner regex (if we're + ;; far enough from the start of *STRING*), then call NEXT-FN + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (>= (- start-pos *start-pos*) len) + (funcall test-matcher (- start-pos len)) + (funcall next-fn start-pos))) + ;; negative look-behind: check failure of inner regex (if we're + ;; far enough from the start of *STRING*), then call NEXT-FN + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (or (< start-pos len) + (not (funcall test-matcher (- start-pos len)))) + (funcall next-fn start-pos)))))) + +(defmacro insert-char-class-tester ((char-class chr-expr) &body body) + "Utility macro to replace each occurence of '(CHAR-CLASS-TEST) +within BODY with the correct test (corresponding to CHAR-CLASS) +against CHR-EXPR." + (with-unique-names (%char-class) + ;; the actual substitution is done here: replace + ;; '(CHAR-CLASS-TEST) with NEW + (flet ((substitute-char-class-tester (new) + (subst new '(char-class-test) body + :test #'equalp))) + `(let* ((,%char-class ,char-class) + (hash (hash ,%char-class)) + (count (if hash + (hash-table-count hash) + most-positive-fixnum)) + ;; collect a list of "all" characters in the hash if + ;; there aren't more than two + (key-list (if (<= count 2) + (loop for chr being the hash-keys of hash + collect chr) + nil)) + downcasedp) + (declare (type fixnum count)) + ;; check if we can partition the hash into three ranges (or + ;; less) + (multiple-value-bind (min1 max1 min2 max2 min3 max3) + (create-ranges-from-hash hash) + ;; if that didn't work and CHAR-CLASS is case-insensitive we + ;; try it again with every character downcased + (when (and (not min1) + (case-insensitive-p ,%char-class)) + (multiple-value-setq (min1 max1 min2 max2 min3 max3) + (create-ranges-from-hash hash :downcasep t)) + (setq downcasedp t)) + (cond ((= count 1) + ;; hash contains exactly one character so we just + ;; check for this single character; (note that this + ;; actually can't happen because this case is + ;; optimized away in CONVERT already...) + (let ((chr1 (first key-list))) + ,@(substitute-char-class-tester + `(char= ,chr-expr chr1)))) + ((= count 2) + ;; hash contains exactly two characters + (let ((chr1 (first key-list)) + (chr2 (second key-list))) + ,@(substitute-char-class-tester + `(let ((chr ,chr-expr)) + (or (char= chr chr1) + (char= chr chr2)))))) + ((word-char-class-p ,%char-class) + ;; special-case: hash is \w, \W, [\w], [\W] or + ;; something equivalent + ,@(substitute-char-class-tester + `(word-char-p ,chr-expr))) + ((= count *regex-char-code-limit*) + ;; according to the ANSI standard we might have all + ;; possible characters in the hash even if it + ;; doesn't contain CHAR-CODE-LIMIT characters but + ;; this doesn't seem to be the case for current + ;; implementations (also note that this optimization + ;; implies that you must not have characters with + ;; character codes beyond *REGEX-CHAR-CODE-LIMIT* in + ;; your regexes if you've changed this limit); we + ;; expect the compiler to optimize this T "test" + ;; away + ,@(substitute-char-class-tester t)) + ((and downcasedp min1 min2 min3) + ;; three different ranges, downcased + ,@(substitute-char-class-tester + `(let ((chr ,chr-expr)) + (or (char-not-greaterp min1 chr max1) + (char-not-greaterp min2 chr max2) + (char-not-greaterp min3 chr max3))))) + ((and downcasedp min1 min2) + ;; two ranges, downcased + ,@(substitute-char-class-tester + `(let ((chr ,chr-expr)) + (or (char-not-greaterp min1 chr max1) + (char-not-greaterp min2 chr max2))))) + ((and downcasedp min1) + ;; one downcased range + ,@(substitute-char-class-tester + `(char-not-greaterp min1 ,chr-expr max1))) + ((and min1 min2 min3) + ;; three ranges + ,@(substitute-char-class-tester + `(let ((chr ,chr-expr)) + (or (char<= min1 chr max1) + (char<= min2 chr max2) + (char<= min3 chr max3))))) + ((and min1 min2) + ;; two ranges + ,@(substitute-char-class-tester + `(let ((chr ,chr-expr)) + (or (char<= min1 chr max1) + (char<= min2 chr max2))))) + (min1 + ;; one range + ,@(substitute-char-class-tester + `(char<= min1 ,chr-expr max1))) + (t + ;; the general case; note that most of the above + ;; "optimizations" are based on experiences and + ;; benchmarks with CMUCL - if you're really + ;; concerned with speed you might find out that the + ;; general case is almost always the best one for + ;; other implementations (because the speed of their + ;; hash-table access in relation to other operations + ;; might be better than in CMUCL) + ,@(substitute-char-class-tester + `(gethash ,chr-expr hash))))))))) + +(defmethod create-matcher-aux ((char-class char-class) next-fn) + (declare (type function next-fn)) + ;; insert a test against the current character within *STRING* + (insert-char-class-tester (char-class (schar *string* start-pos)) + (if (invertedp char-class) + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (not (char-class-test)) + (funcall next-fn (1+ start-pos)))) + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (char-class-test) + (funcall next-fn (1+ start-pos))))))) + +(defmethod create-matcher-aux ((str str) next-fn) + (declare (type fixnum *end-string-pos*) + (type function next-fn) + ;; this special value is set by CREATE-SCANNER when the + ;; closures are built + (special end-string)) + (let* ((len (len str)) + (case-insensitive-p (case-insensitive-p str)) + (start-of-end-string-p (start-of-end-string-p str)) + (skip (skip str)) + (str (str str)) + (chr (schar str 0)) + (end-string (and end-string (str end-string))) + (end-string-len (if end-string + (length end-string) + nil))) + (declare (type fixnum len)) + (cond ((and start-of-end-string-p case-insensitive-p) + ;; closure for the first STR which belongs to the constant + ;; string at the end of the regular expression; + ;; case-insensitive version + (lambda (start-pos) + (declare (type fixnum start-pos end-string-len)) + (let ((test-end-pos (+ start-pos end-string-len))) + (declare (type fixnum test-end-pos)) + ;; either we're at *END-STRING-POS* (which means that + ;; it has already been confirmed that end-string + ;; starts here) or we really have to test + (and (or (= start-pos *end-string-pos*) + (and (<= test-end-pos *end-pos*) + (*string*-equal end-string start-pos test-end-pos + 0 end-string-len))) + (funcall next-fn (+ start-pos len)))))) + (start-of-end-string-p + ;; closure for the first STR which belongs to the constant + ;; string at the end of the regular expression; + ;; case-sensitive version + (lambda (start-pos) + (declare (type fixnum start-pos end-string-len)) + (let ((test-end-pos (+ start-pos end-string-len))) + (declare (type fixnum test-end-pos)) + ;; either we're at *END-STRING-POS* (which means that + ;; it has already been confirmed that end-string + ;; starts here) or we really have to test + (and (or (= start-pos *end-string-pos*) + (and (<= test-end-pos *end-pos*) + (*string*= end-string start-pos test-end-pos + 0 end-string-len))) + (funcall next-fn (+ start-pos len)))))) + (skip + ;; a STR which can be skipped because some other function + ;; has already confirmed that it matches + (lambda (start-pos) + (declare (type fixnum start-pos)) + (funcall next-fn (+ start-pos len)))) + ((and (= len 1) case-insensitive-p) + ;; STR represent exactly one character; case-insensitive + ;; version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (char-equal (schar *string* start-pos) chr) + (funcall next-fn (1+ start-pos))))) + ((= len 1) + ;; STR represent exactly one character; case-sensitive + ;; version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (char= (schar *string* start-pos) chr) + (funcall next-fn (1+ start-pos))))) + (case-insensitive-p + ;; general case, case-insensitive version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((next-pos (+ start-pos len))) + (declare (type fixnum next-pos)) + (and (<= next-pos *end-pos*) + (*string*-equal str start-pos next-pos 0 len) + (funcall next-fn next-pos))))) + (t + ;; general case, case-sensitive version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((next-pos (+ start-pos len))) + (declare (type fixnum next-pos)) + (and (<= next-pos *end-pos*) + (*string*= str start-pos next-pos 0 len) + (funcall next-fn next-pos)))))))) + +(declaim (inline word-boundary-p)) + +(defun word-boundary-p (start-pos) + "Check whether START-POS is a word-boundary within *STRING*." + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum start-pos)) + (let ((1-start-pos (1- start-pos))) + ;; either the character before START-POS is a word-constituent and + ;; the character at START-POS isn't... + (or (and (or (= start-pos *end-pos*) + (and (< start-pos *end-pos*) + (not (word-char-p (schar *string* start-pos))))) + (and (< 1-start-pos *end-pos*) + (<= *start-pos* 1-start-pos) + (word-char-p (schar *string* 1-start-pos)))) + ;; ...or vice versa + (and (or (= start-pos *start-pos*) + (and (< 1-start-pos *end-pos*) + (<= *start-pos* 1-start-pos) + (not (word-char-p (schar *string* 1-start-pos))))) + (and (< start-pos *end-pos*) + (word-char-p (schar *string* start-pos))))))) + +(defmethod create-matcher-aux ((word-boundary word-boundary) next-fn) + (declare (type function next-fn)) + (if (negatedp word-boundary) + (lambda (start-pos) + (and (not (word-boundary-p start-pos)) + (funcall next-fn start-pos))) + (lambda (start-pos) + (and (word-boundary-p start-pos) + (funcall next-fn start-pos))))) + +(defmethod create-matcher-aux ((everything everything) next-fn) + (declare (type function next-fn)) + (if (single-line-p everything) + ;; closure for single-line-mode: we really match everything, so we + ;; just advance the index into *STRING* by one and carry on + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (funcall next-fn (1+ start-pos)))) + ;; not single-line-mode, so we have to make sure we don't match + ;; #\Newline + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (< start-pos *end-pos*) + (char/= (schar *string* start-pos) #\Newline) + (funcall next-fn (1+ start-pos)))))) + +(defmethod create-matcher-aux ((anchor anchor) next-fn) + (declare (type function next-fn)) + (let ((startp (startp anchor)) + (multi-line-p (multi-line-p anchor))) + (cond ((no-newline-p anchor) + ;; this must be and end-anchor and it must be modeless, so + ;; we just have to check whether START-POS equals + ;; *END-POS* + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (= start-pos *end-pos*) + (funcall next-fn start-pos)))) + ((and startp multi-line-p) + ;; a start-anchor in multi-line-mode: check if we're at + ;; *START-POS* or if the last character was #\Newline + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((*start-pos* (or *real-start-pos* *start-pos*))) + (and (or (= start-pos *start-pos*) + (and (<= start-pos *end-pos*) + (> start-pos *start-pos*) + (char= #\Newline + (schar *string* (1- start-pos))))) + (funcall next-fn start-pos))))) + (startp + ;; a start-anchor which is not in multi-line-mode, so just + ;; check whether we're at *START-POS* + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (= start-pos (or *real-start-pos* *start-pos*)) + (funcall next-fn start-pos)))) + (multi-line-p + ;; an end-anchor in multi-line-mode: check if we're at + ;; *END-POS* or if the character we're looking at is + ;; #\Newline + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (or (= start-pos *end-pos*) + (and (< start-pos *end-pos*) + (char= #\Newline + (schar *string* start-pos)))) + (funcall next-fn start-pos)))) + (t + ;; an end-anchor which is not in multi-line-mode, so just + ;; check if we're at *END-POS* or if we're looking at + ;; #\Newline and there's nothing behind it + (lambda (start-pos) + (declare (type fixnum start-pos)) + (and (or (= start-pos *end-pos*) + (and (= start-pos (1- *end-pos*)) + (char= #\Newline + (schar *string* start-pos)))) + (funcall next-fn start-pos))))))) + +(defmethod create-matcher-aux ((back-reference back-reference) next-fn) + (declare (type function next-fn)) + ;; the position of the corresponding REGISTER within the whole + ;; regex; we start to count at 0 + (let ((num (num back-reference))) + (if (case-insensitive-p back-reference) + ;; the case-insensitive version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((reg-start (svref *reg-starts* num)) + (reg-end (svref *reg-ends* num))) + ;; only bother to check if the corresponding REGISTER as + ;; matched successfully already + (and reg-start + (let ((next-pos (+ start-pos (- (the fixnum reg-end) + (the fixnum reg-start))))) + (declare (type fixnum next-pos)) + (and + (<= next-pos *end-pos*) + (*string*-equal *string* start-pos next-pos + reg-start reg-end) + (funcall next-fn next-pos)))))) + ;; the case-sensitive version + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((reg-start (svref *reg-starts* num)) + (reg-end (svref *reg-ends* num))) + ;; only bother to check if the corresponding REGISTER as + ;; matched successfully already + (and reg-start + (let ((next-pos (+ start-pos (- (the fixnum reg-end) + (the fixnum reg-start))))) + (declare (type fixnum next-pos)) + (and + (<= next-pos *end-pos*) + (*string*= *string* start-pos next-pos + reg-start reg-end) + (funcall next-fn next-pos))))))))) + +(defmethod create-matcher-aux ((branch branch) next-fn) + (let* ((test (test branch)) + (then-matcher (create-matcher-aux (then-regex branch) next-fn)) + (else-matcher (create-matcher-aux (else-regex branch) next-fn))) + (declare (type function then-matcher else-matcher)) + (cond ((numberp test) + (lambda (start-pos) + (declare (type fixnum test)) + (if (and (< test (length *reg-starts*)) + (svref *reg-starts* test)) + (funcall then-matcher start-pos) + (funcall else-matcher start-pos)))) + (t + (let ((test-matcher (create-matcher-aux test #'identity))) + (declare (type function test-matcher)) + (lambda (start-pos) + (if (funcall test-matcher start-pos) + (funcall then-matcher start-pos) + (funcall else-matcher start-pos)))))))) + +(defmethod create-matcher-aux ((standalone standalone) next-fn) + (let ((inner-matcher (create-matcher-aux (regex standalone) #'identity))) + (declare (type function next-fn inner-matcher)) + (lambda (start-pos) + (let ((next-pos (funcall inner-matcher start-pos))) + (and next-pos + (funcall next-fn next-pos)))))) + +(defmethod create-matcher-aux ((void void) next-fn) + ;; optimize away VOIDs: don't create a closure, just return NEXT-FN + next-fn) Added: vendor/portableaserve/libs/cl-ppcre/convert.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/convert.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/convert.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,775 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/convert.lisp,v 1.1 2004/02/16 19:37:18 rudi Exp $ + +;;; Here the parse tree is converted into its internal representation +;;; using REGEX objects. At the same time some optimizations are +;;; already applied. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +;;; The flags that represent the "ism" modifiers are always kept +;;; together in a three-element list. We use the following macros to +;;; access individual elements. + +(defmacro case-insensitive-mode-p (flags) + "Accessor macro to extract the first flag out of a three-element flag list." + `(first ,flags)) + +(defmacro multi-line-mode-p (flags) + "Accessor macro to extract the second flag out of a three-element flag list." + `(second ,flags)) + +(defmacro single-line-mode-p (flags) + "Accessor macro to extract the third flag out of a three-element flag list." + `(third ,flags)) + +(defun set-flag (token) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (special flags)) + "Reads a flag token and sets or unsets the corresponding entry in +the special FLAGS list." + (case token + ((:case-insensitive-p) + (setf (case-insensitive-mode-p flags) t)) + ((:case-sensitive-p) + (setf (case-insensitive-mode-p flags) nil)) + ((:multi-line-mode-p) + (setf (multi-line-mode-p flags) t)) + ((:not-multi-line-mode-p) + (setf (multi-line-mode-p flags) nil)) + ((:single-line-mode-p) + (setf (single-line-mode-p flags) t)) + ((:not-single-line-mode-p) + (setf (single-line-mode-p flags) nil)) + (otherwise + (signal-ppcre-syntax-error "Unknown flag token ~A" token)))) + +(defun add-range-to-hash (hash from to) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (special flags)) + "Adds all characters from character FROM to character TO (inclusive) +to the char class hash HASH. Does the right thing with respect to +case-(in)sensitivity as specified by the special variable FLAGS." + (let ((from-code (char-code from)) + (to-code (char-code to))) + (when (> from-code to-code) + (signal-ppcre-syntax-error "Invalid range from ~A to ~A in char-class" + from to)) + (cond ((case-insensitive-mode-p flags) + (loop for code from from-code to to-code + for chr = (code-char code) + do (setf (gethash (char-upcase chr) hash) t + (gethash (char-downcase chr) hash) t))) + (t + (loop for code from from-code to to-code + do (setf (gethash (code-char code) hash) t)))) + hash)) + +(defun convert-char-class-to-hash (list) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Combines all items in LIST into one char class hash and returns it. +Items can be single characters, character ranges like \(:RANGE #\\A +#\\E), or special character classes like :DIGIT-CLASS. Does the right +thing with respect to case-\(in)sensitivity as specified by the +special variable FLAGS." + (loop with hash = (make-hash-table :size (ceiling (expt *regex-char-code-limit* (/ 1 4))) + :rehash-size (float (expt *regex-char-code-limit* (/ 1 4))) + :rehash-threshold 1.0) + for item in list + if (characterp item) + ;; treat a single character C like a range (:RANGE C C) + do (add-range-to-hash hash item item) + else if (symbolp item) + ;; special character classes + do (setq hash + (case item + ((:digit-class) + (merge-hash hash +digit-hash+)) + ((:non-digit-class) + (merge-inverted-hash hash +digit-hash+)) + ((:whitespace-char-class) + (merge-hash hash +whitespace-char-hash+)) + ((:non-whitespace-char-class) + (merge-inverted-hash hash +whitespace-char-hash+)) + ((:word-char-class) + (merge-hash hash +word-char-hash+)) + ((:non-word-char-class) + (merge-inverted-hash hash +word-char-hash+)) + (otherwise + (signal-ppcre-syntax-error + "Unknown symbol ~A in character class" + item)))) + else if (and (consp item) + (eq (car item) :range)) + ;; proper ranges + do (add-range-to-hash hash + (second item) + (third item)) + else do (signal-ppcre-syntax-error "Unknown item ~A in char-class list" + item) + finally (return hash))) + +(defun maybe-split-repetition (regex + greedyp + minimum + maximum + min-len + length + reg-seen) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum minimum) + (type (or fixnum null) maximum)) + "Splits a REPETITION object into a constant and a varying part if +applicable, i.e. something like + a{3,} -> a{3}a* +The arguments to this function correspond to the REPETITION slots of +the same name." + ;; note the usage of COPY-REGEX here; we can't use the same REGEX + ;; object in both REPETITIONS because they will have different + ;; offsets + (when maximum + (when (zerop maximum) + ;; trivial case: don't repeat at all + (return-from maybe-split-repetition + (make-instance 'void))) + (when (= 1 minimum maximum) + ;; another trivial case: "repeat" exactly once + (return-from maybe-split-repetition + regex))) + ;; first set up the constant part of the repetition + ;; maybe that's all we need + (let ((constant-repetition (if (plusp minimum) + (make-instance 'repetition + :regex (copy-regex regex) + :greedyp greedyp + :minimum minimum + :maximum minimum + :min-len min-len + :len length + :contains-register-p reg-seen) + ;; don't create garbage if minimum is 0 + nil))) + (when (and maximum + (= maximum minimum)) + (return-from maybe-split-repetition + ;; no varying part needed because min = max + constant-repetition)) + ;; now construct the varying part + (let ((varying-repetition + (make-instance 'repetition + :regex regex + :greedyp greedyp + :minimum 0 + :maximum (if maximum (- maximum minimum) nil) + :min-len min-len + :len length + :contains-register-p reg-seen))) + (cond ((zerop minimum) + ;; min = 0, no constant part needed + varying-repetition) + ((= 1 minimum) + ;; min = 1, constant part needs no REPETITION wrapped around + (make-instance 'seq + :elements (list (copy-regex regex) + varying-repetition))) + (t + ;; general case + (make-instance 'seq + :elements (list constant-repetition + varying-repetition))))))) + +;; During the conversion of the parse tree we keep track of the start +;; of the parse tree in the special variable STARTS-WITH which'll +;; either hold a STR object or an EVERYTHING object. The latter is the +;; case if the regex starts with ".*" which implicitely anchors the +;; regex at the start (perhaps modulo #\Newline). + +(defmethod maybe-accumulate ((str str)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (special accumulate-start-p starts-with)) + (declare (ftype (function (t) fixnum) len)) + "Accumulate STR into the special variable STARTS-WITH if +ACCUMULATE-START-P (also special) is true and STARTS-WITH is either +NIL or a STR object of the same case mode. Always returns NIL." + (when accumulate-start-p + (etypecase starts-with + (str + ;; STARTS-WITH already holds a STR, so we check if we can + ;; concatenate + (cond ((eq (case-insensitive-p starts-with) + (case-insensitive-p str)) + ;; we modify STARTS-WITH in place + (setf (len starts-with) + (+ (len starts-with) (len str))) + ;; note that we use SLOT-VALUE because the accessor + ;; STR has a declared FTYPE which doesn't fit here + (adjust-array (slot-value starts-with 'str) + (len starts-with) + :fill-pointer t) + (setf (subseq (slot-value starts-with 'str) + (- (len starts-with) (len str))) + (str str) + ;; STR objects that are parts of STARTS-WITH + ;; always have their SKIP slot set to true + ;; because the SCAN function will take care of + ;; them, i.e. the matcher can ignore them + (skip str) t)) + (t (setq accumulate-start-p nil)))) + (null + ;; STARTS-WITH is still empty, so we create a new STR object + (setf starts-with + (make-instance 'str + :str "" + :case-insensitive-p (case-insensitive-p str)) + ;; INITIALIZE-INSTANCE will coerce the STR to a simple + ;; string, so we have to fill it afterwards + (slot-value starts-with 'str) + (make-array (len str) + :initial-contents (str str) + :element-type 'character + :fill-pointer t + :adjustable t) + (len starts-with) + (len str) + ;; see remark about SKIP above + (skip str) t)) + (everything + ;; STARTS-WITH already holds an EVERYTHING object - we can't + ;; concatenate + (setq accumulate-start-p nil)))) + nil) + +(defun convert-aux (parse-tree) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (special flags reg-num accumulate-start-p starts-with max-back-ref)) + "Converts the parse tree PARSE-TREE into a REGEX object and returns it. + +Will also + - split and optimize repetitions, + - accumulate strings or EVERYTHING objects into the special variable + STARTS-WITH, + - keep track of all registers seen in the special variable REG-NUM, + - keep track of the highest backreference seen in the special + variable MAX-BACK-REF, + - maintain and adher to the currently applicable modifiers in the special + variable FLAGS, and + - maybe even wash your car..." + (cond ((consp parse-tree) + (case (first parse-tree) + ;; (:SEQUENCE {<regex>}*) + ((:sequence) + (cond ((cddr parse-tree) + ;; this is essentially like + ;; (MAPCAR 'CONVERT-AUX (REST PARSE-TREE)) + ;; but we don't cons a new list + (loop for parse-tree-rest on (rest parse-tree) + while parse-tree-rest + do (setf (car parse-tree-rest) + (convert-aux (car parse-tree-rest)))) + (make-instance 'seq + :elements (rest parse-tree))) + (t (convert-aux (second parse-tree))))) + ;; (:GROUP {<regex>}*) + ;; this is a syntactical construct equivalent to :SEQUENCE + ;; intended to keep the effect of modifiers local + ((:group) + ;; make a local copy of FLAGS and shadow the global + ;; value while we descend into the enclosed regexes + (let ((flags (copy-list flags))) + (declare (special flags)) + (cond ((cddr parse-tree) + (loop for parse-tree-rest on (rest parse-tree) + while parse-tree-rest + do (setf (car parse-tree-rest) + (convert-aux (car parse-tree-rest)))) + (make-instance 'seq + :elements (rest parse-tree))) + (t (convert-aux (second parse-tree)))))) + ;; (:ALTERNATION {<regex>}*) + ((:alternation) + ;; we must stop accumulating objects into STARTS-WITH + ;; once we reach an alternation + (setq accumulate-start-p nil) + (loop for parse-tree-rest on (rest parse-tree) + while parse-tree-rest + do (setf (car parse-tree-rest) + (convert-aux (car parse-tree-rest)))) + (make-instance 'alternation + :choices (rest parse-tree))) + ;; (:BRANCH <test> <regex>) + ;; <test> must be look-ahead, look-behind or number; + ;; if <regex> is an alternation it must have one or two + ;; choices + ((:branch) + (setq accumulate-start-p nil) + (let* ((test-candidate (second parse-tree)) + (test (cond ((numberp test-candidate) + (when (zerop (the fixnum test-candidate)) + (signal-ppcre-syntax-error + "Register 0 doesn't exist: ~S" + parse-tree)) + (1- (the fixnum test-candidate))) + (t (convert-aux test-candidate)))) + (alternations (convert-aux (third parse-tree)))) + (when (and (not (numberp test)) + (not (typep test 'lookahead)) + (not (typep test 'lookbehind))) + (signal-ppcre-syntax-error + "Branch test must be look-ahead, look-behind or number: ~S" + parse-tree)) + (typecase alternations + (alternation + (case (length (choices alternations)) + ((0) + (signal-ppcre-syntax-error "No choices in branch: ~S" + parse-tree)) + ((1) + (make-instance 'branch + :test test + :then-regex (first + (choices alternations)))) + ((2) + (make-instance 'branch + :test test + :then-regex (first + (choices alternations)) + :else-regex (second + (choices alternations)))) + (otherwise + (signal-ppcre-syntax-error + "Too much choices in branch: ~S" + parse-tree)))) + (t + (make-instance 'branch + :test test + :then-regex alternations))))) + ;; (:POSITIVE-LOOKAHEAD|:NEGATIVE-LOOKAHEAD <regex>) + ((:positive-lookahead :negative-lookahead) + ;; keep the effect of modifiers local to the enclosed + ;; regex and stop accumulating into STARTS-WITH + (setq accumulate-start-p nil) + (let ((flags (copy-list flags))) + (declare (special flags)) + (make-instance 'lookahead + :regex (convert-aux (second parse-tree)) + :positivep (eq (first parse-tree) + :positive-lookahead)))) + ;; (:POSITIVE-LOOKBEHIND|:NEGATIVE-LOOKBEHIND <regex>) + ((:positive-lookbehind :negative-lookbehind) + ;; keep the effect of modifiers local to the enclosed + ;; regex and stop accumulating into STARTS-WITH + (setq accumulate-start-p nil) + (let* ((flags (copy-list flags)) + (regex (convert-aux (second parse-tree))) + (len (regex-length regex))) + (declare (special flags)) + ;; lookbehind assertions must be of fixed length + (unless len + (signal-ppcre-syntax-error + "Variable length look-behind not implemented (yet): ~S" + parse-tree)) + (make-instance 'lookbehind + :regex regex + :positivep (eq (first parse-tree) + :positive-lookbehind) + :len len))) + ;; (:GREEDY-REPETITION|:NON-GREEDY-REPETITION <min> <max> <regex>) + ((:greedy-repetition :non-greedy-repetition) + ;; remember the value of ACCUMULATE-START-P upon entering + (let ((local-accumulate-start-p accumulate-start-p)) + (let ((minimum (second parse-tree)) + (maximum (third parse-tree))) + (declare (type fixnum minimum)) + (declare (type (or null fixnum) maximum)) + (unless (and maximum + (= 1 minimum maximum)) + ;; set ACCUMULATE-START-P to NIL for the rest of + ;; the conversion because we can't continue to + ;; accumulate inside as well as after a proper + ;; repetition + (setq accumulate-start-p nil)) + (let* (reg-seen + (regex (convert-aux (fourth parse-tree))) + (min-len (regex-min-length regex)) + (greedyp (eq (first parse-tree) :greedy-repetition)) + (length (regex-length regex))) + ;; note that this declaration already applies to + ;; the call to CONVERT-AUX above + (declare (special reg-seen)) + (when (and local-accumulate-start-p + (not starts-with) + (zerop minimum) + (not maximum)) + ;; if this repetition is (equivalent to) ".*" + ;; and if we're at the start of the regex we + ;; remember it for ADVANCE-FN (see the SCAN + ;; function) + (setq starts-with (everythingp regex))) + (if (or (not reg-seen) + (not greedyp) + (not length) + (zerop length) + (and maximum (= minimum maximum))) + ;; the repetition doesn't enclose a register, or + ;; it's not greedy, or we can't determine it's + ;; (inner) length, or the length is zero, or the + ;; number of repetitions is fixed; in all of + ;; these cases we don't bother to optimize + (maybe-split-repetition regex + greedyp + minimum + maximum + min-len + length + reg-seen) + ;; otherwise we make a transformation that looks + ;; roughly like one of + ;; <regex>* -> (?:<regex'>*<regex>)? + ;; <regex>+ -> <regex'>*<regex> + ;; where the trick is that as much as possible + ;; registers from <regex> are removed in + ;; <regex'> + (let* (reg-seen ; new instance for REMOVE-REGISTERS + (remove-registers-p t) + (inner-regex (remove-registers regex)) + (inner-repetition + ;; this is the "<regex'>" part + (maybe-split-repetition inner-regex + ;; always greedy + t + ;; reduce minimum by 1 + ;; unless it's already 0 + (if (zerop minimum) + 0 + (1- minimum)) + ;; reduce maximum by 1 + ;; unless it's NIL + (and maximum + (1- maximum)) + min-len + length + reg-seen)) + (inner-seq + ;; this is the "<regex'>*<regex>" part + (make-instance 'seq + :elements (list inner-repetition + regex)))) + ;; note that this declaration already applies + ;; to the call to REMOVE-REGISTERS above + (declare (special remove-registers-p reg-seen)) + ;; wrap INNER-SEQ with a greedy + ;; {0,1}-repetition (i.e. "?") if necessary + (if (plusp minimum) + inner-seq + (maybe-split-repetition inner-seq + t + 0 + 1 + min-len + nil + t)))))))) + ;; (:REGISTER <regex>) + ((:register) + ;; keep the effect of modifiers local to the enclosed + ;; regex; also, assign the current value of REG-NUM to + ;; the corresponding slot of the REGISTER object and + ;; increase this counter afterwards + (let ((flags (copy-list flags)) + (stored-reg-num reg-num)) + (declare (special flags reg-seen)) + (setq reg-seen t) + (incf (the fixnum reg-num)) + (make-instance 'register + :regex (convert-aux (second parse-tree)) + :num stored-reg-num))) + ;; (:STANDALONE <regex>) + ((:standalone) + ;; keep the effect of modifiers local to the enclosed + ;; regex + (let ((flags (copy-list flags))) + (declare (special flags)) + (make-instance 'standalone + :regex (convert-aux (second parse-tree))))) + ;; (:BACK-REFERENCE <number>) + ((:back-reference) + (let ((backref-number (second parse-tree))) + (declare (type fixnum backref-number)) + (when (or (not (typep backref-number 'fixnum)) + (<= backref-number 0)) + (signal-ppcre-syntax-error + "Illegal back-reference: ~S" + parse-tree)) + ;; stop accumulating into STARTS-WITH and increase + ;; MAX-BACK-REF if necessary + (setq accumulate-start-p nil + max-back-ref (max (the fixnum max-back-ref) + backref-number)) + (make-instance 'back-reference + ;; we start counting from 0 internally + :num (1- backref-number) + :case-insensitive-p (case-insensitive-mode-p + flags)))) + ;; (:CHAR-CLASS|:INVERTED-CHAR-CLASS {<item>}*) + ;; where item is one of + ;; - a character + ;; - a character range: (:RANGE <char1> <char2>) + ;; - a special char class symbol like :DIGIT-CHAR-CLASS + ((:char-class :inverted-char-class) + ;; first create the hash-table and some auxiliary values + (let* (hash + hash-keys + (count most-positive-fixnum) + (item-list (rest parse-tree)) + (invertedp (eq (first parse-tree) :inverted-char-class)) + word-char-class-p) + (cond ((every (lambda (item) (eq item :word-char-class)) + item-list) + ;; treat "[\\w]" like "\\w" + (setq word-char-class-p t)) + ((every (lambda (item) (eq item :non-word-char-class)) + item-list) + ;; treat "[\\W]" like "\\W" + (setq word-char-class-p t) + (setq invertedp (not invertedp))) + (t + (setq hash (convert-char-class-to-hash item-list) + count (hash-table-count hash)) + (when (<= count 2) + ;; collect the hash-table keys into a list if + ;; COUNT is smaller than 3 + (setq hash-keys + (loop for chr being the hash-keys of hash + collect chr))))) + (cond ((and (not invertedp) + (= count 1)) + ;; convert one-element hash table into a STR + ;; object and try to accumulate into + ;; STARTS-WITH + (let ((str (make-instance 'str + :str (string + (first hash-keys)) + :case-insensitive-p nil))) + (maybe-accumulate str) + str)) + ((and (not invertedp) + (= count 2) + (char-equal (first hash-keys) (second hash-keys))) + ;; convert two-element hash table into a + ;; case-insensitive STR object and try to + ;; accumulate into STARTS-WITH if the two + ;; characters are CHAR-EQUAL + (let ((str (make-instance 'str + :str (string + (first hash-keys)) + :case-insensitive-p t))) + (maybe-accumulate str) + str)) + (t + ;; the general case; stop accumulating into STARTS-WITH + (setq accumulate-start-p nil) + (make-instance 'char-class + :hash hash + :case-insensitive-p + (case-insensitive-mode-p flags) + :invertedp invertedp + :word-char-class-p word-char-class-p))))) + ;; (:FLAGS {<flag>}*) + ;; where flag is a modifier symbol like :CASE-INSENSITIVE-P + ((:flags) + ;; set/unset the flags corresponding to the symbols + ;; following :FLAGS + (mapc #'set-flag (rest parse-tree)) + ;; we're only interested in the side effect of + ;; setting/unsetting the flags and turn this syntactical + ;; construct into a VOID object which'll be optimized + ;; away when creating the matcher + (make-instance 'void)) + (otherwise + (signal-ppcre-syntax-error + "Unknown token ~A in parse-tree" + (first parse-tree))))) + ((or (characterp parse-tree) (stringp parse-tree)) + ;; turn characters or strings into STR objects and try to + ;; accumulate into STARTS-WITH + (let ((str (make-instance 'str + :str (string parse-tree) + :case-insensitive-p + (case-insensitive-mode-p flags)))) + (maybe-accumulate str) + str)) + (t + ;; and now for the tokens which are symbols + (case parse-tree + ((:void) + (make-instance 'void)) + ((:word-boundary) + (make-instance 'word-boundary :negatedp nil)) + ((:non-word-boundary) + (make-instance 'word-boundary :negatedp t)) + ;; the special character classes + ((:digit-class + :non-digit-class + :word-char-class + :non-word-char-class + :whitespace-char-class + :non-whitespace-char-class) + ;; stop accumulating into STARTS-WITH + (setq accumulate-start-p nil) + (make-instance 'char-class + ;; use the constants defined in util.lisp + :hash (case parse-tree + ((:digit-class + :non-digit-class) + +digit-hash+) + ((:word-char-class + :non-word-char-class) + nil) + ((:whitespace-char-class + :non-whitespace-char-class) + +whitespace-char-hash+)) + ;; this value doesn't really matter but + ;; NIL should result in slightly faster + ;; matchers + :case-insensitive-p nil + :invertedp (member parse-tree + '(:non-digit-class + :non-word-char-class + :non-whitespace-char-class) + :test #'eq) + :word-char-class-p (member parse-tree + '(:word-char-class + :non-word-char-class) + :test #'eq))) + ((:start-anchor ; Perl's "^" + :end-anchor ; Perl's "$" + :modeless-end-anchor-no-newline + ; Perl's "\z" + :modeless-start-anchor ; Perl's "\A" + :modeless-end-anchor) ; Perl's "\Z" + (make-instance 'anchor + :startp (member parse-tree + '(:start-anchor + :modeless-start-anchor) + :test #'eq) + ;; set this value according to the + ;; current settings of FLAGS (unless it's + ;; a modeless anchor) + :multi-line-p + (and (multi-line-mode-p flags) + (not (member parse-tree + '(:modeless-start-anchor + :modeless-end-anchor + :modeless-end-anchor-no-newline) + :test #'eq))) + :no-newline-p + (eq parse-tree + :modeless-end-anchor-no-newline))) + ((:everything) + ;; stop accumulating into STARTS-WITHS + (setq accumulate-start-p nil) + (make-instance 'everything + :single-line-p (single-line-mode-p flags))) + ;; special tokens corresponding to Perl's "ism" modifiers + ((:case-insensitive-p + :case-sensitive-p + :multi-line-mode-p + :not-multi-line-mode-p + :single-line-mode-p + :not-single-line-mode-p) + ;; we're only interested in the side effect of + ;; setting/unsetting the flags and turn these tokens + ;; into VOID objects which'll be optimized away when + ;; creating the matcher + (set-flag parse-tree) + (make-instance 'void)) + (otherwise + (signal-ppcre-syntax-error "Unknown token ~A in parse-tree" + parse-tree)))))) + +(defun convert (parse-tree) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Converts the parse tree PARSE-TREE into an equivalent REGEX object +and returns three values: the REGEX object, the number of registers +seen and an object the regex starts with which is either a STR object +or an EVERYTHING object (if the regex starts with something like +\".*\") or NIL." + ;; this function basically just initializes the special variables + ;; and then calls CONVERT-AUX to do all the work + (let* ((flags (list nil nil nil)) + (reg-num 0) + (accumulate-start-p t) + starts-with + (max-back-ref 0) + (converted-parse-tree (convert-aux parse-tree))) + (declare (special flags reg-num accumulate-start-p starts-with max-back-ref)) + ;; make sure we don't reference registers which aren't there + (when (> (the fixnum max-back-ref) + (the fixnum reg-num)) + (signal-ppcre-syntax-error + "Backreference to register ~A which has not been defined" + max-back-ref)) + (when (typep starts-with 'str) + (setf (slot-value starts-with 'str) + (coerce (slot-value starts-with 'str) 'simple-string))) + (values converted-parse-tree reg-num starts-with))) Added: vendor/portableaserve/libs/cl-ppcre/doc/CVS/Entries =================================================================== --- vendor/portableaserve/libs/cl-ppcre/doc/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/doc/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3 @@ +/benchmarks.2002-12-22.txt/1.1/Mon Feb 16 19:37:17 2004// +/index.html/1.1/Mon Feb 16 19:37:16 2004// +D Added: vendor/portableaserve/libs/cl-ppcre/doc/CVS/Repository =================================================================== --- vendor/portableaserve/libs/cl-ppcre/doc/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/doc/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/libs/cl-ppcre/doc Added: vendor/portableaserve/libs/cl-ppcre/doc/CVS/Root =================================================================== --- vendor/portableaserve/libs/cl-ppcre/doc/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/doc/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/libs/cl-ppcre/doc/benchmarks.2002-12-22.txt =================================================================== --- vendor/portableaserve/libs/cl-ppcre/doc/benchmarks.2002-12-22.txt 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/doc/benchmarks.2002-12-22.txt 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1546 @@ + 1: 0.2862 (100000 repetitions, Perl: 0.2097 seconds, CL-PPCRE: 0.0600 seconds) + 2: 0.4161 (1000000 repetitions, Perl: 0.7690 seconds, CL-PPCRE: 0.3200 seconds) + 3: 0.3939 (100000 repetitions, Perl: 0.2031 seconds, CL-PPCRE: 0.0800 seconds) + 4: 0.4639 (1000000 repetitions, Perl: 0.7976 seconds, CL-PPCRE: 0.3700 seconds) + 5: 0.4400 (100000 repetitions, Perl: 0.1591 seconds, CL-PPCRE: 0.0700 seconds) + 6: 0.5106 (100000 repetitions, Perl: 0.1567 seconds, CL-PPCRE: 0.0800 seconds) + 7: 0.4928 (100000 repetitions, Perl: 0.1826 seconds, CL-PPCRE: 0.0900 seconds) + 8: 0.5934 (100000 repetitions, Perl: 0.1854 seconds, CL-PPCRE: 0.1100 seconds) + 9: 0.3450 (100000 repetitions, Perl: 0.2029 seconds, CL-PPCRE: 0.0700 seconds) + 10: 0.5261 (100000 repetitions, Perl: 0.3231 seconds, CL-PPCRE: 0.1700 seconds) + 11: 0.5556 (100000 repetitions, Perl: 0.3240 seconds, CL-PPCRE: 0.1800 seconds) + 12: 0.5490 (100000 repetitions, Perl: 0.3279 seconds, CL-PPCRE: 0.1800 seconds) + 13: 0.5595 (100000 repetitions, Perl: 0.3217 seconds, CL-PPCRE: 0.1800 seconds) + 14: 0.5917 (100000 repetitions, Perl: 0.3211 seconds, CL-PPCRE: 0.1900 seconds) + 15: 0.5164 (100000 repetitions, Perl: 0.3292 seconds, CL-PPCRE: 0.1700 seconds) + 16: 0.5552 (100000 repetitions, Perl: 0.3242 seconds, CL-PPCRE: 0.1800 seconds) + 17: 0.5273 (100000 repetitions, Perl: 0.3224 seconds, CL-PPCRE: 0.1700 seconds) + 18: 0.5886 (100000 repetitions, Perl: 0.3228 seconds, CL-PPCRE: 0.1900 seconds) + 19: 0.5524 (100000 repetitions, Perl: 0.3259 seconds, CL-PPCRE: 0.1800 seconds) + 20: 0.5860 (100000 repetitions, Perl: 0.3242 seconds, CL-PPCRE: 0.1900 seconds) + 21: 0.5569 (100000 repetitions, Perl: 0.3232 seconds, CL-PPCRE: 0.1800 seconds) + 22: 0.6129 (100000 repetitions, Perl: 0.3263 seconds, CL-PPCRE: 0.2000 seconds) + 23: 0.5789 (100000 repetitions, Perl: 0.3282 seconds, CL-PPCRE: 0.1900 seconds) + 24: 0.5516 (100000 repetitions, Perl: 0.3263 seconds, CL-PPCRE: 0.1800 seconds) + 25: 0.4861 (100000 repetitions, Perl: 0.3291 seconds, CL-PPCRE: 0.1600 seconds) + 26: 0.4879 (100000 repetitions, Perl: 0.3279 seconds, CL-PPCRE: 0.1600 seconds) + 27: 0.4929 (100000 repetitions, Perl: 0.3246 seconds, CL-PPCRE: 0.1600 seconds) + 28: 0.5633 (100000 repetitions, Perl: 0.3195 seconds, CL-PPCRE: 0.1800 seconds) + 29: 0.4901 (100000 repetitions, Perl: 0.3264 seconds, CL-PPCRE: 0.1600 seconds) + 30: 0.5145 (100000 repetitions, Perl: 0.3304 seconds, CL-PPCRE: 0.1700 seconds) + 31: 0.5286 (100000 repetitions, Perl: 0.3216 seconds, CL-PPCRE: 0.1700 seconds) + 32: 0.5306 (100000 repetitions, Perl: 0.3204 seconds, CL-PPCRE: 0.1700 seconds) + 33: 0.5213 (100000 repetitions, Perl: 0.3261 seconds, CL-PPCRE: 0.1700 seconds) + 34: 0.5221 (100000 repetitions, Perl: 0.3256 seconds, CL-PPCRE: 0.1700 seconds) + 35: 0.5858 (100000 repetitions, Perl: 0.3243 seconds, CL-PPCRE: 0.1900 seconds) + 36: 0.5556 (100000 repetitions, Perl: 0.3240 seconds, CL-PPCRE: 0.1800 seconds) + 37: 0.6985 (100000 repetitions, Perl: 0.3293 seconds, CL-PPCRE: 0.2300 seconds) + 38: 0.5760 (100000 repetitions, Perl: 0.3299 seconds, CL-PPCRE: 0.1900 seconds) + 39: 0.6964 (100000 repetitions, Perl: 0.3303 seconds, CL-PPCRE: 0.2300 seconds) + 40: 1.2660 (1000000 repetitions, Perl: 0.7662 seconds, CL-PPCRE: 0.9700 seconds) + 41: 1.5983 (1000000 repetitions, Perl: 0.8509 seconds, CL-PPCRE: 1.3600 seconds) + 42: 1.3381 (1000000 repetitions, Perl: 0.7697 seconds, CL-PPCRE: 1.0300 seconds) + 43: 1.0846 (100000 repetitions, Perl: 0.7284 seconds, CL-PPCRE: 0.7900 seconds) + 44: 0.9248 (100000 repetitions, Perl: 0.7029 seconds, CL-PPCRE: 0.6500 seconds) + 45: 0.9872 (100000 repetitions, Perl: 0.6281 seconds, CL-PPCRE: 0.6200 seconds) + 46: 0.4932 (100000 repetitions, Perl: 0.1622 seconds, CL-PPCRE: 0.0800 seconds) + 47: 0.5567 (100000 repetitions, Perl: 0.1617 seconds, CL-PPCRE: 0.0900 seconds) + 48: 0.7445 (1000000 repetitions, Perl: 0.6179 seconds, CL-PPCRE: 0.4600 seconds) + 49: 1.4152 (1000000 repetitions, Perl: 0.8055 seconds, CL-PPCRE: 1.1400 seconds) + 50: 0.6042 (100000 repetitions, Perl: 0.1324 seconds, CL-PPCRE: 0.0800 seconds) + 51: 0.3376 (100000 repetitions, Perl: 0.2370 seconds, CL-PPCRE: 0.0800 seconds) + 52: 0.3549 (100000 repetitions, Perl: 0.3099 seconds, CL-PPCRE: 0.1100 seconds) + 53: 0.3404 (100000 repetitions, Perl: 0.3525 seconds, CL-PPCRE: 0.1200 seconds) + 54: 0.3398 (100000 repetitions, Perl: 0.3237 seconds, CL-PPCRE: 0.1100 seconds) + 55: 0.3516 (100000 repetitions, Perl: 0.4551 seconds, CL-PPCRE: 0.1600 seconds) + 56: 0.3069 (100000 repetitions, Perl: 0.3258 seconds, CL-PPCRE: 0.1000 seconds) + 57: 0.3032 (100000 repetitions, Perl: 0.6925 seconds, CL-PPCRE: 0.2100 seconds) + 58: 0.3515 (10000 repetitions, Perl: 0.3130 seconds, CL-PPCRE: 0.1100 seconds) + 59: 0.3563 (100000 repetitions, Perl: 0.3088 seconds, CL-PPCRE: 0.1100 seconds) + 60: 0.3429 (100000 repetitions, Perl: 0.6708 seconds, CL-PPCRE: 0.2300 seconds) + 61: 0.3169 (100000 repetitions, Perl: 0.2840 seconds, CL-PPCRE: 0.0900 seconds) + 62: 0.3519 (100000 repetitions, Perl: 0.2842 seconds, CL-PPCRE: 0.1000 seconds) + 63: 0.3443 (100000 repetitions, Perl: 0.2904 seconds, CL-PPCRE: 0.1000 seconds) + 64: 0.3917 (100000 repetitions, Perl: 0.2808 seconds, CL-PPCRE: 0.1100 seconds) + 65: 0.3474 (100000 repetitions, Perl: 0.2878 seconds, CL-PPCRE: 0.1000 seconds) + 66: 0.3473 (100000 repetitions, Perl: 0.2879 seconds, CL-PPCRE: 0.1000 seconds) + 67: 0.4047 (100000 repetitions, Perl: 0.2965 seconds, CL-PPCRE: 0.1200 seconds) + 68: 0.4057 (100000 repetitions, Perl: 0.2958 seconds, CL-PPCRE: 0.1200 seconds) + 69: 0.4091 (100000 repetitions, Perl: 0.2689 seconds, CL-PPCRE: 0.1100 seconds) + 70: 0.4841 (100000 repetitions, Perl: 0.4751 seconds, CL-PPCRE: 0.2300 seconds) + 71: 0.2327 (100000 repetitions, Perl: 0.3438 seconds, CL-PPCRE: 0.0800 seconds) + 72: 0.4767 (100000 repetitions, Perl: 0.3986 seconds, CL-PPCRE: 0.1900 seconds) + 73: 0.3673 (100000 repetitions, Perl: 0.5174 seconds, CL-PPCRE: 0.1900 seconds) + 74: 0.5311 (100000 repetitions, Perl: 0.5460 seconds, CL-PPCRE: 0.2900 seconds) + 75: 0.5722 (100000 repetitions, Perl: 0.5068 seconds, CL-PPCRE: 0.2900 seconds) + 76: 0.5913 (100000 repetitions, Perl: 0.5074 seconds, CL-PPCRE: 0.3000 seconds) + 77: 0.3544 (100000 repetitions, Perl: 0.2257 seconds, CL-PPCRE: 0.0800 seconds) + 78: 0.3919 (100000 repetitions, Perl: 0.4593 seconds, CL-PPCRE: 0.1800 seconds) + 79: 0.4080 (100000 repetitions, Perl: 0.2941 seconds, CL-PPCRE: 0.1200 seconds) + 80: 0.5635 (100000 repetitions, Perl: 0.5147 seconds, CL-PPCRE: 0.2900 seconds) + 81: 0.5616 (100000 repetitions, Perl: 0.5163 seconds, CL-PPCRE: 0.2900 seconds) + 82: 0.4216 (100000 repetitions, Perl: 0.1423 seconds, CL-PPCRE: 0.0600 seconds) + 83: 0.2502 (100000 repetitions, Perl: 0.1199 seconds, CL-PPCRE: 0.0300 seconds) + 84: 0.2546 (100000 repetitions, Perl: 0.1178 seconds, CL-PPCRE: 0.0300 seconds) + 85: 0.2515 (100000 repetitions, Perl: 0.1193 seconds, CL-PPCRE: 0.0300 seconds) + 86: 0.2545 (100000 repetitions, Perl: 0.1179 seconds, CL-PPCRE: 0.0300 seconds) + 87: 0.2535 (100000 repetitions, Perl: 0.1184 seconds, CL-PPCRE: 0.0300 seconds) + 88: 0.2522 (100000 repetitions, Perl: 0.1189 seconds, CL-PPCRE: 0.0300 seconds) + 89: 0.3010 (1000000 repetitions, Perl: 0.8971 seconds, CL-PPCRE: 0.2700 seconds) + 90: 0.2906 (1000000 repetitions, Perl: 0.8947 seconds, CL-PPCRE: 0.2600 seconds) + 91: 0.2800 (1000000 repetitions, Perl: 0.8928 seconds, CL-PPCRE: 0.2500 seconds) + 92: 0.3329 (100000 repetitions, Perl: 0.1202 seconds, CL-PPCRE: 0.0400 seconds) + 93: 0.3394 (100000 repetitions, Perl: 0.1178 seconds, CL-PPCRE: 0.0400 seconds) + 94: 0.2516 (100000 repetitions, Perl: 0.1193 seconds, CL-PPCRE: 0.0300 seconds) + 95: 0.3393 (100000 repetitions, Perl: 0.1179 seconds, CL-PPCRE: 0.0400 seconds) + 96: 0.2891 (1000000 repetitions, Perl: 0.8994 seconds, CL-PPCRE: 0.2600 seconds) + 97: 0.3026 (1000000 repetitions, Perl: 0.8922 seconds, CL-PPCRE: 0.2700 seconds) + 98: 0.2508 (100000 repetitions, Perl: 0.1196 seconds, CL-PPCRE: 0.0300 seconds) + 99: 0.2546 (100000 repetitions, Perl: 0.1178 seconds, CL-PPCRE: 0.0300 seconds) + 100: 0.2493 (100000 repetitions, Perl: 0.1204 seconds, CL-PPCRE: 0.0300 seconds) + 101: 0.3002 (1000000 repetitions, Perl: 0.8994 seconds, CL-PPCRE: 0.2700 seconds) + 102: 0.2904 (1000000 repetitions, Perl: 0.8954 seconds, CL-PPCRE: 0.2600 seconds) + 103: 0.2904 (1000000 repetitions, Perl: 0.8952 seconds, CL-PPCRE: 0.2600 seconds) + 104: 0.2976 (1000000 repetitions, Perl: 0.9073 seconds, CL-PPCRE: 0.2700 seconds) + 105: 0.2999 (1000000 repetitions, Perl: 0.9004 seconds, CL-PPCRE: 0.2700 seconds) + 106: 0.2885 (1000000 repetitions, Perl: 0.9012 seconds, CL-PPCRE: 0.2600 seconds) + 107: 0.2505 (100000 repetitions, Perl: 0.1198 seconds, CL-PPCRE: 0.0300 seconds) + 108: 0.3368 (100000 repetitions, Perl: 0.1188 seconds, CL-PPCRE: 0.0400 seconds) + 109: 0.3018 (1000000 repetitions, Perl: 0.8945 seconds, CL-PPCRE: 0.2700 seconds) + 110: 0.2893 (1000000 repetitions, Perl: 0.8988 seconds, CL-PPCRE: 0.2600 seconds) + 111: 0.3013 (1000000 repetitions, Perl: 0.8963 seconds, CL-PPCRE: 0.2700 seconds) + 112: 0.2876 (1000000 repetitions, Perl: 0.9039 seconds, CL-PPCRE: 0.2600 seconds) + 113: 0.4585 (100000 repetitions, Perl: 0.1309 seconds, CL-PPCRE: 0.0600 seconds) + 114: 0.3816 (100000 repetitions, Perl: 0.1310 seconds, CL-PPCRE: 0.0500 seconds) + 115: 0.2148 (100000 repetitions, Perl: 0.1397 seconds, CL-PPCRE: 0.0300 seconds) + 116: 0.2182 (100000 repetitions, Perl: 0.1375 seconds, CL-PPCRE: 0.0300 seconds) + 117: 0.2147 (100000 repetitions, Perl: 0.1397 seconds, CL-PPCRE: 0.0300 seconds) + 118: 0.2154 (100000 repetitions, Perl: 0.1393 seconds, CL-PPCRE: 0.0300 seconds) + 119: 0.2180 (100000 repetitions, Perl: 0.1376 seconds, CL-PPCRE: 0.0300 seconds) + 120: 0.2171 (100000 repetitions, Perl: 0.1382 seconds, CL-PPCRE: 0.0300 seconds) + 121: 0.2145 (100000 repetitions, Perl: 0.1398 seconds, CL-PPCRE: 0.0300 seconds) + 122: 0.2184 (100000 repetitions, Perl: 0.1374 seconds, CL-PPCRE: 0.0300 seconds) + 123: 0.2172 (100000 repetitions, Perl: 0.1381 seconds, CL-PPCRE: 0.0300 seconds) + 124: 0.2124 (100000 repetitions, Perl: 0.1412 seconds, CL-PPCRE: 0.0300 seconds) + 125: 0.2146 (100000 repetitions, Perl: 0.1398 seconds, CL-PPCRE: 0.0300 seconds) + 126: 0.2834 (100000 repetitions, Perl: 0.1412 seconds, CL-PPCRE: 0.0400 seconds) + 127: 0.2649 (1000000 repetitions, Perl: 0.9439 seconds, CL-PPCRE: 0.2500 seconds) + 128: 0.3613 (100000 repetitions, Perl: 0.1384 seconds, CL-PPCRE: 0.0500 seconds) + 129: 0.2925 (100000 repetitions, Perl: 0.1367 seconds, CL-PPCRE: 0.0400 seconds) + 130: 0.2868 (100000 repetitions, Perl: 0.1394 seconds, CL-PPCRE: 0.0400 seconds) + 131: 0.3982 (100000 repetitions, Perl: 0.1758 seconds, CL-PPCRE: 0.0700 seconds) + 132: 0.3910 (100000 repetitions, Perl: 0.1790 seconds, CL-PPCRE: 0.0700 seconds) + 133: 0.4550 (1000000 repetitions, Perl: 0.6154 seconds, CL-PPCRE: 0.2800 seconds) + 134: 0.2943 (100000 repetitions, Perl: 0.1699 seconds, CL-PPCRE: 0.0500 seconds) + 135: 0.2965 (100000 repetitions, Perl: 0.1686 seconds, CL-PPCRE: 0.0500 seconds) + 136: 0.2959 (100000 repetitions, Perl: 0.1690 seconds, CL-PPCRE: 0.0500 seconds) + 137: 0.3398 (1000000 repetitions, Perl: 0.6180 seconds, CL-PPCRE: 0.2100 seconds) + 138: 0.2963 (100000 repetitions, Perl: 0.1687 seconds, CL-PPCRE: 0.0500 seconds) + 139: 0.3538 (100000 repetitions, Perl: 0.1413 seconds, CL-PPCRE: 0.0500 seconds) + 140: 0.3339 (100000 repetitions, Perl: 0.1498 seconds, CL-PPCRE: 0.0500 seconds) + 141: 0.3863 (100000 repetitions, Perl: 0.1812 seconds, CL-PPCRE: 0.0700 seconds) + 142: 0.3245 (1000000 repetitions, Perl: 0.6163 seconds, CL-PPCRE: 0.2000 seconds) + 143: 0.3688 (100000 repetitions, Perl: 0.1627 seconds, CL-PPCRE: 0.0600 seconds) + 144: 0.3063 (100000 repetitions, Perl: 0.4571 seconds, CL-PPCRE: 0.1400 seconds) + 145: 0.7234 (100000 repetitions, Perl: 0.1244 seconds, CL-PPCRE: 0.0900 seconds) + 146: 0.2700 (100000 repetitions, Perl: 0.4074 seconds, CL-PPCRE: 0.1100 seconds) + 147: 0.8323 (1000000 repetitions, Perl: 0.8771 seconds, CL-PPCRE: 0.7300 seconds) + 148: 0.6980 (1000000 repetitions, Perl: 0.7880 seconds, CL-PPCRE: 0.5500 seconds) + 149: 0.4197 (100000 repetitions, Perl: 0.1668 seconds, CL-PPCRE: 0.0700 seconds) + 150: 0.5716 (1000000 repetitions, Perl: 0.8223 seconds, CL-PPCRE: 0.4700 seconds) + 151: 0.5047 (100000 repetitions, Perl: 0.1585 seconds, CL-PPCRE: 0.0800 seconds) + 152: 0.5141 (100000 repetitions, Perl: 0.1556 seconds, CL-PPCRE: 0.0800 seconds) + 153: 0.5116 (100000 repetitions, Perl: 0.1564 seconds, CL-PPCRE: 0.0800 seconds) + 154: 0.4508 (100000 repetitions, Perl: 0.1553 seconds, CL-PPCRE: 0.0700 seconds) + 155: 0.5214 (100000 repetitions, Perl: 0.1534 seconds, CL-PPCRE: 0.0800 seconds) + 156: 0.6360 (100000 repetitions, Perl: 0.1730 seconds, CL-PPCRE: 0.1100 seconds) + 157: 0.9536 (100000 repetitions, Perl: 0.2202 seconds, CL-PPCRE: 0.2100 seconds) + 158: 1.0349 (100000 repetitions, Perl: 0.2416 seconds, CL-PPCRE: 0.2500 seconds) + 159: 1.0302 (100000 repetitions, Perl: 0.1262 seconds, CL-PPCRE: 0.1300 seconds) + 160: 1.1893 (1000000 repetitions, Perl: 0.8325 seconds, CL-PPCRE: 0.9900 seconds) + 161: 1.2895 (100000 repetitions, Perl: 0.1473 seconds, CL-PPCRE: 0.1900 seconds) + 162: 1.3938 (100000 repetitions, Perl: 0.2152 seconds, CL-PPCRE: 0.3000 seconds) + 163: 0.3708 (100000 repetitions, Perl: 0.3505 seconds, CL-PPCRE: 0.1300 seconds) + 164: 0.4182 (100000 repetitions, Perl: 0.3826 seconds, CL-PPCRE: 0.1600 seconds) + 165: 0.4926 (100000 repetitions, Perl: 0.4060 seconds, CL-PPCRE: 0.2000 seconds) + 166: 0.9852 (1000000 repetitions, Perl: 0.6192 seconds, CL-PPCRE: 0.6100 seconds) + 167: 0.9454 (1000000 repetitions, Perl: 0.8039 seconds, CL-PPCRE: 0.7600 seconds) + 168: 0.7178 (100000 repetitions, Perl: 0.3483 seconds, CL-PPCRE: 0.2500 seconds) + 169: 0.8758 (100000 repetitions, Perl: 0.3426 seconds, CL-PPCRE: 0.3000 seconds) + 170: 1.0131 (1000000 repetitions, Perl: 0.8292 seconds, CL-PPCRE: 0.8400 seconds) + 171: 0.3196 (100000 repetitions, Perl: 0.2503 seconds, CL-PPCRE: 0.0800 seconds) + 172: 0.3538 (100000 repetitions, Perl: 0.2544 seconds, CL-PPCRE: 0.0900 seconds) + 173: 0.3592 (100000 repetitions, Perl: 0.2506 seconds, CL-PPCRE: 0.0900 seconds) + 174: 0.6737 (100000 repetitions, Perl: 0.3117 seconds, CL-PPCRE: 0.2100 seconds) + 175: 0.5639 (100000 repetitions, Perl: 0.4078 seconds, CL-PPCRE: 0.2300 seconds) + 176: 0.5225 (100000 repetitions, Perl: 0.3062 seconds, CL-PPCRE: 0.1600 seconds) + 177: 0.4419 (100000 repetitions, Perl: 0.1131 seconds, CL-PPCRE: 0.0500 seconds) + 178: 0.4992 (100000 repetitions, Perl: 0.2604 seconds, CL-PPCRE: 0.1300 seconds) + 179: 0.4653 (100000 repetitions, Perl: 0.3009 seconds, CL-PPCRE: 0.1400 seconds) + 180: 0.4438 (100000 repetitions, Perl: 0.4056 seconds, CL-PPCRE: 0.1800 seconds) + 181: 0.4672 (100000 repetitions, Perl: 0.4281 seconds, CL-PPCRE: 0.2000 seconds) + 182: 0.7833 (100000 repetitions, Perl: 0.1149 seconds, CL-PPCRE: 0.0900 seconds) + 183: 0.5458 (100000 repetitions, Perl: 0.2382 seconds, CL-PPCRE: 0.1300 seconds) + 184: 0.4734 (100000 repetitions, Perl: 0.4436 seconds, CL-PPCRE: 0.2100 seconds) + 185: 0.5420 (100000 repetitions, Perl: 0.3137 seconds, CL-PPCRE: 0.1700 seconds) + 186: 0.7234 (100000 repetitions, Perl: 0.2074 seconds, CL-PPCRE: 0.1500 seconds) + 187: 0.7521 (100000 repetitions, Perl: 0.2393 seconds, CL-PPCRE: 0.1800 seconds) + 188: 0.6819 (100000 repetitions, Perl: 0.2053 seconds, CL-PPCRE: 0.1400 seconds) + 189: 0.4950 (100000 repetitions, Perl: 0.2020 seconds, CL-PPCRE: 0.1000 seconds) + 190: 0.4918 (100000 repetitions, Perl: 0.2033 seconds, CL-PPCRE: 0.1000 seconds) + 191: 0.5343 (100000 repetitions, Perl: 0.2433 seconds, CL-PPCRE: 0.1300 seconds) + 192: 0.4148 (100000 repetitions, Perl: 0.2411 seconds, CL-PPCRE: 0.1000 seconds) + 193: 0.4709 (100000 repetitions, Perl: 0.2761 seconds, CL-PPCRE: 0.1300 seconds) + 194: 0.5928 (100000 repetitions, Perl: 0.2868 seconds, CL-PPCRE: 0.1700 seconds) + 195: 0.5643 (100000 repetitions, Perl: 0.2835 seconds, CL-PPCRE: 0.1600 seconds) + 196: 0.2465 (100000 repetitions, Perl: 0.1217 seconds, CL-PPCRE: 0.0300 seconds) + 197: 0.4772 (100000 repetitions, Perl: 0.1467 seconds, CL-PPCRE: 0.0700 seconds) + 198: 0.4983 (1000000 repetitions, Perl: 0.6221 seconds, CL-PPCRE: 0.3100 seconds) + 199: 0.2375 (100000 repetitions, Perl: 0.1263 seconds, CL-PPCRE: 0.0300 seconds) + 200: 0.4759 (100000 repetitions, Perl: 0.1471 seconds, CL-PPCRE: 0.0700 seconds) + 201: 0.4963 (1000000 repetitions, Perl: 0.6247 seconds, CL-PPCRE: 0.3100 seconds) + 202: 0.2370 (100000 repetitions, Perl: 0.1266 seconds, CL-PPCRE: 0.0300 seconds) + 203: 0.5375 (100000 repetitions, Perl: 0.1488 seconds, CL-PPCRE: 0.0800 seconds) + 204: 0.4682 (100000 repetitions, Perl: 0.1495 seconds, CL-PPCRE: 0.0700 seconds) + 205: 0.4859 (1000000 repetitions, Perl: 0.6174 seconds, CL-PPCRE: 0.3000 seconds) + 206: 0.5685 (1000000 repetitions, Perl: 0.6156 seconds, CL-PPCRE: 0.3500 seconds) + 207: 1.1822 (100000 repetitions, Perl: 0.2622 seconds, CL-PPCRE: 0.3100 seconds) + 208: 0.8749 (100000 repetitions, Perl: 0.2400 seconds, CL-PPCRE: 0.2100 seconds) + 209: 0.8621 (100000 repetitions, Perl: 0.1392 seconds, CL-PPCRE: 0.1200 seconds) + 210: 2.0520 (100000 repetitions, Perl: 0.1511 seconds, CL-PPCRE: 0.3100 seconds) + 211: 0.2312 (100000 repetitions, Perl: 0.1297 seconds, CL-PPCRE: 0.0300 seconds) + 212: 0.3110 (100000 repetitions, Perl: 0.1286 seconds, CL-PPCRE: 0.0400 seconds) + 213: 0.3096 (100000 repetitions, Perl: 0.1292 seconds, CL-PPCRE: 0.0400 seconds) + 214: 0.2972 (100000 repetitions, Perl: 0.1346 seconds, CL-PPCRE: 0.0400 seconds) + 215: 0.2916 (100000 repetitions, Perl: 0.1372 seconds, CL-PPCRE: 0.0400 seconds) + 216: 0.2908 (100000 repetitions, Perl: 0.1376 seconds, CL-PPCRE: 0.0400 seconds) + 217: 0.3625 (100000 repetitions, Perl: 0.1379 seconds, CL-PPCRE: 0.0500 seconds) + 218: 0.2910 (100000 repetitions, Perl: 0.1374 seconds, CL-PPCRE: 0.0400 seconds) + 219: 0.2351 (100000 repetitions, Perl: 0.1276 seconds, CL-PPCRE: 0.0300 seconds) + 220: 0.3128 (100000 repetitions, Perl: 0.1279 seconds, CL-PPCRE: 0.0400 seconds) + 221: 0.3099 (100000 repetitions, Perl: 0.1291 seconds, CL-PPCRE: 0.0400 seconds) + 222: 0.3134 (100000 repetitions, Perl: 0.1277 seconds, CL-PPCRE: 0.0400 seconds) + 223: 0.3118 (100000 repetitions, Perl: 0.1283 seconds, CL-PPCRE: 0.0400 seconds) + 224: 0.3115 (100000 repetitions, Perl: 0.1284 seconds, CL-PPCRE: 0.0400 seconds) + 225: 0.3098 (100000 repetitions, Perl: 0.1291 seconds, CL-PPCRE: 0.0400 seconds) + 226: 0.3118 (100000 repetitions, Perl: 0.1283 seconds, CL-PPCRE: 0.0400 seconds) + 227: 0.2644 (100000 repetitions, Perl: 0.1513 seconds, CL-PPCRE: 0.0400 seconds) + 228: 0.2621 (100000 repetitions, Perl: 0.1526 seconds, CL-PPCRE: 0.0400 seconds) + 229: 0.1883 (100000 repetitions, Perl: 0.1593 seconds, CL-PPCRE: 0.0300 seconds) + 230: 0.2480 (100000 repetitions, Perl: 0.1613 seconds, CL-PPCRE: 0.0400 seconds) + 231: 0.2458 (100000 repetitions, Perl: 0.1627 seconds, CL-PPCRE: 0.0400 seconds) + 232: 0.1954 (100000 repetitions, Perl: 0.1535 seconds, CL-PPCRE: 0.0300 seconds) + 233: 0.1929 (100000 repetitions, Perl: 0.1555 seconds, CL-PPCRE: 0.0300 seconds) + 234: 0.1934 (100000 repetitions, Perl: 0.1551 seconds, CL-PPCRE: 0.0300 seconds) + 235: 0.2597 (100000 repetitions, Perl: 0.1540 seconds, CL-PPCRE: 0.0400 seconds) + 236: 0.2556 (100000 repetitions, Perl: 0.1565 seconds, CL-PPCRE: 0.0400 seconds) + 237: 0.3496 (100000 repetitions, Perl: 0.1430 seconds, CL-PPCRE: 0.0500 seconds) + 238: 0.3485 (100000 repetitions, Perl: 0.1435 seconds, CL-PPCRE: 0.0500 seconds) + 239: 0.3473 (100000 repetitions, Perl: 0.1440 seconds, CL-PPCRE: 0.0500 seconds) + 240: 0.3362 (1000000 repetitions, Perl: 0.6246 seconds, CL-PPCRE: 0.2100 seconds) + 241: 0.9108 (100000 repetitions, Perl: 0.1427 seconds, CL-PPCRE: 0.1300 seconds) + 242: 0.8320 (100000 repetitions, Perl: 0.1442 seconds, CL-PPCRE: 0.1200 seconds) + 243: 0.9578 (100000 repetitions, Perl: 0.1462 seconds, CL-PPCRE: 0.1400 seconds) + 244: 0.9571 (100000 repetitions, Perl: 0.1463 seconds, CL-PPCRE: 0.1400 seconds) + 245: 1.3241 (100000 repetitions, Perl: 0.1133 seconds, CL-PPCRE: 0.1500 seconds) + 246: 0.8377 (100000 repetitions, Perl: 0.1433 seconds, CL-PPCRE: 0.1200 seconds) + 247: 0.8486 (100000 repetitions, Perl: 0.1414 seconds, CL-PPCRE: 0.1200 seconds) + 248: 0.8450 (100000 repetitions, Perl: 0.1420 seconds, CL-PPCRE: 0.1200 seconds) + 249: 0.8369 (100000 repetitions, Perl: 0.1434 seconds, CL-PPCRE: 0.1200 seconds) + 250: 0.8463 (100000 repetitions, Perl: 0.1418 seconds, CL-PPCRE: 0.1200 seconds) + 251: 0.6517 (100000 repetitions, Perl: 0.2762 seconds, CL-PPCRE: 0.1800 seconds) + 252: 0.6811 (100000 repetitions, Perl: 0.2937 seconds, CL-PPCRE: 0.2000 seconds) + 253: 0.6578 (100000 repetitions, Perl: 0.1824 seconds, CL-PPCRE: 0.1200 seconds) + 254: 0.8682 (100000 repetitions, Perl: 0.3571 seconds, CL-PPCRE: 0.3100 seconds) + 255: 0.7904 (100000 repetitions, Perl: 0.4175 seconds, CL-PPCRE: 0.3300 seconds) + 256: 0.8379 (100000 repetitions, Perl: 0.2745 seconds, CL-PPCRE: 0.2300 seconds) + 257: 0.7974 (100000 repetitions, Perl: 0.3010 seconds, CL-PPCRE: 0.2400 seconds) + 258: 0.8064 (100000 repetitions, Perl: 0.2852 seconds, CL-PPCRE: 0.2300 seconds) + 259: 0.7055 (100000 repetitions, Perl: 0.2977 seconds, CL-PPCRE: 0.2100 seconds) + 260: 0.8818 (100000 repetitions, Perl: 0.3515 seconds, CL-PPCRE: 0.3100 seconds) + 261: 0.8762 (100000 repetitions, Perl: 0.3652 seconds, CL-PPCRE: 0.3200 seconds) + 262: 0.8611 (100000 repetitions, Perl: 0.3020 seconds, CL-PPCRE: 0.2600 seconds) + 263: 0.5267 (100000 repetitions, Perl: 0.1519 seconds, CL-PPCRE: 0.0800 seconds) + 264: 0.5322 (100000 repetitions, Perl: 0.1503 seconds, CL-PPCRE: 0.0800 seconds) + 265: 0.9607 (100000 repetitions, Perl: 0.3123 seconds, CL-PPCRE: 0.3000 seconds) + 266: 0.4526 (100000 repetitions, Perl: 0.2872 seconds, CL-PPCRE: 0.1300 seconds) + 267: 0.6699 (100000 repetitions, Perl: 0.5673 seconds, CL-PPCRE: 0.3800 seconds) + 268: 0.5854 (100000 repetitions, Perl: 0.2221 seconds, CL-PPCRE: 0.1300 seconds) + 269: 0.5397 (100000 repetitions, Perl: 0.2223 seconds, CL-PPCRE: 0.1200 seconds) + 270: 0.5484 (100000 repetitions, Perl: 0.2188 seconds, CL-PPCRE: 0.1200 seconds) + 271: 0.4907 (100000 repetitions, Perl: 0.1834 seconds, CL-PPCRE: 0.0900 seconds) + 272: 0.5724 (100000 repetitions, Perl: 0.1922 seconds, CL-PPCRE: 0.1100 seconds) + 273: 0.4339 (100000 repetitions, Perl: 0.1383 seconds, CL-PPCRE: 0.0600 seconds) + 274: 0.4306 (100000 repetitions, Perl: 0.1394 seconds, CL-PPCRE: 0.0600 seconds) + 275: 0.2869 (100000 repetitions, Perl: 0.1743 seconds, CL-PPCRE: 0.0500 seconds) + 276: 0.4362 (100000 repetitions, Perl: 0.1376 seconds, CL-PPCRE: 0.0600 seconds) + 277: 0.7754 (100000 repetitions, Perl: 0.2321 seconds, CL-PPCRE: 0.1800 seconds) + 278: 0.7791 (100000 repetitions, Perl: 0.2310 seconds, CL-PPCRE: 0.1800 seconds) + 279: 0.7789 (100000 repetitions, Perl: 0.2311 seconds, CL-PPCRE: 0.1800 seconds) + 280: 0.7811 (100000 repetitions, Perl: 0.2305 seconds, CL-PPCRE: 0.1800 seconds) + 281: 0.2450 (100000 repetitions, Perl: 0.2040 seconds, CL-PPCRE: 0.0500 seconds) + 282: 0.2661 (100000 repetitions, Perl: 0.1503 seconds, CL-PPCRE: 0.0400 seconds) + 283: 0.2589 (100000 repetitions, Perl: 0.1931 seconds, CL-PPCRE: 0.0500 seconds) + 284: 0.3521 (100000 repetitions, Perl: 0.1420 seconds, CL-PPCRE: 0.0500 seconds) + 285: 0.3907 (100000 repetitions, Perl: 0.1791 seconds, CL-PPCRE: 0.0700 seconds) + 286: 0.4476 (100000 repetitions, Perl: 0.1787 seconds, CL-PPCRE: 0.0800 seconds) + 287: 0.4616 (100000 repetitions, Perl: 0.1733 seconds, CL-PPCRE: 0.0800 seconds) + 288: 0.4378 (100000 repetitions, Perl: 0.1827 seconds, CL-PPCRE: 0.0800 seconds) + 289: 0.6693 (10000 repetitions, Perl: 0.1643 seconds, CL-PPCRE: 0.1100 seconds) + 290: 0.6433 (100000 repetitions, Perl: 0.9328 seconds, CL-PPCRE: 0.6000 seconds) + 291: 0.5793 (100000 repetitions, Perl: 0.7940 seconds, CL-PPCRE: 0.4600 seconds) + 292: 0.6398 (10000 repetitions, Perl: 0.2657 seconds, CL-PPCRE: 0.1700 seconds) + 293: 0.7511 (10000 repetitions, Perl: 0.3062 seconds, CL-PPCRE: 0.2300 seconds) + 294: 0.7114 (10000 repetitions, Perl: 0.2249 seconds, CL-PPCRE: 0.1600 seconds) + 295: 0.8033 (1000 repetitions, Perl: 0.2739 seconds, CL-PPCRE: 0.2200 seconds) + 296: 0.6041 (1000 repetitions, Perl: 0.1655 seconds, CL-PPCRE: 0.1000 seconds) + 297: 0.8512 (10000 repetitions, Perl: 0.1175 seconds, CL-PPCRE: 0.1000 seconds) + 298: 0.6747 (100000 repetitions, Perl: 0.7707 seconds, CL-PPCRE: 0.5200 seconds) + 299: 0.6291 (100000 repetitions, Perl: 0.6359 seconds, CL-PPCRE: 0.4000 seconds) + 300: 0.7881 (10000 repetitions, Perl: 0.1650 seconds, CL-PPCRE: 0.1300 seconds) + 301: 0.8624 (10000 repetitions, Perl: 0.2087 seconds, CL-PPCRE: 0.1800 seconds) + 302: 1.6513 (100000 repetitions, Perl: 0.7509 seconds, CL-PPCRE: 1.2400 seconds) + 303: 0.8539 (1000 repetitions, Perl: 0.2342 seconds, CL-PPCRE: 0.2000 seconds) + 304: 0.5071 (1000 repetitions, Perl: 0.1578 seconds, CL-PPCRE: 0.0800 seconds) + 305: 0.2994 (100000 repetitions, Perl: 0.2004 seconds, CL-PPCRE: 0.0600 seconds) + 306: 0.3442 (100000 repetitions, Perl: 0.2034 seconds, CL-PPCRE: 0.0700 seconds) + 307: 0.3386 (100000 repetitions, Perl: 0.2067 seconds, CL-PPCRE: 0.0700 seconds) + 308: 0.4439 (100000 repetitions, Perl: 0.2027 seconds, CL-PPCRE: 0.0900 seconds) + 309: 0.2541 (100000 repetitions, Perl: 0.1181 seconds, CL-PPCRE: 0.0300 seconds) + 310: 0.2507 (100000 repetitions, Perl: 0.1197 seconds, CL-PPCRE: 0.0300 seconds) + 311: 0.2546 (100000 repetitions, Perl: 0.1178 seconds, CL-PPCRE: 0.0300 seconds) + 312: 0.3225 (100000 repetitions, Perl: 0.1240 seconds, CL-PPCRE: 0.0400 seconds) + 313: 0.2763 (100000 repetitions, Perl: 0.2171 seconds, CL-PPCRE: 0.0600 seconds) + 314: 0.3364 (100000 repetitions, Perl: 0.2081 seconds, CL-PPCRE: 0.0700 seconds) + 315: 0.5995 (1000000 repetitions, Perl: 0.6171 seconds, CL-PPCRE: 0.3700 seconds) + 316: 0.6933 (100000 repetitions, Perl: 0.1010 seconds, CL-PPCRE: 0.0700 seconds) + 317: 0.7320 (100000 repetitions, Perl: 0.1639 seconds, CL-PPCRE: 0.1200 seconds) + 318: 0.6441 (100000 repetitions, Perl: 0.1708 seconds, CL-PPCRE: 0.1100 seconds) + 319: 0.7726 (100000 repetitions, Perl: 0.1553 seconds, CL-PPCRE: 0.1200 seconds) + 320: 0.2550 (100000 repetitions, Perl: 0.1176 seconds, CL-PPCRE: 0.0300 seconds) + 321: 0.2523 (100000 repetitions, Perl: 0.1189 seconds, CL-PPCRE: 0.0300 seconds) + 322: 0.3355 (100000 repetitions, Perl: 0.1192 seconds, CL-PPCRE: 0.0400 seconds) + 323: 0.2535 (100000 repetitions, Perl: 0.1184 seconds, CL-PPCRE: 0.0300 seconds) + 324: 0.2537 (100000 repetitions, Perl: 0.1182 seconds, CL-PPCRE: 0.0300 seconds) + 325: 0.3130 (1000000 repetitions, Perl: 0.8945 seconds, CL-PPCRE: 0.2800 seconds) + 326: 0.4343 (100000 repetitions, Perl: 0.1381 seconds, CL-PPCRE: 0.0600 seconds) + 327: 0.4595 (100000 repetitions, Perl: 0.1959 seconds, CL-PPCRE: 0.0900 seconds) + 328: 0.5075 (100000 repetitions, Perl: 0.2562 seconds, CL-PPCRE: 0.1300 seconds) + 329: 0.4848 (100000 repetitions, Perl: 0.2063 seconds, CL-PPCRE: 0.1000 seconds) + 330: 0.5754 (100000 repetitions, Perl: 0.2259 seconds, CL-PPCRE: 0.1300 seconds) + 331: 0.4784 (100000 repetitions, Perl: 0.2090 seconds, CL-PPCRE: 0.1000 seconds) + 332: 0.4854 (100000 repetitions, Perl: 0.2472 seconds, CL-PPCRE: 0.1200 seconds) + 333: 0.5108 (100000 repetitions, Perl: 0.1958 seconds, CL-PPCRE: 0.1000 seconds) + 334: 0.5869 (100000 repetitions, Perl: 0.1874 seconds, CL-PPCRE: 0.1100 seconds) + 335: 0.4115 (100000 repetitions, Perl: 0.1944 seconds, CL-PPCRE: 0.0800 seconds) + 336: 0.4591 (100000 repetitions, Perl: 0.1960 seconds, CL-PPCRE: 0.0900 seconds) + 337: 0.4391 (100000 repetitions, Perl: 0.2050 seconds, CL-PPCRE: 0.0900 seconds) + 338: 0.4906 (100000 repetitions, Perl: 0.2242 seconds, CL-PPCRE: 0.1100 seconds) + 339: 0.6043 (100000 repetitions, Perl: 0.1986 seconds, CL-PPCRE: 0.1200 seconds) + 340: 0.6038 (100000 repetitions, Perl: 0.1988 seconds, CL-PPCRE: 0.1200 seconds) + 341: 0.6465 (100000 repetitions, Perl: 0.2011 seconds, CL-PPCRE: 0.1300 seconds) + 342: 0.7695 (100000 repetitions, Perl: 0.2079 seconds, CL-PPCRE: 0.1600 seconds) + 343: 0.7205 (100000 repetitions, Perl: 0.2221 seconds, CL-PPCRE: 0.1600 seconds) + 344: 0.6924 (100000 repetitions, Perl: 0.2166 seconds, CL-PPCRE: 0.1500 seconds) + 345: 0.6438 (100000 repetitions, Perl: 0.2174 seconds, CL-PPCRE: 0.1400 seconds) + 346: 0.7015 (100000 repetitions, Perl: 0.1996 seconds, CL-PPCRE: 0.1400 seconds) + 347: 0.7526 (100000 repetitions, Perl: 0.1993 seconds, CL-PPCRE: 0.1500 seconds) + 348: 0.8079 (100000 repetitions, Perl: 0.2104 seconds, CL-PPCRE: 0.1700 seconds) + 349: 0.7955 (100000 repetitions, Perl: 0.2514 seconds, CL-PPCRE: 0.2000 seconds) + 350: 0.4692 (100000 repetitions, Perl: 0.1492 seconds, CL-PPCRE: 0.0700 seconds) + 351: 0.4673 (100000 repetitions, Perl: 0.1498 seconds, CL-PPCRE: 0.0700 seconds) + 352: 0.4633 (100000 repetitions, Perl: 0.1511 seconds, CL-PPCRE: 0.0700 seconds) + 353: 0.6346 (1000000 repetitions, Perl: 0.6145 seconds, CL-PPCRE: 0.3900 seconds) + 354: 1.1542 (1000000 repetitions, Perl: 0.9097 seconds, CL-PPCRE: 1.0500 seconds) + 355: 0.4759 (100000 repetitions, Perl: 0.2732 seconds, CL-PPCRE: 0.1300 seconds) + 356: 0.6078 (100000 repetitions, Perl: 0.2303 seconds, CL-PPCRE: 0.1400 seconds) + 357: 0.6025 (100000 repetitions, Perl: 0.2324 seconds, CL-PPCRE: 0.1400 seconds) + 358: 0.3389 (100000 repetitions, Perl: 0.1475 seconds, CL-PPCRE: 0.0500 seconds) + 359: 0.2653 (1000000 repetitions, Perl: 0.9424 seconds, CL-PPCRE: 0.2500 seconds) + 360: 0.3383 (100000 repetitions, Perl: 0.1478 seconds, CL-PPCRE: 0.0500 seconds) + 361: 0.4024 (100000 repetitions, Perl: 0.1491 seconds, CL-PPCRE: 0.0600 seconds) + 362: 0.3396 (100000 repetitions, Perl: 0.1472 seconds, CL-PPCRE: 0.0500 seconds) + 363: 0.4028 (100000 repetitions, Perl: 0.1489 seconds, CL-PPCRE: 0.0600 seconds) + 364: 0.2647 (100000 repetitions, Perl: 0.1511 seconds, CL-PPCRE: 0.0400 seconds) + 365: 0.3107 (100000 repetitions, Perl: 0.1609 seconds, CL-PPCRE: 0.0500 seconds) + 366: 0.3260 (100000 repetitions, Perl: 0.1534 seconds, CL-PPCRE: 0.0500 seconds) + 367: 0.3047 (100000 repetitions, Perl: 0.1641 seconds, CL-PPCRE: 0.0500 seconds) + 368: 0.4269 (100000 repetitions, Perl: 0.1405 seconds, CL-PPCRE: 0.0600 seconds) + 369: 0.6208 (1000000 repetitions, Perl: 0.7249 seconds, CL-PPCRE: 0.4500 seconds) + 370: 0.7444 (1000000 repetitions, Perl: 0.7254 seconds, CL-PPCRE: 0.5400 seconds) + 371: 0.6080 (1000000 repetitions, Perl: 0.7237 seconds, CL-PPCRE: 0.4400 seconds) + 372: 0.4148 (100000 repetitions, Perl: 0.1446 seconds, CL-PPCRE: 0.0600 seconds) + 373: 0.3998 (100000 repetitions, Perl: 0.1501 seconds, CL-PPCRE: 0.0600 seconds) + 374: 0.5947 (1000000 repetitions, Perl: 0.7903 seconds, CL-PPCRE: 0.4700 seconds) + 375: 0.6556 (1000000 repetitions, Perl: 0.7932 seconds, CL-PPCRE: 0.5200 seconds) + 376: 0.5811 (1000000 repetitions, Perl: 0.7916 seconds, CL-PPCRE: 0.4600 seconds) + 377: 0.5095 (100000 repetitions, Perl: 0.1374 seconds, CL-PPCRE: 0.0700 seconds) + 378: 0.7533 (100000 repetitions, Perl: 0.1327 seconds, CL-PPCRE: 0.1000 seconds) + 379: 0.2212 (100000 repetitions, Perl: 0.1356 seconds, CL-PPCRE: 0.0300 seconds) + 380: 0.2732 (100000 repetitions, Perl: 0.1830 seconds, CL-PPCRE: 0.0500 seconds) + 381: 0.3535 (100000 repetitions, Perl: 0.1414 seconds, CL-PPCRE: 0.0500 seconds) + 382: 0.3386 (1000000 repetitions, Perl: 0.7974 seconds, CL-PPCRE: 0.2700 seconds) + 383: 0.3481 (100000 repetitions, Perl: 0.1436 seconds, CL-PPCRE: 0.0500 seconds) + 384: 0.3376 (1000000 repetitions, Perl: 0.7998 seconds, CL-PPCRE: 0.2700 seconds) + 385: 0.2810 (100000 repetitions, Perl: 0.1424 seconds, CL-PPCRE: 0.0400 seconds) + 386: 0.3465 (1000000 repetitions, Perl: 0.8081 seconds, CL-PPCRE: 0.2800 seconds) + 387: 0.2732 (100000 repetitions, Perl: 0.1464 seconds, CL-PPCRE: 0.0400 seconds) + 388: 0.2781 (100000 repetitions, Perl: 0.1438 seconds, CL-PPCRE: 0.0400 seconds) + 389: 0.4344 (1000000 repetitions, Perl: 0.8288 seconds, CL-PPCRE: 0.3600 seconds) + 390: 0.3457 (100000 repetitions, Perl: 0.1446 seconds, CL-PPCRE: 0.0500 seconds) + 391: 0.5038 (1000000 repetitions, Perl: 0.8337 seconds, CL-PPCRE: 0.4200 seconds) + 392: 0.2577 (100000 repetitions, Perl: 0.1552 seconds, CL-PPCRE: 0.0400 seconds) + 393: 0.2542 (100000 repetitions, Perl: 0.1573 seconds, CL-PPCRE: 0.0400 seconds) + 394: 0.4403 (1000000 repetitions, Perl: 0.7722 seconds, CL-PPCRE: 0.3400 seconds) + 395: 0.5672 (100000 repetitions, Perl: 0.1587 seconds, CL-PPCRE: 0.0900 seconds) + 396: 0.6214 (100000 repetitions, Perl: 0.1609 seconds, CL-PPCRE: 0.1000 seconds) + 397: 0.5460 (100000 repetitions, Perl: 0.1648 seconds, CL-PPCRE: 0.0900 seconds) + 398: 0.2812 (100000 repetitions, Perl: 0.1778 seconds, CL-PPCRE: 0.0500 seconds) + 399: 0.2775 (100000 repetitions, Perl: 0.1802 seconds, CL-PPCRE: 0.0500 seconds) + 400: 0.3287 (100000 repetitions, Perl: 0.1825 seconds, CL-PPCRE: 0.0600 seconds) + 401: 0.2684 (100000 repetitions, Perl: 0.1863 seconds, CL-PPCRE: 0.0500 seconds) + 402: 0.4942 (100000 repetitions, Perl: 0.1416 seconds, CL-PPCRE: 0.0700 seconds) + 403: 0.5378 (100000 repetitions, Perl: 0.1116 seconds, CL-PPCRE: 0.0600 seconds) + 404: 0.2952 (100000 repetitions, Perl: 0.1694 seconds, CL-PPCRE: 0.0500 seconds) + 405: 0.2887 (100000 repetitions, Perl: 0.1732 seconds, CL-PPCRE: 0.0500 seconds) + 406: 0.6374 (1000000 repetitions, Perl: 0.7844 seconds, CL-PPCRE: 0.5000 seconds) + 407: 0.4260 (100000 repetitions, Perl: 0.1878 seconds, CL-PPCRE: 0.0800 seconds) + 408: 0.4368 (100000 repetitions, Perl: 0.1832 seconds, CL-PPCRE: 0.0800 seconds) + 409: 0.4269 (100000 repetitions, Perl: 0.1874 seconds, CL-PPCRE: 0.0800 seconds) + 410: 0.3848 (100000 repetitions, Perl: 0.1819 seconds, CL-PPCRE: 0.0700 seconds) + 411: 0.4387 (100000 repetitions, Perl: 0.1824 seconds, CL-PPCRE: 0.0800 seconds) + 412: 0.4306 (100000 repetitions, Perl: 0.1858 seconds, CL-PPCRE: 0.0800 seconds) + 413: 0.4817 (100000 repetitions, Perl: 0.1868 seconds, CL-PPCRE: 0.0900 seconds) + 414: 0.4738 (100000 repetitions, Perl: 0.1900 seconds, CL-PPCRE: 0.0900 seconds) + 415: 0.4302 (100000 repetitions, Perl: 0.1860 seconds, CL-PPCRE: 0.0800 seconds) + 416: 0.4258 (100000 repetitions, Perl: 0.1879 seconds, CL-PPCRE: 0.0800 seconds) + 417: 0.4302 (100000 repetitions, Perl: 0.1860 seconds, CL-PPCRE: 0.0800 seconds) + 418: 0.2241 (100000 repetitions, Perl: 0.1785 seconds, CL-PPCRE: 0.0400 seconds) + 419: 0.2783 (100000 repetitions, Perl: 0.1796 seconds, CL-PPCRE: 0.0500 seconds) + 420: 0.2807 (100000 repetitions, Perl: 0.1781 seconds, CL-PPCRE: 0.0500 seconds) + 421: 0.2787 (100000 repetitions, Perl: 0.1794 seconds, CL-PPCRE: 0.0500 seconds) + 422: 0.7300 (100000 repetitions, Perl: 0.3425 seconds, CL-PPCRE: 0.2500 seconds) + 423: 0.8544 (100000 repetitions, Perl: 0.3160 seconds, CL-PPCRE: 0.2700 seconds) + 424: 0.2787 (100000 repetitions, Perl: 0.1794 seconds, CL-PPCRE: 0.0500 seconds) + 425: 0.2306 (100000 repetitions, Perl: 0.1734 seconds, CL-PPCRE: 0.0400 seconds) + 426: 0.3410 (100000 repetitions, Perl: 0.2053 seconds, CL-PPCRE: 0.0700 seconds) + 427: 0.2799 (100000 repetitions, Perl: 0.1786 seconds, CL-PPCRE: 0.0500 seconds) + 428: 0.2829 (100000 repetitions, Perl: 0.1767 seconds, CL-PPCRE: 0.0500 seconds) + 429: 0.4273 (100000 repetitions, Perl: 0.1872 seconds, CL-PPCRE: 0.0800 seconds) + 431: 0.6052 (100000 repetitions, Perl: 0.1983 seconds, CL-PPCRE: 0.1200 seconds) + 432: 0.6033 (100000 repetitions, Perl: 0.1989 seconds, CL-PPCRE: 0.1200 seconds) + 433: 0.6306 (100000 repetitions, Perl: 0.2220 seconds, CL-PPCRE: 0.1400 seconds) + 434: 0.6084 (100000 repetitions, Perl: 0.1972 seconds, CL-PPCRE: 0.1200 seconds) + 435: 0.7267 (1000000 repetitions, Perl: 0.9632 seconds, CL-PPCRE: 0.7000 seconds) + 436: 0.9658 (1000000 repetitions, Perl: 0.6316 seconds, CL-PPCRE: 0.6100 seconds) + 437: 0.7902 (100000 repetitions, Perl: 0.1519 seconds, CL-PPCRE: 0.1200 seconds) + 438: 0.2423 (100000 repetitions, Perl: 0.1238 seconds, CL-PPCRE: 0.0300 seconds) + 439: 0.3170 (100000 repetitions, Perl: 0.1262 seconds, CL-PPCRE: 0.0400 seconds) + 440: 0.2741 (100000 repetitions, Perl: 0.1459 seconds, CL-PPCRE: 0.0400 seconds) + 441: 0.4055 (100000 repetitions, Perl: 0.1480 seconds, CL-PPCRE: 0.0600 seconds) + 442: 0.2719 (100000 repetitions, Perl: 0.1471 seconds, CL-PPCRE: 0.0400 seconds) + 443: 0.2952 (100000 repetitions, Perl: 0.1355 seconds, CL-PPCRE: 0.0400 seconds) + 444: 0.3922 (1000000 repetitions, Perl: 0.8924 seconds, CL-PPCRE: 0.3500 seconds) + 445: 0.2694 (100000 repetitions, Perl: 0.1485 seconds, CL-PPCRE: 0.0400 seconds) + 446: 0.2717 (100000 repetitions, Perl: 0.1472 seconds, CL-PPCRE: 0.0400 seconds) + 447: 0.2136 (100000 repetitions, Perl: 0.1872 seconds, CL-PPCRE: 0.0400 seconds) + 448: 0.2401 (100000 repetitions, Perl: 0.1249 seconds, CL-PPCRE: 0.0300 seconds) + 449: 0.2930 (100000 repetitions, Perl: 0.1024 seconds, CL-PPCRE: 0.0300 seconds) + 450: 0.2929 (100000 repetitions, Perl: 0.1024 seconds, CL-PPCRE: 0.0300 seconds) + 451: 0.2989 (100000 repetitions, Perl: 0.2007 seconds, CL-PPCRE: 0.0600 seconds) + 452: 0.3008 (100000 repetitions, Perl: 0.1995 seconds, CL-PPCRE: 0.0600 seconds) + 453: 0.3715 (100000 repetitions, Perl: 0.2153 seconds, CL-PPCRE: 0.0800 seconds) + 454: 0.4187 (1000000 repetitions, Perl: 0.8120 seconds, CL-PPCRE: 0.3400 seconds) + 455: 0.7238 (100000 repetitions, Perl: 0.3039 seconds, CL-PPCRE: 0.2200 seconds) + 456: 0.7574 (100000 repetitions, Perl: 0.3301 seconds, CL-PPCRE: 0.2500 seconds) + 457: 0.9668 (100000 repetitions, Perl: 0.6309 seconds, CL-PPCRE: 0.6100 seconds) + 458: 0.3100 (100000 repetitions, Perl: 0.1290 seconds, CL-PPCRE: 0.0400 seconds) + 459: 0.3207 (100000 repetitions, Perl: 0.1247 seconds, CL-PPCRE: 0.0400 seconds) + 460: 0.3861 (100000 repetitions, Perl: 0.1295 seconds, CL-PPCRE: 0.0500 seconds) + 461: 0.3780 (100000 repetitions, Perl: 0.1323 seconds, CL-PPCRE: 0.0500 seconds) + 462: 0.3066 (100000 repetitions, Perl: 0.1305 seconds, CL-PPCRE: 0.0400 seconds) + 463: 0.3195 (100000 repetitions, Perl: 0.1252 seconds, CL-PPCRE: 0.0400 seconds) + 464: 0.4669 (100000 repetitions, Perl: 0.1285 seconds, CL-PPCRE: 0.0600 seconds) + 465: 0.4623 (100000 repetitions, Perl: 0.1298 seconds, CL-PPCRE: 0.0600 seconds) + 466: 0.4711 (100000 repetitions, Perl: 0.6580 seconds, CL-PPCRE: 0.3100 seconds) + 467: 0.3991 (100000 repetitions, Perl: 0.2756 seconds, CL-PPCRE: 0.1100 seconds) + 468: 0.4139 (100000 repetitions, Perl: 0.2657 seconds, CL-PPCRE: 0.1100 seconds) + 469: 0.5015 (100000 repetitions, Perl: 0.2193 seconds, CL-PPCRE: 0.1100 seconds) + 470: 0.4581 (100000 repetitions, Perl: 0.2183 seconds, CL-PPCRE: 0.1000 seconds) + 471: 0.3853 (100000 repetitions, Perl: 0.2336 seconds, CL-PPCRE: 0.0900 seconds) + 472: 0.5455 (100000 repetitions, Perl: 0.2200 seconds, CL-PPCRE: 0.1200 seconds) + 473: 0.5154 (100000 repetitions, Perl: 0.2522 seconds, CL-PPCRE: 0.1300 seconds) + 474: 0.6171 (100000 repetitions, Perl: 0.1945 seconds, CL-PPCRE: 0.1200 seconds) + 475: 0.3168 (100000 repetitions, Perl: 0.1578 seconds, CL-PPCRE: 0.0500 seconds) + 476: 0.5424 (100000 repetitions, Perl: 0.4241 seconds, CL-PPCRE: 0.2300 seconds) + 477: 0.4988 (100000 repetitions, Perl: 0.3007 seconds, CL-PPCRE: 0.1500 seconds) + 478: 0.6218 (100000 repetitions, Perl: 0.4342 seconds, CL-PPCRE: 0.2700 seconds) + 479: 0.5608 (100000 repetitions, Perl: 0.1605 seconds, CL-PPCRE: 0.0900 seconds) + 480: 0.5581 (100000 repetitions, Perl: 0.1792 seconds, CL-PPCRE: 0.1000 seconds) + 481: 0.5284 (100000 repetitions, Perl: 0.1514 seconds, CL-PPCRE: 0.0800 seconds) + 482: 0.5586 (100000 repetitions, Perl: 0.3222 seconds, CL-PPCRE: 0.1800 seconds) + 483: 0.4873 (100000 repetitions, Perl: 0.2052 seconds, CL-PPCRE: 0.1000 seconds) + 484: 0.5479 (100000 repetitions, Perl: 0.6388 seconds, CL-PPCRE: 0.3500 seconds) + 485: 0.5229 (100000 repetitions, Perl: 0.2869 seconds, CL-PPCRE: 0.1500 seconds) + 486: 0.5340 (100000 repetitions, Perl: 0.2247 seconds, CL-PPCRE: 0.1200 seconds) + 487: 0.3397 (100000 repetitions, Perl: 0.1766 seconds, CL-PPCRE: 0.0600 seconds) + 488: 0.4438 (100000 repetitions, Perl: 0.1803 seconds, CL-PPCRE: 0.0800 seconds) + 489: 0.5042 (100000 repetitions, Perl: 0.1983 seconds, CL-PPCRE: 0.1000 seconds) + 490: 0.2714 (100000 repetitions, Perl: 0.1474 seconds, CL-PPCRE: 0.0400 seconds) + 491: 0.2673 (100000 repetitions, Perl: 0.1497 seconds, CL-PPCRE: 0.0400 seconds) + 492: 0.3556 (1000000 repetitions, Perl: 0.7312 seconds, CL-PPCRE: 0.2600 seconds) + 493: 0.3586 (1000000 repetitions, Perl: 0.7250 seconds, CL-PPCRE: 0.2600 seconds) + 494: 0.3417 (1000000 repetitions, Perl: 0.6145 seconds, CL-PPCRE: 0.2100 seconds) + 495: 0.4060 (1000000 repetitions, Perl: 0.7390 seconds, CL-PPCRE: 0.3000 seconds) + 496: 0.3838 (1000000 repetitions, Perl: 0.7296 seconds, CL-PPCRE: 0.2800 seconds) + 497: 0.3394 (100000 repetitions, Perl: 0.1179 seconds, CL-PPCRE: 0.0400 seconds) + 498: 0.2507 (100000 repetitions, Perl: 0.1196 seconds, CL-PPCRE: 0.0300 seconds) + 499: 0.2521 (100000 repetitions, Perl: 0.1190 seconds, CL-PPCRE: 0.0300 seconds) + 500: 0.2512 (100000 repetitions, Perl: 0.1194 seconds, CL-PPCRE: 0.0300 seconds) + 501: 0.3337 (100000 repetitions, Perl: 0.1199 seconds, CL-PPCRE: 0.0400 seconds) + 502: 0.3380 (100000 repetitions, Perl: 0.1183 seconds, CL-PPCRE: 0.0400 seconds) + 503: 0.3385 (100000 repetitions, Perl: 0.1182 seconds, CL-PPCRE: 0.0400 seconds) + 504: 0.3383 (100000 repetitions, Perl: 0.1182 seconds, CL-PPCRE: 0.0400 seconds) + 505: 0.2934 (1000000 repetitions, Perl: 0.9203 seconds, CL-PPCRE: 0.2700 seconds) + 506: 0.3109 (1000000 repetitions, Perl: 0.9005 seconds, CL-PPCRE: 0.2800 seconds) + 507: 0.3253 (100000 repetitions, Perl: 0.1845 seconds, CL-PPCRE: 0.0600 seconds) + 508: 0.6707 (100000 repetitions, Perl: 0.6709 seconds, CL-PPCRE: 0.4500 seconds) + 509: 0.8568 (1000000 repetitions, Perl: 0.8753 seconds, CL-PPCRE: 0.7500 seconds) + 510: 1.0720 (100000 repetitions, Perl: 0.1119 seconds, CL-PPCRE: 0.1200 seconds) + 511: 0.3961 (100000 repetitions, Perl: 0.1262 seconds, CL-PPCRE: 0.0500 seconds) + 512: 0.3948 (100000 repetitions, Perl: 0.1266 seconds, CL-PPCRE: 0.0500 seconds) + 513: 0.3915 (100000 repetitions, Perl: 0.1277 seconds, CL-PPCRE: 0.0500 seconds) + 514: 0.5436 (100000 repetitions, Perl: 0.1288 seconds, CL-PPCRE: 0.0700 seconds) + 515: 0.5481 (100000 repetitions, Perl: 0.1277 seconds, CL-PPCRE: 0.0700 seconds) + 516: 0.4678 (100000 repetitions, Perl: 0.1283 seconds, CL-PPCRE: 0.0600 seconds) + 517: 0.5499 (100000 repetitions, Perl: 0.1273 seconds, CL-PPCRE: 0.0700 seconds) + 518: 0.6267 (100000 repetitions, Perl: 0.1277 seconds, CL-PPCRE: 0.0800 seconds) + 519: 0.5435 (100000 repetitions, Perl: 0.1288 seconds, CL-PPCRE: 0.0700 seconds) + 520: 0.5474 (100000 repetitions, Perl: 0.1279 seconds, CL-PPCRE: 0.0700 seconds) + 521: 0.6194 (100000 repetitions, Perl: 0.1292 seconds, CL-PPCRE: 0.0800 seconds) + 522: 0.6198 (100000 repetitions, Perl: 0.1291 seconds, CL-PPCRE: 0.0800 seconds) + 523: 0.5402 (100000 repetitions, Perl: 0.1296 seconds, CL-PPCRE: 0.0700 seconds) + 524: 0.5440 (100000 repetitions, Perl: 0.1287 seconds, CL-PPCRE: 0.0700 seconds) + 525: 0.6254 (100000 repetitions, Perl: 0.1279 seconds, CL-PPCRE: 0.0800 seconds) + 526: 0.6277 (100000 repetitions, Perl: 0.1274 seconds, CL-PPCRE: 0.0800 seconds) + 527: 0.5386 (100000 repetitions, Perl: 0.1300 seconds, CL-PPCRE: 0.0700 seconds) + 528: 0.5282 (100000 repetitions, Perl: 0.1325 seconds, CL-PPCRE: 0.0700 seconds) + 529: 1.0026 (1000000 repetitions, Perl: 0.7181 seconds, CL-PPCRE: 0.7200 seconds) + 530: 0.5673 (100000 repetitions, Perl: 0.1587 seconds, CL-PPCRE: 0.0900 seconds) + 531: 0.5812 (100000 repetitions, Perl: 0.1549 seconds, CL-PPCRE: 0.0900 seconds) + 532: 0.6859 (1000000 repetitions, Perl: 0.7436 seconds, CL-PPCRE: 0.5100 seconds) + 533: 0.5101 (100000 repetitions, Perl: 0.1568 seconds, CL-PPCRE: 0.0800 seconds) + 534: 0.4462 (100000 repetitions, Perl: 0.1569 seconds, CL-PPCRE: 0.0700 seconds) + 535: 0.7151 (1000000 repetitions, Perl: 0.7132 seconds, CL-PPCRE: 0.5100 seconds) + 536: 0.5707 (100000 repetitions, Perl: 0.1577 seconds, CL-PPCRE: 0.0900 seconds) + 537: 0.5677 (100000 repetitions, Perl: 0.1585 seconds, CL-PPCRE: 0.0900 seconds) + 538: 0.5097 (100000 repetitions, Perl: 0.1570 seconds, CL-PPCRE: 0.0800 seconds) + 539: 0.6915 (1000000 repetitions, Perl: 0.7375 seconds, CL-PPCRE: 0.5100 seconds) + 540: 0.5089 (100000 repetitions, Perl: 0.1572 seconds, CL-PPCRE: 0.0800 seconds) + 541: 0.5087 (100000 repetitions, Perl: 0.1573 seconds, CL-PPCRE: 0.0800 seconds) + 542: 0.4399 (100000 repetitions, Perl: 0.1591 seconds, CL-PPCRE: 0.0700 seconds) + 543: 0.4417 (100000 repetitions, Perl: 0.1585 seconds, CL-PPCRE: 0.0700 seconds) + 544: 0.8613 (100000 repetitions, Perl: 0.1741 seconds, CL-PPCRE: 0.1500 seconds) + 545: 0.4573 (100000 repetitions, Perl: 0.2843 seconds, CL-PPCRE: 0.1300 seconds) + 546: 0.7665 (100000 repetitions, Perl: 0.1827 seconds, CL-PPCRE: 0.1400 seconds) + 547: 0.5560 (100000 repetitions, Perl: 0.1439 seconds, CL-PPCRE: 0.0800 seconds) + 548: 0.5507 (100000 repetitions, Perl: 0.1453 seconds, CL-PPCRE: 0.0800 seconds) + 549: 0.6166 (100000 repetitions, Perl: 0.1946 seconds, CL-PPCRE: 0.1200 seconds) + 550: 0.2937 (100000 repetitions, Perl: 0.1362 seconds, CL-PPCRE: 0.0400 seconds) + 551: 0.3012 (100000 repetitions, Perl: 0.1328 seconds, CL-PPCRE: 0.0400 seconds) + 552: 0.2268 (100000 repetitions, Perl: 0.1323 seconds, CL-PPCRE: 0.0300 seconds) + 553: 0.6824 (100000 repetitions, Perl: 0.1905 seconds, CL-PPCRE: 0.1300 seconds) + 554: 0.2956 (100000 repetitions, Perl: 0.1353 seconds, CL-PPCRE: 0.0400 seconds) + 555: 0.2234 (100000 repetitions, Perl: 0.1343 seconds, CL-PPCRE: 0.0300 seconds) + 556: 0.2264 (100000 repetitions, Perl: 0.1325 seconds, CL-PPCRE: 0.0300 seconds) + 557: 0.6351 (100000 repetitions, Perl: 0.4409 seconds, CL-PPCRE: 0.2800 seconds) + 558: 0.5139 (100000 repetitions, Perl: 0.1751 seconds, CL-PPCRE: 0.0900 seconds) + 559: 0.6258 (100000 repetitions, Perl: 0.5274 seconds, CL-PPCRE: 0.3300 seconds) + 560: 0.6464 (100000 repetitions, Perl: 0.4487 seconds, CL-PPCRE: 0.2900 seconds) + 561: 0.5391 (100000 repetitions, Perl: 0.1855 seconds, CL-PPCRE: 0.1000 seconds) + 562: 0.6338 (100000 repetitions, Perl: 0.4576 seconds, CL-PPCRE: 0.2900 seconds) + 563: 0.4424 (100000 repetitions, Perl: 0.1582 seconds, CL-PPCRE: 0.0700 seconds) + 564: 0.4890 (100000 repetitions, Perl: 0.1840 seconds, CL-PPCRE: 0.0900 seconds) + 565: 0.6256 (100000 repetitions, Perl: 0.5435 seconds, CL-PPCRE: 0.3400 seconds) + 566: 0.4351 (100000 repetitions, Perl: 0.1609 seconds, CL-PPCRE: 0.0700 seconds) + 567: 0.4919 (100000 repetitions, Perl: 0.1830 seconds, CL-PPCRE: 0.0900 seconds) + 568: 0.6910 (100000 repetitions, Perl: 0.4631 seconds, CL-PPCRE: 0.3200 seconds) + 569: 0.4384 (100000 repetitions, Perl: 0.1597 seconds, CL-PPCRE: 0.0700 seconds) + 570: 0.4962 (100000 repetitions, Perl: 0.1814 seconds, CL-PPCRE: 0.0900 seconds) + 571: 0.6262 (100000 repetitions, Perl: 0.5429 seconds, CL-PPCRE: 0.3400 seconds) + 572: 0.3394 (100000 repetitions, Perl: 0.1473 seconds, CL-PPCRE: 0.0500 seconds) + 573: 0.3720 (100000 repetitions, Perl: 0.1613 seconds, CL-PPCRE: 0.0600 seconds) + 574: 0.5290 (100000 repetitions, Perl: 0.4915 seconds, CL-PPCRE: 0.2600 seconds) + 575: 0.5686 (100000 repetitions, Perl: 0.1055 seconds, CL-PPCRE: 0.0600 seconds) + 576: 0.2902 (100000 repetitions, Perl: 0.1378 seconds, CL-PPCRE: 0.0400 seconds) + 577: 0.3304 (100000 repetitions, Perl: 0.2421 seconds, CL-PPCRE: 0.0800 seconds) + 578: 0.3620 (100000 repetitions, Perl: 0.1381 seconds, CL-PPCRE: 0.0500 seconds) + 579: 0.3452 (100000 repetitions, Perl: 0.1448 seconds, CL-PPCRE: 0.0500 seconds) + 580: 0.2969 (100000 repetitions, Perl: 0.1684 seconds, CL-PPCRE: 0.0500 seconds) + 581: 0.4167 (100000 repetitions, Perl: 0.1440 seconds, CL-PPCRE: 0.0600 seconds) + 582: 0.4219 (100000 repetitions, Perl: 0.1422 seconds, CL-PPCRE: 0.0600 seconds) + 583: 0.4820 (100000 repetitions, Perl: 0.1452 seconds, CL-PPCRE: 0.0700 seconds) + 584: 0.2670 (100000 repetitions, Perl: 0.1498 seconds, CL-PPCRE: 0.0400 seconds) + 585: 0.2672 (100000 repetitions, Perl: 0.1497 seconds, CL-PPCRE: 0.0400 seconds) + 586: 0.8320 (100000 repetitions, Perl: 0.4207 seconds, CL-PPCRE: 0.3500 seconds) + 587: 0.3310 (100000 repetitions, Perl: 0.1208 seconds, CL-PPCRE: 0.0400 seconds) + 588: 0.3001 (1000000 repetitions, Perl: 0.8997 seconds, CL-PPCRE: 0.2700 seconds) + 589: 0.2536 (100000 repetitions, Perl: 0.1972 seconds, CL-PPCRE: 0.0500 seconds) + 590: 0.4693 (1000000 repetitions, Perl: 0.7671 seconds, CL-PPCRE: 0.3600 seconds) + 591: 0.2681 (100000 repetitions, Perl: 0.1865 seconds, CL-PPCRE: 0.0500 seconds) + 592: 0.2581 (100000 repetitions, Perl: 0.1550 seconds, CL-PPCRE: 0.0400 seconds) + 593: 0.4175 (100000 repetitions, Perl: 0.1916 seconds, CL-PPCRE: 0.0800 seconds) + 594: 0.4450 (100000 repetitions, Perl: 0.1573 seconds, CL-PPCRE: 0.0700 seconds) + 595: 0.4296 (100000 repetitions, Perl: 0.1862 seconds, CL-PPCRE: 0.0800 seconds) + 596: 0.4277 (100000 repetitions, Perl: 0.1871 seconds, CL-PPCRE: 0.0800 seconds) + 597: 0.4308 (100000 repetitions, Perl: 0.1857 seconds, CL-PPCRE: 0.0800 seconds) + 598: 0.7786 (1000000 repetitions, Perl: 0.7835 seconds, CL-PPCRE: 0.6100 seconds) + 599: 0.3235 (100000 repetitions, Perl: 0.1854 seconds, CL-PPCRE: 0.0600 seconds) + 600: 0.3302 (100000 repetitions, Perl: 0.1514 seconds, CL-PPCRE: 0.0500 seconds) + 601: 0.3100 (100000 repetitions, Perl: 0.3871 seconds, CL-PPCRE: 0.1200 seconds) + 602: 0.3929 (100000 repetitions, Perl: 0.5853 seconds, CL-PPCRE: 0.2300 seconds) + 603: 0.2478 (100000 repetitions, Perl: 0.1211 seconds, CL-PPCRE: 0.0300 seconds) + 604: 0.3026 (100000 repetitions, Perl: 0.1322 seconds, CL-PPCRE: 0.0400 seconds) + 605: 0.2324 (100000 repetitions, Perl: 0.1291 seconds, CL-PPCRE: 0.0300 seconds) + 606: 0.2566 (100000 repetitions, Perl: 0.1169 seconds, CL-PPCRE: 0.0300 seconds) + 607: 0.7426 (10000 repetitions, Perl: 0.6598 seconds, CL-PPCRE: 0.4900 seconds) + 608: 0.3101 (100000 repetitions, Perl: 0.1612 seconds, CL-PPCRE: 0.0500 seconds) + 609: 0.3097 (100000 repetitions, Perl: 0.1614 seconds, CL-PPCRE: 0.0500 seconds) + 610: 0.3080 (100000 repetitions, Perl: 0.1624 seconds, CL-PPCRE: 0.0500 seconds) + 611: 0.3044 (100000 repetitions, Perl: 0.1314 seconds, CL-PPCRE: 0.0400 seconds) + 612: 0.2972 (100000 repetitions, Perl: 0.1682 seconds, CL-PPCRE: 0.0500 seconds) + 613: 0.2979 (100000 repetitions, Perl: 0.1678 seconds, CL-PPCRE: 0.0500 seconds) + 614: 0.3004 (100000 repetitions, Perl: 0.1664 seconds, CL-PPCRE: 0.0500 seconds) + 615: 0.2998 (100000 repetitions, Perl: 0.1668 seconds, CL-PPCRE: 0.0500 seconds) + 616: 0.3094 (100000 repetitions, Perl: 0.3232 seconds, CL-PPCRE: 0.1000 seconds) + 617: 0.3499 (100000 repetitions, Perl: 0.4572 seconds, CL-PPCRE: 0.1600 seconds) + 618: 0.3665 (100000 repetitions, Perl: 0.6275 seconds, CL-PPCRE: 0.2300 seconds) + 619: 0.3663 (100000 repetitions, Perl: 0.8190 seconds, CL-PPCRE: 0.3000 seconds) + 620: 0.3761 (10000 repetitions, Perl: 0.1063 seconds, CL-PPCRE: 0.0400 seconds) + 621: 0.3691 (100000 repetitions, Perl: 0.3251 seconds, CL-PPCRE: 0.1200 seconds) + 622: 0.3314 (100000 repetitions, Perl: 0.3319 seconds, CL-PPCRE: 0.1100 seconds) + 623: 0.3612 (100000 repetitions, Perl: 0.3323 seconds, CL-PPCRE: 0.1200 seconds) + 624: 0.3560 (100000 repetitions, Perl: 0.3370 seconds, CL-PPCRE: 0.1200 seconds) + 625: 0.3616 (100000 repetitions, Perl: 0.3319 seconds, CL-PPCRE: 0.1200 seconds) + 626: 0.3517 (100000 repetitions, Perl: 0.1422 seconds, CL-PPCRE: 0.0500 seconds) + 627: 0.2692 (100000 repetitions, Perl: 0.1857 seconds, CL-PPCRE: 0.0500 seconds) + 628: 0.2865 (100000 repetitions, Perl: 0.1745 seconds, CL-PPCRE: 0.0500 seconds) + 630: 0.4441 (100000 repetitions, Perl: 0.1801 seconds, CL-PPCRE: 0.0800 seconds) + 632: 0.6037 (100000 repetitions, Perl: 0.1822 seconds, CL-PPCRE: 0.1100 seconds) + 635: 0.5615 (100000 repetitions, Perl: 0.4096 seconds, CL-PPCRE: 0.2300 seconds) + 636: 0.0000 (10 repetitions, Perl: 6.2984 seconds, CL-PPCRE: 0.0000 seconds) + 637: 0.5417 (100000 repetitions, Perl: 0.4061 seconds, CL-PPCRE: 0.2200 seconds) + 638: 0.0000 (100 repetitions, Perl: 0.1005 seconds, CL-PPCRE: 0.0000 seconds) + 639: 0.5243 (100000 repetitions, Perl: 0.1526 seconds, CL-PPCRE: 0.0800 seconds) + 640: 0.5098 (100000 repetitions, Perl: 0.1373 seconds, CL-PPCRE: 0.0700 seconds) + 641: 0.4568 (100000 repetitions, Perl: 0.2408 seconds, CL-PPCRE: 0.1100 seconds) + 642: 0.4462 (100000 repetitions, Perl: 0.2017 seconds, CL-PPCRE: 0.0900 seconds) + 643: 0.7628 (1000000 repetitions, Perl: 0.7735 seconds, CL-PPCRE: 0.5900 seconds) + 644: 0.4939 (100000 repetitions, Perl: 0.4656 seconds, CL-PPCRE: 0.2300 seconds) + 645: 0.3290 (100000 repetitions, Perl: 0.2128 seconds, CL-PPCRE: 0.0700 seconds) + 646: 0.4070 (100000 repetitions, Perl: 0.3686 seconds, CL-PPCRE: 0.1500 seconds) + 647: 0.4161 (100000 repetitions, Perl: 0.4086 seconds, CL-PPCRE: 0.1700 seconds) + 648: 0.2592 (100000 repetitions, Perl: 0.1158 seconds, CL-PPCRE: 0.0300 seconds) + 649: 0.3547 (100000 repetitions, Perl: 0.3101 seconds, CL-PPCRE: 0.1100 seconds) + 650: 0.4569 (1000000 repetitions, Perl: 0.7879 seconds, CL-PPCRE: 0.3600 seconds) + 651: 0.3252 (100000 repetitions, Perl: 0.1230 seconds, CL-PPCRE: 0.0400 seconds) + 652: 0.3773 (1000000 repetitions, Perl: 0.7950 seconds, CL-PPCRE: 0.3000 seconds) + 653: 0.3258 (100000 repetitions, Perl: 0.1228 seconds, CL-PPCRE: 0.0400 seconds) + 654: 1.4129 (1000000 repetitions, Perl: 0.8140 seconds, CL-PPCRE: 1.1500 seconds) + 655: 1.4957 (1000000 repetitions, Perl: 0.7622 seconds, CL-PPCRE: 1.1400 seconds) + 656: 0.3204 (100000 repetitions, Perl: 0.1560 seconds, CL-PPCRE: 0.0500 seconds) + 659: 0.4925 (100000 repetitions, Perl: 0.1218 seconds, CL-PPCRE: 0.0600 seconds) + 660: 0.3800 (1000000 repetitions, Perl: 0.7895 seconds, CL-PPCRE: 0.3000 seconds) + 661: 0.3298 (100000 repetitions, Perl: 0.1213 seconds, CL-PPCRE: 0.0400 seconds) + 663: 0.4117 (100000 repetitions, Perl: 0.1700 seconds, CL-PPCRE: 0.0700 seconds) + 664: 0.4841 (100000 repetitions, Perl: 0.1239 seconds, CL-PPCRE: 0.0600 seconds) + 665: 0.3108 (100000 repetitions, Perl: 0.1609 seconds, CL-PPCRE: 0.0500 seconds) + 666: 0.3096 (100000 repetitions, Perl: 0.1615 seconds, CL-PPCRE: 0.0500 seconds) + 667: 0.3054 (100000 repetitions, Perl: 0.1310 seconds, CL-PPCRE: 0.0400 seconds) + 668: 0.4166 (100000 repetitions, Perl: 0.1680 seconds, CL-PPCRE: 0.0700 seconds) + 669: 0.4020 (100000 repetitions, Perl: 0.1741 seconds, CL-PPCRE: 0.0700 seconds) + 670: 0.5613 (1000000 repetitions, Perl: 0.7660 seconds, CL-PPCRE: 0.4300 seconds) + 671: 0.3964 (100000 repetitions, Perl: 0.1513 seconds, CL-PPCRE: 0.0600 seconds) + 672: 0.5896 (1000000 repetitions, Perl: 0.7633 seconds, CL-PPCRE: 0.4500 seconds) + 673: 0.4650 (1000000 repetitions, Perl: 0.7742 seconds, CL-PPCRE: 0.3600 seconds) + 674: 0.2537 (100000 repetitions, Perl: 0.1577 seconds, CL-PPCRE: 0.0400 seconds) + 675: 0.5987 (1000000 repetitions, Perl: 0.7683 seconds, CL-PPCRE: 0.4600 seconds) + 676: 0.4043 (1000000 repetitions, Perl: 0.7667 seconds, CL-PPCRE: 0.3100 seconds) + 677: 0.3906 (1000000 repetitions, Perl: 0.7681 seconds, CL-PPCRE: 0.3000 seconds) + 678: 0.2633 (100000 repetitions, Perl: 0.1519 seconds, CL-PPCRE: 0.0400 seconds) + 679: 0.2444 (100000 repetitions, Perl: 0.1227 seconds, CL-PPCRE: 0.0300 seconds) + 680: 0.3258 (100000 repetitions, Perl: 0.1228 seconds, CL-PPCRE: 0.0400 seconds) + 681: 0.3292 (1000000 repetitions, Perl: 0.7897 seconds, CL-PPCRE: 0.2600 seconds) + 682: 0.2429 (100000 repetitions, Perl: 0.1235 seconds, CL-PPCRE: 0.0300 seconds) + 683: 0.3308 (100000 repetitions, Perl: 0.1209 seconds, CL-PPCRE: 0.0400 seconds) + 684: 0.3541 (1000000 repetitions, Perl: 0.7906 seconds, CL-PPCRE: 0.2800 seconds) + 685: 0.3376 (1000000 repetitions, Perl: 0.7996 seconds, CL-PPCRE: 0.2700 seconds) + 686: 0.3260 (100000 repetitions, Perl: 0.1227 seconds, CL-PPCRE: 0.0400 seconds) + 687: 0.2467 (100000 repetitions, Perl: 0.1216 seconds, CL-PPCRE: 0.0300 seconds) + 688: 0.3422 (1000000 repetitions, Perl: 0.7891 seconds, CL-PPCRE: 0.2700 seconds) + 689: 0.3388 (1000000 repetitions, Perl: 0.7970 seconds, CL-PPCRE: 0.2700 seconds) + 690: 0.2430 (100000 repetitions, Perl: 0.1235 seconds, CL-PPCRE: 0.0300 seconds) + 691: 0.3268 (100000 repetitions, Perl: 0.1224 seconds, CL-PPCRE: 0.0400 seconds) + 692: 0.2475 (100000 repetitions, Perl: 0.1212 seconds, CL-PPCRE: 0.0300 seconds) + 694: 0.2583 (100000 repetitions, Perl: 0.1549 seconds, CL-PPCRE: 0.0400 seconds) + 695: 0.3891 (1000000 repetitions, Perl: 0.7710 seconds, CL-PPCRE: 0.3000 seconds) + 697: 0.2431 (100000 repetitions, Perl: 0.1234 seconds, CL-PPCRE: 0.0300 seconds) + 698: 0.2484 (100000 repetitions, Perl: 0.1208 seconds, CL-PPCRE: 0.0300 seconds) + 699: 0.2462 (100000 repetitions, Perl: 0.1218 seconds, CL-PPCRE: 0.0300 seconds) + 700: 0.3274 (1000000 repetitions, Perl: 0.7941 seconds, CL-PPCRE: 0.2600 seconds) + 701: 0.3268 (100000 repetitions, Perl: 0.1224 seconds, CL-PPCRE: 0.0400 seconds) + 702: 0.2446 (100000 repetitions, Perl: 0.1226 seconds, CL-PPCRE: 0.0300 seconds) + 703: 0.2474 (100000 repetitions, Perl: 0.1212 seconds, CL-PPCRE: 0.0300 seconds) + 704: 0.3152 (1000000 repetitions, Perl: 0.7931 seconds, CL-PPCRE: 0.2500 seconds) + 705: 0.3720 (1000000 repetitions, Perl: 0.8065 seconds, CL-PPCRE: 0.3000 seconds) + 706: 0.3264 (100000 repetitions, Perl: 0.1226 seconds, CL-PPCRE: 0.0400 seconds) + 707: 0.3935 (1000000 repetitions, Perl: 0.7878 seconds, CL-PPCRE: 0.3100 seconds) + 708: 0.3254 (100000 repetitions, Perl: 0.1229 seconds, CL-PPCRE: 0.0400 seconds) + 709: 0.3775 (1000000 repetitions, Perl: 0.7948 seconds, CL-PPCRE: 0.3000 seconds) + 710: 0.3276 (100000 repetitions, Perl: 0.1221 seconds, CL-PPCRE: 0.0400 seconds) + 711: 0.2444 (100000 repetitions, Perl: 0.1228 seconds, CL-PPCRE: 0.0300 seconds) + 712: 0.2476 (100000 repetitions, Perl: 0.1212 seconds, CL-PPCRE: 0.0300 seconds) + 713: 0.3040 (1000000 repetitions, Perl: 0.7894 seconds, CL-PPCRE: 0.2400 seconds) + 715: 0.3191 (100000 repetitions, Perl: 0.1567 seconds, CL-PPCRE: 0.0500 seconds) + 716: 0.3000 (100000 repetitions, Perl: 0.1667 seconds, CL-PPCRE: 0.0500 seconds) + 717: 0.2954 (100000 repetitions, Perl: 0.1692 seconds, CL-PPCRE: 0.0500 seconds) + 718: 0.2865 (100000 repetitions, Perl: 0.1745 seconds, CL-PPCRE: 0.0500 seconds) + 719: 0.4718 (1000000 repetitions, Perl: 0.6147 seconds, CL-PPCRE: 0.2900 seconds) + 720: 0.2761 (100000 repetitions, Perl: 0.1811 seconds, CL-PPCRE: 0.0500 seconds) + 721: 0.4707 (1000000 repetitions, Perl: 0.6161 seconds, CL-PPCRE: 0.2900 seconds) + 722: 0.2801 (100000 repetitions, Perl: 0.1785 seconds, CL-PPCRE: 0.0500 seconds) + 723: 0.4566 (1000000 repetitions, Perl: 0.7885 seconds, CL-PPCRE: 0.3600 seconds) + 724: 0.4874 (1000000 repetitions, Perl: 0.6155 seconds, CL-PPCRE: 0.3000 seconds) + 725: 0.5016 (1000000 repetitions, Perl: 0.6180 seconds, CL-PPCRE: 0.3100 seconds) + 726: 0.2828 (100000 repetitions, Perl: 0.1768 seconds, CL-PPCRE: 0.0500 seconds) + 727: 0.5010 (1000000 repetitions, Perl: 0.6188 seconds, CL-PPCRE: 0.3100 seconds) + 728: 0.2833 (100000 repetitions, Perl: 0.1765 seconds, CL-PPCRE: 0.0500 seconds) + 729: 0.4384 (1000000 repetitions, Perl: 0.7756 seconds, CL-PPCRE: 0.3400 seconds) + 730: 0.5023 (1000000 repetitions, Perl: 0.6172 seconds, CL-PPCRE: 0.3100 seconds) + 731: 0.2386 (100000 repetitions, Perl: 0.1676 seconds, CL-PPCRE: 0.0400 seconds) + 732: 0.5181 (1000000 repetitions, Perl: 0.6177 seconds, CL-PPCRE: 0.3200 seconds) + 733: 0.4159 (1000000 repetitions, Perl: 0.7694 seconds, CL-PPCRE: 0.3200 seconds) + 734: 0.2543 (100000 repetitions, Perl: 0.1573 seconds, CL-PPCRE: 0.0400 seconds) + 735: 0.4703 (1000000 repetitions, Perl: 0.6166 seconds, CL-PPCRE: 0.2900 seconds) + 736: 0.2996 (100000 repetitions, Perl: 0.1669 seconds, CL-PPCRE: 0.0500 seconds) + 737: 0.4858 (1000000 repetitions, Perl: 0.6175 seconds, CL-PPCRE: 0.3000 seconds) + 738: 0.4444 (1000000 repetitions, Perl: 0.7876 seconds, CL-PPCRE: 0.3500 seconds) + 739: 0.2519 (100000 repetitions, Perl: 0.1588 seconds, CL-PPCRE: 0.0400 seconds) + 740: 0.4139 (1000000 repetitions, Perl: 0.7731 seconds, CL-PPCRE: 0.3200 seconds) + 741: 0.4308 (1000000 repetitions, Perl: 0.7660 seconds, CL-PPCRE: 0.3300 seconds) + 742: 0.4158 (1000000 repetitions, Perl: 0.7696 seconds, CL-PPCRE: 0.3200 seconds) + 743: 0.4542 (1000000 repetitions, Perl: 0.6165 seconds, CL-PPCRE: 0.2800 seconds) + 744: 0.4251 (100000 repetitions, Perl: 0.1411 seconds, CL-PPCRE: 0.0600 seconds) + 745: 0.4541 (1000000 repetitions, Perl: 0.6166 seconds, CL-PPCRE: 0.2800 seconds) + 746: 0.5009 (1000000 repetitions, Perl: 0.6189 seconds, CL-PPCRE: 0.3100 seconds) + 747: 0.6469 (1000000 repetitions, Perl: 0.7265 seconds, CL-PPCRE: 0.4700 seconds) + 748: 0.4178 (100000 repetitions, Perl: 0.1436 seconds, CL-PPCRE: 0.0600 seconds) + 749: 0.2556 (100000 repetitions, Perl: 0.1565 seconds, CL-PPCRE: 0.0400 seconds) + 750: 0.4699 (1000000 repetitions, Perl: 0.6171 seconds, CL-PPCRE: 0.2900 seconds) + 753: 0.2326 (100000 repetitions, Perl: 0.1290 seconds, CL-PPCRE: 0.0300 seconds) + 754: 0.2557 (100000 repetitions, Perl: 0.1564 seconds, CL-PPCRE: 0.0400 seconds) + 755: 0.3206 (100000 repetitions, Perl: 0.1559 seconds, CL-PPCRE: 0.0500 seconds) + 756: 0.3706 (100000 repetitions, Perl: 0.1349 seconds, CL-PPCRE: 0.0500 seconds) + 757: 0.3777 (100000 repetitions, Perl: 0.1324 seconds, CL-PPCRE: 0.0500 seconds) + 760: 0.2308 (100000 repetitions, Perl: 0.2167 seconds, CL-PPCRE: 0.0500 seconds) + 761: 0.4950 (1000000 repetitions, Perl: 0.7677 seconds, CL-PPCRE: 0.3800 seconds) + 762: 0.4656 (1000000 repetitions, Perl: 0.7731 seconds, CL-PPCRE: 0.3600 seconds) + 763: 0.2372 (100000 repetitions, Perl: 0.2108 seconds, CL-PPCRE: 0.0500 seconds) + 764: 0.4701 (1000000 repetitions, Perl: 0.7658 seconds, CL-PPCRE: 0.3600 seconds) + 765: 0.4926 (1000000 repetitions, Perl: 0.7714 seconds, CL-PPCRE: 0.3800 seconds) + 766: 0.6695 (100000 repetitions, Perl: 0.1792 seconds, CL-PPCRE: 0.1200 seconds) + 767: 1.1548 (1000000 repetitions, Perl: 0.7621 seconds, CL-PPCRE: 0.8800 seconds) + 768: 1.1199 (1000000 repetitions, Perl: 0.7679 seconds, CL-PPCRE: 0.8600 seconds) + 769: 0.3325 (100000 repetitions, Perl: 0.1804 seconds, CL-PPCRE: 0.0600 seconds) + 770: 0.5164 (1000000 repetitions, Perl: 0.7745 seconds, CL-PPCRE: 0.4000 seconds) + 771: 0.2703 (100000 repetitions, Perl: 0.1850 seconds, CL-PPCRE: 0.0500 seconds) + 772: 0.6408 (1000000 repetitions, Perl: 0.7646 seconds, CL-PPCRE: 0.4900 seconds) + 773: 0.4346 (1000000 repetitions, Perl: 0.8284 seconds, CL-PPCRE: 0.3600 seconds) + 774: 0.2671 (100000 repetitions, Perl: 0.1872 seconds, CL-PPCRE: 0.0500 seconds) + 775: 0.6119 (1000000 repetitions, Perl: 0.7681 seconds, CL-PPCRE: 0.4700 seconds) + 776: 0.4309 (1000000 repetitions, Perl: 0.8355 seconds, CL-PPCRE: 0.3600 seconds) + 777: 0.5830 (100000 repetitions, Perl: 0.1544 seconds, CL-PPCRE: 0.0900 seconds) + 778: 1.4436 (1000000 repetitions, Perl: 0.7620 seconds, CL-PPCRE: 1.1000 seconds) + 779: 0.8700 (1000000 repetitions, Perl: 0.8390 seconds, CL-PPCRE: 0.7300 seconds) + 780: 0.3165 (100000 repetitions, Perl: 0.1580 seconds, CL-PPCRE: 0.0500 seconds) + 781: 0.6059 (1000000 repetitions, Perl: 0.7756 seconds, CL-PPCRE: 0.4700 seconds) + 782: 0.4393 (1000000 repetitions, Perl: 0.8194 seconds, CL-PPCRE: 0.3600 seconds) + 783: 0.3732 (1000000 repetitions, Perl: 0.8307 seconds, CL-PPCRE: 0.3100 seconds) + 784: 0.2886 (100000 repetitions, Perl: 0.1733 seconds, CL-PPCRE: 0.0500 seconds) + 785: 0.4761 (1000000 repetitions, Perl: 0.7771 seconds, CL-PPCRE: 0.3700 seconds) + 786: 0.4285 (100000 repetitions, Perl: 0.2567 seconds, CL-PPCRE: 0.1100 seconds) + 787: 0.4003 (100000 repetitions, Perl: 0.2748 seconds, CL-PPCRE: 0.1100 seconds) + 788: 0.4010 (100000 repetitions, Perl: 0.2244 seconds, CL-PPCRE: 0.0900 seconds) + 789: 0.4943 (100000 repetitions, Perl: 0.4451 seconds, CL-PPCRE: 0.2200 seconds) + 791: 0.4275 (100000 repetitions, Perl: 0.4444 seconds, CL-PPCRE: 0.1900 seconds) + 792: 0.5687 (100000 repetitions, Perl: 0.4748 seconds, CL-PPCRE: 0.2700 seconds) + 793: 0.6169 (100000 repetitions, Perl: 0.4539 seconds, CL-PPCRE: 0.2800 seconds) + 794: 0.6400 (100000 repetitions, Perl: 0.4531 seconds, CL-PPCRE: 0.2900 seconds) + 795: 0.2678 (100000 repetitions, Perl: 0.2240 seconds, CL-PPCRE: 0.0600 seconds) + 796: 0.3119 (100000 repetitions, Perl: 0.1924 seconds, CL-PPCRE: 0.0600 seconds) + 797: 0.5787 (100000 repetitions, Perl: 0.3801 seconds, CL-PPCRE: 0.2200 seconds) + 798: 0.6085 (100000 repetitions, Perl: 0.3287 seconds, CL-PPCRE: 0.2000 seconds) + 799: 0.4050 (1000000 repetitions, Perl: 0.8149 seconds, CL-PPCRE: 0.3300 seconds) + 800: 0.3213 (100000 repetitions, Perl: 0.1556 seconds, CL-PPCRE: 0.0500 seconds) + 801: 0.2587 (100000 repetitions, Perl: 0.1546 seconds, CL-PPCRE: 0.0400 seconds) + 802: 0.3436 (100000 repetitions, Perl: 0.1455 seconds, CL-PPCRE: 0.0500 seconds) + 803: 0.4407 (100000 repetitions, Perl: 0.1361 seconds, CL-PPCRE: 0.0600 seconds) + 804: 0.6222 (1000000 repetitions, Perl: 0.7233 seconds, CL-PPCRE: 0.4500 seconds) + 805: 0.4411 (100000 repetitions, Perl: 0.1360 seconds, CL-PPCRE: 0.0600 seconds) + 806: 0.6147 (1000000 repetitions, Perl: 0.7158 seconds, CL-PPCRE: 0.4400 seconds) + 807: 0.2206 (100000 repetitions, Perl: 0.1814 seconds, CL-PPCRE: 0.0400 seconds) + 808: 0.2470 (100000 repetitions, Perl: 0.2024 seconds, CL-PPCRE: 0.0500 seconds) + 809: 0.2735 (100000 repetitions, Perl: 0.1828 seconds, CL-PPCRE: 0.0500 seconds) + 810: 0.2674 (100000 repetitions, Perl: 0.1870 seconds, CL-PPCRE: 0.0500 seconds) + 811: 0.3405 (100000 repetitions, Perl: 0.1468 seconds, CL-PPCRE: 0.0500 seconds) + 812: 0.4059 (100000 repetitions, Perl: 0.1478 seconds, CL-PPCRE: 0.0600 seconds) + 813: 0.2085 (100000 repetitions, Perl: 0.2398 seconds, CL-PPCRE: 0.0500 seconds) + 814: 0.4373 (1000000 repetitions, Perl: 0.6174 seconds, CL-PPCRE: 0.2700 seconds) + 815: 0.2669 (100000 repetitions, Perl: 0.1874 seconds, CL-PPCRE: 0.0500 seconds) + 816: 0.7040 (100000 repetitions, Perl: 0.1847 seconds, CL-PPCRE: 0.1300 seconds) + 817: 0.4656 (100000 repetitions, Perl: 0.2148 seconds, CL-PPCRE: 0.1000 seconds) + 818: 0.4928 (100000 repetitions, Perl: 0.1420 seconds, CL-PPCRE: 0.0700 seconds) + 819: 0.6155 (100000 repetitions, Perl: 0.1625 seconds, CL-PPCRE: 0.1000 seconds) + 820: 0.4187 (100000 repetitions, Perl: 0.1433 seconds, CL-PPCRE: 0.0600 seconds) + 821: 0.4519 (100000 repetitions, Perl: 0.1328 seconds, CL-PPCRE: 0.0600 seconds) + 822: 0.5520 (1000000 repetitions, Perl: 0.7970 seconds, CL-PPCRE: 0.4400 seconds) + 823: 0.6456 (1000000 repetitions, Perl: 0.7899 seconds, CL-PPCRE: 0.5100 seconds) + 824: 0.5695 (1000000 repetitions, Perl: 0.7901 seconds, CL-PPCRE: 0.4500 seconds) + 825: 5.6157 (100000 repetitions, Perl: 0.1086 seconds, CL-PPCRE: 0.6100 seconds) + 826: 0.4859 (100000 repetitions, Perl: 0.1852 seconds, CL-PPCRE: 0.0900 seconds) + 827: 0.4928 (100000 repetitions, Perl: 0.2232 seconds, CL-PPCRE: 0.1100 seconds) + 828: 0.4467 (100000 repetitions, Perl: 0.2238 seconds, CL-PPCRE: 0.1000 seconds) + 829: 0.4870 (100000 repetitions, Perl: 0.1848 seconds, CL-PPCRE: 0.0900 seconds) + 830: 0.4523 (10000 repetitions, Perl: 0.2432 seconds, CL-PPCRE: 0.1100 seconds) + 831: 0.4011 (10000 repetitions, Perl: 0.1994 seconds, CL-PPCRE: 0.0800 seconds) + 832: 0.5870 (100000 repetitions, Perl: 0.1533 seconds, CL-PPCRE: 0.0900 seconds) + 833: 0.6449 (100000 repetitions, Perl: 0.1706 seconds, CL-PPCRE: 0.1100 seconds) + 834: 0.5824 (100000 repetitions, Perl: 0.1717 seconds, CL-PPCRE: 0.1000 seconds) + 835: 0.7363 (100000 repetitions, Perl: 0.3259 seconds, CL-PPCRE: 0.2400 seconds) + 836: 0.3287 (100000 repetitions, Perl: 0.1521 seconds, CL-PPCRE: 0.0500 seconds) + 837: 0.4946 (100000 repetitions, Perl: 0.1617 seconds, CL-PPCRE: 0.0800 seconds) + 838: 0.4950 (100000 repetitions, Perl: 0.1616 seconds, CL-PPCRE: 0.0800 seconds) + 839: 0.2466 (100000 repetitions, Perl: 0.2839 seconds, CL-PPCRE: 0.0700 seconds) + 840: 0.2690 (100000 repetitions, Perl: 0.4832 seconds, CL-PPCRE: 0.1300 seconds) + 841: 0.4333 (100000 repetitions, Perl: 0.8077 seconds, CL-PPCRE: 0.3500 seconds) + 842: 0.3721 (100000 repetitions, Perl: 0.3763 seconds, CL-PPCRE: 0.1400 seconds) + 843: 0.3971 (100000 repetitions, Perl: 0.5288 seconds, CL-PPCRE: 0.2100 seconds) + 844: 0.4906 (100000 repetitions, Perl: 0.4077 seconds, CL-PPCRE: 0.2000 seconds) + 845: 0.3136 (100000 repetitions, Perl: 0.1595 seconds, CL-PPCRE: 0.0500 seconds) + 847: 0.4496 (1000000 repetitions, Perl: 0.7786 seconds, CL-PPCRE: 0.3500 seconds) + 848: 0.4622 (1000000 repetitions, Perl: 0.7789 seconds, CL-PPCRE: 0.3600 seconds) + 849: 0.4740 (100000 repetitions, Perl: 0.1899 seconds, CL-PPCRE: 0.0900 seconds) + 850: 0.8123 (1000000 repetitions, Perl: 0.8002 seconds, CL-PPCRE: 0.6500 seconds) + 851: 0.9209 (1000000 repetitions, Perl: 0.6190 seconds, CL-PPCRE: 0.5700 seconds) + 852: 0.8913 (1000000 repetitions, Perl: 0.6171 seconds, CL-PPCRE: 0.5500 seconds) + 853: 0.4788 (100000 repetitions, Perl: 0.1880 seconds, CL-PPCRE: 0.0900 seconds) + 854: 0.9083 (1000000 repetitions, Perl: 0.6165 seconds, CL-PPCRE: 0.5600 seconds) + 855: 0.5293 (100000 repetitions, Perl: 0.1700 seconds, CL-PPCRE: 0.0900 seconds) + 856: 0.5205 (100000 repetitions, Perl: 0.1729 seconds, CL-PPCRE: 0.0900 seconds) + 857: 0.4842 (100000 repetitions, Perl: 0.1446 seconds, CL-PPCRE: 0.0700 seconds) + 858: 0.4118 (100000 repetitions, Perl: 0.1457 seconds, CL-PPCRE: 0.0600 seconds) + 859: 0.8257 (1000000 repetitions, Perl: 0.7630 seconds, CL-PPCRE: 0.6300 seconds) + 860: 0.7571 (1000000 repetitions, Perl: 0.7661 seconds, CL-PPCRE: 0.5800 seconds) + 861: 0.8254 (1000000 repetitions, Perl: 0.7633 seconds, CL-PPCRE: 0.6300 seconds) + 862: 0.7463 (1000000 repetitions, Perl: 0.7637 seconds, CL-PPCRE: 0.5700 seconds) + 863: 0.3740 (100000 repetitions, Perl: 0.1604 seconds, CL-PPCRE: 0.0600 seconds) + 864: 0.3688 (100000 repetitions, Perl: 0.1627 seconds, CL-PPCRE: 0.0600 seconds) + 865: 0.4717 (1000000 repetitions, Perl: 0.7632 seconds, CL-PPCRE: 0.3600 seconds) + 866: 0.3015 (100000 repetitions, Perl: 0.1327 seconds, CL-PPCRE: 0.0400 seconds) + 867: 0.3042 (100000 repetitions, Perl: 0.1315 seconds, CL-PPCRE: 0.0400 seconds) + 868: 0.4176 (100000 repetitions, Perl: 0.1437 seconds, CL-PPCRE: 0.0600 seconds) + 869: 0.4879 (100000 repetitions, Perl: 0.1435 seconds, CL-PPCRE: 0.0700 seconds) + 870: 0.4843 (1000000 repetitions, Perl: 0.7640 seconds, CL-PPCRE: 0.3700 seconds) + 871: 0.5737 (1000000 repetitions, Perl: 0.7669 seconds, CL-PPCRE: 0.4400 seconds) + 872: 0.4173 (100000 repetitions, Perl: 0.1917 seconds, CL-PPCRE: 0.0800 seconds) + 873: 0.3683 (100000 repetitions, Perl: 0.1900 seconds, CL-PPCRE: 0.0700 seconds) + 874: 0.3494 (100000 repetitions, Perl: 0.1431 seconds, CL-PPCRE: 0.0500 seconds) + 875: 0.2311 (100000 repetitions, Perl: 0.1731 seconds, CL-PPCRE: 0.0400 seconds) + 876: 0.3566 (100000 repetitions, Perl: 0.2804 seconds, CL-PPCRE: 0.1000 seconds) + 877: 0.3548 (100000 repetitions, Perl: 0.2819 seconds, CL-PPCRE: 0.1000 seconds) + 878: 0.3539 (100000 repetitions, Perl: 0.2826 seconds, CL-PPCRE: 0.1000 seconds) + 879: 0.4957 (1000000 repetitions, Perl: 0.7666 seconds, CL-PPCRE: 0.3800 seconds) + 880: 0.6677 (100000 repetitions, Perl: 0.2396 seconds, CL-PPCRE: 0.1600 seconds) + 881: 0.3568 (100000 repetitions, Perl: 0.2803 seconds, CL-PPCRE: 0.1000 seconds) + 882: 0.3561 (100000 repetitions, Perl: 0.2808 seconds, CL-PPCRE: 0.1000 seconds) + 883: 0.3531 (100000 repetitions, Perl: 0.2832 seconds, CL-PPCRE: 0.1000 seconds) + 884: 0.4939 (1000000 repetitions, Perl: 0.7693 seconds, CL-PPCRE: 0.3800 seconds) + 885: 0.6675 (100000 repetitions, Perl: 0.2397 seconds, CL-PPCRE: 0.1600 seconds) + 886: 0.1878 (100000 repetitions, Perl: 0.2662 seconds, CL-PPCRE: 0.0500 seconds) + 887: 0.2227 (100000 repetitions, Perl: 0.2694 seconds, CL-PPCRE: 0.0600 seconds) + 888: 0.1826 (100000 repetitions, Perl: 0.2738 seconds, CL-PPCRE: 0.0500 seconds) + 889: 0.2220 (100000 repetitions, Perl: 0.1352 seconds, CL-PPCRE: 0.0300 seconds) + 890: 0.3370 (1000000 repetitions, Perl: 0.7715 seconds, CL-PPCRE: 0.2600 seconds) + 891: 0.3276 (1000000 repetitions, Perl: 0.7632 seconds, CL-PPCRE: 0.2500 seconds) + 892: 0.3100 (100000 repetitions, Perl: 0.1936 seconds, CL-PPCRE: 0.0600 seconds) + 893: 0.2601 (100000 repetitions, Perl: 0.1923 seconds, CL-PPCRE: 0.0500 seconds) + 894: 0.4041 (1000000 repetitions, Perl: 0.6187 seconds, CL-PPCRE: 0.2500 seconds) + 895: 0.3268 (1000000 repetitions, Perl: 0.7651 seconds, CL-PPCRE: 0.2500 seconds) + 896: 0.3254 (1000000 repetitions, Perl: 0.7683 seconds, CL-PPCRE: 0.2500 seconds) + 897: 0.4751 (100000 repetitions, Perl: 0.2105 seconds, CL-PPCRE: 0.1000 seconds) + 898: 0.4364 (100000 repetitions, Perl: 0.2062 seconds, CL-PPCRE: 0.0900 seconds) + 899: 0.4444 (100000 repetitions, Perl: 0.1350 seconds, CL-PPCRE: 0.0600 seconds) + 900: 0.5022 (100000 repetitions, Perl: 0.1394 seconds, CL-PPCRE: 0.0700 seconds) + 901: 0.7035 (1000000 repetitions, Perl: 0.7676 seconds, CL-PPCRE: 0.5400 seconds) + 902: 0.4586 (100000 repetitions, Perl: 0.1527 seconds, CL-PPCRE: 0.0700 seconds) + 903: 0.4671 (100000 repetitions, Perl: 0.1713 seconds, CL-PPCRE: 0.0800 seconds) + 904: 0.3907 (100000 repetitions, Perl: 0.1792 seconds, CL-PPCRE: 0.0700 seconds) + 905: 0.3864 (100000 repetitions, Perl: 0.1812 seconds, CL-PPCRE: 0.0700 seconds) + 906: 0.3806 (100000 repetitions, Perl: 0.2102 seconds, CL-PPCRE: 0.0800 seconds) + 907: 0.3776 (100000 repetitions, Perl: 0.2118 seconds, CL-PPCRE: 0.0800 seconds) + 908: 0.3921 (100000 repetitions, Perl: 0.2295 seconds, CL-PPCRE: 0.0900 seconds) + 909: 0.4301 (100000 repetitions, Perl: 0.1860 seconds, CL-PPCRE: 0.0800 seconds) + 910: 0.3195 (100000 repetitions, Perl: 0.1878 seconds, CL-PPCRE: 0.0600 seconds) + 911: 0.2436 (100000 repetitions, Perl: 0.1642 seconds, CL-PPCRE: 0.0400 seconds) + 912: 0.3041 (100000 repetitions, Perl: 0.1315 seconds, CL-PPCRE: 0.0400 seconds) + 913: 0.2414 (100000 repetitions, Perl: 0.1243 seconds, CL-PPCRE: 0.0300 seconds) + 914: 0.2742 (100000 repetitions, Perl: 0.1823 seconds, CL-PPCRE: 0.0500 seconds) + 915: 0.2971 (100000 repetitions, Perl: 0.1683 seconds, CL-PPCRE: 0.0500 seconds) + 916: 0.3023 (100000 repetitions, Perl: 0.1323 seconds, CL-PPCRE: 0.0400 seconds) + 917: 0.2352 (100000 repetitions, Perl: 0.1276 seconds, CL-PPCRE: 0.0300 seconds) + 918: 0.3308 (100000 repetitions, Perl: 0.2418 seconds, CL-PPCRE: 0.0800 seconds) + 919: 0.2534 (100000 repetitions, Perl: 0.1578 seconds, CL-PPCRE: 0.0400 seconds) + 920: 0.2807 (100000 repetitions, Perl: 0.1781 seconds, CL-PPCRE: 0.0500 seconds) + 921: 0.3005 (100000 repetitions, Perl: 0.1997 seconds, CL-PPCRE: 0.0600 seconds) + 922: 0.3028 (100000 repetitions, Perl: 0.2312 seconds, CL-PPCRE: 0.0700 seconds) + 923: 0.3821 (100000 repetitions, Perl: 0.2355 seconds, CL-PPCRE: 0.0900 seconds) + 924: 0.2499 (100000 repetitions, Perl: 0.1601 seconds, CL-PPCRE: 0.0400 seconds) + 925: 0.2759 (100000 repetitions, Perl: 0.1813 seconds, CL-PPCRE: 0.0500 seconds) + 926: 0.2996 (100000 repetitions, Perl: 0.2003 seconds, CL-PPCRE: 0.0600 seconds) + 927: 0.3238 (100000 repetitions, Perl: 0.2162 seconds, CL-PPCRE: 0.0700 seconds) + 928: 0.4485 (100000 repetitions, Perl: 0.1784 seconds, CL-PPCRE: 0.0800 seconds) + 929: 0.5143 (100000 repetitions, Perl: 0.1750 seconds, CL-PPCRE: 0.0900 seconds) + 930: 0.4808 (100000 repetitions, Perl: 0.1872 seconds, CL-PPCRE: 0.0900 seconds) + 931: 0.5237 (100000 repetitions, Perl: 0.2864 seconds, CL-PPCRE: 0.1500 seconds) + 932: 0.4539 (100000 repetitions, Perl: 0.1763 seconds, CL-PPCRE: 0.0800 seconds) + 933: 0.5025 (100000 repetitions, Perl: 0.1791 seconds, CL-PPCRE: 0.0900 seconds) + 934: 0.4820 (100000 repetitions, Perl: 0.1867 seconds, CL-PPCRE: 0.0900 seconds) + 935: 0.5277 (100000 repetitions, Perl: 0.2843 seconds, CL-PPCRE: 0.1500 seconds) + 936: 0.4468 (100000 repetitions, Perl: 0.2238 seconds, CL-PPCRE: 0.1000 seconds) + 937: 0.3800 (100000 repetitions, Perl: 0.2631 seconds, CL-PPCRE: 0.1000 seconds) + 938: 0.4090 (100000 repetitions, Perl: 0.2934 seconds, CL-PPCRE: 0.1200 seconds) + 939: 0.4672 (100000 repetitions, Perl: 0.1926 seconds, CL-PPCRE: 0.0900 seconds) + 940: 0.6314 (100000 repetitions, Perl: 0.1742 seconds, CL-PPCRE: 0.1100 seconds) + 941: 0.6664 (100000 repetitions, Perl: 0.1801 seconds, CL-PPCRE: 0.1200 seconds) + 942: 0.6355 (100000 repetitions, Perl: 0.1731 seconds, CL-PPCRE: 0.1100 seconds) + 943: 0.6240 (100000 repetitions, Perl: 0.1763 seconds, CL-PPCRE: 0.1100 seconds) + 944: 0.6861 (100000 repetitions, Perl: 0.1749 seconds, CL-PPCRE: 0.1200 seconds) + 945: 0.7400 (100000 repetitions, Perl: 0.1757 seconds, CL-PPCRE: 0.1300 seconds) + 946: 0.7302 (100000 repetitions, Perl: 0.1780 seconds, CL-PPCRE: 0.1300 seconds) + 947: 0.6298 (100000 repetitions, Perl: 0.1747 seconds, CL-PPCRE: 0.1100 seconds) + 948: 0.6705 (100000 repetitions, Perl: 0.1790 seconds, CL-PPCRE: 0.1200 seconds) + 949: 0.6259 (100000 repetitions, Perl: 0.1758 seconds, CL-PPCRE: 0.1100 seconds) + 950: 0.6232 (100000 repetitions, Perl: 0.1765 seconds, CL-PPCRE: 0.1100 seconds) + 951: 0.6639 (100000 repetitions, Perl: 0.1807 seconds, CL-PPCRE: 0.1200 seconds) + 952: 0.7448 (100000 repetitions, Perl: 0.1745 seconds, CL-PPCRE: 0.1300 seconds) + 953: 0.6846 (100000 repetitions, Perl: 0.1753 seconds, CL-PPCRE: 0.1200 seconds) + 954: 0.2594 (100000 repetitions, Perl: 0.2313 seconds, CL-PPCRE: 0.0600 seconds) + 955: 0.2587 (100000 repetitions, Perl: 0.2319 seconds, CL-PPCRE: 0.0600 seconds) + 956: 0.3055 (100000 repetitions, Perl: 0.2291 seconds, CL-PPCRE: 0.0700 seconds) + 957: 0.4766 (100000 repetitions, Perl: 0.2308 seconds, CL-PPCRE: 0.1100 seconds) + 958: 0.4771 (100000 repetitions, Perl: 0.2725 seconds, CL-PPCRE: 0.1300 seconds) + 959: 0.4772 (100000 repetitions, Perl: 0.3144 seconds, CL-PPCRE: 0.1500 seconds) + 960: 0.6517 (100000 repetitions, Perl: 0.1841 seconds, CL-PPCRE: 0.1200 seconds) + 961: 0.4511 (100000 repetitions, Perl: 0.2217 seconds, CL-PPCRE: 0.1000 seconds) + 962: 0.3977 (100000 repetitions, Perl: 0.2263 seconds, CL-PPCRE: 0.0900 seconds) + 963: 0.4044 (100000 repetitions, Perl: 0.2226 seconds, CL-PPCRE: 0.0900 seconds) + 964: 0.4084 (100000 repetitions, Perl: 0.2204 seconds, CL-PPCRE: 0.0900 seconds) + 965: 0.4408 (100000 repetitions, Perl: 0.2269 seconds, CL-PPCRE: 0.1000 seconds) + 966: 0.4340 (100000 repetitions, Perl: 0.2304 seconds, CL-PPCRE: 0.1000 seconds) + 967: 0.4000 (100000 repetitions, Perl: 0.2250 seconds, CL-PPCRE: 0.0900 seconds) + 968: 0.4063 (100000 repetitions, Perl: 0.2215 seconds, CL-PPCRE: 0.0900 seconds) + 969: 0.4449 (100000 repetitions, Perl: 0.2248 seconds, CL-PPCRE: 0.1000 seconds) + 970: 0.4263 (100000 repetitions, Perl: 0.1877 seconds, CL-PPCRE: 0.0800 seconds) + 971: 0.4445 (100000 repetitions, Perl: 0.2250 seconds, CL-PPCRE: 0.1000 seconds) + 972: 0.4297 (100000 repetitions, Perl: 0.1862 seconds, CL-PPCRE: 0.0800 seconds) + 973: 0.3937 (100000 repetitions, Perl: 0.1778 seconds, CL-PPCRE: 0.0700 seconds) + 974: 0.3974 (100000 repetitions, Perl: 0.1761 seconds, CL-PPCRE: 0.0700 seconds) + 975: 0.3941 (100000 repetitions, Perl: 0.1776 seconds, CL-PPCRE: 0.0700 seconds) + 976: 0.3917 (100000 repetitions, Perl: 0.1787 seconds, CL-PPCRE: 0.0700 seconds) + 977: 0.3929 (100000 repetitions, Perl: 0.1781 seconds, CL-PPCRE: 0.0700 seconds) + 978: 0.3915 (100000 repetitions, Perl: 0.1788 seconds, CL-PPCRE: 0.0700 seconds) + 979: 0.3970 (100000 repetitions, Perl: 0.1763 seconds, CL-PPCRE: 0.0700 seconds) + 980: 0.3956 (100000 repetitions, Perl: 0.1770 seconds, CL-PPCRE: 0.0700 seconds) + 981: 0.3936 (100000 repetitions, Perl: 0.1779 seconds, CL-PPCRE: 0.0700 seconds) + 982: 0.3955 (100000 repetitions, Perl: 0.1770 seconds, CL-PPCRE: 0.0700 seconds) + 983: 0.3928 (100000 repetitions, Perl: 0.1782 seconds, CL-PPCRE: 0.0700 seconds) + 984: 0.3968 (100000 repetitions, Perl: 0.1764 seconds, CL-PPCRE: 0.0700 seconds) + 985: 0.2590 (100000 repetitions, Perl: 0.2317 seconds, CL-PPCRE: 0.0600 seconds) + 986: 0.3023 (100000 repetitions, Perl: 0.2315 seconds, CL-PPCRE: 0.0700 seconds) + 987: 0.4364 (100000 repetitions, Perl: 0.2521 seconds, CL-PPCRE: 0.1100 seconds) + 988: 0.3976 (100000 repetitions, Perl: 0.2515 seconds, CL-PPCRE: 0.1000 seconds) + 989: 0.3863 (100000 repetitions, Perl: 0.2071 seconds, CL-PPCRE: 0.0800 seconds) + 990: 0.3864 (100000 repetitions, Perl: 0.2070 seconds, CL-PPCRE: 0.0800 seconds) + 991: 0.2795 (100000 repetitions, Perl: 0.2504 seconds, CL-PPCRE: 0.0700 seconds) + 992: 0.3350 (100000 repetitions, Perl: 0.2686 seconds, CL-PPCRE: 0.0900 seconds) + 993: 0.1875 (100000 repetitions, Perl: 0.2133 seconds, CL-PPCRE: 0.0400 seconds) + 994: 0.4958 (100000 repetitions, Perl: 0.2218 seconds, CL-PPCRE: 0.1100 seconds) + 995: 0.4927 (100000 repetitions, Perl: 0.2233 seconds, CL-PPCRE: 0.1100 seconds) + 996: 0.4889 (100000 repetitions, Perl: 0.1841 seconds, CL-PPCRE: 0.0900 seconds) + 997: 0.4658 (100000 repetitions, Perl: 0.1503 seconds, CL-PPCRE: 0.0700 seconds) + 998: 0.3414 (100000 repetitions, Perl: 0.1464 seconds, CL-PPCRE: 0.0500 seconds) + 999: 0.3149 (100000 repetitions, Perl: 0.1588 seconds, CL-PPCRE: 0.0500 seconds) +1000: 0.3993 (100000 repetitions, Perl: 0.1503 seconds, CL-PPCRE: 0.0600 seconds) +1001: 0.3749 (100000 repetitions, Perl: 0.1600 seconds, CL-PPCRE: 0.0600 seconds) +1002: 0.4008 (100000 repetitions, Perl: 0.1497 seconds, CL-PPCRE: 0.0600 seconds) +1003: 0.3744 (100000 repetitions, Perl: 0.1603 seconds, CL-PPCRE: 0.0600 seconds) +1004: 0.3792 (100000 repetitions, Perl: 0.1582 seconds, CL-PPCRE: 0.0600 seconds) +1005: 0.5061 (100000 repetitions, Perl: 0.1581 seconds, CL-PPCRE: 0.0800 seconds) +1006: 0.5539 (100000 repetitions, Perl: 0.1625 seconds, CL-PPCRE: 0.0900 seconds) +1007: 0.5210 (100000 repetitions, Perl: 0.1727 seconds, CL-PPCRE: 0.0900 seconds) +1008: 0.5835 (100000 repetitions, Perl: 0.1714 seconds, CL-PPCRE: 0.1000 seconds) +1009: 0.6770 (1000000 repetitions, Perl: 0.7681 seconds, CL-PPCRE: 0.5200 seconds) +1010: 0.6788 (1000000 repetitions, Perl: 0.7660 seconds, CL-PPCRE: 0.5200 seconds) +1011: 0.6545 (1000000 repetitions, Perl: 0.7640 seconds, CL-PPCRE: 0.5000 seconds) +1012: 0.6682 (1000000 repetitions, Perl: 0.7632 seconds, CL-PPCRE: 0.5100 seconds) +1013: 0.4885 (100000 repetitions, Perl: 0.1433 seconds, CL-PPCRE: 0.0700 seconds) +1014: 0.4995 (100000 repetitions, Perl: 0.1401 seconds, CL-PPCRE: 0.0700 seconds) +1015: 0.4964 (100000 repetitions, Perl: 0.1410 seconds, CL-PPCRE: 0.0700 seconds) +1016: 0.4570 (100000 repetitions, Perl: 0.1532 seconds, CL-PPCRE: 0.0700 seconds) +1017: 0.4607 (100000 repetitions, Perl: 0.1519 seconds, CL-PPCRE: 0.0700 seconds) +1018: 0.4578 (100000 repetitions, Perl: 0.1529 seconds, CL-PPCRE: 0.0700 seconds) +1019: 0.4573 (100000 repetitions, Perl: 0.1531 seconds, CL-PPCRE: 0.0700 seconds) +1020: 0.4685 (100000 repetitions, Perl: 0.1281 seconds, CL-PPCRE: 0.0600 seconds) +1021: 0.5708 (100000 repetitions, Perl: 0.1402 seconds, CL-PPCRE: 0.0800 seconds) +1022: 0.4815 (100000 repetitions, Perl: 0.1661 seconds, CL-PPCRE: 0.0800 seconds) +1023: 0.4868 (100000 repetitions, Perl: 0.1643 seconds, CL-PPCRE: 0.0800 seconds) +1024: 0.4939 (100000 repetitions, Perl: 0.1620 seconds, CL-PPCRE: 0.0800 seconds) +1025: 0.5472 (100000 repetitions, Perl: 0.1645 seconds, CL-PPCRE: 0.0900 seconds) +1026: 0.5505 (100000 repetitions, Perl: 0.1635 seconds, CL-PPCRE: 0.0900 seconds) +1027: 0.5315 (100000 repetitions, Perl: 0.1505 seconds, CL-PPCRE: 0.0800 seconds) +1028: 0.5022 (100000 repetitions, Perl: 0.1394 seconds, CL-PPCRE: 0.0700 seconds) +1029: 0.3264 (100000 repetitions, Perl: 0.2145 seconds, CL-PPCRE: 0.0700 seconds) +1030: 0.3346 (100000 repetitions, Perl: 0.1494 seconds, CL-PPCRE: 0.0500 seconds) +1031: 0.4008 (100000 repetitions, Perl: 0.1497 seconds, CL-PPCRE: 0.0600 seconds) +1032: 0.2813 (100000 repetitions, Perl: 0.2133 seconds, CL-PPCRE: 0.0600 seconds) +1033: 0.3560 (100000 repetitions, Perl: 0.2247 seconds, CL-PPCRE: 0.0800 seconds) +1034: 0.3124 (100000 repetitions, Perl: 0.2241 seconds, CL-PPCRE: 0.0700 seconds) +1035: 0.2817 (100000 repetitions, Perl: 0.1420 seconds, CL-PPCRE: 0.0400 seconds) +1036: 0.3732 (100000 repetitions, Perl: 0.1608 seconds, CL-PPCRE: 0.0600 seconds) +1037: 0.8908 (1000000 repetitions, Perl: 0.6174 seconds, CL-PPCRE: 0.5500 seconds) +1038: 0.8891 (1000000 repetitions, Perl: 0.6186 seconds, CL-PPCRE: 0.5500 seconds) +1039: 0.9084 (1000000 repetitions, Perl: 0.6164 seconds, CL-PPCRE: 0.5600 seconds) +1040: 0.4134 (100000 repetitions, Perl: 0.5080 seconds, CL-PPCRE: 0.2100 seconds) +1041: 0.3771 (100000 repetitions, Perl: 0.3978 seconds, CL-PPCRE: 0.1500 seconds) +1042: 0.4070 (100000 repetitions, Perl: 0.4423 seconds, CL-PPCRE: 0.1800 seconds) +1043: 0.3686 (100000 repetitions, Perl: 0.4069 seconds, CL-PPCRE: 0.1500 seconds) +1044: 0.4354 (100000 repetitions, Perl: 0.7580 seconds, CL-PPCRE: 0.3300 seconds) +1045: 0.4202 (100000 repetitions, Perl: 0.7616 seconds, CL-PPCRE: 0.3200 seconds) +1046: 0.4074 (100000 repetitions, Perl: 0.4173 seconds, CL-PPCRE: 0.1700 seconds) +1047: 0.4346 (100000 repetitions, Perl: 0.7823 seconds, CL-PPCRE: 0.3400 seconds) +1048: 0.4338 (100000 repetitions, Perl: 0.7837 seconds, CL-PPCRE: 0.3400 seconds) +1049: 0.4215 (100000 repetitions, Perl: 0.7829 seconds, CL-PPCRE: 0.3300 seconds) +1050: 0.4348 (100000 repetitions, Perl: 0.7819 seconds, CL-PPCRE: 0.3400 seconds) +1051: 0.4342 (100000 repetitions, Perl: 0.7831 seconds, CL-PPCRE: 0.3400 seconds) +1052: 0.4315 (100000 repetitions, Perl: 0.7879 seconds, CL-PPCRE: 0.3400 seconds) +1053: 1.1017 (1000000 repetitions, Perl: 0.6172 seconds, CL-PPCRE: 0.6800 seconds) +1054: 1.1006 (1000000 repetitions, Perl: 0.6179 seconds, CL-PPCRE: 0.6800 seconds) +1055: 1.1014 (1000000 repetitions, Perl: 0.6174 seconds, CL-PPCRE: 0.6800 seconds) +1056: 0.4202 (100000 repetitions, Perl: 0.4997 seconds, CL-PPCRE: 0.2100 seconds) +1057: 0.4627 (100000 repetitions, Perl: 0.3890 seconds, CL-PPCRE: 0.1800 seconds) +1058: 0.4481 (100000 repetitions, Perl: 0.4240 seconds, CL-PPCRE: 0.1900 seconds) +1059: 0.4822 (100000 repetitions, Perl: 0.3941 seconds, CL-PPCRE: 0.1900 seconds) +1060: 0.4665 (100000 repetitions, Perl: 0.6645 seconds, CL-PPCRE: 0.3100 seconds) +1061: 0.4661 (100000 repetitions, Perl: 0.6651 seconds, CL-PPCRE: 0.3100 seconds) +1062: 0.4250 (100000 repetitions, Perl: 0.4000 seconds, CL-PPCRE: 0.1700 seconds) +1063: 0.4645 (100000 repetitions, Perl: 0.6889 seconds, CL-PPCRE: 0.3200 seconds) +1064: 0.4515 (100000 repetitions, Perl: 0.6866 seconds, CL-PPCRE: 0.3100 seconds) +1065: 0.4666 (100000 repetitions, Perl: 0.6858 seconds, CL-PPCRE: 0.3200 seconds) +1066: 0.4514 (100000 repetitions, Perl: 0.6867 seconds, CL-PPCRE: 0.3100 seconds) +1067: 0.4803 (100000 repetitions, Perl: 0.6871 seconds, CL-PPCRE: 0.3300 seconds) +1068: 0.4521 (100000 repetitions, Perl: 0.6857 seconds, CL-PPCRE: 0.3100 seconds) +1069: 0.2367 (100000 repetitions, Perl: 0.1690 seconds, CL-PPCRE: 0.0400 seconds) +1070: 0.2927 (100000 repetitions, Perl: 0.1708 seconds, CL-PPCRE: 0.0500 seconds) +1071: 0.2937 (100000 repetitions, Perl: 0.1702 seconds, CL-PPCRE: 0.0500 seconds) +1072: 0.4285 (1000000 repetitions, Perl: 0.7935 seconds, CL-PPCRE: 0.3400 seconds) +1073: 0.4273 (1000000 repetitions, Perl: 0.7958 seconds, CL-PPCRE: 0.3400 seconds) +1074: 0.4155 (1000000 repetitions, Perl: 0.7702 seconds, CL-PPCRE: 0.3200 seconds) +1075: 0.3433 (100000 repetitions, Perl: 0.1456 seconds, CL-PPCRE: 0.0500 seconds) +1076: 0.3420 (100000 repetitions, Perl: 0.1462 seconds, CL-PPCRE: 0.0500 seconds) +1077: 0.4112 (100000 repetitions, Perl: 0.1459 seconds, CL-PPCRE: 0.0600 seconds) +1078: 0.4726 (100000 repetitions, Perl: 0.1481 seconds, CL-PPCRE: 0.0700 seconds) +1079: 0.2441 (100000 repetitions, Perl: 0.1229 seconds, CL-PPCRE: 0.0300 seconds) +1080: 0.3215 (100000 repetitions, Perl: 0.1244 seconds, CL-PPCRE: 0.0400 seconds) +1081: 0.4700 (100000 repetitions, Perl: 0.1489 seconds, CL-PPCRE: 0.0700 seconds) +1082: 0.4060 (100000 repetitions, Perl: 0.1478 seconds, CL-PPCRE: 0.0600 seconds) +1083: 0.6335 (1000000 repetitions, Perl: 0.6156 seconds, CL-PPCRE: 0.3900 seconds) +1084: 0.5988 (1000000 repetitions, Perl: 0.6179 seconds, CL-PPCRE: 0.3700 seconds) +1085: 0.4737 (100000 repetitions, Perl: 0.1478 seconds, CL-PPCRE: 0.0700 seconds) +1086: 0.4662 (100000 repetitions, Perl: 0.1502 seconds, CL-PPCRE: 0.0700 seconds) +1087: 0.4698 (100000 repetitions, Perl: 0.1490 seconds, CL-PPCRE: 0.0700 seconds) +1088: 0.4444 (100000 repetitions, Perl: 0.1575 seconds, CL-PPCRE: 0.0700 seconds) +1089: 0.6147 (1000000 repetitions, Perl: 0.6181 seconds, CL-PPCRE: 0.3800 seconds) +1090: 0.7628 (1000000 repetitions, Perl: 0.6162 seconds, CL-PPCRE: 0.4700 seconds) +1091: 0.4155 (100000 repetitions, Perl: 0.1444 seconds, CL-PPCRE: 0.0600 seconds) +1092: 0.3413 (100000 repetitions, Perl: 0.1465 seconds, CL-PPCRE: 0.0500 seconds) +1093: 0.3394 (100000 repetitions, Perl: 0.1473 seconds, CL-PPCRE: 0.0500 seconds) +1094: 0.4168 (100000 repetitions, Perl: 0.1439 seconds, CL-PPCRE: 0.0600 seconds) +1095: 0.4189 (100000 repetitions, Perl: 0.1432 seconds, CL-PPCRE: 0.0600 seconds) +1096: 0.4240 (100000 repetitions, Perl: 0.1415 seconds, CL-PPCRE: 0.0600 seconds) +1097: 0.6320 (1000000 repetitions, Perl: 0.7278 seconds, CL-PPCRE: 0.4600 seconds) +1098: 0.7439 (1000000 repetitions, Perl: 0.7259 seconds, CL-PPCRE: 0.5400 seconds) +1099: 0.4353 (100000 repetitions, Perl: 0.1378 seconds, CL-PPCRE: 0.0600 seconds) +1100: 0.2869 (100000 repetitions, Perl: 0.1743 seconds, CL-PPCRE: 0.0500 seconds) +1101: 0.2916 (100000 repetitions, Perl: 0.1714 seconds, CL-PPCRE: 0.0500 seconds) +1102: 0.6549 (1000000 repetitions, Perl: 0.7787 seconds, CL-PPCRE: 0.5100 seconds) +1103: 0.2606 (100000 repetitions, Perl: 0.1151 seconds, CL-PPCRE: 0.0300 seconds) +1104: 0.3060 (100000 repetitions, Perl: 0.1307 seconds, CL-PPCRE: 0.0400 seconds) +1105: 0.3699 (100000 repetitions, Perl: 0.1622 seconds, CL-PPCRE: 0.0600 seconds) +1106: 0.3107 (100000 repetitions, Perl: 0.1609 seconds, CL-PPCRE: 0.0500 seconds) +1107: 0.4186 (100000 repetitions, Perl: 0.1433 seconds, CL-PPCRE: 0.0600 seconds) +1108: 0.3705 (100000 repetitions, Perl: 0.1620 seconds, CL-PPCRE: 0.0600 seconds) +1109: 0.3070 (100000 repetitions, Perl: 0.1303 seconds, CL-PPCRE: 0.0400 seconds) +1110: 0.2271 (100000 repetitions, Perl: 0.1321 seconds, CL-PPCRE: 0.0300 seconds) +1111: 0.3084 (100000 repetitions, Perl: 0.1621 seconds, CL-PPCRE: 0.0500 seconds) +1112: 0.2849 (100000 repetitions, Perl: 0.1755 seconds, CL-PPCRE: 0.0500 seconds) +1113: 0.2561 (100000 repetitions, Perl: 0.1562 seconds, CL-PPCRE: 0.0400 seconds) +1114: 0.2522 (100000 repetitions, Perl: 0.1586 seconds, CL-PPCRE: 0.0400 seconds) +1115: 0.3156 (100000 repetitions, Perl: 0.1584 seconds, CL-PPCRE: 0.0500 seconds) +1116: 0.2411 (100000 repetitions, Perl: 0.1659 seconds, CL-PPCRE: 0.0400 seconds) +1117: 0.3145 (100000 repetitions, Perl: 0.1590 seconds, CL-PPCRE: 0.0500 seconds) +1118: 0.3867 (100000 repetitions, Perl: 0.1293 seconds, CL-PPCRE: 0.0500 seconds) +1119: 0.4624 (100000 repetitions, Perl: 0.1298 seconds, CL-PPCRE: 0.0600 seconds) +1120: 0.3085 (100000 repetitions, Perl: 0.1621 seconds, CL-PPCRE: 0.0500 seconds) +1121: 0.3127 (100000 repetitions, Perl: 0.1599 seconds, CL-PPCRE: 0.0500 seconds) +1122: 0.3696 (100000 repetitions, Perl: 0.1623 seconds, CL-PPCRE: 0.0600 seconds) +1123: 0.3817 (100000 repetitions, Perl: 0.1310 seconds, CL-PPCRE: 0.0500 seconds) +1124: 0.5259 (100000 repetitions, Perl: 0.1711 seconds, CL-PPCRE: 0.0900 seconds) +1125: 0.3481 (100000 repetitions, Perl: 0.1723 seconds, CL-PPCRE: 0.0600 seconds) +1126: 0.5827 (100000 repetitions, Perl: 0.1716 seconds, CL-PPCRE: 0.1000 seconds) +1127: 0.5218 (1000000 repetitions, Perl: 0.8432 seconds, CL-PPCRE: 0.4400 seconds) +1128: 0.5541 (100000 repetitions, Perl: 0.1444 seconds, CL-PPCRE: 0.0800 seconds) +1129: 0.4897 (1000000 repetitions, Perl: 0.9190 seconds, CL-PPCRE: 0.4500 seconds) +1130: 0.6666 (1000000 repetitions, Perl: 0.9151 seconds, CL-PPCRE: 0.6100 seconds) +1131: 0.5408 (1000000 repetitions, Perl: 0.8506 seconds, CL-PPCRE: 0.4600 seconds) +1132: 0.7029 (1000000 repetitions, Perl: 0.9105 seconds, CL-PPCRE: 0.6400 seconds) +1133: 0.3426 (100000 repetitions, Perl: 0.1751 seconds, CL-PPCRE: 0.0600 seconds) +1134: 0.4030 (100000 repetitions, Perl: 0.1737 seconds, CL-PPCRE: 0.0700 seconds) +1135: 0.3455 (100000 repetitions, Perl: 0.1737 seconds, CL-PPCRE: 0.0600 seconds) +1136: 0.2454 (100000 repetitions, Perl: 0.1223 seconds, CL-PPCRE: 0.0300 seconds) +1137: 0.3244 (100000 repetitions, Perl: 0.1233 seconds, CL-PPCRE: 0.0400 seconds) +1138: 0.2405 (100000 repetitions, Perl: 0.1247 seconds, CL-PPCRE: 0.0300 seconds) +1139: 0.3148 (1000000 repetitions, Perl: 0.7941 seconds, CL-PPCRE: 0.2500 seconds) +1140: 0.3763 (100000 repetitions, Perl: 0.1595 seconds, CL-PPCRE: 0.0600 seconds) +1141: 0.3067 (100000 repetitions, Perl: 0.1630 seconds, CL-PPCRE: 0.0500 seconds) +1142: 0.3115 (100000 repetitions, Perl: 0.1605 seconds, CL-PPCRE: 0.0500 seconds) +1143: 0.3903 (100000 repetitions, Perl: 0.1281 seconds, CL-PPCRE: 0.0500 seconds) +1144: 0.2431 (100000 repetitions, Perl: 0.1234 seconds, CL-PPCRE: 0.0300 seconds) +1145: 0.2490 (100000 repetitions, Perl: 0.1205 seconds, CL-PPCRE: 0.0300 seconds) +1146: 0.2464 (100000 repetitions, Perl: 0.1218 seconds, CL-PPCRE: 0.0300 seconds) +1147: 0.3224 (1000000 repetitions, Perl: 0.7755 seconds, CL-PPCRE: 0.2500 seconds) +1148: 0.2474 (100000 repetitions, Perl: 0.1213 seconds, CL-PPCRE: 0.0300 seconds) +1149: 0.2453 (100000 repetitions, Perl: 0.1223 seconds, CL-PPCRE: 0.0300 seconds) +1150: 0.2402 (100000 repetitions, Perl: 0.1249 seconds, CL-PPCRE: 0.0300 seconds) +1151: 0.3149 (1000000 repetitions, Perl: 0.7939 seconds, CL-PPCRE: 0.2500 seconds) +1152: 0.3758 (100000 repetitions, Perl: 0.1596 seconds, CL-PPCRE: 0.0600 seconds) +1153: 0.5027 (100000 repetitions, Perl: 0.1591 seconds, CL-PPCRE: 0.0800 seconds) +1154: 0.4940 (100000 repetitions, Perl: 0.1619 seconds, CL-PPCRE: 0.0800 seconds) +1155: 0.5548 (100000 repetitions, Perl: 0.1262 seconds, CL-PPCRE: 0.0700 seconds) +1156: 0.2429 (100000 repetitions, Perl: 0.1235 seconds, CL-PPCRE: 0.0300 seconds) +1157: 0.2446 (100000 repetitions, Perl: 0.1227 seconds, CL-PPCRE: 0.0300 seconds) +1158: 0.2415 (100000 repetitions, Perl: 0.1242 seconds, CL-PPCRE: 0.0300 seconds) +1159: 0.3301 (1000000 repetitions, Perl: 0.7877 seconds, CL-PPCRE: 0.2600 seconds) +1160: 0.2993 (100000 repetitions, Perl: 0.1336 seconds, CL-PPCRE: 0.0400 seconds) +1161: 0.3004 (100000 repetitions, Perl: 0.1332 seconds, CL-PPCRE: 0.0400 seconds) +1162: 0.4877 (100000 repetitions, Perl: 0.1640 seconds, CL-PPCRE: 0.0800 seconds) +1163: 0.2980 (100000 repetitions, Perl: 0.1678 seconds, CL-PPCRE: 0.0500 seconds) +1164: 0.3522 (100000 repetitions, Perl: 0.1419 seconds, CL-PPCRE: 0.0500 seconds) +1165: 0.3501 (100000 repetitions, Perl: 0.1428 seconds, CL-PPCRE: 0.0500 seconds) +1166: 0.4903 (1000000 repetitions, Perl: 0.6119 seconds, CL-PPCRE: 0.3000 seconds) +1167: 0.5138 (100000 repetitions, Perl: 0.1752 seconds, CL-PPCRE: 0.0900 seconds) +1168: 0.4740 (100000 repetitions, Perl: 0.1899 seconds, CL-PPCRE: 0.0900 seconds) +1169: 0.7838 (100000 repetitions, Perl: 0.1786 seconds, CL-PPCRE: 0.1400 seconds) +1170: 0.5897 (100000 repetitions, Perl: 0.2374 seconds, CL-PPCRE: 0.1400 seconds) +1171: 0.4120 (100000 repetitions, Perl: 0.1456 seconds, CL-PPCRE: 0.0600 seconds) +1172: 0.3606 (100000 repetitions, Perl: 0.3050 seconds, CL-PPCRE: 0.1100 seconds) +1173: 0.3640 (100000 repetitions, Perl: 0.3022 seconds, CL-PPCRE: 0.1100 seconds) +1174: 0.3397 (100000 repetitions, Perl: 0.2943 seconds, CL-PPCRE: 0.1000 seconds) +1175: 0.3675 (100000 repetitions, Perl: 0.2993 seconds, CL-PPCRE: 0.1100 seconds) +1176: 0.3699 (100000 repetitions, Perl: 0.1892 seconds, CL-PPCRE: 0.0700 seconds) +1177: 0.3681 (100000 repetitions, Perl: 0.1902 seconds, CL-PPCRE: 0.0700 seconds) +1178: 0.2174 (100000 repetitions, Perl: 0.1380 seconds, CL-PPCRE: 0.0300 seconds) +1179: 0.4697 (1000000 repetitions, Perl: 0.6175 seconds, CL-PPCRE: 0.2900 seconds) +1180: 0.5686 (100000 repetitions, Perl: 0.1583 seconds, CL-PPCRE: 0.0900 seconds) +1181: 0.5004 (100000 repetitions, Perl: 0.1599 seconds, CL-PPCRE: 0.0800 seconds) +1182: 0.3159 (100000 repetitions, Perl: 0.1583 seconds, CL-PPCRE: 0.0500 seconds) +1183: 0.3580 (100000 repetitions, Perl: 0.2234 seconds, CL-PPCRE: 0.0800 seconds) +1184: 0.4515 (100000 repetitions, Perl: 0.1550 seconds, CL-PPCRE: 0.0700 seconds) +1185: 0.2848 (100000 repetitions, Perl: 0.1755 seconds, CL-PPCRE: 0.0500 seconds) +1186: 0.2827 (100000 repetitions, Perl: 0.1769 seconds, CL-PPCRE: 0.0500 seconds) +1187: 0.7259 (100000 repetitions, Perl: 0.2066 seconds, CL-PPCRE: 0.1500 seconds) +1188: 0.2363 (100000 repetitions, Perl: 0.1693 seconds, CL-PPCRE: 0.0400 seconds) +1189: 0.6586 (100000 repetitions, Perl: 0.3340 seconds, CL-PPCRE: 0.2200 seconds) +1190: 0.5050 (100000 repetitions, Perl: 0.2178 seconds, CL-PPCRE: 0.1100 seconds) +1191: 0.4693 (100000 repetitions, Perl: 0.1918 seconds, CL-PPCRE: 0.0900 seconds) +1192: 0.3908 (100000 repetitions, Perl: 0.2047 seconds, CL-PPCRE: 0.0800 seconds) +1193: 0.4733 (100000 repetitions, Perl: 0.2324 seconds, CL-PPCRE: 0.1100 seconds) +1194: 0.4724 (100000 repetitions, Perl: 0.2329 seconds, CL-PPCRE: 0.1100 seconds) +1195: 0.4342 (100000 repetitions, Perl: 0.2534 seconds, CL-PPCRE: 0.1100 seconds) +1196: 0.3314 (100000 repetitions, Perl: 0.1811 seconds, CL-PPCRE: 0.0600 seconds) +1197: 0.5206 (1000000 repetitions, Perl: 0.6147 seconds, CL-PPCRE: 0.3200 seconds) +1198: 0.7281 (1000000 repetitions, Perl: 0.6180 seconds, CL-PPCRE: 0.4500 seconds) +1199: 0.5142 (100000 repetitions, Perl: 0.1556 seconds, CL-PPCRE: 0.0800 seconds) +1200: 0.5652 (100000 repetitions, Perl: 0.2123 seconds, CL-PPCRE: 0.1200 seconds) +1201: 0.8035 (100000 repetitions, Perl: 0.1494 seconds, CL-PPCRE: 0.1200 seconds) +1202: 0.4921 (100000 repetitions, Perl: 0.2439 seconds, CL-PPCRE: 0.1200 seconds) +1203: 0.5212 (100000 repetitions, Perl: 0.1727 seconds, CL-PPCRE: 0.0900 seconds) +1204: 0.5820 (100000 repetitions, Perl: 0.1890 seconds, CL-PPCRE: 0.1100 seconds) +1205: 0.5753 (100000 repetitions, Perl: 0.2260 seconds, CL-PPCRE: 0.1300 seconds) +1206: 0.5358 (100000 repetitions, Perl: 0.2986 seconds, CL-PPCRE: 0.1600 seconds) +1207: 0.5399 (100000 repetitions, Perl: 0.2963 seconds, CL-PPCRE: 0.1600 seconds) +1208: 1.0716 (100000 repetitions, Perl: 0.2053 seconds, CL-PPCRE: 0.2200 seconds) +1209: 1.1409 (100000 repetitions, Perl: 0.2104 seconds, CL-PPCRE: 0.2400 seconds) +1210: 1.1050 (100000 repetitions, Perl: 0.1991 seconds, CL-PPCRE: 0.2200 seconds) +1211: 0.4698 (1000000 repetitions, Perl: 0.6173 seconds, CL-PPCRE: 0.2900 seconds) +1212: 0.4866 (1000000 repetitions, Perl: 0.6165 seconds, CL-PPCRE: 0.3000 seconds) +1213: 0.3107 (100000 repetitions, Perl: 0.1931 seconds, CL-PPCRE: 0.0600 seconds) +1214: 0.4636 (100000 repetitions, Perl: 0.2157 seconds, CL-PPCRE: 0.1000 seconds) +1215: 0.4719 (100000 repetitions, Perl: 0.2755 seconds, CL-PPCRE: 0.1300 seconds) +1216: 0.2852 (100000 repetitions, Perl: 0.1753 seconds, CL-PPCRE: 0.0500 seconds) +1217: 0.4211 (100000 repetitions, Perl: 0.1900 seconds, CL-PPCRE: 0.0800 seconds) +1218: 0.3272 (100000 repetitions, Perl: 0.1528 seconds, CL-PPCRE: 0.0500 seconds) +1219: 0.4935 (100000 repetitions, Perl: 0.1824 seconds, CL-PPCRE: 0.0900 seconds) +1220: 0.6097 (100000 repetitions, Perl: 0.1968 seconds, CL-PPCRE: 0.1200 seconds) +1221: 0.5091 (100000 repetitions, Perl: 0.1375 seconds, CL-PPCRE: 0.0700 seconds) +1222: 0.5014 (100000 repetitions, Perl: 0.1396 seconds, CL-PPCRE: 0.0700 seconds) +1223: 0.4948 (100000 repetitions, Perl: 0.1617 seconds, CL-PPCRE: 0.0800 seconds) +1224: 0.5640 (100000 repetitions, Perl: 0.3192 seconds, CL-PPCRE: 0.1800 seconds) +1225: 0.8114 (100000 repetitions, Perl: 0.3327 seconds, CL-PPCRE: 0.2700 seconds) +1226: 0.5465 (100000 repetitions, Perl: 0.9515 seconds, CL-PPCRE: 0.5200 seconds) +1227: 0.7252 (10000 repetitions, Perl: 0.1379 seconds, CL-PPCRE: 0.1000 seconds) +1228: 0.3727 (100000 repetitions, Perl: 0.1342 seconds, CL-PPCRE: 0.0500 seconds) +1229: 0.4447 (100000 repetitions, Perl: 0.1349 seconds, CL-PPCRE: 0.0600 seconds) +1230: 0.3507 (100000 repetitions, Perl: 0.1426 seconds, CL-PPCRE: 0.0500 seconds) +1231: 0.3976 (100000 repetitions, Perl: 0.1006 seconds, CL-PPCRE: 0.0400 seconds) +1232: 0.5323 (1000000 repetitions, Perl: 0.7890 seconds, CL-PPCRE: 0.4200 seconds) +1233: 0.4362 (1000000 repetitions, Perl: 0.8253 seconds, CL-PPCRE: 0.3600 seconds) +1234: 0.4144 (1000000 repetitions, Perl: 0.8204 seconds, CL-PPCRE: 0.3400 seconds) +1235: 0.3422 (100000 repetitions, Perl: 0.1461 seconds, CL-PPCRE: 0.0500 seconds) +1236: 0.3898 (100000 repetitions, Perl: 0.1539 seconds, CL-PPCRE: 0.0600 seconds) +1237: 0.3885 (100000 repetitions, Perl: 0.1545 seconds, CL-PPCRE: 0.0600 seconds) +1238: 0.5008 (100000 repetitions, Perl: 0.1997 seconds, CL-PPCRE: 0.1000 seconds) +1239: 0.5094 (100000 repetitions, Perl: 0.1963 seconds, CL-PPCRE: 0.1000 seconds) +1240: 0.4515 (100000 repetitions, Perl: 0.1550 seconds, CL-PPCRE: 0.0700 seconds) +1241: 0.6930 (1000000 repetitions, Perl: 0.6205 seconds, CL-PPCRE: 0.4300 seconds) +1242: 0.6343 (1000000 repetitions, Perl: 0.6148 seconds, CL-PPCRE: 0.3900 seconds) +1243: 0.5096 (100000 repetitions, Perl: 0.1570 seconds, CL-PPCRE: 0.0800 seconds) +1244: 0.5477 (100000 repetitions, Perl: 0.1826 seconds, CL-PPCRE: 0.1000 seconds) +1245: 0.5955 (100000 repetitions, Perl: 0.1847 seconds, CL-PPCRE: 0.1100 seconds) +1246: 0.5025 (100000 repetitions, Perl: 0.1592 seconds, CL-PPCRE: 0.0800 seconds) +1247: 0.6442 (1000000 repetitions, Perl: 0.6209 seconds, CL-PPCRE: 0.4000 seconds) +1248: 0.8571 (1000000 repetitions, Perl: 0.6183 seconds, CL-PPCRE: 0.5300 seconds) +1249: 0.4124 (100000 repetitions, Perl: 0.1697 seconds, CL-PPCRE: 0.0700 seconds) +1250: 0.4076 (100000 repetitions, Perl: 0.1472 seconds, CL-PPCRE: 0.0600 seconds) +1251: 0.4063 (100000 repetitions, Perl: 0.1477 seconds, CL-PPCRE: 0.0600 seconds) +1252: 0.4719 (100000 repetitions, Perl: 0.1483 seconds, CL-PPCRE: 0.0700 seconds) +1253: 0.4707 (100000 repetitions, Perl: 0.1487 seconds, CL-PPCRE: 0.0700 seconds) +1254: 0.4641 (100000 repetitions, Perl: 0.1293 seconds, CL-PPCRE: 0.0600 seconds) +1255: 0.4680 (1000000 repetitions, Perl: 0.9401 seconds, CL-PPCRE: 0.4400 seconds) +1256: 0.4910 (100000 repetitions, Perl: 0.1018 seconds, CL-PPCRE: 0.0500 seconds) +1257: 0.4802 (100000 repetitions, Perl: 0.1249 seconds, CL-PPCRE: 0.0600 seconds) +1258: 0.4269 (100000 repetitions, Perl: 0.1405 seconds, CL-PPCRE: 0.0600 seconds) +1259: 0.2609 (100000 repetitions, Perl: 0.1150 seconds, CL-PPCRE: 0.0300 seconds) +1260: 0.3090 (100000 repetitions, Perl: 0.1294 seconds, CL-PPCRE: 0.0400 seconds) +1261: 0.4528 (100000 repetitions, Perl: 0.1325 seconds, CL-PPCRE: 0.0600 seconds) +1262: 0.4556 (100000 repetitions, Perl: 0.1317 seconds, CL-PPCRE: 0.0600 seconds) +1263: 0.5502 (100000 repetitions, Perl: 0.1454 seconds, CL-PPCRE: 0.0800 seconds) +1264: 0.4150 (100000 repetitions, Perl: 0.1446 seconds, CL-PPCRE: 0.0600 seconds) +1265: 0.3445 (100000 repetitions, Perl: 0.1161 seconds, CL-PPCRE: 0.0400 seconds) +1266: 0.4460 (100000 repetitions, Perl: 0.1345 seconds, CL-PPCRE: 0.0600 seconds) +1267: 0.4512 (100000 repetitions, Perl: 0.1330 seconds, CL-PPCRE: 0.0600 seconds) +1268: 0.2792 (100000 repetitions, Perl: 0.1075 seconds, CL-PPCRE: 0.0300 seconds) +1269: 0.3707 (100000 repetitions, Perl: 0.1079 seconds, CL-PPCRE: 0.0400 seconds) +1270: 0.4187 (100000 repetitions, Perl: 0.1433 seconds, CL-PPCRE: 0.0600 seconds) +1271: 0.3944 (100000 repetitions, Perl: 0.1268 seconds, CL-PPCRE: 0.0500 seconds) +1272: 0.3111 (100000 repetitions, Perl: 0.1286 seconds, CL-PPCRE: 0.0400 seconds) +1273: 0.2980 (100000 repetitions, Perl: 0.1342 seconds, CL-PPCRE: 0.0400 seconds) +1274: 0.4554 (100000 repetitions, Perl: 0.1318 seconds, CL-PPCRE: 0.0600 seconds) +1275: 0.4558 (100000 repetitions, Perl: 0.1316 seconds, CL-PPCRE: 0.0600 seconds) +1276: 0.4516 (100000 repetitions, Perl: 0.1329 seconds, CL-PPCRE: 0.0600 seconds) +1277: 0.3876 (100000 repetitions, Perl: 0.1032 seconds, CL-PPCRE: 0.0400 seconds) +1278: 0.4804 (100000 repetitions, Perl: 0.1041 seconds, CL-PPCRE: 0.0500 seconds) +1279: 0.4588 (100000 repetitions, Perl: 0.1308 seconds, CL-PPCRE: 0.0600 seconds) +1280: 0.2754 (100000 repetitions, Perl: 0.1452 seconds, CL-PPCRE: 0.0400 seconds) +1281: 0.2799 (100000 repetitions, Perl: 0.1429 seconds, CL-PPCRE: 0.0400 seconds) +1282: 0.5499 (100000 repetitions, Perl: 0.1455 seconds, CL-PPCRE: 0.0800 seconds) +1283: 0.3526 (100000 repetitions, Perl: 0.1134 seconds, CL-PPCRE: 0.0400 seconds) +1284: 0.3570 (100000 repetitions, Perl: 0.1121 seconds, CL-PPCRE: 0.0400 seconds) +1285: 0.3734 (100000 repetitions, Perl: 0.1339 seconds, CL-PPCRE: 0.0500 seconds) +1286: 0.3545 (100000 repetitions, Perl: 0.1410 seconds, CL-PPCRE: 0.0500 seconds) +1287: 0.4091 (100000 repetitions, Perl: 0.1467 seconds, CL-PPCRE: 0.0600 seconds) +1288: 0.4858 (1000000 repetitions, Perl: 0.6176 seconds, CL-PPCRE: 0.3000 seconds) +1289: 0.6510 (100000 repetitions, Perl: 0.1382 seconds, CL-PPCRE: 0.0900 seconds) +1290: 0.6770 (100000 repetitions, Perl: 0.1477 seconds, CL-PPCRE: 0.1000 seconds) +1291: 0.6942 (100000 repetitions, Perl: 0.2305 seconds, CL-PPCRE: 0.1600 seconds) +1292: 0.6907 (100000 repetitions, Perl: 0.2316 seconds, CL-PPCRE: 0.1600 seconds) +1293: 0.4198 (100000 repetitions, Perl: 0.1429 seconds, CL-PPCRE: 0.0600 seconds) +1294: 0.4822 (100000 repetitions, Perl: 0.1452 seconds, CL-PPCRE: 0.0700 seconds) +1295: 0.4146 (100000 repetitions, Perl: 0.1447 seconds, CL-PPCRE: 0.0600 seconds) +1296: 0.3391 (100000 repetitions, Perl: 0.3244 seconds, CL-PPCRE: 0.1100 seconds) +1297: 0.3420 (100000 repetitions, Perl: 0.3217 seconds, CL-PPCRE: 0.1100 seconds) +1298: 0.3516 (100000 repetitions, Perl: 0.3128 seconds, CL-PPCRE: 0.1100 seconds) +1299: 0.3490 (100000 repetitions, Perl: 0.3152 seconds, CL-PPCRE: 0.1100 seconds) +1300: 0.3570 (100000 repetitions, Perl: 0.1961 seconds, CL-PPCRE: 0.0700 seconds) +1301: 0.3511 (100000 repetitions, Perl: 0.1994 seconds, CL-PPCRE: 0.0700 seconds) +1302: 0.3363 (100000 repetitions, Perl: 0.1487 seconds, CL-PPCRE: 0.0500 seconds) +1303: 0.2163 (100000 repetitions, Perl: 0.1387 seconds, CL-PPCRE: 0.0300 seconds) +1304: 0.5458 (100000 repetitions, Perl: 0.1649 seconds, CL-PPCRE: 0.0900 seconds) +1305: 0.5308 (100000 repetitions, Perl: 0.1696 seconds, CL-PPCRE: 0.0900 seconds) +1306: 0.2966 (100000 repetitions, Perl: 0.1686 seconds, CL-PPCRE: 0.0500 seconds) +1307: 0.4821 (100000 repetitions, Perl: 0.1867 seconds, CL-PPCRE: 0.0900 seconds) +1308: 0.4939 (100000 repetitions, Perl: 0.1620 seconds, CL-PPCRE: 0.0800 seconds) +1309: 0.3487 (100000 repetitions, Perl: 0.1434 seconds, CL-PPCRE: 0.0500 seconds) +1310: 0.3636 (100000 repetitions, Perl: 0.1375 seconds, CL-PPCRE: 0.0500 seconds) +1311: 0.6696 (100000 repetitions, Perl: 0.2539 seconds, CL-PPCRE: 0.1700 seconds) +1312: 0.3703 (100000 repetitions, Perl: 0.1350 seconds, CL-PPCRE: 0.0500 seconds) +1313: 0.4320 (100000 repetitions, Perl: 0.1389 seconds, CL-PPCRE: 0.0600 seconds) +1314: 0.6490 (100000 repetitions, Perl: 0.3544 seconds, CL-PPCRE: 0.2300 seconds) +1315: 0.5671 (100000 repetitions, Perl: 0.2292 seconds, CL-PPCRE: 0.1300 seconds) +1316: 0.5198 (100000 repetitions, Perl: 0.2116 seconds, CL-PPCRE: 0.1100 seconds) +1317: 0.4623 (100000 repetitions, Perl: 0.1730 seconds, CL-PPCRE: 0.0800 seconds) +1318: 0.6373 (100000 repetitions, Perl: 0.1883 seconds, CL-PPCRE: 0.1200 seconds) +1319: 0.6446 (100000 repetitions, Perl: 0.1862 seconds, CL-PPCRE: 0.1200 seconds) +1320: 0.6559 (100000 repetitions, Perl: 0.2135 seconds, CL-PPCRE: 0.1400 seconds) +1321: 0.4390 (100000 repetitions, Perl: 0.1822 seconds, CL-PPCRE: 0.0800 seconds) +1322: 0.5881 (100000 repetitions, Perl: 0.1700 seconds, CL-PPCRE: 0.1000 seconds) +1323: 0.7739 (100000 repetitions, Perl: 0.1680 seconds, CL-PPCRE: 0.1300 seconds) +1324: 0.3400 (100000 repetitions, Perl: 0.1471 seconds, CL-PPCRE: 0.0500 seconds) +1325: 0.5080 (100000 repetitions, Perl: 0.2559 seconds, CL-PPCRE: 0.1300 seconds) +1326: 0.5332 (100000 repetitions, Perl: 0.1875 seconds, CL-PPCRE: 0.1000 seconds) +1327: 0.5438 (100000 repetitions, Perl: 0.2023 seconds, CL-PPCRE: 0.1100 seconds) +1328: 0.5896 (100000 repetitions, Perl: 0.2374 seconds, CL-PPCRE: 0.1400 seconds) +1329: 0.6437 (100000 repetitions, Perl: 0.4194 seconds, CL-PPCRE: 0.2700 seconds) +1330: 0.5475 (100000 repetitions, Perl: 0.3105 seconds, CL-PPCRE: 0.1700 seconds) +1331: 0.5626 (100000 repetitions, Perl: 0.3022 seconds, CL-PPCRE: 0.1700 seconds) +1332: 1.2478 (100000 repetitions, Perl: 0.1763 seconds, CL-PPCRE: 0.2200 seconds) +1333: 1.3674 (100000 repetitions, Perl: 0.1828 seconds, CL-PPCRE: 0.2500 seconds) +1334: 1.2733 (100000 repetitions, Perl: 0.1728 seconds, CL-PPCRE: 0.2200 seconds) +1335: 0.5285 (100000 repetitions, Perl: 0.1325 seconds, CL-PPCRE: 0.0700 seconds) +1336: 0.4142 (100000 repetitions, Perl: 0.1690 seconds, CL-PPCRE: 0.0700 seconds) +1337: 0.4689 (1000000 repetitions, Perl: 0.6185 seconds, CL-PPCRE: 0.2900 seconds) +1338: 0.4705 (1000000 repetitions, Perl: 0.6164 seconds, CL-PPCRE: 0.2900 seconds) +1339: 0.5296 (100000 repetitions, Perl: 0.1511 seconds, CL-PPCRE: 0.0800 seconds) +1340: 0.5221 (100000 repetitions, Perl: 0.1915 seconds, CL-PPCRE: 0.1000 seconds) +1341: 0.5562 (100000 repetitions, Perl: 0.2337 seconds, CL-PPCRE: 0.1300 seconds) +1342: 0.4419 (100000 repetitions, Perl: 0.1358 seconds, CL-PPCRE: 0.0600 seconds) +1343: 0.6095 (100000 repetitions, Perl: 0.1477 seconds, CL-PPCRE: 0.0900 seconds) +1344: 0.3896 (100000 repetitions, Perl: 0.1540 seconds, CL-PPCRE: 0.0600 seconds) +1345: 0.5580 (100000 repetitions, Perl: 0.1613 seconds, CL-PPCRE: 0.0900 seconds) +1346: 0.5612 (100000 repetitions, Perl: 0.1960 seconds, CL-PPCRE: 0.1100 seconds) +1347: 0.3277 (100000 repetitions, Perl: 0.2136 seconds, CL-PPCRE: 0.0700 seconds) +1348: 0.2471 (100000 repetitions, Perl: 0.2428 seconds, CL-PPCRE: 0.0600 seconds) +1349: 0.2891 (100000 repetitions, Perl: 0.2767 seconds, CL-PPCRE: 0.0800 seconds) +1350: 0.3802 (100000 repetitions, Perl: 0.2104 seconds, CL-PPCRE: 0.0800 seconds) +1351: 0.3484 (100000 repetitions, Perl: 0.2583 seconds, CL-PPCRE: 0.0900 seconds) +1352: 0.3698 (100000 repetitions, Perl: 0.2433 seconds, CL-PPCRE: 0.0900 seconds) +1353: 0.3679 (100000 repetitions, Perl: 0.2447 seconds, CL-PPCRE: 0.0900 seconds) +1354: 0.3893 (100000 repetitions, Perl: 0.3853 seconds, CL-PPCRE: 0.1500 seconds) +1355: 0.3846 (100000 repetitions, Perl: 0.2600 seconds, CL-PPCRE: 0.1000 seconds) +1356: 0.4225 (100000 repetitions, Perl: 0.3313 seconds, CL-PPCRE: 0.1400 seconds) +1357: 0.4133 (100000 repetitions, Perl: 0.3145 seconds, CL-PPCRE: 0.1300 seconds) +1358: 0.4143 (100000 repetitions, Perl: 0.3379 seconds, CL-PPCRE: 0.1400 seconds) +1359: 0.3678 (100000 repetitions, Perl: 0.3806 seconds, CL-PPCRE: 0.1400 seconds) +1360: 0.4124 (100000 repetitions, Perl: 0.3637 seconds, CL-PPCRE: 0.1500 seconds) +1361: 0.4276 (100000 repetitions, Perl: 0.3508 seconds, CL-PPCRE: 0.1500 seconds) +1362: 0.4059 (100000 repetitions, Perl: 0.3449 seconds, CL-PPCRE: 0.1400 seconds) +1363: 0.3658 (100000 repetitions, Perl: 0.3827 seconds, CL-PPCRE: 0.1400 seconds) +1364: 0.4070 (100000 repetitions, Perl: 0.3440 seconds, CL-PPCRE: 0.1400 seconds) +1365: 0.4046 (100000 repetitions, Perl: 0.2966 seconds, CL-PPCRE: 0.1200 seconds) +1366: 0.3032 (100000 repetitions, Perl: 0.2639 seconds, CL-PPCRE: 0.0800 seconds) +1367: 0.5464 (100000 repetitions, Perl: 0.1464 seconds, CL-PPCRE: 0.0800 seconds) +1368: 0.2849 (100000 repetitions, Perl: 0.1404 seconds, CL-PPCRE: 0.0400 seconds) +1369: 0.4075 (100000 repetitions, Perl: 0.4172 seconds, CL-PPCRE: 0.1700 seconds) +1370: 0.9250 (1000000 repetitions, Perl: 0.6162 seconds, CL-PPCRE: 0.5700 seconds) +1371: 0.4216 (100000 repetitions, Perl: 0.7589 seconds, CL-PPCRE: 0.3200 seconds) +1372: 0.4316 (100000 repetitions, Perl: 0.7877 seconds, CL-PPCRE: 0.3400 seconds) +1373: 0.6365 (100000 repetitions, Perl: 0.2828 seconds, CL-PPCRE: 0.1800 seconds) +1374: 0.7316 (100000 repetitions, Perl: 0.2324 seconds, CL-PPCRE: 0.1700 seconds) +1375: 0.6991 (100000 repetitions, Perl: 0.2575 seconds, CL-PPCRE: 0.1800 seconds) +1376: 0.4090 (100000 repetitions, Perl: 0.3912 seconds, CL-PPCRE: 0.1600 seconds) +1377: 0.2652 (100000 repetitions, Perl: 0.1885 seconds, CL-PPCRE: 0.0500 seconds) +1378: 0.3020 (100000 repetitions, Perl: 0.1325 seconds, CL-PPCRE: 0.0400 seconds) +1379: 0.2309 (100000 repetitions, Perl: 0.1299 seconds, CL-PPCRE: 0.0300 seconds) +1380: 0.2177 (100000 repetitions, Perl: 0.1838 seconds, CL-PPCRE: 0.0400 seconds) +1381: 0.2384 (100000 repetitions, Perl: 0.1678 seconds, CL-PPCRE: 0.0400 seconds) +1382: 0.2337 (100000 repetitions, Perl: 0.1711 seconds, CL-PPCRE: 0.0400 seconds) +1383: 0.2700 (100000 repetitions, Perl: 0.1852 seconds, CL-PPCRE: 0.0500 seconds) +1384: 0.2408 (100000 repetitions, Perl: 0.1661 seconds, CL-PPCRE: 0.0400 seconds) +1385: 0.4655 (100000 repetitions, Perl: 0.3437 seconds, CL-PPCRE: 0.1600 seconds) +1386: 0.8942 (100000 repetitions, Perl: 0.1342 seconds, CL-PPCRE: 0.1200 seconds) +1387: 0.3001 (100000 repetitions, Perl: 0.3665 seconds, CL-PPCRE: 0.1100 seconds) +1388: 0.3030 (100000 repetitions, Perl: 0.5611 seconds, CL-PPCRE: 0.1700 seconds) +1389: 0.3822 (100000 repetitions, Perl: 0.6802 seconds, CL-PPCRE: 0.2600 seconds) +1390: 0.4852 (100000 repetitions, Perl: 0.2473 seconds, CL-PPCRE: 0.1200 seconds) +1391: 0.7024 (100000 repetitions, Perl: 0.1424 seconds, CL-PPCRE: 0.1000 seconds) +1392: 0.3041 (100000 repetitions, Perl: 0.1644 seconds, CL-PPCRE: 0.0500 seconds) +1393: 0.5266 (100000 repetitions, Perl: 0.1709 seconds, CL-PPCRE: 0.0900 seconds) +1394: 0.3038 (100000 repetitions, Perl: 0.1646 seconds, CL-PPCRE: 0.0500 seconds) +1395: 0.4551 (100000 repetitions, Perl: 0.1758 seconds, CL-PPCRE: 0.0800 seconds) +1396: 0.3618 (1000000 repetitions, Perl: 0.8845 seconds, CL-PPCRE: 0.3200 seconds) +1397: 0.4574 (1000000 repetitions, Perl: 0.7651 seconds, CL-PPCRE: 0.3500 seconds) +1398: 0.3032 (100000 repetitions, Perl: 0.1649 seconds, CL-PPCRE: 0.0500 seconds) +1399: 0.4585 (100000 repetitions, Perl: 0.1745 seconds, CL-PPCRE: 0.0800 seconds) +1400: 0.3029 (100000 repetitions, Perl: 0.1651 seconds, CL-PPCRE: 0.0500 seconds) +1401: 0.4451 (100000 repetitions, Perl: 0.1797 seconds, CL-PPCRE: 0.0800 seconds) +1402: 0.4356 (1000000 repetitions, Perl: 0.7805 seconds, CL-PPCRE: 0.3400 seconds) +1403: 0.4575 (1000000 repetitions, Perl: 0.7651 seconds, CL-PPCRE: 0.3500 seconds) +1404: 0.3098 (100000 repetitions, Perl: 0.1614 seconds, CL-PPCRE: 0.0500 seconds) +1405: 0.4778 (100000 repetitions, Perl: 0.1674 seconds, CL-PPCRE: 0.0800 seconds) +1406: 0.3176 (100000 repetitions, Perl: 0.1574 seconds, CL-PPCRE: 0.0500 seconds) +1407: 0.5297 (100000 repetitions, Perl: 0.1699 seconds, CL-PPCRE: 0.0900 seconds) +1408: 0.3185 (100000 repetitions, Perl: 0.1570 seconds, CL-PPCRE: 0.0500 seconds) +1409: 0.4814 (1000000 repetitions, Perl: 0.7686 seconds, CL-PPCRE: 0.3700 seconds) +1410: 0.3147 (100000 repetitions, Perl: 0.1589 seconds, CL-PPCRE: 0.0500 seconds) +1411: 0.5297 (100000 repetitions, Perl: 0.1699 seconds, CL-PPCRE: 0.0900 seconds) +1412: 0.4106 (1000000 repetitions, Perl: 0.7793 seconds, CL-PPCRE: 0.3200 seconds) +1413: 0.4384 (1000000 repetitions, Perl: 0.7756 seconds, CL-PPCRE: 0.3400 seconds) +1414: 0.3158 (100000 repetitions, Perl: 0.1583 seconds, CL-PPCRE: 0.0500 seconds) +1415: 0.4746 (100000 repetitions, Perl: 0.1686 seconds, CL-PPCRE: 0.0800 seconds) +1416: 0.3202 (100000 repetitions, Perl: 0.1561 seconds, CL-PPCRE: 0.0500 seconds) +1417: 0.5344 (100000 repetitions, Perl: 0.1684 seconds, CL-PPCRE: 0.0900 seconds) +1418: 0.4052 (1000000 repetitions, Perl: 0.7651 seconds, CL-PPCRE: 0.3100 seconds) +1419: 0.3992 (1000000 repetitions, Perl: 0.7765 seconds, CL-PPCRE: 0.3100 seconds) +1420: 0.3187 (100000 repetitions, Perl: 0.1569 seconds, CL-PPCRE: 0.0500 seconds) +1421: 0.4692 (100000 repetitions, Perl: 0.1705 seconds, CL-PPCRE: 0.0800 seconds) +1422: 0.4313 (1000000 repetitions, Perl: 0.7652 seconds, CL-PPCRE: 0.3300 seconds) +1423: 0.4179 (1000000 repetitions, Perl: 0.7656 seconds, CL-PPCRE: 0.3200 seconds) +1424: 0.9233 (1000000 repetitions, Perl: 0.6174 seconds, CL-PPCRE: 0.5700 seconds) +1425: 0.5082 (100000 repetitions, Perl: 0.1377 seconds, CL-PPCRE: 0.0700 seconds) +1426: 0.5301 (100000 repetitions, Perl: 0.1698 seconds, CL-PPCRE: 0.0900 seconds) +1427: 0.4377 (100000 repetitions, Perl: 0.1371 seconds, CL-PPCRE: 0.0600 seconds) +1428: 0.8477 (100000 repetitions, Perl: 0.1533 seconds, CL-PPCRE: 0.1300 seconds) +1429: 0.5569 (100000 repetitions, Perl: 0.1616 seconds, CL-PPCRE: 0.0900 seconds) +1430: 0.5470 (100000 repetitions, Perl: 0.1645 seconds, CL-PPCRE: 0.0900 seconds) +1431: 0.2694 (100000 repetitions, Perl: 0.3340 seconds, CL-PPCRE: 0.0900 seconds) +1432: 0.3398 (100000 repetitions, Perl: 0.2648 seconds, CL-PPCRE: 0.0900 seconds) +1433: 0.3196 (100000 repetitions, Perl: 0.1564 seconds, CL-PPCRE: 0.0500 seconds) +1434: 0.2563 (100000 repetitions, Perl: 0.1561 seconds, CL-PPCRE: 0.0400 seconds) +1435: 0.2549 (100000 repetitions, Perl: 0.1569 seconds, CL-PPCRE: 0.0400 seconds) +1436: 0.3966 (1000000 repetitions, Perl: 0.7817 seconds, CL-PPCRE: 0.3100 seconds) +1437: 0.3186 (100000 repetitions, Perl: 0.1569 seconds, CL-PPCRE: 0.0500 seconds) +1438: 0.2879 (100000 repetitions, Perl: 0.1737 seconds, CL-PPCRE: 0.0500 seconds) +1440: 0.4261 (100000 repetitions, Perl: 0.1877 seconds, CL-PPCRE: 0.0800 seconds) +1441: 0.2673 (100000 repetitions, Perl: 0.1871 seconds, CL-PPCRE: 0.0500 seconds) +1442: 0.3109 (100000 repetitions, Perl: 0.2573 seconds, CL-PPCRE: 0.0800 seconds) +1443: 0.8570 (100000 repetitions, Perl: 0.1750 seconds, CL-PPCRE: 0.1500 seconds) +1444: 0.4761 (100000 repetitions, Perl: 0.1470 seconds, CL-PPCRE: 0.0700 seconds) +1445: 0.2776 (100000 repetitions, Perl: 0.1441 seconds, CL-PPCRE: 0.0400 seconds) +1446: 0.4592 (100000 repetitions, Perl: 0.1525 seconds, CL-PPCRE: 0.0700 seconds) +1447: 0.4758 (100000 repetitions, Perl: 0.1471 seconds, CL-PPCRE: 0.0700 seconds) +1448: 0.5301 (100000 repetitions, Perl: 0.1698 seconds, CL-PPCRE: 0.0900 seconds) +1449: 0.6724 (100000 repetitions, Perl: 0.1933 seconds, CL-PPCRE: 0.1300 seconds) +1450: 0.6677 (100000 repetitions, Perl: 0.1947 seconds, CL-PPCRE: 0.1300 seconds) +1451: 0.4503 (100000 repetitions, Perl: 0.1999 seconds, CL-PPCRE: 0.0900 seconds) +1452: 0.4078 (100000 repetitions, Perl: 0.1962 seconds, CL-PPCRE: 0.0800 seconds) +1453: 0.5974 (100000 repetitions, Perl: 0.1339 seconds, CL-PPCRE: 0.0800 seconds) +1454: 0.6096 (100000 repetitions, Perl: 0.1312 seconds, CL-PPCRE: 0.0800 seconds) +1455: 0.4783 (100000 repetitions, Perl: 0.1464 seconds, CL-PPCRE: 0.0700 seconds) +1456: 0.2228 (100000 repetitions, Perl: 0.1347 seconds, CL-PPCRE: 0.0300 seconds) +1457: 0.3958 (100000 repetitions, Perl: 0.1516 seconds, CL-PPCRE: 0.0600 seconds) +1458: 0.4623 (100000 repetitions, Perl: 0.1514 seconds, CL-PPCRE: 0.0700 seconds) +1459: 0.4619 (100000 repetitions, Perl: 0.1515 seconds, CL-PPCRE: 0.0700 seconds) +1460: 0.4710 (100000 repetitions, Perl: 0.1699 seconds, CL-PPCRE: 0.0800 seconds) +1461: 0.4722 (100000 repetitions, Perl: 0.1482 seconds, CL-PPCRE: 0.0700 seconds) +1462: 0.5930 (100000 repetitions, Perl: 0.1686 seconds, CL-PPCRE: 0.1000 seconds) +1463: 0.5698 (100000 repetitions, Perl: 0.1579 seconds, CL-PPCRE: 0.0900 seconds) +1464: 0.8227 (1000000 repetitions, Perl: 0.6199 seconds, CL-PPCRE: 0.5100 seconds) +1465: 0.5918 (100000 repetitions, Perl: 0.1352 seconds, CL-PPCRE: 0.0800 seconds) +1466: 0.7302 (100000 repetitions, Perl: 0.1370 seconds, CL-PPCRE: 0.1000 seconds) +1467: 0.3578 (100000 repetitions, Perl: 0.2795 seconds, CL-PPCRE: 0.1000 seconds) +1468: 0.3107 (100000 repetitions, Perl: 0.2574 seconds, CL-PPCRE: 0.0800 seconds) +1469: 0.3741 (100000 repetitions, Perl: 0.2139 seconds, CL-PPCRE: 0.0800 seconds) +1470: 0.4383 (100000 repetitions, Perl: 0.2281 seconds, CL-PPCRE: 0.1000 seconds) +1471: 0.1875 (100000 repetitions, Perl: 0.1600 seconds, CL-PPCRE: 0.0300 seconds) +1472: 0.1889 (100000 repetitions, Perl: 0.1588 seconds, CL-PPCRE: 0.0300 seconds) +1473: 0.2495 (100000 repetitions, Perl: 0.1603 seconds, CL-PPCRE: 0.0400 seconds) +1474: 0.2374 (100000 repetitions, Perl: 0.1685 seconds, CL-PPCRE: 0.0400 seconds) +1475: 0.5786 (100000 repetitions, Perl: 0.2420 seconds, CL-PPCRE: 0.1400 seconds) +1476: 0.3304 (100000 repetitions, Perl: 0.2724 seconds, CL-PPCRE: 0.0900 seconds) +1477: 0.4475 (100000 repetitions, Perl: 0.1788 seconds, CL-PPCRE: 0.0800 seconds) +1478: 0.6218 (100000 repetitions, Perl: 0.2412 seconds, CL-PPCRE: 0.1500 seconds) +1479: 0.5484 (100000 repetitions, Perl: 0.1459 seconds, CL-PPCRE: 0.0800 seconds) +1480: 0.6176 (100000 repetitions, Perl: 0.1457 seconds, CL-PPCRE: 0.0900 seconds) +1481: 0.5064 (100000 repetitions, Perl: 0.2567 seconds, CL-PPCRE: 0.1300 seconds) +1482: 0.9923 (100000 repetitions, Perl: 0.3023 seconds, CL-PPCRE: 0.3000 seconds) +1483: 0.4191 (100000 repetitions, Perl: 0.1909 seconds, CL-PPCRE: 0.0800 seconds) +1484: 0.4962 (100000 repetitions, Perl: 0.1814 seconds, CL-PPCRE: 0.0900 seconds) +1485: 0.5508 (100000 repetitions, Perl: 0.2542 seconds, CL-PPCRE: 0.1400 seconds) +1486: 1.0588 (100000 repetitions, Perl: 0.3022 seconds, CL-PPCRE: 0.3200 seconds) +1487: 0.7284 (100000 repetitions, Perl: 0.6453 seconds, CL-PPCRE: 0.4700 seconds) +1488: 0.7429 (100000 repetitions, Perl: 0.6461 seconds, CL-PPCRE: 0.4800 seconds) +1489: 0.4189 (100000 repetitions, Perl: 0.1910 seconds, CL-PPCRE: 0.0800 seconds) +1490: 0.3235 (100000 repetitions, Perl: 0.1546 seconds, CL-PPCRE: 0.0500 seconds) +1491: 0.5143 (100000 repetitions, Perl: 0.1556 seconds, CL-PPCRE: 0.0800 seconds) +1492: 0.4563 (100000 repetitions, Perl: 0.1534 seconds, CL-PPCRE: 0.0700 seconds) +1493: 0.5185 (100000 repetitions, Perl: 0.1543 seconds, CL-PPCRE: 0.0800 seconds) +1494: 0.4955 (100000 repetitions, Perl: 0.1615 seconds, CL-PPCRE: 0.0800 seconds) +1495: 0.4944 (100000 repetitions, Perl: 0.1618 seconds, CL-PPCRE: 0.0800 seconds) +1496: 0.4331 (100000 repetitions, Perl: 0.8082 seconds, CL-PPCRE: 0.3500 seconds) +1497: 0.7886 (1000000 repetitions, Perl: 0.7608 seconds, CL-PPCRE: 0.6000 seconds) +1498: 0.5902 (1000000 repetitions, Perl: 0.7624 seconds, CL-PPCRE: 0.4500 seconds) +1499: 0.2554 (100000 repetitions, Perl: 0.1566 seconds, CL-PPCRE: 0.0400 seconds) +1500: 0.2541 (100000 repetitions, Perl: 0.1574 seconds, CL-PPCRE: 0.0400 seconds) +1501: 0.2524 (100000 repetitions, Perl: 0.1585 seconds, CL-PPCRE: 0.0400 seconds) +1502: 0.3265 (100000 repetitions, Perl: 0.3369 seconds, CL-PPCRE: 0.1100 seconds) +1503: 0.3811 (100000 repetitions, Perl: 0.3674 seconds, CL-PPCRE: 0.1400 seconds) +1504: 0.3815 (100000 repetitions, Perl: 0.3670 seconds, CL-PPCRE: 0.1400 seconds) +1505: 0.3818 (100000 repetitions, Perl: 0.3667 seconds, CL-PPCRE: 0.1400 seconds) +1506: 0.4213 (100000 repetitions, Perl: 0.4510 seconds, CL-PPCRE: 0.1900 seconds) +1507: 0.4781 (100000 repetitions, Perl: 0.5438 seconds, CL-PPCRE: 0.2600 seconds) +1508: 0.6455 (100000 repetitions, Perl: 0.6972 seconds, CL-PPCRE: 0.4500 seconds) +1509: 0.5764 (100000 repetitions, Perl: 0.5899 seconds, CL-PPCRE: 0.3400 seconds) +1510: 0.5361 (100000 repetitions, Perl: 0.4850 seconds, CL-PPCRE: 0.2600 seconds) +1511: 0.7082 (1000000 repetitions, Perl: 0.6495 seconds, CL-PPCRE: 0.4600 seconds) +1512: 0.5625 (100000 repetitions, Perl: 0.1600 seconds, CL-PPCRE: 0.0900 seconds) +1513: 0.5700 (100000 repetitions, Perl: 0.1579 seconds, CL-PPCRE: 0.0900 seconds) +1514: 0.5287 (100000 repetitions, Perl: 0.2837 seconds, CL-PPCRE: 0.1500 seconds) +1515: 0.5201 (100000 repetitions, Perl: 0.2884 seconds, CL-PPCRE: 0.1500 seconds) +1516: 0.5035 (100000 repetitions, Perl: 0.2780 seconds, CL-PPCRE: 0.1400 seconds) +1517: 0.5849 (100000 repetitions, Perl: 0.2906 seconds, CL-PPCRE: 0.1700 seconds) +1518: 0.6021 (100000 repetitions, Perl: 0.2824 seconds, CL-PPCRE: 0.1700 seconds) +1519: 0.6077 (100000 repetitions, Perl: 0.3127 seconds, CL-PPCRE: 0.1900 seconds) +1520: 0.7115 (100000 repetitions, Perl: 0.6746 seconds, CL-PPCRE: 0.4800 seconds) +1521: 0.7063 (100000 repetitions, Perl: 0.6796 seconds, CL-PPCRE: 0.4800 seconds) +1522: 0.7059 (100000 repetitions, Perl: 0.6658 seconds, CL-PPCRE: 0.4700 seconds) +1523: 0.7191 (100000 repetitions, Perl: 0.6675 seconds, CL-PPCRE: 0.4800 seconds) +1524: 0.4683 (100000 repetitions, Perl: 0.1922 seconds, CL-PPCRE: 0.0900 seconds) +1525: 0.4213 (100000 repetitions, Perl: 0.2136 seconds, CL-PPCRE: 0.0900 seconds) +1526: 0.0286 (10000 repetitions, Perl: 0.3498 seconds, CL-PPCRE: 0.0100 seconds) +1527: 0.6763 (100000 repetitions, Perl: 0.8429 seconds, CL-PPCRE: 0.5700 seconds) +1528: 0.8554 (1000000 repetitions, Perl: 0.8768 seconds, CL-PPCRE: 0.7500 seconds) +1529: 0.9597 (100000 repetitions, Perl: 0.1146 seconds, CL-PPCRE: 0.1100 seconds) +1530: 0.2910 (100000 repetitions, Perl: 0.2406 seconds, CL-PPCRE: 0.0700 seconds) +1531: 0.2867 (100000 repetitions, Perl: 0.2442 seconds, CL-PPCRE: 0.0700 seconds) +1532: 0.3131 (100000 repetitions, Perl: 0.1597 seconds, CL-PPCRE: 0.0500 seconds) +1533: 0.3589 (100000 repetitions, Perl: 0.2508 seconds, CL-PPCRE: 0.0900 seconds) +1534: 0.3536 (100000 repetitions, Perl: 0.2546 seconds, CL-PPCRE: 0.0900 seconds) +1535: 0.3596 (100000 repetitions, Perl: 0.1947 seconds, CL-PPCRE: 0.0700 seconds) +1536: 0.3210 (100000 repetitions, Perl: 0.2492 seconds, CL-PPCRE: 0.0800 seconds) +1537: 0.2765 (100000 repetitions, Perl: 0.2531 seconds, CL-PPCRE: 0.0700 seconds) +1538: 0.3216 (100000 repetitions, Perl: 0.1866 seconds, CL-PPCRE: 0.0600 seconds) +1539: 0.3169 (100000 repetitions, Perl: 0.2524 seconds, CL-PPCRE: 0.0800 seconds) +1540: 0.3192 (100000 repetitions, Perl: 0.2506 seconds, CL-PPCRE: 0.0800 seconds) +1541: 0.3373 (100000 repetitions, Perl: 0.2075 seconds, CL-PPCRE: 0.0700 seconds) +1542: 0.7186 (100000 repetitions, Perl: 0.2644 seconds, CL-PPCRE: 0.1900 seconds) +1543: 0.7809 (100000 repetitions, Perl: 0.4354 seconds, CL-PPCRE: 0.3400 seconds) +1544: 0.7975 (100000 repetitions, Perl: 0.4389 seconds, CL-PPCRE: 0.3500 seconds) +1545: 0.7251 (100000 repetitions, Perl: 0.2620 seconds, CL-PPCRE: 0.1900 seconds) +1546: 0.7521 (100000 repetitions, Perl: 0.4387 seconds, CL-PPCRE: 0.3300 seconds) +1547: 0.8778 (100000 repetitions, Perl: 0.4443 seconds, CL-PPCRE: 0.3900 seconds) +1548: 0.5969 (100000 repetitions, Perl: 0.3016 seconds, CL-PPCRE: 0.1800 seconds) +1549: 0.7601 (100000 repetitions, Perl: 0.4736 seconds, CL-PPCRE: 0.3600 seconds) +1550: 0.7864 (100000 repetitions, Perl: 0.4832 seconds, CL-PPCRE: 0.3800 seconds) +1551: 0.5106 (100000 repetitions, Perl: 0.3330 seconds, CL-PPCRE: 0.1700 seconds) +1552: 0.4608 (100000 repetitions, Perl: 0.3038 seconds, CL-PPCRE: 0.1400 seconds) +1553: 0.4988 (100000 repetitions, Perl: 0.3207 seconds, CL-PPCRE: 0.1600 seconds) +1554: 0.3418 (100000 repetitions, Perl: 0.3803 seconds, CL-PPCRE: 0.1300 seconds) +1555: 0.3461 (100000 repetitions, Perl: 0.2311 seconds, CL-PPCRE: 0.0800 seconds) +1556: 0.2425 (100000 repetitions, Perl: 0.1237 seconds, CL-PPCRE: 0.0300 seconds) +1557: 0.3378 (100000 repetitions, Perl: 0.1184 seconds, CL-PPCRE: 0.0400 seconds) +1558: 0.3310 (100000 repetitions, Perl: 0.1208 seconds, CL-PPCRE: 0.0400 seconds) +1559: 0.3415 (100000 repetitions, Perl: 0.1171 seconds, CL-PPCRE: 0.0400 seconds) +1560: 0.3131 (1000000 repetitions, Perl: 0.8943 seconds, CL-PPCRE: 0.2800 seconds) +1561: 0.3385 (100000 repetitions, Perl: 0.1182 seconds, CL-PPCRE: 0.0400 seconds) +1562: 0.2542 (100000 repetitions, Perl: 0.1180 seconds, CL-PPCRE: 0.0300 seconds) +1563: 0.2498 (100000 repetitions, Perl: 0.1201 seconds, CL-PPCRE: 0.0300 seconds) +1564: 0.3125 (1000000 repetitions, Perl: 0.8961 seconds, CL-PPCRE: 0.2800 seconds) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/doc/index.html =================================================================== --- vendor/portableaserve/libs/cl-ppcre/doc/index.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/doc/index.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1934 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>CL-PPCRE - portable Perl-compatible regular expressions for Common Lisp</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + a.none { text-decoration: none; color:black } + a.none:visited { text-decoration: none; color:black } + a.none:active { text-decoration: none; color:black } + a.none:hover { text-decoration: none; color:black } + a { text-decoration: none; } + a:visited { text-decoration: none; } + a:active { text-decoration: underline; } + a:hover { text-decoration: underline; } + </style> +</head> + +<body bgcolor=white> + +<h2>CL-PPCRE - portable Perl-compatible regular expressions for Common Lisp</h2> + +<blockquote> +   <h3>Abstract</h3> + +CL-PPCRE is a portable regular expression library for Common Lisp +which has the following features: + +<ul> + +<li>It is compatible with Perl. (Well - as far as you can be +compatible with a language defined by its ever-changing +implementation. Currently, as of December 2002, CL-PPCRE is more +compatible with the regex semantics of Perl 5.8.0 than, say, +Perl 5.6.1 is...:) It even correctly parses and applies <a +href="http://www.oreilly.com/catalog/regex2/">Jeffrey Friedl's</a> +famous 6600-byte long RFC822 address pattern. + +<li>It is fast. If compiled with <a +href="http://www.cons.org/cmucl/">CMUCL</a> it <a +href="#performance">outperforms</a> Perl's highly optimized regex engine (written +in C) which to my knowledge is faster than most other regex engines +around. If compiled with <a +href="http://clisp.sourceforge.net/">CLISP</a> it is still comparable +to CLISP's own regex implementation which is also written in +C. + +<li>It is portable, i.e. the code aims to be strictly <a +href="http://www.lispworks.com/reference/HyperSpec/Front/index.htm">ANSI-compliant</a>. If +you encounter any deviations this is an error and should be +reported to <a +href="#mail">the mailing list</a>. CL-PPCRE has been +successfully tested with the following Common Lisp implementations: + +<ul> + +<li><a href="http://www.franz.com/products/allegrocl/">Allegro Common Lisp</a> (6.2 trial on Gentoo Linux 1.1a) +<li><a href="http://clisp.sourceforge.net/">CLISP</a> (2.30 on Gentoo Linux 1.1a and 2.29 on Windows XP pro) +<li><a href="http://www.cons.org/cmucl/">CMUCL</a> (18e on Gentoo Linux 1.1a) +<li><a href="http://www.cormanlisp.com/">Corman Lisp</a> (2.5 on Windows XP pro) +<li><a href="http://ecls.sourceforge.net/">ECL</a> (0.9c on Gentoo Linux 1.1a) +<li><a href="http://www.digitool.com/">Macintosh Common Lisp</a> (4.3 demo on MacOS 9.1 - only tested with CL-PPCRE 0.1.x) +<li><a href="http://openmcl.clozure.com/">OpenMCL</a> (0.13.4 on MacOS X 10.2.2 - only tested with CL-PPCRE 0.1.x) +<li><a href="http://sbcl.sourceforge.net/">SBCL</a> (0.8.4 on Gentoo Linux 1.1a) +<li><a href="http://www.scieneer.com/scl/">Scieneer Common Lisp</a> (1.1.1 evaluation on Gentoo Linux 1.1a - only tested with CL-PPCRE 0.1.x) +<li><a href="http://www.lispworks.com/">Xanalys LispWorks</a> (4.2.7 professional on Gentoo Linux 1.1a and 4.3.6 professional on Windows XP pro) + +</ul> + +If you succeed in using CL-PPCRE on other platforms please <a +href="#mail">let us know</a>. + + +Note that the tests mainly made sure that the package compiled +without errors and that the <a href="#test">test suite</a> - which +compiles about 1,500 regex strings into scanners and applies these to +target strings with the <a href="#scan"><code>SCAN</code></a> function +- yields the expected results. Other functions like <a +href="#split"><code>SPLIT</code></a>, <a +href="#all-matches"><code>ALL-MATCHES</code></a>, <a +href="#regex-replace"><code>REGEX-REPLACE</code></a>, <a +href="#regex-apropos"><code>REGEX-APROPOS</code></a>, or <a +href="#do-scans">the <code>DO</code>-macros</a> have only been tested +on CMUCL and LispWorks which were my main development platforms. + + Also, I don't have the time to re-test any implementation with +every new release of CL-PPCRE. <a href="#mail">Let us +know</a> if your implementation is listed above and fails with a +recent version and I'll try to fix it. + +<li>It is thread-safe. Although the code uses closures +extensively, no state which dynamically changes during the scanning +process is stored in the lexical environments of the closures, so it +should be safe to use CL-PPCRE in a multi-threaded program. Tests with +LispWorks and Scieneer Common Lisp seem to confirm this. + +<li>It comes with convenient features like a <a +href="#split"><code>SPLIT</code></a> function, a couple of <a +href="#do-scans"><code>DO</code>-like loop constructs</a>, and a <a +href="#regex-apropos"><code>regex-based APROPOS feature</code></a> +similar to the one found in <a +href="http://www.gnu.org/software/emacs/emacs.html">Emacs</a>. + +<li>In addition to specifying regular expressions as strings like in +Perl you can also use <a +href="#create-scanner2">S-expressions</a> which obviously is +more Lisp-y. + +<li>Is it is fully documented so I might have a chance to +understand my own code in about six months... :) + +<li>It comes with a <a +href="http://www.opensource.org/licenses/bsd-license.php">BSD-style +license</a> so you can basically do with it whatever you want. + +</ul> + +</blockquote> + +   <h3><a class=none name="contents">Contents</a></h3> +<ol> + <li><a href="#howto">How to use CL-PPCRE</a> + <ol> + <li><a href="#create-scanner1"><code>create-scanner</code></a> (for Perl regex strings) + <li><a href="#create-scanner2"><code>create-scanner</code></a> (for parse trees) + <li><a href="#scan"><code>scan</code></a> + <li><a href="#scan-to-strings"><code>scan-to-strings</code></a> + <li><a href="#register-groups-bind"><code>register-groups-bind</code></a> + <li><a href="#do-scans"><code>do-scans</code></a> + <li><a href="#do-matches"><code>do-matches</code></a> + <li><a href="#do-matches-as-strings"><code>do-matches-as-strings</code></a> + <li><a href="#do-register-groups"><code>do-register-groups</code></a> + <li><a href="#all-matches"><code>all-matches</code></a> + <li><a href="#all-matches-as-strings"><code>all-matches-as-strings</code></a> + <li><a href="#split"><code>split</code></a> + <li><a href="#regex-replace"><code>regex-replace</code></a> + <li><a href="#regex-replace-all"><code>regex-replace-all</code></a> + <li><a href="#regex-apropos"><code>regex-apropos</code></a> + <li><a href="#regex-apropos-list"><code>regex-apropos-list</code></a> + <li><a href="#regex-char-code-limit"><code>*regex-char-code-limit*</code></a> + <li><a href="#use-bmh-matchers"><code>*use-bmh-matchers*</code></a> + <li><a href="#*allow-quoting*"><code>*allow-quoting*</code></a> + <li><a href="#quote-meta-chars"><code>quote-meta-chars</code></a> + <li><a href="#ppcre-error"><code>ppcre-error</code></a> + <li><a href="#ppcre-invocation-error"><code>ppcre-invocation-error</code></a> + <li><a href="#ppcre-syntax-error"><code>ppcre-syntax-error</code></a> + <li><a href="#ppcre-syntax-error-string"><code>ppcre-syntax-error-string</code></a> + <li><a href="#ppcre-syntax-error-pos"><code>ppcre-syntax-error-pos</code></a> + </ol> + <li><a href="#install">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#test">Testing CL-PPCRE</a> + <li><a href="#perl">Compatibility with Perl</a> + <ol> + <li><a href="#empty">Empty strings instead of <code>undef</code> in <code>$1</code>, <code>$2</code>, etc.</a> + <li><a href="#scope">Strange scoping of embedded modifiers</a> + <li><a href="#inconsistent">Inconsistent capturing of <code>$1</code>, <code>$2</code>, etc.</a> + <li><a href="#lookaround">Captured groups not available outside of look-aheads and look-behinds</a> + <li><a href="#order">Alternations don't always work from left to right</a> + <li><a href="#mac"><code>"\r"</code> doesn't work with MCL</a> + <li><a href="#alpha">What about <code>"\w"</code>?</a> + </ol> + <li><a href="#performance">Performance</a> + <ol> + <li><a href="#bench">Benchmarking</a> + <li><a href="#other">Other performance issues</a> + </ol> + <li><a href="#bugs">Bugs and problems</a> + <ol> + <li><a href="#stack">Stack overflow</a> + <li><a href="#quote"><code>"\Q"</code> doesn't work, or does it?</a> + <li><a href="#backslash">Backslashes may confuse you...</a> + </ol> + <li><a href="#remarks">Remarks</a> + <li><a href="#ack">Acknowledgements</a> +</ol> + +   <h3><a class=none name="howto">How to use CL-PPCRE</a></h3> + +CL-PPCRE exports the following symbols: + + [Function] + <a class=none name="create-scanner1">create-scanner string <tt>&key</tt> case-insensitive-mode multi-line-mode single-line-mode extended-mode destructive => scanner</a> + +<blockquote> Accepts a string which is a regular expression in +Perl syntax and returns a closure which will scan strings for this +regular expression. The mode keyboard arguments are equivalent to the +<code>"imsx"</code> modifiers in Perl. The +<code>destructive</code> keyword will be ignored. + +The function accepts most of the regex syntax of Perl 5 as described +in <a +href="http://www.perldoc.com/perl5.8.0/pod/perlre.html"><code>man +perlre</code></a> including extended features like non-greedy +repetitions, positive and negative look-ahead and look-behind +assertions, "standalone" subexpressions, and conditional +subpatterns. The following Perl features are (currently) not +supported: + +<ul> + +<li><code>(?{ code })</code> and <code>(??{ code })</code> because +they obviously don't make sense in Lisp. + +<li><code>\N{name}</code> (named characters), <code>\x{263a}</code> +(wide hex characters), <code>\l</code>, <code>\u</code>, +<code>\L</code>, and <code>\U</code> +because they're actually not part of Perl's regex syntax and +(honestly) because I was too lazy - but see <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a>. + +<li><code>\pP</code> and <code>\PP</code> (named properties), +<code>\X</code> (extended Unicode), and <code>\C</code> (single +character). But you can of course use all characters +supported by your CL implementation. + +<li>Posix character classes like <code>[[:alpha]]</code>. I +might add this in the future. + +<li><code>\G</code> for Perl's <code>pos()</code> because we don't have it. + +</ul> + +Note, however, that <code>\t</code>, <code>\n</code>, <code>\r</code>, +<code>\f</code>, <code>\a</code>, <code>\e</code>, <code>\033</code> +(octal character codes), <code>\x1B</code> (hexadecimal character +codes), <code>\c[</code> (control characters), <code>\w</code>, +<code>\W</code>, <code>\s</code>, <code>\S</code>, <code>\d</code>, +<code>\D</code>, <code>\b</code>, <code>\B</code>, <code>\A</code>, +<code>\Z</code>, and <code>\z</code> are supported. + +Since version 0.6.0 CL-PPCRE also supports Perl's <code>\Q</code> and <code>\E</code> - see <a +href="#*allow-quoting*"><code>*ALLOW-QUOTING*</code></a> below. Make sure you also read <a href="#quote">the relevant section</a> in "<a href="#bugs">Bugs and problems</a>." + +The keyword arguments are just for your +convenience. You can always use embedded modifiers like +<code>"(?i-s)"</code> instead.</blockquote> + + + [Function] + <a class=none name="create-scanner2">create-scanner parse-tree <tt>&key</tt> case-insensitive-mode multi-line-mode single-line-mode extended-mode destructive => scanner</a> +<blockquote> +This is similar to <a +href="#create-scanner1"><code>CREATE-SCANNER</code></a> above but +accepts a parse tree as its first argument. A parse tree is an S-expression +conforming to the following syntax: + +<ul> + +<li>Every string and character is a parse tree and is treated +literally as a part of the regular expression, +i.e. parentheses, brackets, asterisks and such aren't special. + +<li>The symbol <code>:VOID</code> is equivalent to the empty string. + +<li>The symbol <code>:EVERYTHING</code> is equivalent to Perl's dot, +i.e it matches everything (except maybe a newline character depending +on the mode). + +<li>The symbols <code>:WORD-BOUNDARY</code> and +<code>:NON-WORD-BOUNDARY</code> are equivalent to Perl's +<code>"\b"</code> and <code>"\B"</code>. + +<li>The symbols <code>:DIGIT-CLASS</code>, +<code>:NON-DIGIT-CLASS</code>, <code>:WORD-CHAR-CLASS</code>, +<code>:NON-WORD-CHAR-CLASS</code>, +<code>:WHITESPACE-CHAR-CLASS</code>, and +<code>:NON-WHITESPACE-CHAR-CLASS</code> are equivalent to Perl's +special character classes <code>"\d"</code>, +<code>"\D"</code>, <code>"\w"</code>, +<code>"\W"</code>, <code>"\s"</code>, and +<code>"\S"</code> respectively. + +<li>The symbols <code>:START-ANCHOR</code>, <code>:END-ANCHOR</code>, +<code>:MODELESS-START-ANCHOR</code>, +<code>:MODELESS-END-ANCHOR</code>, and +<code>:MODELESS-END-ANCHOR-NO-NEWLINE</code> are equivalent to Perl's +<code>"^"</code>, <code>"$"</code>, +<code>"\A"</code>, <code>"\Z"</code>, and +<code>"\z"</code> respectively. + +<li>The symbols <code>:CASE-INSENSITIVE-P</code>, +<code>:CASE-SENSITIVE-P</code>, <code>:MULTI-LINE-MODE-P</code>, +<code>:NOT-MULTI-LINE-MODE-P</code>, <code>:SINGLE-LINE-MODE-P</code>, +and <code>:NOT-SINGLE-LINE-MODE-P</code> are equivalent to Perl's +embedded modifiers <code>"(?i)"</code>, +<code>"(?-i)"</code>, <code>"(?m)"</code>, +<code>"(?-m)"</code>, <code>"(?s)"</code>, and +<code>"(?-s)"</code>. As usual, changes applied to modes are +kept local to the innermost enclosing grouping or clustering +construct. + +<li><code>(:FLAGS {<modifier>}*)</code> where +<code><modifier></code> is one of the modifier symbols from +above is used to group modifier symbols. The modifiers are applied +from left to right. (This construct is obviously redundant. It is only +there because it's used by the parser.) + +<li><code>(:SEQUENCE {<parse-tree>}*)</code> means a +sequence of parse trees, i.e. the parse trees must match one after +another. Example: <code>(:SEQUENCE #\f #\o #\o)</code> is equivalent +to the parse tree <code>"foo"</code>. + +<li><code>(:GROUP {<parse-tree>}*)</code> is like +<code>:SEQUENCE</code> but changes applied to modifier flags (see +above) are kept local to the parse trees enclosed by this +construct. Think of it as the S-expression variant of Perl's +<code>"(?:<pattern>)"</code> construct. + +<li><code>(:ALTERNATION {<parse-tree>}*)</code> means an +alternation of parse trees, i.e. one of the parse trees must +match. Example: <code>(:ALTERNATION #\b #\a #\z)</code> is equivalent +to the Perl regex string <code>"b|a|z"</code>. + +<li><code>(:BRANCH <test> +<parse-tree>)</code> is for conditional regular +expressions. <code><test></code> is either a number which +stands for a register or a parse tree which is a look-ahead or +look-behind assertion. See the entry for +<code>(?(<condition>)<yes-pattern>|<no-pattern>)</code> +in <a +href="http://www.perldoc.com/perl5.8.0/pod/perlre.html#Extended-Patterns"><code>man +perlre</code></a> for the semantics of this construct. If +<code><parse-tree></code> is an alternation is +must enclose exactly one or two parse trees where the second +one (if present) will be treated as the "no-pattern" - in +all other cases <code><parse-tree></code> will be treated +as the "yes-pattern". + +<li><code>(:POSITIVE-LOOKAHEAD|:NEGATIVE-LOOKAHEAD|:POSITIVE-LOOKBEHIND|:NEGATIVE-LOOKBEHIND +<parse-tree>)</code> should be pretty obvious... + +<li><code>(:GREEDY-REPETITION|:NON-GREEDY-REPETITION +<min> <max> +<parse-tree>)</code> where +<code><min></code> is a non-negative integer and +<code><max></code> is either a non-negative integer not +smaller than <code><min></code> or <code>NIL</code> will +result in a regular expression which tries to match +<code><parse-tree></code> at least +<code><min></code> times and at most +<code><max></code> times (or as often as possible if +<code><max></code> is <code>NIL</code>). So, e.g., +<code>(:NON-GREEDY-REPETITION 0 1 "ab")</code> is equivalent +to the Perl regex string <code>"(?:ab)??"</code>. + +<li><code>(:STANDALONE <parse-tree>)</code> is an +"independent" subexpression, i.e. <code>(:STANDALONE +"bar")</code> is equivalent to the Perl regex string +<code>"(?>bar)"</code>. + +<li><code>(:REGISTER <parse-tree>)</code> is a capturing +register group. As usual, registers are counted from left to right +beginning with 1. + +<li><code>(:BACK-REFERENCE <number>)</code> where +<code><number></code> is a positive integer is a back-reference to a +register group. + +<li><code>(:CHAR-CLASS|:INVERTED-CHAR-CLASS +{<item>}*)</code> where <code><item></code> +is either a character, a character range, or a symbol for a +special character class (see above) will be translated into a (one +character wide) character class. A character range looks like +<code>(:RANGE <char1> <char2>)</code> where +<code><char1></code> and +<code><char2></code> are characters such that +<code>(CHAR<= <char1> <char2>)</code> is +true. Example: <code>(:INVERTED-CHAR-CLASS #\a (:RANGE #\D #\G) +:DIGIT-CLASS)</code> is equivalent to the Perl regex string +<code>"[^aD-G\d]"</code>. + +</ul> + +Because <code>CREATE-SCANNER</code> is defined as a generic function +which dispatches on its first argument there's a certain ambiguity: +Although strings are valid parse trees they will be interpreted as +Perl regex strings when given to <code>CREATE-SCANNER</code>. To +circumvent this you can always use the equivalent parse tree <code>(:GROUP +<string>)</code> instead. + +Note that currently <code>CREATE-SCANNER</code> doesn't always check +for the well-formedness of its first argument, i.e. you are expected +to provide correct parse trees. This will most likely change in +future releases. + +The usage of the keyword argument <code>extended-mode</code> obviously +doesn't make sense if <code>CREATE-SCANNER</code> is applied to parse +trees and will signal an error. + +If <code>destructive</code> is not <code>NIL</code> (the default is +<code>NIL</code>) the function is allowed to destructively modify +<code>parse-tree</code> while creating the scanner. + +If you want to find out how parse trees are related to Perl regex +strings you should play around with +<code>CL-PPCRE::PARSE-STRING</code> - a function which converts Perl +regex strings to parse trees. Here are some examples: + +<pre> +* (cl-ppcre::parse-string "(ab)*") +(:GREEDY-REPETITION 0 NIL (:REGISTER "ab")) + +* (cl-ppcre::parse-string "(a(b))") +(:REGISTER (:SEQUENCE #\a (:REGISTER #\b))) + +* (cl-ppcre::parse-string "(?:abc){3,5}") +(:GREEDY-REPETITION 3 5 (:GROUP "abc")) +;; (:GREEDY-REPETITION 3 5 "abc") would also be OK + +* (cl-ppcre::parse-string "a(?i)b(?-i)c") +(:SEQUENCE #\a + (:SEQUENCE (:FLAGS :CASE-INSENSITIVE-P) + (:SEQUENCE #\b (:SEQUENCE (:FLAGS :CASE-SENSITIVE-P) #\c)))) +;; same as (:SEQUENCE #\a :CASE-INSENSITIVE-P #\b :CASE-SENSITIVE-P #\c) + +* (cl-ppcre::parse-string "(?=a)b") +(:SEQUENCE (:POSITIVE-LOOKAHEAD #\a) #\b) +</pre></blockquote> + + +For the rest of this section <code>regex</code> can +always be a string (which is interpreted as a Perl regular +expression), a parse tree, or a scanner created by +<code>CREATE-SCANNER</code>. The +<code>start</code> and <code>end</code> +keyword parameters are always used as in <a +href="#scan"><code>SCAN</code></a>. + + + + + [Function] + <a class=none name="scan">scan regex target-string <tt>&key</tt> start end => match-start, match-end, reg-starts, reg-ends</a> + +<blockquote> +Searches the string <code>target-string</code> from +<code>start</code> (which defaults to 0) to +<code>end</code> (which default to the length of +<code>target-string</code>) and tries to match +<code>regex</code>. On success returns four values - the start +of the match, the end of the match, and two arrays denoting the +beginnings and ends of register matches. On failure returns +<code>NIL</code>. <code>target-string</code> will be coerced to a +simple string if it isn't one already. + +<code>SCAN</code> acts as if the part of +<code>target-string</code> between <code>start</code> +and <code>end</code> were a standalone string, i.e. look-aheads +and look-behinds can't look beyond these boundaries. + +Examples: +<pre> +* (cl-ppcre:scan "(a)*b" "xaaabd") +1 +5 +#(3) +#(4) + +* (cl-ppcre:scan "(a)*b" "xaaabd" :start 1) +1 +5 +#(3) +#(4) + +* (cl-ppcre:scan "(a)*b" "xaaabd" :start 2) +2 +5 +#(3) +#(4) + +* (cl-ppcre:scan "(a)*b" "xaaabd" :end 4) +NIL + +* (cl-ppcre:scan '(:GREEDY-REPETITION 0 NIL #\b) "bbbc") +0 +3 +#() +#() + +* (cl-ppcre:scan '(:GREEDY-REPETITION 4 6 #\b) "bbbc") +NIL + +* (let ((s (cl-ppcre:create-scanner "(([a-c])+)x"))) + (cl-ppcre:scan s "abcxy")) +0 +4 +#(0 2) +#(3 3) +</pre></blockquote> + + + + [Function] + <a class=none name="scan-to-strings">scan-to-strings regex target-string <tt>&key</tt> start end sharedp => match, regs</a> + +<blockquote> +Like <a href="#scan"><code>SCAN</code></a> but returns substrings of +<code>target-string</code> instead of positions, i.e. this +function returns two values on success: the whole match as a string +plus an array of substrings (or <code>NIL</code>s) corresponding to +the matched registers. If <code>sharedp</code> is true, the substrings may share structure with +<code>target-string</code>. + +Examples: +<pre> +* (cl-ppcre:scan-to-strings "[^b]*b" "aaabd") +"aaab" +#() + +* (cl-ppcre:scan-to-strings "([^b])*b" "aaabd") +"aaab" +#("a") + +* (cl-ppcre:scan-to-strings "(([^b])*)b" "aaabd") +"aaab" +#("aaa" "a") +</pre></blockquote> + + + [Macro] + <a class=none name="register-groups-bind">register-groups-bind var-list (regex target-string <tt>&key</tt> start end sharedp) declaration* statement* => result*</a> + +<blockquote> +Evaluates <code>statement*</code> with the variables in <code>var-list</code> bound to the +corresponding register groups after <code>target-string</code> has been matched +against <code>regex</code>, i.e. each variable is either +bound to a string or to <code>NIL</code>. If there is no match, the <code>statement*</code> forms are not +executed. For each element of +<code>var-list</code> which is <code>NIL</code> there's no binding to the corresponding register +group. The number of variables in <code>var-list</code> must not be greater than +the number of register groups. If <code>sharedp</code> is true, the substrings may +share structure with <code>target-string</code>. +Examples: +<pre> +* (register-groups-bind (first second third fourth) + ("((a)|(b)|(c))+" "abababc" :sharedp t) + (list first second third fourth)) +("c" "a" "b" "c") +* (register-groups-bind (nil second third fourth) + ;; note that we don't bind the first and fifth register group + ("((a)|(b)|(c))()+" "abababc" :start 6) + (list second third fourth)) +(NIL NIL "c") +* (register-groups-bind (first) + ("(a|b)+" "accc" :start 1) + (format t "This will not be printed: ~A" first)) +NIL +</pre> +</blockquote> + + [Macro] + <a class=none name="do-scans">do-scans (match-start match-end reg-starts reg-ends regex target-string <tt>&optional</tt> result-form <tt>&key</tt> start end) declaration* statement* => result*</a> + +<blockquote> +A macro which iterates over <code>target-string</code> and +tries to match <code>regex</code> as often as possible +evaluating <code>statement*</code> with +<code>match-start</code>, <code>match-end</code>, +<code>reg-starts</code>, and <code>reg-ends</code> bound +to the four return values of each match (see <a +href="#scan"><code>SCAN</code></a>) in turn. After the last match, +returns <code>result-form</code> if provided or +<code>NIL</code> otherwise. An implicit block named <code>NIL</code> +surrounds <code>DO-SCANS</code>; <code>RETURN</code> may be used to +terminate the loop immediately. If <code>regex</code> matches +an empty string the scan is continued one position behind this match. + +This is the most general macro to iterate over all matches in a target +string. See the source code of <a +href="#do-matches"><code>DO-MATCHES</code></a>, <a +href="#all-matches"><code>ALL-MATCHES</code></a>, <a +href="#split"><code>SPLIT</code></a>, or <a +href="#regex-replace-all"><code>REGEX-REPLACE-ALL</code></a> for examples of its +usage.</blockquote> + + + + + [Macro] + <a class=none name="do-matches">do-matches (match-start match-end regex target-string <tt>&optional</tt> result-form <tt>&key</tt> start end) declaration* statement* => result*</a> + +<blockquote> +Like <a href="#do-scans"><code>DO-SCANS</code></a> but doesn't bind +variables to the register arrays. +Example: +<pre> +* (defun foo (regex target-string &key (start 0) (end (length target-string))) + (let ((sum 0)) + (cl-ppcre:do-matches (s e regex target-string nil :start start :end end) + (incf sum (- e s))) + (format t "~,2F% of the string was inside of a match~%" + ;; note: doesn't check for division by zero + (float (* 100 (/ sum (- end start))))))) + +FOO + +* (foo "a" "abcabcabc") +33.33% of the string was inside of a match +NIL +* (foo "aa|b" "aacabcbbc") +55.56% of the string was inside of a match +NIL +</pre></blockquote> + + + + + [Macro] + <a class=none name="do-matches-as-strings">do-matches-as-strings (match-var regex target-string <tt>&optional</tt> result-form <tt>&key</tt> start end sharedp) declaration* statement* => result*</a> + +<blockquote> +Like <a href="#do-matches"><code>DO-MATCHES</code></a> but binds +<code>match-var</code> to the substring of +<code>target-string</code> corresponding to each match in turn. If <code>sharedp</code> is true, the substrings may share structure with +<code>target-string</code>. + +Example: +<pre> +* (defun crossfoot (target-string &key (start 0) (end (length target-string))) + (let ((sum 0)) + (cl-ppcre:do-matches-as-strings (m :digit-class + target-string nil + :start start :end end) + (incf sum (parse-integer m))) + (if (< sum 10) + sum + (crossfoot (format nil "~A" sum))))) + +CROSSFOOT + +* (crossfoot "bar") +0 + +* (crossfoot "a3x") +3 + +* (crossfoot "12345") +6 +</pre> + +Of course, in real life you would do this with <a href="#do-matches"><code>DO-MATCHES</code></a> and use the <code>start</code> and <code>end</code> keyword parameters of <a href="http://www.lispworks.com/reference/HyperSpec/Body/f_parse_.htm"><code>PARSE-INTEGER</code></a>.</blockquote> + + [Macro] + <a class=none name="do-register-groups">do-register-groups var-list (regex target-string <tt>&optional</tt> result-form <tt>&key</tt> start end sharedp) declaration* statement* => result*</a> + +<blockquote> +Iterates over <code>target-string</code> and tries to match <code>regex</code> as often as +possible evaluating <code>statement*</code> with the variables in <code>var-list</code> bound to the +corresponding register groups for each match in turn, i.e. each +variable is either bound to a string or to <code>NIL</code>. The number of +variables in <code>var-list</code> must not be greater than the number of register +groups. For each element of +<code>var-list</code> which is <code>NIL</code> there's no binding to the corresponding register +group. After the last match, returns <code>result-form</code> if provided or <code>NIL</code> +otherwise. An implicit block named <code>NIL</code> surrounds <code>DO-REGISTER-GROUPS</code>; +<code>RETURN</code> may be used to terminate the loop immediately. If <code>regex</code> matches +an empty string the scan is continued one position behind this +match. If <code>sharedp</code> is true, the substrings may share structure with +<code>target-string</code>. +Example: +<pre> +* (do-register-groups (first second third fourth) + ("((a)|(b)|(c))" "abababc" nil :start 2 :sharedp t) + (print (list first second third fourth))) +("a" "a" NIL NIL) +("b" NIL "b" NIL) +("a" "a" NIL NIL) +("b" NIL "b" NIL) +("c" NIL NIL "c") +NIL +</pre> +</blockquote> + + + [Function] + <a class=none name="all-matches">all-matches regex target-string <tt>&key</tt> start end => list</a> + +<blockquote> +Returns a list containing the start and end positions of all matches +of <code>regex</code> against +<code>target-string</code>, i.e. if there are <code>N</code> +matches the list contains <code>(* 2 N)</code> elements. If +<code>regex</code> matches an empty string the scan is +continued one position behind this match. + +Examples: +<pre> +* (cl-ppcre:all-matches "a" "foo bar baz") +(5 6 9 10) + +* (cl-ppcre:all-matches "\\w*" "foo bar baz") +(0 3 3 3 4 7 7 7 8 11 11 11) +</pre></blockquote> + + + + + [Function] + <a class=none name="all-matches-as-strings">all-matches-as-strings regex target-string <tt>&key</tt> start end sharedp => list</a> + +<blockquote> +Like <a href="#all-matches"><code>ALL-MATCHES</code></a> but +returns a list of substrings instead. If <code>sharedp</code> is true, the substrings may share structure with +<code>target-string</code>. + +Examples: +<pre> +* (cl-ppcre:all-matches-as-strings "a" "foo bar baz") +("a" "a") + +* (cl-ppcre:all-matches-as-strings "\\w*" "foo bar baz") +("foo" "" "bar" "" "baz" "") +</pre></blockquote> + + + + + + + [Function] + <a class=none name="split">split regex target-string <tt>&key</tt> start end limit with-registers-p omit-unmatched-p sharedp => list</a> + +<blockquote> +Matches <code>regex</code> against +<code>target-string</code> as often as possible and returns a +list of the substrings between the matches. If +<code>with-registers-p</code> is true, substrings corresponding +to matched registers are inserted into the list as well. If +<code>omit-unmatched-p</code> is true, unmatched registers will +simply be left out, otherwise they will show up as +<code>NIL</code>. <code>limit</code> limits the number of +elements returned - registers aren't counted. If +<code>limit</code> is <code>NIL</code> (or 0 which is +equivalent), trailing empty strings are removed from the result list. +If <code>regex</code> matches an empty string the scan is +continued one position behind this match. If <code>sharedp</code> is true, the substrings may share structure with +<code>target-string</code>. + +Beginning with CL-PPCRE 0.2.0, this function also tries hard to be +Perl-compatible - thus the somewhat peculiar behaviour. But note that +it hasn't been as extensively tested as <a +href="#scan"><code>SCAN</code></a>. + +Examples: +<pre> +* (cl-ppcre:split "\\s+" "foo bar baz +frob") +("foo" "bar" "baz" "frob") + +* (cl-ppcre:split "\\s*" "foo bar baz") +("f" "o" "o" "b" "a" "r" "b" "a" "z") + +* (cl-ppcre:split "(\\s+)" "foo bar baz") +("foo" "bar" "baz") + +* (cl-ppcre:split "(\\s+)" "foo bar baz" :with-registers-p t) +("foo" " " "bar" " " "baz") + +* (cl-ppcre:split "(\\s)(\\s*)" "foo bar baz" :with-registers-p t) +("foo" " " "" "bar" " " " " "baz") + +* (cl-ppcre:split "(,)|(;)" "foo,bar;baz" :with-registers-p t) +("foo" "," NIL "bar" NIL ";" "baz") + +* (cl-ppcre:split "(,)|(;)" "foo,bar;baz" :with-registers-p t :omit-unmatched-p t) +("foo" "," "bar" ";" "baz") + +* (cl-ppcre:split ":" "a:b:c:d:e:f:g::") +("a" "b" "c" "d" "e" "f" "g") + +* (cl-ppcre:split ":" "a:b:c:d:e:f:g::" :limit 1) +("a:b:c:d:e:f:g::") + +* (cl-ppcre:split ":" "a:b:c:d:e:f:g::" :limit 2) +("a" "b:c:d:e:f:g::") + +* (cl-ppcre:split ":" "a:b:c:d:e:f:g::" :limit 3) +("a" "b" "c:d:e:f:g::") + +* (cl-ppcre:split ":" "a:b:c:d:e:f:g::" :limit 1000) +("a" "b" "c" "d" "e" "f" "g" "" "") +</pre></blockquote> + + + + + + [Function] + <a class=none name="regex-replace">regex-replace regex target-string replacement <tt>&key</tt> start end preserve-case => list</a> + +<blockquote> Try to match <code>target-string</code> +between <code>start</code> and <code>end</code> against +<code>regex</code> and replace the first match with +<code>replacement</code>. + +<code>replacement</code> can be a string which may contain the +special substrings <code>"\&"</code> for the whole +match, <code>"\`"</code> for the part of +<code>target-string</code> before the match, +<code>"\'"</code> for the part of +<code>target-string</code> after the match, +<code>"\N"</code> or <code>"\{N}"</code> for the +<code>N</code>th register where <code>N</code> is a positive integer. + +<code>replacement</code> can also be a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_f.htm#function_des…">function +designator</a> in which case the match will be replaced with the +result of calling the function designated by +<code>replacement</code> with the arguments +<code>target-string</code>, <code>start</code>, +<code>end</code>, <code>match-start</code>, +<code>match-end</code>, <code>reg-starts</code>, and +<code>reg-ends</code>. (<code>reg-starts</code> and +<code>reg-ends</code> are arrays holding the start and end +positions of matched registers (or <code>NIL</code>) - the meaning of +the other arguments should be obvious.) + +Finally, <code>replacement</code> can be a list where each +element is a string (which will be inserted verbatim), one of the +symbols <code>:match</code>, <code>:before-match</code>, or +<code>:after-match</code> (corresponding to +<code>"\&"</code>, <code>"\`"</code>, and +<code>"\'"</code> above), an integer <code>N</code> +(representing register <code>(1+ N)</code>), or a function +designator. + +If <code>preserve-case</code> is true (default is +<code>NIL</code>), the replacement will try to preserve the case (all +upper case, all lower case, or capitalized) of the match. The result +will always be a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> +string, even if <code>regex</code> doesn't match. + +Examples: + +<pre> +* (cl-ppcre:regex-replace "fo+" "foo bar" "frob") +"frob bar" + +* (cl-ppcre:regex-replace "fo+" "FOO bar" "frob") +"FOO bar" + +* (cl-ppcre:regex-replace "(?i)fo+" "FOO bar" "frob") +"frob bar" + +* (cl-ppcre:regex-replace "(?i)fo+" "FOO bar" "frob" :preserve-case t) +"FROB bar" + +* (cl-ppcre:regex-replace "(?i)fo+" "Foo bar" "frob" :preserve-case t) +"Frob bar" + +* (cl-ppcre:regex-replace "bar" "foo bar baz" "[frob (was '\\&' between '\\`' and '\\'')]") +"foo [frob (was 'bar' between 'foo ' and ' baz')] baz" + +* (cl-ppcre:regex-replace "bar" "foo bar baz" + '("[frob (was '" :match "' between '" :before-match "' and '" :after-match "')]")) +"foo [frob (was 'bar' between 'foo ' and ' baz')] baz" +</pre></blockquote> + + + [Function] + <a class=none name="regex-replace-all">regex-replace-all regex target-string replacement <tt>&key</tt> start end preserve-case => list</a> + +<blockquote> +Like <a href="#regex-replace"><code>REGEX-REPLACE</code></a> but replaces all matches. + +Examples: + +<pre> +* (cl-ppcre:regex-replace-all "(?i)fo+" "foo Fooo FOOOO bar" "frob" :preserve-case t) +"frob Frob FROB bar" + +* (cl-ppcre:regex-replace-all "(?i)f(o+)" "foo Fooo FOOOO bar" "fr\\1b" :preserve-case t) +"froob Frooob FROOOOB bar" + +* (let ((qp-regex (cl-ppcre:create-scanner "[\\x80-\\xff]"))) + (defun encode-quoted-printable (string) + "Convert 8-bit string to quoted-printable representation." + ;; won't work for Corman Lisp because non-ASCII characters aren't 8-bit there + (flet ((convert (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-end reg-starts reg-ends)) + (format nil "=~2,'0x" (char-code (char target-string match-start))))) + (cl-ppcre:regex-replace-all qp-regex string #'convert)))) +Converted ENCODE-QUOTED-PRINTABLE. +ENCODE-QUOTED-PRINTABLE + +* (encode-quoted-printable "Fête Sørensen naïve Hühner Straße") +"F=EAte S=F8rensen na=EFve H=FChner Stra=DFe" + +* (let ((url-regex (cl-ppcre:create-scanner "[^a-zA-Z0-9_\\-.]"))) + (defun url-encode (string) + "URL-encode a string." + ;; won't work for Corman Lisp because non-ASCII characters aren't 8-bit there + (flet ((convert (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-end reg-starts reg-ends)) + (format nil "%~2,'0x" (char-code (char target-string match-start))))) + (cl-ppcre:regex-replace-all url-regex string #'convert)))) +Converted URL-ENCODE. +URL-ENCODE + +* (url-encode "Fête Sørensen naïve Hühner Straße") +"F%EAte%20S%F8rensen%20na%EFve%20H%FChner%20Stra%DFe" + +* (defun how-many (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (format nil "~A" (- (svref reg-ends 0) + (svref reg-starts 0)))) +HOW-MANY + +* (cl-ppcre:regex-replace-all "{(.+?)}" + "foo{...}bar{.....}{..}baz{....}frob" + (list "[" 'how-many " dots]")) +"foo[3 dots]bar[5 dots][2 dots]baz[4 dots]frob" +</pre></blockquote> + + [Function] + <a class=none name="regex-apropos">regex-apropos regex <tt>&optional</tt> packages <tt>&key</tt> case-insensitive => list</a> + +<blockquote> +Like <a +href="http://www.lispworks.com/reference/HyperSpec/Body/f_apropo.htm"><code>APROPOS</code></a> +but searches for interned symbols which match the regular expression +<code>regex</code>. The output is implementation-dependent. If +<code>case-insensitive</code> is true (which is the default) +and <code>regex</code> isn't already a scanner, a +case-insensitive scanner is used. + +Here are examples for CMUCL: + +<pre> +* *package* +#<The COMMON-LISP-USER package, 16/21 internal, 0/9 external> + +* (defun foo (n &optional (k 0)) (+ 3 n k)) +FOO + +* (defparameter foo "bar") +FOO + +* (defparameter |foobar| 42) +|foobar| + +* (defparameter fooboo 43) +FOOBOO + +* (defclass frobar () ()) +#<STANDARD-CLASS FROBAR {4874E625}> + +* (cl-ppcre:regex-apropos "foo(?:bar)?") +FOO [variable] value: "bar" + [compiled function] (N &OPTIONAL (K 0)) +FOOBOO [variable] value: 43 +|foobar| [variable] value: 42 + +* (cl-ppcre:regex-apropos "(?:foo|fro)bar") +PCL::|COMMON-LISP-USER::FROBAR class predicate| [compiled closure] +FROBAR [class] #<STANDARD-CLASS FROBAR {4874E625}> +|foobar| [variable] value: 42 + +* (cl-ppcre:regex-apropos "(?:foo|fro)bar" 'cl-user) +FROBAR [class] #<STANDARD-CLASS FROBAR {4874E625}> +|foobar| [variable] value: 42 + +* (cl-ppcre:regex-apropos "(?:foo|fro)bar" '(pcl ext)) +PCL::|COMMON-LISP-USER::FROBAR class predicate| [compiled closure] + +* (cl-ppcre:regex-apropos "foo") +FOO [variable] value: "bar" + [compiled function] (N &OPTIONAL (K 0)) +FOOBOO [variable] value: 43 +|foobar| [variable] value: 42 + +* (cl-ppcre:regex-apropos "foo" nil :case-insensitive nil) +|foobar| [variable] value: 42 +</pre></blockquote> + + + + + [Function] + <a class=none name="regex-apropos-list">regex-apropos-list regex <tt>&optional</tt> packages <tt>&key</tt> upcase => list</a> + +<blockquote> +Like <a +href="http://www.lispworks.com/reference/HyperSpec/Body/f_apropo.htm"><code>APROPOS-LIST</code></a> +but searches for interned symbols which match the regular expression +<code>regex</code>. If <code>case-insensitive</code> is +true (which is the default) and <code>regex</code> isn't +already a scanner, a case-insensitive scanner is used. + +Example (continued from above): + +<pre> +* (cl-ppcre:regex-apropos-list "foo(?:bar)?") +(|foobar| FOOBOO FOO) +</pre></blockquote> + + [Special variable] + <a class=none name="regex-char-code-limit">*regex-char-code-limit*</a> + +<blockquote> This variable controls whether scanners take into +account all characters of your CL implementation or only those the <a +href="http://www.lispworks.com/reference/HyperSpec/Body/f_char_c.htm#char-code"><code>CHAR-CODE</code></a> +of which is not larger than its value. It is only relevant if the +regular expression contains certain character classes. The default is +<a +href="http://www.lispworks.com/reference/HyperSpec/Body/v_char_c.htm"><code>CHAR-CODE-LIMIT</code></a>, +and you might see significant speed and space improvements during +scanner creation if, say, your target strings only contain <a +href="http://wwwwbs.cs.tu-berlin.de/user/czyborra/charsets/">ISO-8859-1</a> +characters and you're using an implementation like AllegroCL, +LispWorks, or CLISP where <code>CHAR-CODE-LIMIT</code> has a value +much higher than 255. The <a href="#test">test suite</a> will +automatically set <code>*REGEX-CHAR-CODE-LIMIT*</code> to 255 while +you're running the default test. + +Here's an example with LispWorks: + +<pre> +CL-USER 23 > (time (cl-ppcre:create-scanner "[3\\D]")) +Timing the evaluation of (CL-PPCRE:CREATE-SCANNER "[3\\D]") + +user time = 0.443 +system time = 0.001 +Elapsed time = 0:00:01 +Allocation = 546600 bytes standard / 2162611 bytes fixlen +0 Page faults +#<closure 20654AF2> + +CL-USER 24 > (time (let ((cl-ppcre:*regex-char-code-limit* 255)) (cl-ppcre:create-scanner "[3\\D]"))) +Timing the evaluation of (LET ((CL-PPCRE:*REGEX-CHAR-CODE-LIMIT* 255)) (CL-PPCRE:CREATE-SCANNER "[3\\D]")) + +user time = 0.000 +system time = 0.000 +Elapsed time = 0:00:00 +Allocation = 3336 bytes standard / 8338 bytes fixlen +0 Page faults +#<closure 206569DA> +</pre> + +Note: Due to the nature of <code>LOAD-TIME-VALUE</code> and the <a +href="#compiler-macro">compiler macro for <code>SCAN</code></a> some +scanners might be created in a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_n.htm#null_lexical…">null +lexical environment</a> at load time or at compile time so be careful +to which value <code>*REGEX-CHAR-CODE-LIMIT*</code> is bound at that +time. The default value should always yield correct results unless you +play dirty tricks with implementation-dependent behaviour, though.</blockquote> + + [Special variable] + <a class=none name="use-bmh-matchers">*use-bmh-matchers*</a> + +<blockquote> Usually, the scanners created by <a +href="#create-scanner1"><code>CREATE-SCANNER</code></a> (or +implicitely by other functions and macros) will use fast <a +href="http://www-igm.univ-mlv.fr/~lecroq/string/node18.html">Boyer-Moore-Horspool +matchers</a> to check for constant strings at the start or end of the +regular expression. If <code>*USE-BMH-MATCHERS*</code> is +<code>NIL</code> (the default is <code>T</code>), the standard +function <a +href="http://www.lispworks.com/reference/HyperSpec/Body/f_search.htm"><code>SEARCH</code></a> +will be used instead. This will usually be a bit slower but can save +lots of space if you're storing many scanners. The <a +href="#test">test suite</a> will automatically set +<code>*USE-BMH-MATCHERS*</code> to <code>NIL</code> while you're running +the default test. + +Note: Due to the nature of <code>LOAD-TIME-VALUE</code> and the <a +href="#compiler-macro">compiler macro for <code>SCAN</code></a> some +scanners might be created in a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_n.htm#null_lexical…">null +lexical environment</a> at load time or at compile time so be careful +to which value <code>*USE-BMH-MATCHERS*</code> is bound at that +time.</blockquote> + + [Special variable] + <a class=none name="*allow-quoting*">*allow-quoting*</a> + +<blockquote> +If this value is true (the default is <code>NIL</code>) +CL-PPCRE will support <code>\Q</code> and <code>\E</code> in regex +strings to quote (disable) metacharacters. Note that this entails a +slight performance penalty when creating scanners because (a copy of) the regex +string is modified (probably more than once) before it +is fed to the parser. Also, the parser's <a +href="#ppcre-syntax-error">syntax error messages</a> will complain +about the converted string and not about the original regex string. + +<pre> +* (cl-ppcre:scan "^a+$" "a+") +NIL + +* (let ((cl-ppcre:*allow-quoting* t)) + (cl-ppcre:scan "^\\Qa+\\E$" "a+")) +0 +2 +#() +#() + +* (let ((cl-ppcre:*allow-quoting* t)) + (cl-ppcre:scan "\\Qa()\\E(?#comment\\Q)a**b" "()ab")) + +Quantifier '*' not allowed at position 19 in string "a\$\$(?#commentQ)a**b" +</pre> + +Note how in the last example the regex string in the error message is +different from the first argument to the <code>SCAN</code> +function. Also note that the second example might be easier to +understand (and Lisp-ier) if you write it like this: + +<pre> +* (cl-ppcre:scan '(:sequence :start-anchor + "a+" ;; no quoting necessary + :end-anchor) + "a+") +0 +2 +#() +#() +</pre> + +Make sure you also read <a href="#quote">the relevant section</a> in "<a href="#bugs">Bugs and problems</a>." + +</blockquote> + + [Function] + <a class=none name="quote-meta-chars">quote-meta-chars string => string'</a> + +<blockquote> +This is a simple utility function used when <a +href="#*allow-quoting*"><code>*ALLOW-QUOTING*</code></a> is +true. It returns a string <code>STRING'</code> where all +non-word characters (everything except ASCII characters, digits and +underline) of <code>STRING</code> are quoted by prepending a +backslash similar to Perl's <code>quotemeta</code> function. It always returns a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> +string. +<pre> +* (cl-ppcre:quote-meta-chars "[a-z]*") +"\\[a\\-z\\]\\*" +</pre></blockquote> + + [Condition type] + <a class=none name="ppcre-error">ppcre-error</a> + +<blockquote> +Every error signaled by CL-PPCRE is of type +<code>PPCRE-ERROR</code>. This is a direct subtype of <a +href="http://www.lispworks.com/reference/HyperSpec/Body/e_smp_er.htm"><code>SIMPLE-ERROR</code></a> +without any additional slots or options. +</blockquote> + + [Condition type] + <a class=none name="ppcre-invocation-error">ppcre-invocation-error</a> + +<blockquote> +Errors of type <code>PPCRE-INVOCATION-ERROR</code> +are signaled if one of the exported functions of CL-PPCRE is called with wrong or +inconsistent arguments. This is a direct subtype of <a +href="#ppcre-error"><code>PPCRE-ERROR</code></a> without any +additional slots or options. +</blockquote> + + [Condition type] + <a class=none name="ppcre-syntax-error">ppcre-syntax-error</a> + +<blockquote> +An error of type <code>PPCRE-SYNTAX-ERROR</code> is signaled if +CL-PPCRE's parser encounters an error when trying to parse a regex +string or to convert a parse tree into its internal representation. +This is a direct subtype of <a +href="#ppcre-error"><code>PPCRE-ERROR</code></a> with two additional +slots. These denote the regex string which HTML-PPCRE was parsing and +the position within the string where the error occured. If the error +happens while CL-PPCRE is converting a parse tree both of these slots +contain <code>NIL</code>. (See the next two entries on how to access +these slots.) + +As many syntax errors can't be detected before the parser is at the +end of the stream, the row and column usually denote the last position +where the parser was happy and not the position where it gave up. + +<pre> +* (handler-case + (cl-ppcre:scan "foo**x" "fooox") + (cl-ppcre:ppcre-syntax-error (condition) + (format t "Houston, we've got a problem with the string ~S:~%~ + Looks like something went wrong at position ~A.~%~ + The last message we received was \"~?\"." + (cl-ppcre:ppcre-syntax-error-string condition) + (cl-ppcre:ppcre-syntax-error-pos condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (values))) +Houston, we've got a problem with the string "foo**x": +Looks like something went wrong at position 4. +The last message we received was "Quantifier '*' not allowed". +</pre> +</blockquote> + + [Function] + <a class=none name="ppcre-syntax-error-string">ppcre-syntax-error-string</a> condition => string</a> + +<blockquote> +If <code>condition</code> is a condition of type <a +href="#ppcre-syntax-error"><code>PPCRE-SYNTAX-ERROR</code></a> this +function will return the string the parser was parsing when the error was +encountered (or <code>NIL</code> if the error happened while trying to +convert a parse tree). This might be particularly useful when <a +href="#*allow-quoting*"><code>*ALLOW-QUOTING*</code></a> is +true because in this case the offending string might not be the one you gave to the <a +href="#create-scanner1"><code>CREATE-SCANNER</code></a> function. +</blockquote> + + [Function] + <a class=none name="ppcre-syntax-error-pos">ppcre-syntax-error-pos</a> condition => number</a> + +<blockquote> +If <code>condition</code> is a condition of type <a +href="#ppcre-syntax-error"><code>PPCRE-SYNTAX-ERROR</code></a> this +function will return the position within the string where the error +occured (or <code>NIL</code> if the error happened while trying to +convert a parse tree). +</blockquote> + + +   <h3><a name="install" class=none>Download and installation</a></h3> + +CL-PPCRE together with this documentation can be downloaded from <a +href="http://weitz.de/files/cl-ppcre.tgz">http://weitz.de/files/cl-ppcre.tgz</a>. The +current version is 0.7.3 - older versions are +available for download through URLs like +<code>http://weitz.de/files/cl-ppcre-<version>.tgz</code>. A <a +href="CHANGELOG">CHANGELOG</a> is available. + +If you're on <a href="http://www.debian.org/">Debian</a> you should +probably use the <a +href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-ppcre&sea…">cl-ppcre +Debian package</a> which is available thanks to <a href="http://b9.com/">Kevin +Rosenberg</a>. There's also a port +for <a href="http://www.cliki.net/gentoo">Gentoo Linux</a> thanks to Matthew Kennedy and a <a href="http://www.freebsd.org/cgi/url.cgi?ports/textproc/cl-ppcre/pkg-descr">FreeBSD port</a> thanks to Henrik Motakef. +Installation via <a +href="http://www.cliki.net/asdf-install">asdf-install</a> should as well +be possible. + +CL-PPCRE comes with simple system definitions for <a +href="http://www.cliki.net/mk-defsystem">MK:DEFSYSTEM</a> and <a +href="http://www.cliki.net/asdf">asdf</a> so you can either adapt it +to your needs or just unpack the archive and from within the CL-PPCRE +directory start your Lisp image and evaluate the form +<code>(mk:compile-system "cl-ppcre")</code> (or the +equivalent one for asdf) which should compile and load the whole +system. + +If for some reason you don't want to use MK:DEFSYSTEM or asdf you +can just <code>LOAD</code> the file <code>load.lisp</code> or you +can also get away with something like this: + +<pre> +(loop for name in '("packages" "specials" "util" "errors" "lexer" + "parser" "regex-class" "convert" "optimize" + "closures" "repetition-closures" "scanner" "api") + do (compile-file (make-pathname :name name + :type "lisp")) + (load name)) +</pre> + +Note that on CL implementations which use the Python compiler +(i.e. CMUCL, SBCL, SCL) you can concatenate the compiled object files +to create one single object file which you can load afterwards: + +<pre> +cat {packages,specials,util,errors,lexer,parser,regex-class,convert,optimize,closures,repetition-closures,scanner,api}.x86f > cl-ppcre.x86f +</pre> + +(Replace ".<code>x86f</code>" with the correct suffix for +your platform.) + + +   <h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use the <a +href="http://common-lisp.net/mailman/listinfo/cl-ppcre-devel">cl-ppcre-devel +mailing list</a>. If you want to be notified about future releases +subscribe to the <a +href="http://common-lisp.net/mailman/listinfo/cl-ppcre-announce">cl-ppcre-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. + +   <h3><a name="test" class=none>Testing CL-PPCRE</a></h3> + +CL-PPCRE comes with a comprehensive test suite most of which is stolen +from the <a href="http://www.pcre.org/">PCRE</a> library. You can use +it like this: + +<pre> +* (mk:compile-system "cl-ppcre-test") +; Loading #p"/home/edi/cl-ppcre/cl-ppcre.system". +; Loading #p"/home/edi/cl-ppcre/packages.x86f". +; Loading #p"/home/edi/cl-ppcre/specials.x86f". +; Loading #p"/home/edi/cl-ppcre/util.x86f". +; Loading #p"/home/edi/cl-ppcre/errors.x86f". +; Loading #p"/home/edi/cl-ppcre/lexer.x86f". +; Loading #p"/home/edi/cl-ppcre/parser.x86f". +; Loading #p"/home/edi/cl-ppcre/regex-class.x86f". +; Loading #p"/home/edi/cl-ppcre/convert.x86f". +; Loading #p"/home/edi/cl-ppcre/optimize.x86f". +; Loading #p"/home/edi/cl-ppcre/closures.x86f". +; Loading #p"/home/edi/cl-ppcre/repetition-closures.x86f". +; Loading #p"/home/edi/cl-ppcre/scanner.x86f". +; Loading #p"/home/edi/cl-ppcre/api.x86f". +; Loading #p"/home/edi/cl-ppcre/ppcre-tests.x86f". +NIL + +* (cl-ppcre-test:test) + +;; .... +;; (a list of <a href="#perl">incompatibilities with Perl</a>) +</pre> + +(If you're not using MK:DEFSYSTEM or asdf it suffices to build +CL-PPCRE and then compile and load the file +<code>ppcre-tests.lisp</code>.) + +With LispWorks, SCL, and SBCL (starting from version 0.8.4.8) you can also call +<code>CL-PPCRE-TEST:TEST</code> with a keyword argument argument +<code>THREADED</code> which - in addition to the usual tests - will +also check whether the scanners created by CL-PPCRE are thread-safe. + +Note that the file <code>testdata</code> provided with CL-PPCRE +was created on a Linux system with Perl 5.8.0. You can (and you +should if you're on Mac OS or Windows) create your own +<code>testdata</code> with the Perl script +<code>perltest.pl</code>: + +<pre> +edi@bird:~/cl-ppcre > perl perltest.pl < testinput > testdata +</pre> + +Of course you can also create your own tests - the format accepted by +<code>perltest.pl</code> should be rather clear from looking at the +file <code>testinput</code>. Note that the target strings are wrapped +in double quotes and then fed to Perl's <code>eval</code> so you can +use ugly Perl constructs like, say, <code>a@{['b' x 10]}c</code> which +will result in the target string +<code>"abbbbbbbbbbc"</code>. + +   <h3><a name="perl" class=none>Compatibility with Perl</a></h3> + +Depending on your Perl version you might encounter a couple of small +incompatibilities with Perl most of which aren't due to CL-PPCRE: + +<h4><a name="empty" class=none>Empty strings instead of <code>undef</code> in <code>$1</code>, <code>$2</code>, etc.</a></h4> + +(Cf. case #629 of <a href="#test"><code>testdata</code></a>.) +This is <a +href="http://groups.google.com/groups?threadm=87u1kw8hfr.fsf%40dyn164.dbdmedia.de">a +bug</a> in Perl 5.6.1 and earlier which has been fixed in 5.8.0. + +<h4><a name="scope" class=none>Strange scoping of embedded modifiers</a></h4> + +(Cf. case #430 of <a href="#test"><code>testdata</code></a>.) +This is <a +href="http://groups.google.com/groups?threadm=871y80dpqh.fsf%40bird.agharta.de">a +bug</a> in Perl 5.6.1 and earlier which has been fixed in 5.8.0. + +<h4><a name="inconsistent" class=none>Inconsistent capturing of <code>$1</code>, <code>$2</code>, etc.</a></h4> + +(Cf. case #662 of <a href="#test"><code>testdata</code></a>.) +This is <a +href="http://bugs6.perl.org/rt2/Ticket/Display.html?id=18708">a +bug</a> in Perl which hasn't been fixed yet. + +<h4><a name="lookaround" class=none>Captured groups not available outside of look-aheads and look-behinds</a></h4> + +(Cf. case #1439 of <a href="#test"><code>testdata</code></a>.) +Well, OK, this ain't a Perl bug. I just can't quite understand why +captured groups should only be seen within the scope of a look-ahead +or look-behind. For the moment, CL-PPCRE and Perl agree to +disagree... :) + +<h4><a name="order" class=none>Alternations don't always work from left to right</a></h4> + +(Cf. case #790 of <a href="#test"><code>testdata</code></a>.) I +also think this a Perl bug but I currently have lost the drive to +report it. + +<h4><a name="mac" class=none><code>"\r"</code> doesn't work with MCL</a></h4> + +(Cf. case #9 of <a href="#test"><code>testdata</code></a>.) For +some strange reason that I don't understand MCL translates +<code>#\Return</code> to <code>(CODE-CHAR 10)</code> while MacPerl +translates <code>"\r"</code> to <code>(CODE-CHAR +13)</code>. Hmmm... + +<h4><a name="alpha" class=none>What about <code>"\w"</code>?</a></h4> + +CL-PPCRE uses <a +href="http://www.lispworks.com/reference/HyperSpec/Body/f_alphan.htm"><code>ALPHANUMERICP</code></a> +to decide whether a character matches Perl's +<code>"\w"</code>, so depending on your CL implementation +you might encounter differences between Perl and CL-PPCRE when +matching non-ASCII characters. + +   <h3><a name="performance" class=none>Performance</a></h3> + +<h4><a name="bench" class=none>Benchmarking</a></h4> + +The <a href="">CL-PPCRE test suite</a> can also be used for +benchmarking purposes: If you call <code>perltest.pl</code> with a +command line argument it will be interpreted as the number of seconds +each test should run. Perl will time its tests accordingly and create +output which, when fed to <code>CL-PPCRE-TEST:TEST</code>, will result +in a benchmark. Here's an example: + +<pre> +edi@bird:~/cl-ppcre > echo "/((a{0,5}){0,5})*[c]/ +aaaaaaaaaaaac + +/((a{0,5})*)*[c]/ +aaaaaaaaaaaac" | perl perltest.pl .5 > timedata +1 +2 + +edi@bird:~/cl-ppcre > cmucl -quiet +; Loading #p"/home/edi/.cmucl-init". + +* (mk:compile-system "cl-ppcre-test") +; Loading #p"/home/edi/cl-ppcre/cl-ppcre.system". +; Loading #p"/home/edi/cl-ppcre/packages.x86f". +; Loading #p"/home/edi/cl-ppcre/specials.x86f". +; Loading #p"/home/edi/cl-ppcre/util.x86f". +; Loading #p"/home/edi/cl-ppcre/errors.x86f". +; Loading #p"/home/edi/cl-ppcre/lexer.x86f". +; Loading #p"/home/edi/cl-ppcre/parser.x86f". +; Loading #p"/home/edi/cl-ppcre/regex-class.x86f". +; Loading #p"/home/edi/cl-ppcre/convert.x86f". +; Loading #p"/home/edi/cl-ppcre/optimize.x86f". +; Loading #p"/home/edi/cl-ppcre/closures.x86f". +; Loading #p"/home/edi/cl-ppcre/repetition-closures.x86f". +; Loading #p"/home/edi/cl-ppcre/scanner.x86f". +; Loading #p"/home/edi/cl-ppcre/api.x86f". +; Loading #p"/home/edi/cl-ppcre/ppcre-tests.x86f". +NIL + +* (cl-ppcre-test:test :file-name "/home/edi/cl-ppcre/timedata") + 1: 0.5559 (1000000 repetitions, Perl: 4.5330 seconds, CL-PPCRE: 2.5200 seconds) + 2: 0.4573 (1000000 repetitions, Perl: 4.5922 seconds, CL-PPCRE: 2.1000 seconds) +NIL +</pre> + +We gave two test cases to <code>perltest.pl</code> and asked it to repeat those tests often enough so that it takes at least 0.5 seconds to run each of them. In both cases, CMUCL was about twice as fast as Perl. + +Here are some more benchmarks (done with Perl 5.6.1 and CMUCL 18d+): + + +<table border=1> +<tr><td>Test case</td><td>Repetitions</td><td>Perl (sec)</td><td>CL-PPCRE (sec)</td><td>Ratio CL-PPCRE/Perl</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /(.)*/s</code></td><td align=right>100000</td><td align=right>0.1394</td><td align=right>0.0700</td><td align=right>0.5022</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /(.)*/s</code></td><td align=right>100000</td><td align=right>0.1628</td><td align=right>0.0600</td><td align=right>0.3685</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /(.)*/s</code></td><td align=right>100000</td><td align=right>0.5071</td><td align=right>0.0600</td><td align=right>0.1183</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /(.)*/s</code></td><td align=right>10000</td><td align=right>0.3902</td><td align=right>0.0000</td><td align=right>0.0000</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /.*/</code></td><td align=right>100000</td><td align=right>0.1520</td><td align=right>0.0800</td><td align=right>0.5262</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /.*/</code></td><td align=right>100000</td><td align=right>0.3786</td><td align=right>0.5400</td><td align=right>1.4263</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /.*/</code></td><td align=right>10000</td><td align=right>0.2709</td><td align=right>0.5100</td><td align=right>1.8826</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /.*/</code></td><td align=right>1000</td><td align=right>0.2734</td><td align=right>0.5100</td><td align=right>1.8656</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /.*/s</code></td><td align=right>100000</td><td align=right>0.1320</td><td align=right>0.0300</td><td align=right>0.2274</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /.*/s</code></td><td align=right>100000</td><td align=right>0.1634</td><td align=right>0.0300</td><td align=right>0.1836</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /.*/s</code></td><td align=right>100000</td><td align=right>0.5304</td><td align=right>0.0300</td><td align=right>0.0566</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /.*/s</code></td><td align=right>10000</td><td align=right>0.3966</td><td align=right>0.0000</td><td align=right>0.0000</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /x*/</code></td><td align=right>100000</td><td align=right>0.1507</td><td align=right>0.0900</td><td align=right>0.5970</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /x*/</code></td><td align=right>100000</td><td align=right>0.3782</td><td align=right>0.6300</td><td align=right>1.6658</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /x*/</code></td><td align=right>10000</td><td align=right>0.2730</td><td align=right>0.6000</td><td align=right>2.1981</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /x*/</code></td><td align=right>1000</td><td align=right>0.2708</td><td align=right>0.5900</td><td align=right>2.1790</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /[xy]*/</code></td><td align=right>100000</td><td align=right>0.2637</td><td align=right>0.1500</td><td align=right>0.5688</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /[xy]*/</code></td><td align=right>10000</td><td align=right>0.1449</td><td align=right>0.1200</td><td align=right>0.8282</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /[xy]*/</code></td><td align=right>1000</td><td align=right>0.1344</td><td align=right>0.1100</td><td align=right>0.8185</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /[xy]*/</code></td><td align=right>100</td><td align=right>0.1355</td><td align=right>0.1200</td><td align=right>0.8857</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /(.)*/</code></td><td align=right>100000</td><td align=right>0.1523</td><td align=right>0.1100</td><td align=right>0.7220</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /(.)*/</code></td><td align=right>100000</td><td align=right>0.3735</td><td align=right>0.5700</td><td align=right>1.5262</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /(.)*/</code></td><td align=right>10000</td><td align=right>0.2735</td><td align=right>0.5100</td><td align=right>1.8647</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /(.)*/</code></td><td align=right>1000</td><td align=right>0.2598</td><td align=right>0.5000</td><td align=right>1.9242</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /(x)*/</code></td><td align=right>100000</td><td align=right>0.1565</td><td align=right>0.1300</td><td align=right>0.8307</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /(x)*/</code></td><td align=right>100000</td><td align=right>0.3783</td><td align=right>0.6600</td><td align=right>1.7446</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /(x)*/</code></td><td align=right>10000</td><td align=right>0.2720</td><td align=right>0.6000</td><td align=right>2.2055</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /(x)*/</code></td><td align=right>1000</td><td align=right>0.2725</td><td align=right>0.6000</td><td align=right>2.2020</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /(y|x)*/</code></td><td align=right>10000</td><td align=right>0.2411</td><td align=right>0.1000</td><td align=right>0.4147</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /(y|x)*/</code></td><td align=right>1000</td><td align=right>0.2313</td><td align=right>0.0900</td><td align=right>0.3891</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /(y|x)*/</code></td><td align=right>100</td><td align=right>0.2336</td><td align=right>0.0900</td><td align=right>0.3852</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /(y|x)*/</code></td><td align=right>10</td><td align=right>0.4165</td><td align=right>0.0900</td><td align=right>0.2161</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /([xy])*/</code></td><td align=right>100000</td><td align=right>0.2678</td><td align=right>0.1800</td><td align=right>0.6721</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /([xy])*/</code></td><td align=right>10000</td><td align=right>0.1459</td><td align=right>0.1200</td><td align=right>0.8227</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /([xy])*/</code></td><td align=right>1000</td><td align=right>0.1372</td><td align=right>0.1100</td><td align=right>0.8017</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /([xy])*/</code></td><td align=right>100</td><td align=right>0.1358</td><td align=right>0.1100</td><td align=right>0.8098</td></tr> +<tr><td><code>"@{['x' x 100]}" =~ /((x){2})*/</code></td><td align=right>10000</td><td align=right>0.1073</td><td align=right>0.0400</td><td align=right>0.3727</td></tr> +<tr><td><code>"@{['x' x 1000]}" =~ /((x){2})*/</code></td><td align=right>10000</td><td align=right>0.9146</td><td align=right>0.2400</td><td align=right>0.2624</td></tr> +<tr><td><code>"@{['x' x 10000]}" =~ /((x){2})*/</code></td><td align=right>1000</td><td align=right>0.9020</td><td align=right>0.2300</td><td align=right>0.2550</td></tr> +<tr><td><code>"@{['x' x 100000]}" =~ /((x){2})*/</code></td><td align=right>100</td><td align=right>0.8983</td><td align=right>0.2300</td><td align=right>0.2560</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}FOOBARBAZ" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>100000</td><td align=right>0.2829</td><td align=right>0.2300</td><td align=right>0.8129</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}FOOBARBAZ" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.1859</td><td align=right>0.1700</td><td align=right>0.9143</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}FOOBARBAZ" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>1000</td><td align=right>0.1420</td><td align=right>0.1700</td><td align=right>1.1968</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}NOPE" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>1000000</td><td align=right>0.9196</td><td align=right>0.4600</td><td align=right>0.5002</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}NOPE" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>100000</td><td align=right>0.2166</td><td align=right>0.2500</td><td align=right>1.1542</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}NOPE" =~ /[a-z]*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.1465</td><td align=right>0.2300</td><td align=right>1.5696</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}FOOBARBAZ" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>100000</td><td align=right>0.2917</td><td align=right>0.2600</td><td align=right>0.8915</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}FOOBARBAZ" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.1811</td><td align=right>0.1800</td><td align=right>0.9942</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}FOOBARBAZ" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>1000</td><td align=right>0.1424</td><td align=right>0.1600</td><td align=right>1.1233</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}NOPE" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>1000000</td><td align=right>0.9154</td><td align=right>0.7400</td><td align=right>0.8083</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}NOPE" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>100000</td><td align=right>0.2170</td><td align=right>0.2800</td><td align=right>1.2901</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}NOPE" =~ /([a-z])*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.1497</td><td align=right>0.2300</td><td align=right>1.5360</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}FOOBARBAZ" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.4359</td><td align=right>0.1500</td><td align=right>0.3441</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}FOOBARBAZ" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>1000</td><td align=right>0.5456</td><td align=right>0.1500</td><td align=right>0.2749</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}FOOBARBAZ" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>10</td><td align=right>0.2039</td><td align=right>0.0600</td><td align=right>0.2943</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}NOPE" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>1000000</td><td align=right>0.9311</td><td align=right>0.7400</td><td align=right>0.7947</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}NOPE" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>100000</td><td align=right>0.2162</td><td align=right>0.2700</td><td align=right>1.2489</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}NOPE" =~ /([a-z]|ab)*FOOBARBAZ/</code></td><td align=right>10000</td><td align=right>0.1488</td><td align=right>0.2300</td><td align=right>1.5455</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..100)]}NOPE" =~ /[a-z]*FOOBARBAZ/i</code></td><td align=right>1000</td><td align=right>0.1555</td><td align=right>0.0000</td><td align=right>0.0000</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..1000)]}NOPE" =~ /[a-z]*FOOBARBAZ/i</code></td><td align=right>10</td><td align=right>0.1441</td><td align=right>0.0000</td><td align=right>0.0000</td></tr> +<tr><td><code>"@{[join undef, map { chr(ord('a') + rand 26) } (1..10000)]}NOPE" =~ /[a-z]*FOOBARBAZ/i</code></td><td align=right>10</td><td align=right>13.7150</td><td align=right>0.0100</td><td align=right>0.0007</td></tr> + +</table> + + +As you might have noticed, Perl shines if it can reduce significant +parts of the matching process to cases where it can advance through +the target string one character at a time. This leads to C code where +you can very efficiently test and increment a pointer into a string in +a tight loop and can hardly be beaten with CL. In almost all other +cases, the CMUCL/CL-PPCRE combination is usually faster than Perl - +sometimes a lot faster. + +As most of the examples above were chosen to make Perl look good +here's <a href="benchmarks.2002-12-22.txt">another benchmark</a> - the +result of running <a href="#test"><code>perltest.pl</code></a> against the +full <a href="#test"><code>testdata</code></a> file with a time +limit of 0.1 seconds, CL-PPCRE 0.1.2 on CMUCL 18e-pre +vs. Perl 5.6.1. CL-PPCRE is faster than Perl in 1511 of 1545 +cases - in 1045 cases it's more than twice as fast. + +Note that Perl as well as CL-PPCRE keep the rightmost matches in +registers - keep that in mind if you benchmark against other regex +implementations. Also note that <code>CL-PPCRE-TEST:TEST</code> +automatically skips test cases where Perl and CL-PPCRE don't agree. + +<h4><a name="other" class=none>Other performance issues</a></h4> + +While the scanners created by CL-PPCRE are pretty fast, the process +which creates scanners from Perl regex strings and parse trees isn't +that speedy and conses a lot. It is recommended that you store and +re-use scanners if possible. The <code>DO-</code>macros will do this +for you automatically. + +However, beginning with version 0.5.2, CL-PPCRE uses a <a +name="compiler-macro" +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#compiler_mac…">compiler +macro</a> and <a +href="http://www.lispworks.com/reference/HyperSpec/Body/s_ld_tim.htm"><code>LOAD-TIME-VALUE</code></a> +to make sure that the scanner is only built once if the first argument +to <code>SCAN</code>, <code>SCAN-TO-STRINGS</code>, or +<code>REGEX-REPLACE</code> is a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#constant_form">constant +form</a>. (But see the notes for <a +href="#regex-char-code-limit"><code>*REGEX-CHAR-CODE-LIMIT*</code></a> and +<a href="#use-bmh-matchers"><code>*USE-BMH-MATCHERS*</code></a>.) + +Here's an example of its effect + +<pre> +* (trace cl-ppcre::convert) +(CL-PPCRE::CONVERT) +* (defun foo (string) (cl-ppcre:scan "(?s).*" string)) +FOO +* (time (foo "The quick brown fox")) +Compiling LAMBDA NIL: +Compiling Top-Level Form: + + 0: (CL-PPCRE::CONVERT #<lambda-list-unavailable>) + 0: CL-PPCRE::CONVERT returned + #<CL-PPCRE::SEQ {48B033C5}> + 0 + #<CL-PPCRE::EVERYTHING {48B031D5}> +Evaluation took: + 0.0 seconds of real time + 0.00293 seconds of user run time + 9.77e-4 seconds of system run time + 0 page faults and + 11,408 bytes consed. +0 +19 +#() +#() +* (time (foo "The quick brown fox")) +Compiling LAMBDA NIL: +Compiling Top-Level Form: + + 0: (CL-PPCRE::CONVERT #<lambda-list-unavailable>) + 0: CL-PPCRE::CONVERT returned + #<CL-PPCRE::SEQ {48B14C4D}> + 0 + #<CL-PPCRE::EVERYTHING {48B14B65}> +Evaluation took: + 0.0 seconds of real time + 0.00293 seconds of user run time + 0.0 seconds of system run time + 0 page faults and + 10,960 bytes consed. +0 +19 +#() +#() +* (compile 'foo) + 0: (CL-PPCRE::CONVERT #<lambda-list-unavailable>) + 0: CL-PPCRE::CONVERT returned + #<CL-PPCRE::SEQ {48B1FEC5}> + 0 + #<CL-PPCRE::EVERYTHING {48B1FDDD}> +Compiling LAMBDA (STRING): +Compiling Top-Level Form: +FOO +NIL +NIL +* (time (foo "The quick brown fox")) +Compiling LAMBDA NIL: +Compiling Top-Level Form: + +Evaluation took: + 0.0 seconds of real time + 0.0 seconds of user run time + 0.0 seconds of system run time + 0 page faults and + 0 bytes consed. +0 +19 +#() +#() +* (time (foo "The quick brown fox")) +Compiling LAMBDA NIL: +Compiling Top-Level Form: + +Evaluation took: + 0.0 seconds of real time + 0.0 seconds of user run time + 0.0 seconds of system run time + 0 page faults and + 0 bytes consed. +0 +19 +#() +#() +* +</pre> + + +Of course, the usual rules for creating efficient regular expressions +apply to CL-PPCRE as well although it can optimize a couple of cases +itself. The most important rule is probably that you shouldn't use +capturing groups if you don't need the captured information, i.e. use +<code>"(?:a|b)*"</code> instead of +<code>"(a|b)*"</code> if you don't need to refer to the +register. (In fact, in this particular case CL-PPCRE will be able to +optimize away the register group, but it won't if you replace +<code>"a|b"</code> with, say, +<code>"a|bc"</code>.) + +Another point worth mentioning is that you definitely should use +single-line mode if you have long strings without +<code>#\Newline</code> (or where you don't care about the line breaks) +and plan to use regular expressions like +<code>".*"</code>. See the <a href="#bench">benchmarks</a> +for comparisons between single-line mode and normal mode with such +target strings. + +Another thing to consider is that, for performance reasons, CL-PPCRE +assumes that most of the target strings you're trying to match are <a +href="http://www.lispworks.com/reference/HyperSpec/Body/t_smp_st.htm">simple +strings</a> and coerces non-simple strings to simple strings before +scanning them. If you plan on working with non-simple strings mostly +you might consider modifying the CL-PPCRE source code. This is easy: +Change all occurences of <code>SCHAR</code> to <code>CHAR</code> and +redefine the macro in <code>util.lisp</code> where the coercion takes +place - that's all. + +   <h3><a name="bugs" class=none>Bugs and problems</a></h3> + +<h4><a name="stack" class=none>Stack overflow</a></h4> + +CL-PPCRE can optimize away a lot of unnecessary backtracking but +sometimes this simply isn't possible. With complicated regular +expressions and long strings this might lead to stack overflows +depending on your machine and your CL implementation. + +Here's one example with CLISP: + +<pre> +[1]> (defun target (n) (concatenate 'string (make-string n :initial-element #\a) "b")) +TARGET + +[2]> (cl-ppcre:scan "a*" (target 1000)) +0 ; +1000 ; +#() ; +#() + +[3]> (cl-ppcre:scan "(?:a|b)*" (target 1000)) +0 ; +1001 ; +#() ; +#() + +[4]> (cl-ppcre:scan "(a|b)*" (target 1000)) +0 ; +1001 ; +#(1000) ; +#(1001) + +[5]> (cl-ppcre:scan "(a|b)*" (target 10000)) +0 ; +10001 ; +#(10000) ; +#(10001) + +[6]> (cl-ppcre:scan "(a|b)*" (target 100000)) +0 ; +100001 ; +#(100000) ; +#(100001) + +[7]> (cl-ppcre:scan "(a|b)*" (target 1000000)) +0 ; +1000001 ; +#(1000000) ; +#(1000001) + +;; No problem until now - but... + +[8]> (cl-ppcre:scan "(a|)*" (target 100000)) +*** - Lisp stack overflow. RESET + +[9]> (cl-ppcre:scan "(a|)*" (target 3200)) +*** - Lisp stack overflow. RESET +</pre> + + +With CMUCL the situation is better and worse at the same time. It will +take a lot longer until CMUCL gives up but if it gives up the whole +Lisp image will silently die (at least on my machine): + +<pre> +* (defun target (n) (concatenate 'string (make-string n :initial-element #\a) "b")) +TARGET + +* (cl-ppcre:scan "(a|)*" (target 3200)) +0 +3200 +#(3200) +#(3200) + +* (cl-ppcre:scan "(a|)*" (target 10000)) +0 +10000 +#(10000) +#(10000) + +* (cl-ppcre:scan "(a|)*" (target 100000)) +0 +100000 +#(100000) +#(100000) + +* (cl-ppcre:scan "(a|)*" (target 1000000)) +0 +1000000 +#(1000000) +#(1000000) + +;; No problem until now - but... + +* (cl-ppcre:scan "(a|)*" (target 10000000)) +edi@bird:~ > +</pre> + +This behaviour can be changed with very conservative optimization settings but that'll make CL-PPCRE crawl compared to Perl. + + +You might want to compare this to the way Perl handles the same situation. It might lie to you: + +<pre> +edi@bird:~ > perl -le '$_="a" x 32766 . "b"; /(a|)*/; print $1' + +edi@bird:~ > perl -le '$_="a" x 32767 . "b"; /(a|)*/; print $1' +a +</pre> + +Or it might warn you before it's lying to you: +<pre> +edi@bird:~ > perl -lwe '$_="a" x 32767 . "b"; /(a|)*/; print $1' +Complex regular subexpression recursion limit (32766) exceeded at -e line 1. +a +</pre> + +Or it might simply die: +<pre> +edi@bird:~ > /opt/perl-5.8/bin/perl -lwe '$_="a" x 32767 . "b"; /(a|)*/; print $1' +Segmentation fault +</pre> + +Your mileage may vary, of course... + +<h4><a name="quote" class=none><code>"\Q"</code> doesn't work, or does it?</a></h4> + +In Perl the following code works as expected, i.e. it prints <code>1</code>. +<pre> +#!/usr/bin/perl -l + +$a = '\E*'; +print 1 + if '\E*\E*' =~ /(?:\Q$a\E){2}/; +</pre> + +If you try to do something similar in CL-PPCRE you get an error: + +<pre> +* (let ((cl-ppcre:*allow-quoting* t) + (a "\\E*")) + (cl-ppcre:scan (concatenate 'string "(?:\\Q" a "\\E){2}") "\\E*\\E*")) +Quantifier '*' not allowed at position 3 in string "(?:*\\E){2}" +</pre> + +The error message might give you a hint as to why this happens: +Because <a href="#*allow-quoting*"><code>*ALLOW-QUOTING*</code></a> +was true the concatenated string was pre-processed before it +was fed to CL-PPCRE's parser - the result of this pre-processing is +<code>"(?:*\\E){2}"</code> because the +<code>"\\E"</code> in the string <code>A</code> was taken to +be the end of the quoted section started by +<code>"\\Q"</code>. This cannot happen in Perl due to its +complicated interpolation rules - see <code>man perlop</code> for +the scary details. It can happen in CL-PPCRE, though. +Bummer! + +What gives? <code>"\\Q...\\E"</code> in CL-PPCRE should only +be used in literal strings. If you want to quote arbitrary strings +try <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a> or use <a +href="#quote-meta-chars"><code>QUOTE-META-CHARS</code></a>: +<pre> +* (let ((a "\\E*")) + (cl-ppcre:scan (concatenate 'string + "(?:" (cl-ppcre:quote-meta-chars a) "){2}") + "\\E*\\E*")) +0 +6 +#() +#() +</pre> +Or, even better and Lisp-ier, use the <a href="#create-scanner2">S-expression syntax</a> instead - no need for quoting in this case: +<pre> +* (let ((a "\\E*")) + (cl-ppcre:scan `(:greedy-repetition 2 2 ,a) + "\\E*\\E*")) +0 +6 +#() +#() +</pre> + +<h4><a name="backslash" class=none>Backslashes may confuse you...</a></h4> + +<pre> +* (let ((a "y\\y")) + (cl-ppcre:scan a a)) +NIL +</pre> + +You didn't expect this to yield <code>NIL</code>, did you? Shouldn't something like <code>(CL-PPCRE:SCAN A A)</code> always return a true value? No, because the first and the second argument to <code>SCAN</code> are handled differently: The first argument is fed to CL-PPCRE's parser and is treated like a Perl regular expression. In particular, the parser "sees" <code>\y</code> and converts it to <code>y</code> because <code>\y</code> has no special meaning in regular expressions. So, the regular expression is the constant string <code>"yy"</code>. But the second argument isn't converted - it is left as is, i.e. it's equivalent to Perl's <code>'y\y'</code>. In other words, this example would be equivalent to the Perl code + +<pre> +'y\y' =~ /y\y/; +</pre> + +or to + +<pre> +$a = 'y\y'; +$a =~ /$a/; +</pre> + +which should explain why it doesn't match. + +Still confused? You might want to try <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a>. + +   <h3><a class=none name="remarks">Remarks</a></h3> + +The sample output from CMUCL and CLISP has been slightly edited to +increase readability. + +All test cases and benchmarks in this document where performed on an +IBM Thinkpad T23 laptop (Pentium III 1.2 GHz, +768 MB RAM) running <a href="http://www.gentoo.org/">Gentoo +Linux</a> 1.1a. + +   <h3><a class=none name="ack">Acknowledgements</a></h3> + +Although I didn't use their code I was heavily inspired by looking at +the Scheme/CL regex implementations of <a +href="http://www.ccs.neu.edu/home/dorai/pregexp/pregexp.html">Dorai +Sitaram</a> and <a +href="http://www.geocities.com/mparker762/clawk#regex">Michael +Parker</a>. Also, the nice folks from CMUCL's <a +href="http://www.cons.org/cmucl/support.html">mailing list</a> as well +as the output of Perl's <code>use re "debug"</code> pragma +have been very helpful in optimizing the scanners created by CL-PPCRE. + + +The asdf system definitions were kindly provided by Marco +Baringer. Hannu Koivisto provided patches to make the +<code>.system</code> files more usable. Thanks to Kevin Rosenberg and +Douglas Crosher for pointing out how to be friendly to case-sensitive +ACL images. Thanks to Karsten Poeck and JP Massar for their help in +making CL-PPCRE work with Corman Lisp. JP Massar and Kent M. Pitman +also helped to improve/fix the test suite and the compiler macro. + + +Thanks to the guys at "Café Olé" in Hamburg +where I wrote most of the code and thanks to my wife for lending me +her PowerBook to test CL-PPCRE with MCL and OpenMCL. + + +$Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/doc/index.html,v 1.1 2004/02/16 19:37:16 rudi Exp $ +<a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/errors.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/errors.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/errors.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,72 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-LISP; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/errors.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defvar *syntax-error-string* nil + "The string which caused the syntax error.") + +(define-condition ppcre-error (simple-error) + () + (:documentation "All errors signaled by CL-PPCRE are of +this type.")) + +(define-condition ppcre-syntax-error (ppcre-error) + ((string :initarg :string + :reader ppcre-syntax-error-string) + (pos :initarg :pos + :reader ppcre-syntax-error-pos)) + (:default-initargs + :pos nil + :string *syntax-error-string*) + (:report (lambda (condition stream) + (format stream "~?~@[ at position ~A~]~@[ in string ~S~]" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + (ppcre-syntax-error-pos condition) + (ppcre-syntax-error-string condition))))) + +(define-condition ppcre-invocation-error (ppcre-error) + () + (:documentation "Signaled when CL-PPCRE functions are +invoked with wrong arguments.")) + +(defmacro signal-ppcre-syntax-error* (pos format-control &rest format-arguments) + `(error 'ppcre-syntax-error + :pos ,pos + :format-control ,format-control + :format-arguments (list ,@format-arguments))) + +(defmacro signal-ppcre-syntax-error (format-control &rest format-arguments) + `(signal-ppcre-syntax-error* nil ,format-control ,@format-arguments)) + +(defmacro signal-ppcre-invocation-error (format-control &rest format-arguments) + `(error 'ppcre-invocation-error + :format-control ,format-control + :format-arguments (list ,@format-arguments))) Added: vendor/portableaserve/libs/cl-ppcre/lexer.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/lexer.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/lexer.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,769 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/lexer.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; The lexer's responsibility is to convert the regex string into a +;;; sequence of tokens which are in turn consumed by the parser. +;;; +;;; The lexer is aware of Perl's 'extended mode' and it also 'knows' +;;; (with a little help from the parser) how many register groups it +;;; has opened so far. (The latter is necessary for interpreting +;;; strings like "\\10" correctly.) + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(declaim (inline map-char-to-special-class)) +(defun map-char-to-special-char-class (chr) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Maps escaped characters like \"\\d\" to the tokens which represent +their associated character classes." + (case chr + ((#\d) + :digit-class) + ((#\D) + :non-digit-class) + ((#\w) + :word-char-class) + ((#\W) + :non-word-char-class) + ((#\s) + :whitespace-char-class) + ((#\S) + :non-whitespace-char-class))) + +(locally + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (defstruct (lexer (:constructor make-lexer-internal)) + "LEXER structures are used to hold the regex string which is +currently lexed and to keep track of the lexer's state." + (str "" + :type string + :read-only t) + (len 0 + :type fixnum + :read-only t) + (reg 0 + :type fixnum) + (pos 0 + :type fixnum) + (last-pos nil + :type list))) + +(defun make-lexer (string) + (declare (inline make-lexer-internal) + (type string string)) + (make-lexer-internal :str (maybe-coerce-to-simple-string string) + :len (length string))) + +(declaim (inline end-of-string-p)) +(defun end-of-string-p (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Tests whether we're at the end of the regex string." + (<= (lexer-len lexer) + (lexer-pos lexer))) + +(declaim (inline looking-at-p)) +(defun looking-at-p (lexer chr) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Tests whether the next character the lexer would see is CHR. +Does not respect extended mode." + (and (not (end-of-string-p lexer)) + (char= (schar (lexer-str lexer) (lexer-pos lexer)) + chr))) + +(declaim (inline next-char-non-extended)) +(defun next-char-non-extended (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns the next character which is to be examined and updates the +POS slot. Does not respect extended mode." + (cond ((end-of-string-p lexer) + nil) + (t + (prog1 + (schar (lexer-str lexer) (lexer-pos lexer)) + (incf (lexer-pos lexer)))))) + +(defun next-char (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns the next character which is to be examined and updates the +POS slot. Respects extended mode, i.e. whitespace, comments, and also +nested comments are skipped if applicable." + (let ((next-char (next-char-non-extended lexer)) + last-loop-pos) + (loop + ;; remember where we started + (setq last-loop-pos (lexer-pos lexer)) + ;; first we look for nested comments like (?#foo) + (when (and next-char + (char= next-char #$) + (looking-at-p lexer #\?)) + (incf (lexer-pos lexer)) + (cond ((looking-at-p lexer #\#) + ;; must be a nested comment - so we have to search for + ;; the closing parenthesis + (let ((error-pos (- (lexer-pos lexer) 2))) + (unless + ;; loop 'til ')' or end of regex string and + ;; return NIL if ')' wasn't encountered + (loop for skip-char = next-char + then (next-char-non-extended lexer) + while (and skip-char + (char/= skip-char #$)) + finally (return skip-char)) + (signal-ppcre-syntax-error + error-pos + "Comment group not closed"))) + (setq next-char (next-char-non-extended lexer))) + (t + ;; undo effect of previous INCF if we didn't see a # + (decf (lexer-pos lexer))))) + (when *extended-mode-p* + ;; now - if we're in extended mode - we skip whitespace and + ;; comments; repeat the following loop while we look at + ;; whitespace or #\# + (loop while (and next-char + (or (char= next-char #\#) + (whitespacep next-char))) + do (setq next-char + (if (char= next-char #\#) + ;; if we saw a comment marker skip until + ;; we're behind #\Newline... + (loop for skip-char = next-char + then (next-char-non-extended lexer) + while (and skip-char + (char/= skip-char #\Newline)) + finally (return (next-char-non-extended lexer))) + ;; ...otherwise (whitespace) skip until we + ;; see the next non-whitespace character + (loop for skip-char = next-char + then (next-char-non-extended lexer) + while (and skip-char + (whitespacep skip-char)) + finally (return skip-char)))))) + ;; if the position has moved we have to repeat our tests + ;; because of cases like /^a (?#xxx) (?#yyy) {3}c/x which + ;; would be equivalent to /^a{3}c/ in Perl + (unless (> (lexer-pos lexer) last-loop-pos) + (return next-char))))) + +(declaim (inline fail)) +(defun fail (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Moves (LEXER-POS LEXER) back to the last position stored in +\(LEXER-LAST-POS LEXER) and pops the LAST-POS stack." + (unless (lexer-last-pos lexer) + (signal-ppcre-syntax-error "LAST-POS stack of LEXER ~A is empty" lexer)) + (setf (lexer-pos lexer) (pop (lexer-last-pos lexer))) + nil) + +(defun get-number (lexer &key (radix 10) max-length no-whitespace-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Read and consume the number the lexer is currently looking at and +return it. Returns NIL if no number could be identified. +RADIX is used as in PARSE-INTEGER. If MAX-LENGTH is not NIL we'll read +at most the next MAX-LENGTH characters. If NO-WHITESPACE-P is not NIL +we don't tolerate whitespace in front of the number." + (when (or (end-of-string-p lexer) + (and no-whitespace-p + (whitespacep (schar (lexer-str lexer) (lexer-pos lexer))))) + (return-from get-number nil)) + (multiple-value-bind (integer new-pos) + (parse-integer (lexer-str lexer) + :start (lexer-pos lexer) + :end (if max-length + (let ((end-pos (+ (lexer-pos lexer) + (the fixnum max-length))) + (lexer-len (lexer-len lexer))) + (if (< end-pos lexer-len) + end-pos + lexer-len)) + (lexer-len lexer)) + :radix radix + :junk-allowed t) + (cond ((and integer (>= (the fixnum integer) 0)) + (setf (lexer-pos lexer) new-pos) + integer) + (t nil)))) + +(declaim (inline try-number)) +(defun try-number (lexer &key (radix 10) max-length no-whitespace-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Like GET-NUMBER but won't consume anything if no number is seen." + ;; remember current position + (push (lexer-pos lexer) (lexer-last-pos lexer)) + (let ((number (get-number lexer + :radix radix + :max-length max-length + :no-whitespace-p no-whitespace-p))) + (or number (fail lexer)))) + +(declaim (inline make-char-from-code)) +(defun make-char-from-code (number error-pos) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Create character from char-code NUMBER. NUMBER can be NIL +which is interpreted as 0. ERROR-POS is the position where +the corresponding number started within the regex string." + ;; Only look at rightmost eight bits in compliance with Perl + (let ((code (logand #o377 (the fixnum (or number 0))))) + (or (and (< code char-code-limit) + (code-char code)) + (signal-ppcre-syntax-error + error-pos + "No character for hex-code ~X" + number)))) + +(defun unescape-char (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Convert the characters(s) following a backslash into a token +which is returned. This function is to be called when the backslash +has already been consumed. Special character classes like \\W are +handled elsewhere." + (when (end-of-string-p lexer) + (signal-ppcre-syntax-error "String ends with backslash")) + (let ((chr (next-char-non-extended lexer))) + (case chr + ((#\E) + ;; if \Q quoting is on this is ignored, otherwise it's just an + ;; #\E + (if *allow-quoting* + :void + #\E)) + ((#\c) + ;; \cx means control-x in Perl + (let ((next-char (next-char-non-extended lexer))) + (unless next-char + (signal-ppcre-syntax-error* + (lexer-pos lexer) + "Character missing after '\\c' at position ~A")) + (code-char (logxor #x40 (char-code (char-upcase next-char)))))) + ((#\x) + ;; \x should be followed by a hexadecimal char code, + ;; two digits or less + (let* ((error-pos (lexer-pos lexer)) + (number (get-number lexer :radix 16 :max-length 2 :no-whitespace-p t))) + ;; note that it is OK if \x is followed by zero digits + (make-char-from-code number error-pos))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + ;; \x should be followed by an octal char code, + ;; three digits or less + (let* ((error-pos (decf (lexer-pos lexer))) + (number (get-number lexer :radix 8 :max-length 3))) + (make-char-from-code number error-pos))) + ;; the following five character names are 'semi-standard' + ;; according to the CLHS but I'm not aware of any implementation + ;; that doesn't implement them + ((#\t) + #\Tab) + ((#\n) + #\Newline) + ((#\r) + #\Return) + ((#\f) + #\Page) + ((#\b) + #\Backspace) + ((#\a) + (code-char 7)) ; ASCII bell + ((#\e) + (code-char 27)) ; ASCII escape + (otherwise + ;; all other characters aren't affected by a backslash + chr)))) + +(defun collect-char-class (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Reads and consumes characters from regex string until a right +bracket is seen. Assembles them into a list $which is returned) of +characters, character ranges, like \(:RANGE #\\A #\\E) for a-e, and +tokens representing special character classes." + (let ((start-pos (lexer-pos lexer)) ; remember start for error message + hyphen-seen + last-char + list) + (flet ((handle-char (c) + "Do the right thing with character C depending on whether +we're inside a range or not." + (cond ((and hyphen-seen last-char) + (setf (car list) (list :range last-char c) + last-char nil)) + (t + (push c list) + (setq last-char c))) + (setq hyphen-seen nil))) + (loop for first = t then nil + for c = (next-char-non-extended lexer) + ;; leave loop if at end of string + while c + do (cond + ((char= c #\$ + ;; we've seen a backslash + (let ((next-char (next-char-non-extended lexer))) + (case next-char + ((#\d #\D #\w #\W #\s #\S) + ;; a special character class + (push (map-char-to-special-char-class next-char) list) + ;; if the last character was a hyphen + ;; just collect it literally + (when hyphen-seen + (push #\- list)) + ;; if the next character is a hyphen do the same + (when (looking-at-p lexer #\-) + (push #\- list) + (incf (lexer-pos lexer))) + (setq hyphen-seen nil)) + ((#\E) + ;; if \Q quoting is on we ignore \E, + ;; otherwise it's just a plain #\E + (unless *allow-quoting* + (handle-char #\E))) + (otherwise + ;; otherwise unescape the following character(s) + (decf (lexer-pos lexer)) + (handle-char (unescape-char lexer)))))) + (first + ;; the first character must not be a right bracket + ;; and isn't treated specially if it's a hyphen + (handle-char c)) + ((char= c #\]) + ;; end of character class + ;; make sure we collect a pending hyphen + (when hyphen-seen + (setq hyphen-seen nil) + (handle-char #\-)) + ;; reverse the list to preserve the order intended + ;; by the author of the regex string + (return-from collect-char-class (nreverse list))) + ((and (char= c #\-) + last-char + (not hyphen-seen)) + ;; if the last character was 'just a character' + ;; we expect to be in the middle of a range + (setq hyphen-seen t)) + ((char= c #\-) + ;; otherwise this is just an ordinary hyphen + (handle-char #\-)) + (t + ;; default case - just collect the character + (handle-char c)))) + ;; we can only exit the loop normally if we've reached the end + ;; of the regex string without seeing a right bracket + (signal-ppcre-syntax-error* + start-pos + "Missing right bracket to close character class")))) + +(defun maybe-parse-flags (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Reads a sequence of modifiers \(including #\\- to reverse their +meaning) and returns a corresponding list of \"flag\" tokens. The +\"x\" modifier is treated specially in that it dynamically modifies +the behaviour of the lexer itself via the special variable +*EXTENDED-MODE-P*." + (prog1 + (loop with set = t + for chr = (next-char-non-extended lexer) + unless chr + do (signal-ppcre-syntax-error "Unexpected end of string") + while (find chr "-imsx" :test #'char=) + ;; the first #\- will invert the meaning of all modifiers + ;; following it + if (char= chr #\-) + do (setq set nil) + else if (char= chr #\x) + do (setq *extended-mode-p* set) + else collect (if set + (case chr + ((#\i) + :case-insensitive-p) + ((#\m) + :multi-line-mode-p) + ((#\s) + :single-line-mode-p)) + (case chr + ((#\i) + :case-sensitive-p) + ((#\m) + :not-multi-line-mode-p) + ((#\s) + :not-single-line-mode-p)))) + (decf (lexer-pos lexer)))) + +(defun get-quantifier (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns a list of two values (min max) if what the lexer is looking +at can be interpreted as a quantifier. Otherwise returns NIL and +resets the lexer to its old position." + ;; remember starting position for FAIL and UNGET-TOKEN functions + (push (lexer-pos lexer) (lexer-last-pos lexer)) + (let ((next-char (next-char lexer))) + (case next-char + ((#\*) + ;; * (Kleene star): match 0 or more times + '(0 nil)) + ((#\+) + ;; +: match 1 or more times + '(1 nil)) + ((#\?) + ;; ?: match 0 or 1 times + '(0 1)) + ((#\{) + ;; one of + ;; {n}: match exactly n times + ;; {n,}: match at least n times + ;; {n,m}: match at least n but not more than m times + ;; note that anything not matching one of these patterns will + ;; be interpreted literally - even whitespace isn't allowed + (let ((num1 (get-number lexer :no-whitespace-p t))) + (if num1 + (let ((next-char (next-char-non-extended lexer))) + (case next-char + ((#\,) + (let* ((num2 (get-number lexer :no-whitespace-p t)) + (next-char (next-char-non-extended lexer))) + (case next-char + ((#\}) + ;; this is the case {n,} (NUM2 is NIL) or {n,m} + (list num1 num2)) + (otherwise + (fail lexer))))) + ((#\}) + ;; this is the case {n} + (list num1 num1)) + (otherwise + (fail lexer)))) + ;; no number following left curly brace, so we treat it + ;; like a normal character + (fail lexer)))) + ;; cannot be a quantifier + (otherwise + (fail lexer))))) + +(defun get-token (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns and consumes the next token from the regex string (or NIL)." + ;; remember starting position for UNGET-TOKEN function + (push (lexer-pos lexer) + (lexer-last-pos lexer)) + (let ((next-char (next-char lexer))) + (cond (next-char + (case next-char + ;; the easy cases first - the following six characters + ;; always have a special meaning and get translated + ;; into tokens immediately + ((#\)) + :close-paren) + ((#\|) + :vertical-bar) + ((#\?) + :question-mark) + ((#\.) + :everything) + ((#\^) + :start-anchor) + ((#\$) + :end-anchor) + ((#\+ #\*) + ;; quantifiers will always be consumend by + ;; GET-QUANTIFIER, they must not appear here + (signal-ppcre-syntax-error* + (1- (lexer-pos lexer)) + "Quantifier '~A' not allowed" + next-char)) + ((#\{) + ;; left brace isn't a special character in it's own + ;; right but we must check if what follows might + ;; look like a quantifier + (let ((this-pos (lexer-pos lexer)) + (this-last-pos (lexer-last-pos lexer))) + (unget-token lexer) + (when (get-quantifier lexer) + (signal-ppcre-syntax-error* + (car this-last-pos) + "Quantifier '~A' not allowed" + (subseq (lexer-str lexer) + (car this-last-pos) + (lexer-pos lexer)))) + (setf (lexer-pos lexer) this-pos + (lexer-last-pos lexer) this-last-pos) + next-char)) + ((#\[) + ;; left bracket always starts a character class + (cons (cond ((looking-at-p lexer #\^) + (incf (lexer-pos lexer)) + :inverted-char-class) + (t + :char-class)) + (collect-char-class lexer))) + ((#\\) + ;; backslash might mean different things so we have + ;; to peek one char ahead: + (let ((next-char (next-char-non-extended lexer))) + (case next-char + ((#\A) + :modeless-start-anchor) + ((#\Z) + :modeless-end-anchor) + ((#\z) + :modeless-end-anchor-no-newline) + ((#\b) + :word-boundary) + ((#\B) + :non-word-boundary) + ((#\d #\D #\w #\W #\s #\S) + ;; these will be treated like character classes + (map-char-to-special-char-class next-char)) + ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + ;; uh, a digit... + (let* ((old-pos (decf (lexer-pos lexer))) + ;; ...so let's get the whole number first + (backref-number (get-number lexer))) + (declare (type fixnum backref-number)) + (cond ((and (> backref-number (lexer-reg lexer)) + (<= 10 backref-number)) + ;; \10 and higher are treated as octal + ;; character codes if we haven't + ;; opened that much register groups + ;; yet + (setf (lexer-pos lexer) old-pos) + ;; re-read the number from the old + ;; position and convert it to its + ;; corresponding character + (make-char-from-code (get-number lexer :radix 8 :max-length 3) + old-pos)) + (t + ;; otherwise this must refer to a + ;; backreference + (list :back-reference backref-number))))) + ((#\0) + ;; this always means an octal character code + ;; (at most three digits) + (let ((old-pos (decf (lexer-pos lexer)))) + (make-char-from-code (get-number lexer :radix 8 :max-length 3) + old-pos))) + (otherwise + ;; in all other cases just unescape the + ;; character + (decf (lexer-pos lexer)) + (unescape-char lexer))))) + ((#$) + ;; an open parenthesis might mean different things + ;; depending on what follows... + (cond ((looking-at-p lexer #\?) + ;; this is the case '(?' (and probably more behind) + (incf (lexer-pos lexer)) + ;; we have to check for modifiers first + ;; because a colon might follow + (let* ((flags (maybe-parse-flags lexer)) + (next-char (next-char-non-extended lexer))) + ;; modifiers are only allowed if a colon + ;; or a closing parenthesis are following + (when (and flags + (not (find next-char ":)" :test #'char=))) + (signal-ppcre-syntax-error* + (car (lexer-last-pos lexer)) + "Sequence '~A' not recognized" + (subseq (lexer-str lexer) + (car (lexer-last-pos lexer)) + (lexer-pos lexer)))) + (case next-char + ((nil) + ;; syntax error + (signal-ppcre-syntax-error + "End of string following '(?'")) + ((#$) + ;; an empty group except for the flags + ;; (if there are any) + (or (and flags + (cons :flags flags)) + :void)) + ((#$) + ;; branch + :open-paren-paren) + ((#\>) + ;; standalone + :open-paren-greater) + ((#\=) + ;; positive look-ahead + :open-paren-equal) + ((#\!) + ;; negative look-ahead + :open-paren-exclamation) + ((#\:) + ;; non-capturing group - return flags as + ;; second value + (values :open-paren-colon flags)) + ((#\<) + ;; might be a look-behind assertion, so + ;; check next character + (let ((next-char (next-char-non-extended lexer))) + (case next-char + ((#\=) + ;; positive look-behind + :open-paren-less-equal) + ((#\!) + ;; negative look-behind + :open-paren-less-exclamation) + ((#$) + ;; Perl allows "(?<)" and treats + ;; it like a null string + :void) + ((nil) + ;; syntax error + (signal-ppcre-syntax-error + "End of string following '(?<'")) + (t + ;; also syntax error + (signal-ppcre-syntax-error* + (1- (lexer-pos lexer)) + "Character '~A' may not follow '(?<'" + next-char ))))) + (otherwise + (signal-ppcre-syntax-error* + (1- (lexer-pos lexer)) + "Character '~A' may not follow '(?'" + next-char))))) + (t + ;; if next-char was not #\? (this is within + ;; the first COND), we've just seen an opening + ;; parenthesis and leave it like that + :open-paren))) + (otherwise + ;; all other characters are their own tokens + next-char))) + ;; we didn't get a character (this if the "else" branch from + ;; the first IF), so we don't return a token but NIL + (t + (pop (lexer-last-pos lexer)) + nil)))) + +(declaim (inline unget-token)) +(defun unget-token (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Moves the lexer back to the last position stored in the LAST-POS stack." + (if (lexer-last-pos lexer) + (setf (lexer-pos lexer) + (pop (lexer-last-pos lexer))) + (error "No token to unget $this should not happen)"))) + +(declaim (inline start-of-subexpr-p)) +(defun start-of-subexpr-p (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Tests whether the next token can start a valid sub-expression, i.e. +a stand-alone regex." + (let* ((pos (lexer-pos lexer)) + (next-char (next-char lexer))) + (not (or (null next-char) + (prog1 + (member (the character next-char) + '(#$ #\|) + :test #'char=) + (setf (lexer-pos lexer) pos)))))) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/load.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/load.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/load.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,62 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/load.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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-ppcre-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(loop for file in '("packages" + "specials" + "util" + "errors" + "lexer" + "parser" + "regex-class" + "convert" + "optimize" + "closures" + "repetition-closures" + "scanner" + "api" + "ppcre-tests") + do (let ((pathname (make-pathname :name file :type "lisp" :version nil + :defaults *cl-ppcre-base-directory*))) + #-:cormanlisp + (let ((compiled-pathname (compile-file-pathname pathname))) + (unless (probe-file compiled-pathname) + (compile-file pathname)) + (setq pathname compiled-pathname)) + (load pathname))) + + + + + Added: vendor/portableaserve/libs/cl-ppcre/optimize.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/optimize.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/optimize.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,597 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/optimize.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; This file contains optimizations which can be applied to converted +;;; parse trees. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defun string-list-to-simple-string (string-list) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Concatenates a list of strings to one simple-string." + ;; this function provided by JP Massar; note that we can't use APPLY + ;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT + (let ((total-size 0)) + (declare (type fixnum total-size)) + (dolist (string string-list) + (declare (type string string)) + (incf total-size (length string))) + (let ((result-string (make-sequence 'simple-string total-size)) + (curr-pos 0)) + (declare (type fixnum curr-pos)) + (dolist (string string-list) + (declare (type string string)) + (replace result-string string :start1 curr-pos) + (incf curr-pos (length string))) + result-string))) + +(defgeneric flatten (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Merges adjacent sequences and alternations, i.e. it +transforms #<SEQ #<STR \"a\"> #<SEQ #<STR \"b\"> #<STR \"c\">>> to +#<SEQ #<STR \"a\"> #<STR \"b\"> #<STR \"c\">>. This is a destructive +operation on REGEX.")) + +(defmethod flatten ((seq seq)) + ;; this looks more complicated than it is because we modify SEQ in + ;; place to avoid unnecessary consing + (let ((elements-rest (elements seq))) + (loop + (unless elements-rest + (return)) + (let ((flattened-element (flatten (car elements-rest))) + (next-elements-rest (cdr elements-rest))) + (cond ((typep flattened-element 'seq) + ;; FLATTENED-ELEMENT is a SEQ object, so we "splice" + ;; it into out list of elements + (let ((flattened-element-elements + (elements flattened-element))) + (setf (car elements-rest) + (car flattened-element-elements) + (cdr elements-rest) + (nconc (cdr flattened-element-elements) + (cdr elements-rest))))) + (t + ;; otherwise we just replace the current element with + ;; its flattened counterpart + (setf (car elements-rest) flattened-element))) + (setq elements-rest next-elements-rest)))) + (let ((elements (elements seq))) + (cond ((cadr elements) + seq) + ((cdr elements) + (first elements)) + (t (make-instance 'void))))) + +(defmethod flatten ((alternation alternation)) + ;; same algorithm as above + (let ((choices-rest (choices alternation))) + (loop + (unless choices-rest + (return)) + (let ((flattened-choice (flatten (car choices-rest))) + (next-choices-rest (cdr choices-rest))) + (cond ((typep flattened-choice 'alternation) + (let ((flattened-choice-choices + (choices flattened-choice))) + (setf (car choices-rest) + (car flattened-choice-choices) + (cdr choices-rest) + (nconc (cdr flattened-choice-choices) + (cdr choices-rest))))) + (t + (setf (car choices-rest) flattened-choice))) + (setq choices-rest next-choices-rest)))) + (let ((choices (choices alternation))) + (cond ((cadr choices) + alternation) + ((cdr choices) + (first choices)) + (t (signal-ppcre-syntax-error + "Encountered alternation without choices."))))) + +(defmethod flatten ((branch branch)) + (with-slots ((test test) + (then-regex then-regex) + (else-regex else-regex)) + branch + (setq test + (if (numberp test) + test + (flatten test)) + then-regex (flatten then-regex) + else-regex (flatten else-regex)) + branch)) + +(defmethod flatten ((regex regex)) + (typecase regex + ((or repetition register lookahead lookbehind standalone) + ;; if REGEX contains exactly one inner REGEX object flatten it + (setf (regex regex) + (flatten (regex regex))) + regex) + (t + ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING, + ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, and WORD-BOUNDARY) do + ;; nothing + regex))) + +(defgeneric gather-strings (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Collects adjacent strings or characters into one +string provided they have the same case mode. This is a destructive +operation on REGEX.")) + +(defmethod gather-strings ((seq seq)) + ;; note that GATHER-STRINGS is to be applied after FLATTEN, i.e. it + ;; expects SEQ to be flattened already; in particular, SEQ cannot be + ;; empty and cannot contain embedded SEQ objects + (let* ((start-point (cons nil (elements seq))) + (curr-point start-point) + old-case-mode + collector + collector-start + (collector-length 0) + skip) + (declare (type fixnum collector-length)) + (loop + (let ((elements-rest (cdr curr-point))) + (unless elements-rest + (return)) + (let* ((element (car elements-rest)) + (case-mode (case-mode element old-case-mode))) + (cond ((and case-mode + (eq case-mode old-case-mode)) + ;; if ELEMENT is a STR and we have collected a STR of + ;; the same case mode in the last iteration we + ;; concatenate ELEMENT onto COLLECTOR and remember the + ;; value of its SKIP slot + (let ((old-collector-length collector-length)) + (unless (and (adjustable-array-p collector) + (array-has-fill-pointer-p collector)) + (setq collector + (make-array collector-length + :initial-contents collector + :element-type 'character + :fill-pointer t + :adjustable t) + collector-start nil)) + (adjust-array collector + (incf collector-length (len element)) + :fill-pointer t) + (setf (subseq collector + old-collector-length) + (str element) + ;; it suffices to remember the last SKIP slot + ;; because due to the way MAYBE-ACCUMULATE + ;; works adjacent STR objects have the same + ;; SKIP value + skip (skip element))) + (setf (cdr curr-point) (cdr elements-rest))) + (t + (let ((collected-string + (cond (collector-start + collector-start) + (collector + ;; if we have collected something already + ;; we convert it into a STR + (make-instance 'str + :skip skip + :str collector + :case-insensitive-p + (eq old-case-mode + :case-insensitive))) + (t nil)))) + (cond (case-mode + ;; if ELEMENT is a string with a different case + ;; mode than the last one we have either just + ;; converted COLLECTOR into a STR or COLLECTOR + ;; is still empty; in both cases we can now + ;; begin to fill it anew + (setq collector (str element) + collector-start element + ;; and we remember the SKIP value as above + skip (skip element) + collector-length (len element)) + (cond (collected-string + (setf (car elements-rest) + collected-string + curr-point + (cdr curr-point))) + (t + (setf (cdr curr-point) + (cdr elements-rest))))) + (t + ;; otherwise this is not a STR so we apply + ;; GATHER-STRINGS to it and collect it directly + ;; into RESULT + (cond (collected-string + (setf (car elements-rest) + collected-string + curr-point + (cdr curr-point) + (cdr curr-point) + (cons (gather-strings element) + (cdr curr-point)) + curr-point + (cdr curr-point))) + (t + (setf (car elements-rest) + (gather-strings element) + curr-point + (cdr curr-point)))) + ;; we also have to empty COLLECTOR here in case + ;; it was still filled from the last iteration + (setq collector nil + collector-start nil)))))) + (setq old-case-mode case-mode)))) + (when collector + (setf (cdr curr-point) + (cons + (make-instance 'str + :skip skip + :str collector + :case-insensitive-p + (eq old-case-mode + :case-insensitive)) + nil))) + (setf (elements seq) (cdr start-point)) + seq)) + +(defmethod gather-strings ((alternation alternation)) + ;; loop ON the choices of ALTERNATION so we can modify them directly + (loop for choices-rest on (choices alternation) + while choices-rest + do (setf (car choices-rest) + (gather-strings (car choices-rest)))) + alternation) + +(defmethod gather-strings ((branch branch)) + (with-slots ((test test) + (then-regex then-regex) + (else-regex else-regex)) + branch + (setq test + (if (numberp test) + test + (gather-strings test)) + then-regex (gather-strings then-regex) + else-regex (gather-strings else-regex)) + branch)) + +(defmethod gather-strings ((regex regex)) + (typecase regex + ((or repetition register lookahead lookbehind standalone) + ;; if REGEX contains exactly one inner REGEX object apply + ;; GATHER-STRINGS to it + (setf (regex regex) + (gather-strings (regex regex))) + regex) + (t + ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING, + ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, and WORD-BOUNDARY) do + ;; nothing + regex))) + +;; Note that START-ANCHORED-P will be called after FLATTEN and GATHER-STRINGS. + +(defgeneric start-anchored-p (regex &optional in-seq-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns T if REGEX starts with a \"real\" start +anchor, i.e. one that's not in multi-line mode, NIL otherwise. If +IN-SEQ-P is true the function will return :ZERO-LENGTH if REGEX is a +zero-length assertion.")) + +(defmethod start-anchored-p ((seq seq) &optional in-seq-p) + (declare (ignore in-seq-p)) + ;; note that START-ANCHORED-P is to be applied after FLATTEN and + ;; GATHER-STRINGS, i.e. SEQ cannot be empty and cannot contain + ;; embedded SEQ objects + (loop for element in (elements seq) + for anchored-p = (start-anchored-p element t) + ;; skip zero-length elements because they won't affect the + ;; "anchoredness" of the sequence + while (eq anchored-p :zero-length) + finally (return (and anchored-p (not (eq anchored-p :zero-length)))))) + +(defmethod start-anchored-p ((alternation alternation) &optional in-seq-p) + (declare (ignore in-seq-p)) + ;; clearly an alternation can only be start-anchored if all of its + ;; choices are start-anchored + (loop for choice in (choices alternation) + always (start-anchored-p choice))) + +(defmethod start-anchored-p ((branch branch) &optional in-seq-p) + (declare (ignore in-seq-p)) + (and (start-anchored-p (then-regex branch)) + (start-anchored-p (else-regex branch)))) + +(defmethod start-anchored-p ((repetition repetition) &optional in-seq-p) + (declare (ignore in-seq-p)) + ;; well, this wouldn't make much sense, but anyway... + (and (plusp (minimum repetition)) + (start-anchored-p (regex repetition)))) + +(defmethod start-anchored-p ((register register) &optional in-seq-p) + (declare (ignore in-seq-p)) + (start-anchored-p (regex register))) + +(defmethod start-anchored-p ((standalone standalone) &optional in-seq-p) + (declare (ignore in-seq-p)) + (start-anchored-p (regex standalone))) + +(defmethod start-anchored-p ((anchor anchor) &optional in-seq-p) + (declare (ignore in-seq-p)) + (and (startp anchor) + (not (multi-line-p anchor)))) + +(defmethod start-anchored-p ((regex regex) &optional in-seq-p) + (typecase regex + ((or lookahead lookbehind word-boundary void) + ;; zero-length assertions + (if in-seq-p + :zero-length + nil)) + (t + ;; BACK-REFERENCE, CHAR-CLASS, EVERYTHING, and STR + nil))) + +;; Note that END-STRING-AUX will be called after FLATTEN and GATHER-STRINGS. + +(defgeneric end-string-aux (regex &optional old-case-insensitive-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns the constant string (if it exists) REGEX +ends with wrapped into a STR object, otherwise NIL. +OLD-CASE-INSENSITIVE-P is the CASE-INSENSITIVE-P slot of the last STR +collected or :VOID if no STR has been collected yet. (This is a helper +function called by END-STRIN.)")) + +(defmethod end-string-aux ((str str) + &optional (old-case-insensitive-p :void)) + (declare (special last-str)) + (cond ((and (not (skip str)) ; avoid constituents of STARTS-WITH + ;; only use STR if nothing has been collected yet or if + ;; the collected string has the same value for + ;; CASE-INSENSITIVE-P + (or (eq old-case-insensitive-p :void) + (eq (case-insensitive-p str) old-case-insensitive-p))) + (setf last-str str + ;; set the SKIP property of this STR + (skip str) t) + str) + (t nil))) + +(defmethod end-string-aux ((seq seq) + &optional (old-case-insensitive-p :void)) + (declare (special continuep)) + (let (case-insensitive-p + concatenated-string + concatenated-start + (concatenated-length 0)) + (declare (type fixnum concatenated-length)) + (loop for element in (reverse (elements seq)) + ;; remember the case-(in)sensitivity of the last relevant + ;; STR object + for loop-old-case-insensitive-p = old-case-insensitive-p + then (if skip + loop-old-case-insensitive-p + (case-insensitive-p element-end)) + ;; the end-string of the current element + for element-end = (end-string-aux element + loop-old-case-insensitive-p) + ;; whether we encountered a zero-length element + for skip = (if element-end + (zerop (len element-end)) + nil) + ;; set CONTINUEP to NIL if we have to stop collecting to + ;; alert END-STRING-AUX methods on enclosing SEQ objects + unless element-end + do (setq continuep nil) + ;; end loop if we neither got a STR nor a zero-length + ;; element + while element-end + ;; only collect if not zero-length + unless skip + do (cond (concatenated-string + (when concatenated-start + (setf concatenated-string + (make-array concatenated-length + :initial-contents (reverse (str concatenated-start)) + :element-type 'character + :fill-pointer t + :adjustable t) + concatenated-start nil)) + (let ((len (len element-end)) + (str (str element-end))) + (declare (type fixnum len)) + (incf concatenated-length len) + (loop for i of-type fixnum downfrom (1- len) to 0 + do (vector-push-extend (char str i) + concatenated-string)))) + (t + (setf concatenated-string + t + concatenated-start + element-end + concatenated-length + (len element-end) + case-insensitive-p + (case-insensitive-p element-end)))) + ;; stop collecting if END-STRING-AUX on inner SEQ has said so + while continuep) + (cond ((zerop concatenated-length) + ;; don't bother to return zero-length strings + nil) + (concatenated-start + concatenated-start) + (t + (make-instance 'str + :str (nreverse concatenated-string) + :case-insensitive-p case-insensitive-p))))) + +(defmethod end-string-aux ((register register) + &optional (old-case-insensitive-p :void)) + (end-string-aux (regex register) old-case-insensitive-p)) + +(defmethod end-string-aux ((standalone standalone) + &optional (old-case-insensitive-p :void)) + (end-string-aux (regex standalone) old-case-insensitive-p)) + +(defmethod end-string-aux ((regex regex) + &optional (old-case-insensitive-p :void)) + (declare (special last-str end-anchored-p continuep)) + (typecase regex + ((or anchor lookahead lookbehind word-boundary void) + ;; a zero-length REGEX object - for the sake of END-STRING-AUX + ;; this is a zero-length string + (when (and (typep regex 'anchor) + (not (startp regex)) + (or (no-newline-p regex) + (not (multi-line-p regex))) + (eq old-case-insensitive-p :void)) + ;; if this is a "real" end-anchor and we haven't collected + ;; anything so far we can set END-ANCHORED-P (where 1 or 0 + ;; indicate whether we accept a #\Newline at the end or not) + (setq end-anchored-p (if (no-newline-p regex) 0 1))) + (make-instance 'str + :str "" + :case-insensitive-p :void)) + (t + ;; (ALTERNATION, BACK-REFERENCE, BRANCH, CHAR-CLASS, EVERYTHING, + ;; REPETITION) + nil))) + +(defmethod end-string ((regex regex)) + (declare (special end-string-offset)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns the constant string (if it exists) REGEX ends with wrapped +into a STR object, otherwise NIL." + ;; LAST-STR points to the last STR object (seen from the end) that's + ;; part of END-STRING; CONTINUEP is set to T if we stop collecting + ;; in the middle of a SEQ + (let ((continuep t) + last-str) + (declare (special continuep last-str)) + (prog1 + (end-string-aux regex) + (when last-str + ;; if we've found something set the START-OF-END-STRING-P of + ;; the leftmost STR collected accordingly and remember the + ;; OFFSET of this STR (in a special variable provided by the + ;; caller of this function) + (setf (start-of-end-string-p last-str) t + end-string-offset (offset last-str)))))) + +(defgeneric compute-min-rest (regex current-min-rest) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns the minimal length of REGEX plus +CURRENT-MIN-REST. This is similar to REGEX-MIN-LENGTH except that it +recurses down into REGEX and sets the MIN-REST slots of REPETITION +objects.")) + +(defmethod compute-min-rest ((seq seq) current-min-rest) + (loop for element in (reverse (elements seq)) + for last-min-rest = current-min-rest then this-min-rest + for this-min-rest = (compute-min-rest element last-min-rest) + finally (return this-min-rest))) + +(defmethod compute-min-rest ((alternation alternation) current-min-rest) + (loop for choice in (choices alternation) + minimize (compute-min-rest choice current-min-rest))) + +(defmethod compute-min-rest ((branch branch) current-min-rest) + (min (compute-min-rest (then-regex branch) current-min-rest) + (compute-min-rest (else-regex branch) current-min-rest))) + +(defmethod compute-min-rest ((str str) current-min-rest) + (+ current-min-rest (len str))) + +(defmethod compute-min-rest ((repetition repetition) current-min-rest) + (setf (min-rest repetition) current-min-rest) + (compute-min-rest (regex repetition) current-min-rest) + (+ current-min-rest (* (minimum repetition) (min-len repetition)))) + +(defmethod compute-min-rest ((register register) current-min-rest) + (compute-min-rest (regex register) current-min-rest)) + +(defmethod compute-min-rest ((standalone standalone) current-min-rest) + (declare (ignore current-min-rest)) + (compute-min-rest (regex standalone) 0)) + +(defmethod compute-min-rest ((lookahead lookahead) current-min-rest) + (compute-min-rest (regex lookahead) 0) + current-min-rest) + +(defmethod compute-min-rest ((lookbehind lookbehind) current-min-rest) + (compute-min-rest (regex lookbehind) (+ current-min-rest (len lookbehind))) + current-min-rest) + +(defmethod compute-min-rest ((regex regex) current-min-rest) + (typecase regex + ((or char-class everything) + (1+ current-min-rest)) + (t + ;; zero min-len and no embedded regexes (ANCHOR, + ;; BACK-REFERENCE, VOID, and WORD-BOUNDARY) + current-min-rest))) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/packages.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/packages.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/packages.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,88 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/packages.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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) + +#-:cormanlisp +(defpackage #:cl-ppcre + (:nicknames #:ppcre) + (:use #:cl) + (:export #:create-scanner + #:scan + #:scan-to-strings + #:do-scans + #:do-matches + #:do-matches-as-strings + #:all-matches + #:all-matches-as-strings + #:split + #:regex-replace + #:regex-replace-all + #:regex-apropos + #:regex-apropos-list + #:quote-meta-chars + #:*regex-char-code-limit* + #:*use-bmh-matchers* + #:*allow-quoting* + #:ppcre-error + #:ppcre-invocation-error + #:ppcre-syntax-error + #:ppcre-syntax-error-string + #:ppcre-syntax-error-pos + #:register-groups-bind + #:do-register-groups)) + +#+:cormanlisp +(defpackage "CL-PPCRE" + (:nicknames "PPCRE") + (:use "CL") + (:export "CREATE-SCANNER" + "SCAN" + "SCAN-TO-STRINGS" + "DO-SCANS" + "DO-MATCHES" + "DO-MATCHES-AS-STRINGS" + "ALL-MATCHES" + "ALL-MATCHES-AS-STRINGS" + "SPLIT" + "REGEX-REPLACE" + "REGEX-REPLACE-ALL" + "REGEX-APROPOS" + "REGEX-APROPOS-LIST" + "QUOTE-META-CHARS" + "*REGEX-CHAR-CODE-LIMIT*" + "*USE-BMH-MATCHERS*" + "*ALLOW-QUOTING*" + "PPCRE-ERROR" + "PPCRE-INVOCATION-ERROR" + "PPCRE-SYNTAX-ERROR" + "PPCRE-SYNTAX-ERROR-STRING" + "PPCRE-SYNTAX-ERROR-POS" + "REGISTER-GROUPS-BIND" + "DO-REGISTER-GROUPS")) Added: vendor/portableaserve/libs/cl-ppcre/parser.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/parser.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/parser.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,347 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/parser.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; The parser will - with the help of the lexer - parse a regex +;;; string and convert it into a "parse tree" (see docs for details +;;; about the syntax of these trees). Note that the lexer might return +;;; illegal parse trees. It is assumed that the conversion process +;;; later on will track them down. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defun group (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Parses and consumes a <group>. +The productions are: <group> -> \"(\"<regex>\")\" + \"(?:\"<regex>\")\" + \"(?<\"<regex>\")\" + \"(?<flags>:\"<regex>\")\" + \"(?=\"<regex>\")\" + \"(?!\"<regex>\")\" + \"(?<=\"<regex>\")\" + \"(?<!\"<regex>\")\" + \"(?(\"<num>\")\"<regex>\")\" + \"(?(\"<regex>\")\"<regex>\")\" + <legal-token> +where <flags> is parsed by the lexer function MAYBE-PARSE-FLAGS. +Will return <parse-tree> or (<grouping-type> <parse-tree>) where +<grouping-type> is one of six keywords - see source for details." + (multiple-value-bind (open-token flags) + (get-token lexer) + (cond ((eq open-token :open-paren-paren) + ;; special case for conditional regular expressions; note + ;; that at this point we accept a couple of illegal + ;; combinations which'll be sorted out later by the + ;; converter + (let* ((open-paren-pos (car (lexer-last-pos lexer))) + ;; check if what follows "(?(" is a number + (number (try-number lexer :no-whitespace-p t)) + ;; make changes to extended-mode-p local + (*extended-mode-p* *extended-mode-p*)) + (declare (type fixnum open-paren-pos)) + (cond (number + ;; condition is a number (i.e. refers to a + ;; back-reference) + (let* ((inner-close-token (get-token lexer)) + (reg-expr (reg-expr lexer)) + (close-token (get-token lexer))) + (unless (eq inner-close-token :close-paren) + (signal-ppcre-syntax-error* + (+ open-paren-pos 2) + "Opening paren has no matching closing paren")) + (unless (eq close-token :close-paren) + (signal-ppcre-syntax-error* + open-paren-pos + "Opening paren has no matching closing paren")) + (list :branch number reg-expr))) + (t + ;; condition must be a full regex (actually a + ;; look-behind or look-ahead); and here comes a + ;; terrible kludge: instead of being cleanly + ;; separated from the lexer, the parser pushes + ;; back the lexer by one position, thereby + ;; landing in the middle of the 'token' "(?(" - + ;; yuck!! + (decf (lexer-pos lexer)) + (let* ((inner-reg-expr (group lexer)) + (reg-expr (reg-expr lexer)) + (close-token (get-token lexer))) + (unless (eq close-token :close-paren) + (signal-ppcre-syntax-error* + open-paren-pos + "Opening paren has no matching closing paren")) + (list :branch inner-reg-expr reg-expr)))))) + ((member open-token '(:open-paren + :open-paren-colon + :open-paren-greater + :open-paren-equal + :open-paren-exclamation + :open-paren-less-equal + :open-paren-less-exclamation) + :test #'eq) + ;; make changes to extended-mode-p local + (let ((*extended-mode-p* *extended-mode-p*)) + ;; we saw one of the six token representing opening + ;; parentheses + (let* ((open-paren-pos (car (lexer-last-pos lexer))) + (reg-expr (reg-expr lexer)) + (close-token (get-token lexer))) + (when (eq open-token :open-paren) + ;; if this is the "("<regex>")" production we have to + ;; increment the register counter of the lexer + (incf (lexer-reg lexer))) + (unless (eq close-token :close-paren) + ;; the token following <regex> must be the closing + ;; parenthesis or this is a syntax error + (signal-ppcre-syntax-error* + open-paren-pos + "Opening paren has no matching closing paren")) + (if flags + ;; if the lexer has returned a list of flags this must + ;; have been the "(?:"<regex>")" production + (cons :group (nconc flags (list reg-expr))) + (list (case open-token + ((:open-paren) + :register) + ((:open-paren-colon) + :group) + ((:open-paren-greater) + :standalone) + ((:open-paren-equal) + :positive-lookahead) + ((:open-paren-exclamation) + :negative-lookahead) + ((:open-paren-less-equal) + :positive-lookbehind) + ((:open-paren-less-exclamation) + :negative-lookbehind)) + reg-expr))))) + (t + ;; this is the <legal-token> production; <legal-token> is + ;; any token which passes START-OF-SUBEXPR-P (otherwise + ;; parsing had already stopped in the SEQ method) + open-token)))) + +(defun greedy-quant (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Parses and consumes a <greedy-quant>. +The productions are: <greedy-quant> -> <group> | <group><quantifier> +where <quantifier> is parsed by the lexer function GET-QUANTIFIER. +Will return <parse-tree> or (:GREEDY-REPETITION <min> <max> <parse-tree>)." + (let* ((group (group lexer)) + (token (get-quantifier lexer))) + (if token + ;; if GET-QUANTIFIER returned a non-NIL value it's the + ;; two-element list (<min> <max>) + (list :greedy-repetition (first token) (second token) group) + group))) + +(defun quant (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Parses and consumes a <quant>. +The productions are: <quant> -> <greedy-quant> | <greedy-quant>\"?\". +Will return the <parse-tree> returned by GREEDY-QUANT and optionally +change :GREEDY-REPETITION to :NON-GREEDY-REPETITION." + (let* ((greedy-quant (greedy-quant lexer)) + (pos (lexer-pos lexer)) + (next-char (next-char lexer))) + (when next-char + (if (char= next-char #\?) + (setf (car greedy-quant) :non-greedy-repetition) + (setf (lexer-pos lexer) pos))) + greedy-quant)) + +(defun seq (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Parses and consumes a <seq>. +The productions are: <seq> -> <quant> | <quant><seq>. +Will return <parse-tree> or (:SEQUENCE <parse-tree> <parse-tree>)." + (flet ((make-array-from-two-chars (char1 char2) + (let ((string (make-array 2 + :element-type 'character + :fill-pointer t + :adjustable t))) + (setf (aref string 0) char1) + (setf (aref string 1) char2) + string))) + ;; Note that we're calling START-OF-SUBEXPR-P before we actually try + ;; to parse a <seq> or <quant> in order to catch empty regular + ;; expressions + (if (start-of-subexpr-p lexer) + (let ((quant (quant lexer))) + (if (start-of-subexpr-p lexer) + (let* ((seq (seq lexer)) + (quant-is-char-p (characterp quant)) + (seq-is-sequence-p (and (consp seq) + (eq (first seq) :sequence)))) + (cond ((and quant-is-char-p + (characterp seq)) + (make-array-from-two-chars seq quant)) + ((and quant-is-char-p + (stringp seq)) + (vector-push-extend quant seq) + seq) + ((and quant-is-char-p + seq-is-sequence-p + (characterp (second seq))) + (cond ((cddr seq) + (setf (cdr seq) + (cons + (make-array-from-two-chars (second seq) + quant) + (cddr seq))) + seq) + (t (make-array-from-two-chars (second seq) quant)))) + ((and quant-is-char-p + seq-is-sequence-p + (stringp (second seq))) + (cond ((cddr seq) + (setf (cdr seq) + (cons + (progn + (vector-push-extend quant (second seq)) + (second seq)) + (cddr seq))) + seq) + (t + (vector-push-extend quant (second seq)) + (second seq)))) + (seq-is-sequence-p + ;; if <seq> is also a :SEQUENCE parse tree we merge + ;; both lists into one to avoid unnecessary consing + (setf (cdr seq) + (cons quant (cdr seq))) + seq) + (t (list :sequence quant seq)))) + quant)) + :void))) + +(defun reg-expr (lexer) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Parses and consumes a <regex>, a complete regular expression. +The productions are: <regex> -> <seq> | <seq>\"|\"<regex>. +Will return <parse-tree> or (:ALTERNATION <parse-tree> <parse-tree>)." + (let ((pos (lexer-pos lexer))) + (case (next-char lexer) + ((nil) + ;; if we didn't get any token we return :VOID which stands for + ;; "empty regular expression" + :void) + ((#\|) + ;; now check whether the expression started with a vertical + ;; bar, i.e. <seq> - the left alternation - is empty + (list :alternation :void (reg-expr lexer))) + (otherwise + ;; otherwise un-read the character we just saw and parse a + ;; <seq> plus the character following it + (setf (lexer-pos lexer) pos) + (let* ((seq (seq lexer)) + (pos (lexer-pos lexer))) + (case (next-char lexer) + ((nil) + ;; no further character, just a <seq> + seq) + ((#\|) + ;; if the character was a vertical bar, this is an + ;; alternation and we have the second production + (let ((reg-expr (reg-expr lexer))) + (cond ((and (consp reg-expr) + (eq (first reg-expr) :alternation)) + ;; again we try to merge as above in SEQ + (setf (cdr reg-expr) + (cons seq (cdr reg-expr))) + reg-expr) + (t (list :alternation seq reg-expr))))) + (otherwise + ;; a character which is not a vertical bar - this is + ;; either a syntax error or we're inside of a group and + ;; the next character is a closing parenthesis; so we + ;; just un-read the character and let another function + ;; take care of it + (setf (lexer-pos lexer) pos) + seq))))))) + +(defun reverse-strings (parse-tree) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (cond ((stringp parse-tree) + (nreverse parse-tree)) + ((consp parse-tree) + (loop for parse-tree-rest on parse-tree + while parse-tree-rest + do (setf (car parse-tree-rest) + (reverse-strings (car parse-tree-rest)))) + parse-tree) + (t parse-tree))) + +(defun parse-string (string) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Translate the regex string STRING into a parse tree." + (let* ((lexer (make-lexer string)) + (parse-tree (reverse-strings (reg-expr lexer)))) + ;; check whether we've consumed the whole regex string + (if (end-of-string-p lexer) + parse-tree + (signal-ppcre-syntax-error* + (lexer-pos lexer) + "Expected end of string")))) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/perltest.pl =================================================================== --- vendor/portableaserve/libs/cl-ppcre/perltest.pl 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/perltest.pl 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,174 @@ +#!/usr/bin/perl + +# This is a heavily modified version of the file 'perltest' which +# comes with the PCRE library package, which is open source software, +# written by Philip Hazel, and copyright by the University of +# Cambridge, England. + +# The PCRE library package is available from +# <ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre/> + +use Time::HiRes qw(time); + +sub string_for_lisp { + my(@a, $t, $in_string, $switch); + + my $string = shift; + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + + return "\"$string\"" + if $string =~ /^[\n\x20-\x7f]*$/; + + $in_string = 1; + foreach $c (split(//, $string)) { + if (ord $c >= 32 and ord $c < 127) { + if ($in_string) { + $t .= $c; + } else { + $in_string = 1; + $t = $c; + } + } else { + if ($in_string) { + push @a, "\"$t\""; + $in_string = 0; + $switch = 1; + } + push @a, ord $c; + } + } + if ($switch) { + if ($in_string) { + push @a, "\"$t\""; + } + '(' . (join ' ', @a) . ')'; + } else { + "\"$t\""; + } +} + +$min_time = shift; + +NEXT_RE: while (1) { + last + if !($_ = <>); + next + if $_ eq ""; + + $pattern = $_; + + while ($pattern !~ /^\s*(.).*\1/s) { + last + if !($_ = <>); + $pattern .= $_; + } + + chomp($pattern); + $pattern =~ s/\s+$//; + $pattern =~ s/\+(?=[a-z]*$)//; + + $multi_line_mode = ($pattern =~ /m[a-z]*$/) ? 't' : 'nil'; + $single_line_mode = ($pattern =~ /s[a-z]*$/) ? 't' : 'nil'; + $extended_mode = ($pattern =~ /x[a-z]*$/) ? 't' : 'nil'; + $case_insensitive_mode = ($pattern =~ /i[a-z]*$/) ? 't' : 'nil'; + $pattern =~ s/^(.*)g([a-z]*)$/\1\2/; + + $pattern_for_lisp = $pattern; + $pattern_for_lisp =~ s/[a-z]*$//; + $pattern_for_lisp =~ s/^\s*(.)(.*)\1/$2/s; + $pattern_for_lisp =~ s/\\/\\\\/g; + $pattern_for_lisp =~ s/"/\\"/g; + + $pattern = "/(?#)/$2" + if ($pattern =~ /^(.)\1(.*)$/); + + while (1) { + last NEXT_RE + if !($_ = <>); + + chomp; + + s/\s+$//; + s/^\s+//; + + last + if ($_ eq ""); + + $info_string = string_for_lisp "\"$_\" =~ $pattern"; + $x = eval "\"$_\""; + + @subs = (); + + eval <<"END"; +if (\$x =~ ${pattern}) { + push \@subs,\$&; + push \@subs,\$1; + push \@subs,\$2; + push \@subs,\$3; + push \@subs,\$4; + push \@subs,\$5; + push \@subs,\$6; + push \@subs,\$7; + push \@subs,\$8; + push \@subs,\$9; + push \@subs,\$10; + push \@subs,\$11; + push \@subs,\$12; + push \@subs,\$13; + push \@subs,\$14; + push \@subs,\$15; + push \@subs,\$16; +} + +\$test = sub { + my \$times = shift; + + my \$start = time; + for (my \$i = 0; \$i < \$times; \$i++) { + \$x =~ ${pattern}; + } + return time - \$start; +}; +END + + $times = 1; + $used = 0; + $counter++; + print STDERR "$counter\n"; + + if ($@) { + $error = 't'; + } else { + $error = 'nil'; + if ($min_time) { + $times = 10; + while (1) { + $used = &$test($times); + last + if $used > $min_time; + $times *= 10; + } + } + } + + print "($counter $info_string \"$pattern_for_lisp\" $case_insensitive_mode $multi_line_mode $single_line_mode $extended_mode " . string_for_lisp($x) . " $error $times $used "; + if (!@subs) { + print 'nil nil'; + } else { + print string_for_lisp($subs[0]) . ' ('; + undef $not_first; + for ($i = 1; $i <= 16; $i++) { + print ' ' + unless $i == 1; + if (defined $subs[$i]) { + print string_for_lisp $subs[$i]; + } else { + print 'nil'; + } + } + print ')'; + } + print ")\n"; + } +} Added: vendor/portableaserve/libs/cl-ppcre/ppcre-tests.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/ppcre-tests.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/ppcre-tests.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,296 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/ppcre-tests.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Copyright (c) 2002-2003, 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) + +#-:cormanlisp +(defpackage #:cl-ppcre-test + (:use #:cl #:cl-ppcre) + (:export #:test)) + +#+:cormanlisp +(defpackage "CL-PPCRE-TEST" + (:use "CL" "CL-PPCRE") + (:export "TEST")) + +(in-package #:cl-ppcre-test) + +(defparameter *cl-ppcre-test-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defun full-gc () + "Start a full garbage collection." + ;; what are the corresponding values for MCL and OpenMCL? + #+:allegro (excl:gc t) + #+(or :cmu :scl) (ext:gc :full t) + #+:ecl (si:gc t) + #+:clisp (ext:gc) + #+:cormanlisp (loop for i from 0 to 3 do (cormanlisp:gc i)) + #+:lispworks (hcl:mark-and-sweep 3) + #+:sbcl (sb-ext:gc :full t)) + +;; warning: ugly code ahead!! +;; this is just a quick hack for testing purposes + +(defun time-regex (factor regex string + &key case-insensitive-mode + multi-line-mode + single-line-mode + extended-mode) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Auxiliary function used by TEST to benchmark a regex scanner +against Perl timings." + (declare (type string string)) + (let* ((scanner (create-scanner regex + :case-insensitive-mode case-insensitive-mode + :multi-line-mode multi-line-mode + :single-line-mode single-line-mode + :extended-mode extended-mode)) + ;; make sure GC doesn't invalidate our benchmarking + (dummy (full-gc)) + (start (get-internal-real-time))) + (declare (ignore dummy)) + (dotimes (i factor) + (funcall scanner string 0 (length string))) + (float (/ (- (get-internal-real-time) start) internal-time-units-per-second)))) + +#+(or scl + lispworks + (and sbcl sb-thread)) +(defun threaded-scan (scanner target-string &key (threads 10) (repetitions 5000)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Auxiliary function used by TEST to check whether SCANNER is thread-safe." + (full-gc) + (let ((collector (make-array threads)) + (counter 0)) + (loop for i below threads + do (let* ((j i) + (fn + (lambda () + (let ((r (random repetitions))) + (loop for k below repetitions + if (= k r) + do (setf (aref collector j) + (let ((result + (multiple-value-list + (cl-ppcre:scan scanner target-string)))) + (unless (cdr result) + (setq result '(nil nil #() #()))) + result)) + else + do (cl-ppcre:scan scanner target-string)) + (incf counter))))) + #+scl (thread:thread-create fn) + #+lispworks (mp:process-run-function "" nil fn) + #+(and sbcl sb-thread) (sb-thread:make-thread fn))) + (loop while (< counter threads) + do (sleep .1)) + (destructuring-bind (first-start first-end first-reg-starts first-reg-ends) + (aref collector 0) + (loop for (start end reg-starts reg-ends) across collector + if (or (not (eql first-start start)) + (not (eql first-end end)) + (/= (length first-reg-starts) (length reg-starts)) + (/= (length first-reg-ends) (length reg-ends)) + (loop for first-reg-start across first-reg-starts + for reg-start across reg-starts + thereis (not (eql first-reg-start reg-start))) + (loop for first-reg-end across first-reg-ends + for reg-end across reg-ends + thereis (not (eql first-reg-end reg-end)))) + do (return (format nil "~&Inconsistent results during multi-threading")))))) + +(defun create-string-from-input (input) + (cond ((or (null input) + (stringp input)) + input) + (t + (cl-ppcre::string-list-to-simple-string + (loop for element in input + if (stringp element) + collect element + else + collect (string (code-char element))))))) + +(defun test (&key (file-name + (make-pathname :name "testdata" + :type nil :version nil + :defaults *cl-ppcre-test-base-directory*) + file-name-provided-p) + threaded) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (ignorable threaded)) + "Loop through all test cases in FILE-NAME and print report. Only in +LispWorks and SCL: If THREADED is true, also test whether the scanners +work multi-threaded." + (with-open-file (stream file-name + #+(or :allegro :clisp :scl) + :external-format + #+(or :allegro :clisp :scl) + (if file-name-provided-p + :default + #+:allegro :iso-8859-1 + #+:clisp charset:iso-8859-1 + #+:scl :iso-8859-1)) + (loop with testcount of-type fixnum = 0 + with *regex-char-code-limit* = (if file-name-provided-p + *regex-char-code-limit* + ;; the standard test suite + ;; doesn't need full + ;; Unicode support + 255) + with *allow-quoting* = (if file-name-provided-p + *allow-quoting* + t) + for input-line = (read stream nil nil) + for (counter info-string regex + case-insensitive-mode multi-line-mode + single-line-mode extended-mode + string perl-error factor + perl-time ex-result ex-subs) = input-line + while input-line + do (let ((info-string (create-string-from-input info-string)) + (regex (create-string-from-input regex)) + (string (create-string-from-input string)) + (ex-result (create-string-from-input ex-result)) + (ex-subs (mapcar #'create-string-from-input ex-subs)) + (errors '())) + ;; provide some visual feedback for slow CL + ;; implementations; suggested by JP Massar + (incf testcount) + #+(or scl + lispworks + (and sbcl sb-thread)) + (when threaded + (format t "Test #~A (ID ~A)~%" testcount counter) + (force-output)) + (unless #-(or scl + lispworks + (and sbcl sb-thread)) + nil + #+(or scl + lispworks + (and sbcl sb-thread)) + threaded + (when (zerop (mod testcount 10)) + (format t ".") + (force-output)) + (when (zerop (mod testcount 100)) + (terpri))) + (handler-case + (let* ((*use-bmh-matchers* (if (and (> factor 1) (plusp perl-time)) + *use-bmh-matchers* + ;; if we only check for + ;; correctness we don't + ;; care about speed that + ;; match (but rather + ;; about space + ;; constraints of the + ;; trial versions) + nil)) + (scanner (create-scanner regex + :case-insensitive-mode case-insensitive-mode + :multi-line-mode multi-line-mode + :single-line-mode single-line-mode + :extended-mode extended-mode))) + (multiple-value-bind (result1 result2 sub-starts sub-ends) + (scan scanner string) + (cond (perl-error + (push (format nil + "~&expected an error but got a result") + errors)) + (t + (when (not (eq result1 ex-result)) + (if result1 + (let ((result (subseq string result1 result2))) + (unless (string= result ex-result) + (push (format nil + "~&expected ~S but got ~S" + ex-result result) + errors)) + (setq sub-starts (coerce sub-starts 'list) + sub-ends (coerce sub-ends 'list)) + (loop for i from 0 + for ex-sub in ex-subs + for sub-start = (nth i sub-starts) + for sub-end = (nth i sub-ends) + for sub = (if (and sub-start sub-end) + (subseq string sub-start sub-end) + nil) + unless (string= ex-sub sub) + do (push (format nil + "~&\\~A: expected ~S but got ~S" + (1+ i) ex-sub sub) errors))) + (push (format nil + "~&expected ~S but got ~S" + ex-result result1) + errors))))) + #+(or scl + lispworks + (and sbcl sb-thread)) + (when threaded + (let ((thread-result (threaded-scan scanner string))) + (when thread-result + (push thread-result errors)))))) + (condition (msg) + (unless perl-error + (push (format nil "~&got an unexpected error: '~A'" msg) + errors)))) + (setq errors (nreverse errors)) + (cond (errors + (when (or (<= factor 1) (zerop perl-time)) + (format t "~&~4@A (~A):~{~& ~A~}~%" + counter info-string errors))) + ((and (> factor 1) (plusp perl-time)) + (let ((result (time-regex factor regex string + :case-insensitive-mode case-insensitive-mode + :multi-line-mode multi-line-mode + :single-line-mode single-line-mode + :extended-mode extended-mode))) + (format t "~&~4@A: ~,4F (~A repetitions, Perl: ~,4F seconds, CL-PPCRE: ~,4F seconds)" counter + (float (/ result perl-time)) factor perl-time result) + #+:cormanlisp (force-output *standard-output*))) + (t nil)))) + (values))) Added: vendor/portableaserve/libs/cl-ppcre/regex-class.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/regex-class.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/regex-class.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,752 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/regex-class.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; This file defines the REGEX class and some utility methods for +;;; this class. REGEX objects are used to represent the (transformed) +;;; parse trees internally + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(locally + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (defclass regex () + () + (:documentation "The REGEX base class. All other classes inherit from this one.")) + + + (defclass seq (regex) + ((elements :initarg :elements + :accessor elements + :type cons + :documentation "A list of REGEX objects.")) + (:documentation "SEQ objects represents sequences of +regexes. (Like \"ab\" is the sequence of \"a\" and \"b\".)")) + + (defclass alternation (regex) + ((choices :initarg :choices + :accessor choices + :type cons + :documentation "A list of REGEX objects")) + (:documentation "ALTERNATION objects represent alternations of +regexes. (Like \"a|b\" ist the alternation of \"a\" or \"b\".)")) + + (defclass lookahead (regex) + ((regex :initarg :regex + :accessor regex + :documentation "The REGEX object we're checking.") + (positivep :initarg :positivep + :reader positivep + :documentation "Whether this assertion is positive.")) + (:documentation "LOOKAHEAD objects represent look-ahead assertions.")) + + (defclass lookbehind (regex) + ((regex :initarg :regex + :accessor regex + :documentation "The REGEX object we're checking.") + (positivep :initarg :positivep + :reader positivep + :documentation "Whether this assertion is positive.") + (len :initarg :len + :accessor len + :type fixnum + :documentation "The (fixed) length of the enclosed regex.")) + (:documentation "LOOKBEHIND objects represent look-behind assertions.")) + + (defclass repetition (regex) + ((regex :initarg :regex + :accessor regex + :documentation "The REGEX that's repeated.") + (greedyp :initarg :greedyp + :reader greedyp + :documentation "Whether the repetition is greedy.") + (minimum :initarg :minimum + :accessor minimum + :type fixnum + :documentation "The minimal number of repetitions.") + (maximum :initarg :maximum + :accessor maximum + :documentation "The maximal number of repetitions. +Can be NIL for unbounded.") + (min-len :initarg :min-len + :reader min-len + :documentation "The minimal length of the enclosed regex.") + (len :initarg :len + :reader len + :documentation "The length of the enclosed regex. NIL if unknown.") + (min-rest :initform 0 + :accessor min-rest + :type fixnum + :documentation "The minimal number of characters which must +appear after this repetition.") + (contains-register-p :initarg :contains-register-p + :reader contains-register-p + :documentation "If the regex contains a register.")) + (:documentation "REPETITION objects represent repetitions of regexes.")) + + (defclass register (regex) + ((regex :initarg :regex + :accessor regex + :documentation "The inner regex.") + (num :initarg :num + :reader num + :type fixnum + :documentation "The number of this register, starting from 0. +This is the index into *REGS-START* and *REGS-END*.")) + (:documentation "REGISTER objects represent register groups.")) + + (defclass standalone (regex) + ((regex :initarg :regex + :accessor regex + :documentation "The inner regex.")) + (:documentation "A standalone regular expression.")) + + (defclass back-reference (regex) + ((num :initarg :num + :accessor num + :type fixnum + :documentation "The number of the register this reference refers to.") + (case-insensitive-p :initarg :case-insensitive-p + :reader case-insensitive-p + :documentation "Whether we check case-insensitively.")) + (:documentation "BACK-REFERENCE objects represent backreferences.")) + + (defclass char-class (regex) + ((hash :initarg :hash + :reader hash + :type (or hash-table null) + :documentation "A hash table the keys of which are the characters; +the values are always T.") + (case-insensitive-p :initarg :case-insensitive-p + :reader case-insensitive-p + :documentation "If the char class case-insensitive.") + (invertedp :initarg :invertedp + :reader invertedp + :documentation "Whether we mean the inverse of the char class.") + (word-char-class-p :initarg :word-char-class-p + :reader word-char-class-p + :documentation "Whether this CHAR CLASS +represents the special class WORD-CHAR-CLASS.")) + (:documentation "CHAR-CLASS objects represent character classes.")) + + (defclass str (regex) + ((str :initarg :str + :accessor str + :type string + :documentation "The actual string.") + (len :initform 0 + :accessor len + :type fixnum + :documentation "The length of the string.") + (case-insensitive-p :initarg :case-insensitive-p + :reader case-insensitive-p + :documentation "If we match case-insensitively.") + (offset :initform nil + :accessor offset + :documentation "Offset from the left of the whole parse tree. +The first regex has offset 0. +NIL if unknown, i.e. behind a variable-length regex.") + (skip :initform nil + :initarg :skip + :accessor skip + :documentation "If we can avoid testing for this string +because the SCAN function has done this already.") + (start-of-end-string-p :initform nil + :accessor start-of-end-string-p + :documentation "If this is the unique STR which +starts END-STRING (a slot of MATCHER).")) + (:documentation "STR objects represent string.")) + + (defclass anchor (regex) + ((startp :initarg :startp + :reader startp + :documentation "Whether this is a \"start anchor\".") + (multi-line-p :initarg :multi-line-p + :reader multi-line-p + :documentation "Whether we're in multi-line mode, +i.e. whether each #\\Newline is surrounded by anchors.") + (no-newline-p :initarg :no-newline-p + :reader no-newline-p + :documentation "Whether we ignore #\\Newline at the end.")) + (:documentation "ANCHOR objects represent anchors like \"^\" or \"$\".")) + + (defclass everything (regex) + ((single-line-p :initarg :single-line-p + :reader single-line-p + :documentation "Whether we're in single-line mode, +i.e. whether we also match #\\Newline.")) + (:documentation "EVERYTHING objects represent regexes matching +\"everything\", i.e. dots.")) + + (defclass word-boundary (regex) + ((negatedp :initarg :negatedp + :reader negatedp + :documentation "Whether we mean the opposite, +i.e. no word-boundary.")) + (:documentation "WORD-BOUNDARY objects represent word-boundary assertions.")) + + (defclass branch (regex) + ((test :initarg :test + :accessor test + :documentation "The test of this branch, one of LOOKAHEAD, +LOOKBEHIND, or a number.") + (then-regex :initarg :then-regex + :accessor then-regex + :documentation "The regex that's to be matched if the +test succeeds.") + (else-regex :initarg :else-regex + :initform (make-instance 'void) + :accessor else-regex + :documentation "The regex that's to be matched if the +test fails.")) + (:documentation "BRANCH objects represent Perl's conditional regular +expressions.")) + + (defclass void (regex) + () + (:documentation "VOID objects represent empty regular expressions."))) + +(declaim (ftype (function (t) simple-string) str)) + +;;; The following four methods allow a VOID object to behave like a +;;; zero-length STR object (only readers needed) + +(defmethod initialize-instance :after ((str str) &rest init-args) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (ignore init-args)) + "Automatically computes the length of a STR after initialization." + (let ((str-slot (slot-value str 'str))) + (unless (typep str-slot 'simple-string) + (setf (slot-value str 'str) (coerce str-slot 'simple-string)))) + (setf (len str) (length (str str)))) + +(defmethod len ((void void)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + 0) + +(defmethod str ((void void)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "") + +(defmethod skip ((void void)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + nil) + +(defmethod start-of-end-string-p ((void void)) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + nil) + +(defgeneric case-mode (regex old-case-mode) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Utility function used by the optimizer (see GATHER-STRINGS). +Returns a keyword denoting the case-(in)sensitivity of a STR or its +second argument if the STR has length 0. Returns NIL for REGEX objects +which are not of type STR.")) + +(defmethod case-mode ((str str) old-case-mode) + (cond ((zerop (len str)) + old-case-mode) + ((case-insensitive-p str) + :case-insensitive) + (t + :case-sensitive))) + +(defmethod case-mode ((regex regex) old-case-mode) + (declare (ignore old-case-mode)) + nil) + +(defgeneric copy-regex (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Implements a deep copy of a REGEX object.")) + +(defmethod copy-regex ((anchor anchor)) + (make-instance 'anchor + :startp (startp anchor) + :multi-line-p (multi-line-p anchor) + :no-newline-p (no-newline-p anchor))) + +(defmethod copy-regex ((everything everything)) + (make-instance 'everything + :single-line-p (single-line-p everything))) + +(defmethod copy-regex ((word-boundary word-boundary)) + (make-instance 'word-boundary + :negatedp (negatedp word-boundary))) + +(defmethod copy-regex ((void void)) + (make-instance 'void)) + +(defmethod copy-regex ((lookahead lookahead)) + (make-instance 'lookahead + :regex (copy-regex (regex lookahead)) + :positivep (positivep lookahead))) + +(defmethod copy-regex ((seq seq)) + (make-instance 'seq + :elements (mapcar #'copy-regex (elements seq)))) + +(defmethod copy-regex ((alternation alternation)) + (make-instance 'alternation + :choices (mapcar #'copy-regex (choices alternation)))) + +(defmethod copy-regex ((branch branch)) + (with-slots ((test test)) + branch + (make-instance 'branch + :test (if (typep test 'regex) + (copy-regex test) + test) + :then-regex (copy-regex (then-regex branch)) + :else-regex (copy-regex (else-regex branch))))) + +(defmethod copy-regex ((lookbehind lookbehind)) + (make-instance 'lookbehind + :regex (copy-regex (regex lookbehind)) + :positivep (positivep lookbehind) + :len (len lookbehind))) + +(defmethod copy-regex ((repetition repetition)) + (make-instance 'repetition + :regex (copy-regex (regex repetition)) + :greedyp (greedyp repetition) + :minimum (minimum repetition) + :maximum (maximum repetition) + :min-len (min-len repetition) + :len (len repetition) + :contains-register-p (contains-register-p repetition))) + +(defmethod copy-regex ((register register)) + (make-instance 'register + :regex (copy-regex (regex register)) + :num (num register))) + +(defmethod copy-regex ((standalone standalone)) + (make-instance 'standalone + :regex (copy-regex (regex standalone)))) + +(defmethod copy-regex ((back-reference back-reference)) + (make-instance 'back-reference + :num (num back-reference) + :case-insensitive-p (case-insensitive-p back-reference))) + +(defmethod copy-regex ((char-class char-class)) + (make-instance 'char-class + :hash (hash char-class) + :case-insensitive-p (case-insensitive-p char-class) + :invertedp (invertedp char-class) + :word-char-class-p (word-char-class-p char-class))) + +(defmethod copy-regex ((str str)) + (make-instance 'str + :str (str str) + :case-insensitive-p (case-insensitive-p str))) + +;;; Note that COPY-REGEX and REMOVE-REGISTERS could have easily been +;;; wrapped into one function. Maybe in the next release... + +;;; Further note that this function is used by CONVERT to factor out +;;; complicated repetitions, i.e. cases like +;;; (a)* -> (?:a*(a))? +;;; This won't work for, say, +;;; ((a)|(b))* -> (?:(?:a|b)*((a)|(b)))? +;;; and therefore we stop REGISTER removal once we see an ALTERNATION. + +(defgeneric remove-registers (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns a deep copy of a REGEX (see COPY-REGEX) and +optionally removes embedded REGISTER objects if possible and if the +special variable REMOVE-REGISTERS-P is true.")) + +(defmethod remove-registers ((register register)) + (declare (special remove-registers-p reg-seen)) + (cond (remove-registers-p + (remove-registers (regex register))) + (t + ;; mark REG-SEEN as true so enclosing REPETITION objects + ;; (see method below) know if they contain a register or not + (setq reg-seen t) + (copy-regex register)))) + +(defmethod remove-registers ((repetition repetition)) + (let* (reg-seen + (inner-regex (remove-registers (regex repetition)))) + ;; REMOVE-REGISTERS will set REG-SEEN (see method above) if + ;; (REGEX REPETITION) contains a REGISTER + (declare (special reg-seen)) + (make-instance 'repetition + :regex inner-regex + :greedyp (greedyp repetition) + :minimum (minimum repetition) + :maximum (maximum repetition) + :min-len (min-len repetition) + :len (len repetition) + :contains-register-p reg-seen))) + +(defmethod remove-registers ((standalone standalone)) + (make-instance 'standalone + :regex (remove-registers (regex standalone)))) + +(defmethod remove-registers ((lookahead lookahead)) + (make-instance 'lookahead + :regex (remove-registers (regex lookahead)) + :positivep (positivep lookahead))) + +(defmethod remove-registers ((lookbehind lookbehind)) + (make-instance 'lookbehind + :regex (remove-registers (regex lookbehind)) + :positivep (positivep lookbehind) + :len (len lookbehind))) + +(defmethod remove-registers ((branch branch)) + (with-slots ((test test)) + branch + (make-instance 'branch + :test (if (typep test 'regex) + (remove-registers test) + test) + :then-regex (remove-registers (then-regex branch)) + :else-regex (remove-registers (else-regex branch))))) + +(defmethod remove-registers ((alternation alternation)) + (declare (special remove-registers-p)) + ;; an ALTERNATION, so we can't remove REGISTER objects further down + (setq remove-registers-p nil) + (copy-regex alternation)) + +(defmethod remove-registers ((regex regex)) + (copy-regex regex)) + +(defmethod remove-registers ((seq seq)) + (make-instance 'seq + :elements (mapcar #'remove-registers (elements seq)))) + +(defgeneric everythingp (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns an EVERYTHING object if REGEX is equivalent +to this object, otherwise NIL. So, \"(.){1}\" would return true +(i.e. the object corresponding to \".\", for example.")) + +(defmethod everythingp ((seq seq)) + ;; we might have degenerate cases like (:SEQUENCE :VOID ...) + ;; due to the parsing process + (let ((cleaned-elements (remove-if #'(lambda (element) + (typep element 'void)) + (elements seq)))) + (and (= 1 (length cleaned-elements)) + (everythingp (first cleaned-elements))))) + +(defmethod everythingp ((alternation alternation)) + (with-slots ((choices choices)) + alternation + (and (= 1 (length choices)) + ;; this is unlikely to happen for human-generated regexes, + ;; but machine-generated ones might look like this + (everythingp (first choices))))) + +(defmethod everythingp ((repetition repetition)) + (with-slots ((maximum maximum) + (minimum minimum) + (regex regex)) + repetition + (and maximum + (= 1 minimum maximum) + ;; treat "<regex>{1,1}" like "<regex>" + (everythingp regex)))) + +(defmethod everythingp ((register register)) + (everythingp (regex register))) + +(defmethod everythingp ((standalone standalone)) + (everythingp (regex standalone))) + +(defmethod everythingp ((everything everything)) + everything) + +(defmethod everythingp ((regex regex)) + ;; the general case for ANCHOR, BACK-REFERENCE, BRANCH, CHAR-CLASS, + ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, and WORD-BOUNDARY + nil) + +(defgeneric regex-length (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Return the length of REGEX if it is fixed, NIL otherwise.")) + +(defmethod regex-length ((seq seq)) + ;; simply add all inner lengths unless one of them is NIL + (loop for sub-regex in (elements seq) + for len = (regex-length sub-regex) + if (not len) do (return nil) + sum len)) + +(defmethod regex-length ((alternation alternation)) + ;; only return a true value if all inner lengths are non-NIL and + ;; mutually equal + (loop for sub-regex in (choices alternation) + for old-len = nil then len + for len = (regex-length sub-regex) + if (or (not len) + (and old-len (/= len old-len))) do (return nil) + finally (return len))) + +(defmethod regex-length ((branch branch)) + ;; only return a true value if both alternations have a length and + ;; if they're equal + (let ((then-length (regex-length (then-regex branch)))) + (and then-length + (eql then-length (regex-length (else-regex branch))) + then-length))) + +(defmethod regex-length ((repetition repetition)) + ;; we can only compute the length of a REPETITION object if the + ;; number of repetitions is fixed; note that we don't call + ;; REGEX-LENGTH for the inner regex, we assume that the LEN slot is + ;; always set correctly + (with-slots ((len len) + (minimum minimum) + (maximum maximum)) + repetition + (if (and len + (eq minimum maximum)) + (* minimum len) + nil))) + +(defmethod regex-length ((register register)) + (regex-length (regex register))) + +(defmethod regex-length ((standalone standalone)) + (regex-length (regex standalone))) + +(defmethod regex-length ((back-reference back-reference)) + ;; with enough effort we could possibly do better here, but + ;; currently we just give up and return NIL + nil) + +(defmethod regex-length ((char-class char-class)) + 1) + +(defmethod regex-length ((everything everything)) + 1) + +(defmethod regex-length ((str str)) + (len str)) + +(defmethod regex-length ((regex regex)) + ;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and + ;; WORD-BOUNDARY (which all have zero-length) + 0) + +(defgeneric regex-min-length (regex) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns the minimal length of REGEX.")) + +(defmethod regex-min-length ((seq seq)) + ;; simply add all inner minimal lengths + (loop for sub-regex in (elements seq) + for len = (regex-min-length sub-regex) + sum len)) + +(defmethod regex-min-length ((alternation alternation)) + ;; minimal length of an alternation is the minimal length of the + ;; "shortest" element + (loop for sub-regex in (choices alternation) + for len = (regex-min-length sub-regex) + minimize len)) + +(defmethod regex-min-length ((branch branch)) + ;; minimal length of both alternations + (min (regex-min-length (then-regex branch)) + (regex-min-length (else-regex branch)))) + +(defmethod regex-min-length ((repetition repetition)) + ;; obviously the product of the inner minimal length and the minimal + ;; number of repetitions + (* (minimum repetition) (min-len repetition))) + +(defmethod regex-min-length ((register register)) + (regex-min-length (regex register))) + +(defmethod regex-min-length ((standalone standalone)) + (regex-min-length (regex standalone))) + +(defmethod regex-min-length ((char-class char-class)) + 1) + +(defmethod regex-min-length ((everything everything)) + 1) + +(defmethod regex-min-length ((str str)) + (len str)) + +(defmethod regex-min-length ((regex regex)) + ;; the general case for ANCHOR, BACK-REFERENCE, LOOKAHEAD, + ;; LOOKBEHIND, VOID, and WORD-BOUNDARY + 0) + +(defgeneric compute-offsets (regex start-pos) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (:documentation "Returns the offset the following regex would have +relative to START-POS or NIL if we can't compute it. Sets the OFFSET +slot of REGEX to START-POS if REGEX is a STR. May also affect OFFSET +slots of STR objects further down the tree.")) + +;; note that we're actually only interested in the offset of +;; "top-level" STR objects (see ADVANCE-FN in the SCAN function) so we +;; can stop at variable-length alternations and don't need to descend +;; into repetitions + +(defmethod compute-offsets ((seq seq) start-pos) + (loop for element in (elements seq) + ;; advance offset argument for next call while looping through + ;; the elements + for pos = start-pos then curr-offset + for curr-offset = (compute-offsets element pos) + while curr-offset + finally (return curr-offset))) + +(defmethod compute-offsets ((alternation alternation) start-pos) + (loop for choice in (choices alternation) + for old-offset = nil then curr-offset + for curr-offset = (compute-offsets choice start-pos) + ;; we stop immediately if two alternations don't result in the + ;; same offset + if (or (not curr-offset) + (and old-offset (/= curr-offset old-offset))) + do (return nil) + finally (return curr-offset))) + +(defmethod compute-offsets ((branch branch) start-pos) + ;; only return offset if both alternations have equal value + (let ((then-offset (compute-offsets (then-regex branch) start-pos))) + (and then-offset + (eql then-offset (compute-offsets (else-regex branch) start-pos)) + then-offset))) + +(defmethod compute-offsets ((repetition repetition) start-pos) + ;; no need to descend into the inner regex + (with-slots ((len len) + (minimum minimum) + (maximum maximum)) + repetition + (if (and len + (eq minimum maximum)) + ;; fixed number of repetitions, so we know how to proceed + (+ start-pos (* minimum len)) + ;; otherwise return NIL + nil))) + +(defmethod compute-offsets ((register register) start-pos) + (compute-offsets (regex register) start-pos)) + +(defmethod compute-offsets ((standalone standalone) start-pos) + (compute-offsets (regex standalone) start-pos)) + +(defmethod compute-offsets ((char-class char-class) start-pos) + (1+ start-pos)) + +(defmethod compute-offsets ((everything everything) start-pos) + (1+ start-pos)) + +(defmethod compute-offsets ((str str) start-pos) + (setf (offset str) start-pos) + (+ start-pos (len str))) + +(defmethod compute-offsets ((back-reference back-reference) start-pos) + ;; with enough effort we could possibly do better here, but + ;; currently we just give up and return NIL + (declare (ignore start-pos)) + nil) + +(defmethod compute-offsets ((regex regex) start-pos) + ;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and + ;; WORD-BOUNDARY (which all have zero-length) + start-pos) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/repetition-closures.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/repetition-closures.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/repetition-closures.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,868 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/repetition-closures.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; This is actually a part of closures.lisp which we put into a +;;; separate file because it is rather complex. We only deal with +;;; REPETITIONs here. Note that this part of the code contains some +;;; rather crazy micro-optimizations which were introduced to be as +;;; competitive with Perl as possible in tight loops. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defmacro incf-after (place &optional (delta 1) &environment env) + "Utility macro inspired by C's \"place++\", i.e. first return the +value of PLACE and afterwards increment it by DELTA." + (with-unique-names (%temp) + (multiple-value-bind (vars vals store-vars writer-form reader-form) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list vars vals) + (,%temp ,reader-form) + (,(car store-vars) (+ ,%temp ,delta))) + ,writer-form + ,%temp)))) + +;; code for greedy repetitions with minimum zero + +(defmacro greedy-constant-length-closure (check-curr-pos) + "This is the template for simple greedy repetitions (where simple +means that the minimum number of repetitions is zero, that the inner +regex to be checked is of fixed length LEN, and that it doesn't +contain registers, i.e. there's no need for backtracking). +CHECK-CURR-POS is a form which checks whether the inner regex of the +repetition matches at CURR-POS." + `(if maximum + (lambda (start-pos) + (declare (type fixnum start-pos maximum)) + ;; because we know LEN we know in advance where to stop at the + ;; latest; we also take into consideration MIN-REST, i.e. the + ;; minimal length of the part behind the repetition + (let ((target-end-pos (min (1+ (- *end-pos* len min-rest)) + ;; don't go further than MAXIMUM + ;; repetitions, of course + (+ start-pos + (the fixnum (* len maximum))))) + (curr-pos start-pos)) + (declare (type fixnum target-end-pos curr-pos)) + (block greedy-constant-length-matcher + ;; we use an ugly TAGBODY construct because this might be a + ;; tight loop and this version is a bit faster than our LOOP + ;; version (at least in CMUCL) + (tagbody + forward-loop + ;; first go forward as far as possible, i.e. while + ;; the inner regex matches + (when (>= curr-pos target-end-pos) + (go backward-loop)) + (when ,check-curr-pos + (incf curr-pos len) + (go forward-loop)) + backward-loop + ;; now go back LEN steps each until we're able to match + ;; the rest of the regex + (when (< curr-pos start-pos) + (return-from greedy-constant-length-matcher nil)) + (let ((result (funcall next-fn curr-pos))) + (when result + (return-from greedy-constant-length-matcher result))) + (decf curr-pos len) + (go backward-loop))))) + ;; basically the same code; it's just a bit easier because we're + ;; not bounded by MAXIMUM + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((target-end-pos (1+ (- *end-pos* len min-rest))) + (curr-pos start-pos)) + (declare (type fixnum target-end-pos curr-pos)) + (block greedy-constant-length-matcher + (tagbody + forward-loop + (when (>= curr-pos target-end-pos) + (go backward-loop)) + (when ,check-curr-pos + (incf curr-pos len) + (go forward-loop)) + backward-loop + (when (< curr-pos start-pos) + (return-from greedy-constant-length-matcher nil)) + (let ((result (funcall next-fn curr-pos))) + (when result + (return-from greedy-constant-length-matcher result))) + (decf curr-pos len) + (go backward-loop))))))) + +(defun create-greedy-everything-matcher (maximum min-rest next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum min-rest) + (type function next-fn)) + "Creates a closure which just matches as far ahead as possible, +i.e. a closure for a dot in single-line mode." + (if maximum + (lambda (start-pos) + (declare (type fixnum start-pos maximum)) + ;; because we know LEN we know in advance where to stop at the + ;; latest; we also take into consideration MIN-REST, i.e. the + ;; minimal length of the part behind the repetition + (let ((target-end-pos (min (+ start-pos maximum) + (- *end-pos* min-rest)))) + (declare (type fixnum target-end-pos)) + ;; start from the highest possible position and go backward + ;; until we're able to match the rest of the regex + (loop for curr-pos of-type fixnum from target-end-pos downto start-pos + thereis (funcall next-fn curr-pos)))) + ;; basically the same code; it's just a bit easier because we're + ;; not bounded by MAXIMUM + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((target-end-pos (- *end-pos* min-rest))) + (declare (type fixnum target-end-pos)) + (loop for curr-pos of-type fixnum from target-end-pos downto start-pos + thereis (funcall next-fn curr-pos)))))) + +(defmethod create-greedy-constant-length-matcher ((repetition repetition) + next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is greedy and the minimal number of repetitions is +zero. It is furthermore assumed that the inner regex of REPETITION is +of fixed length and doesn't contain registers." + (let ((len (len repetition)) + (maximum (maximum repetition)) + (regex (regex repetition)) + (min-rest (min-rest repetition))) + (declare (type fixnum len min-rest) + (type function next-fn)) + (cond ((zerop len) + ;; inner regex has zero-length, so we can discard it + ;; completely + next-fn) + (t + ;; now first try to optimize for a couple of common cases + (typecase regex + (str + (let ((str (str regex))) + (if (= 1 len) + ;; a single character + (let ((chr (schar str 0))) + (if (case-insensitive-p regex) + (greedy-constant-length-closure + (char-equal chr (schar *string* curr-pos))) + (greedy-constant-length-closure + (char= chr (schar *string* curr-pos))))) + ;; a string + (if (case-insensitive-p regex) + (greedy-constant-length-closure + (*string*-equal str curr-pos (+ curr-pos len) 0 len)) + (greedy-constant-length-closure + (*string*= str curr-pos (+ curr-pos len) 0 len)))))) + (char-class + ;; a character class + (insert-char-class-tester (regex (schar *string* curr-pos)) + (if (invertedp regex) + (greedy-constant-length-closure + (not (char-class-test))) + (greedy-constant-length-closure + (char-class-test))))) + (everything + ;; an EVERYTHING object, i.e. a dot + (if (single-line-p regex) + (create-greedy-everything-matcher maximum min-rest next-fn) + (greedy-constant-length-closure + (char/= #\Newline (schar *string* curr-pos))))) + (t + ;; the general case - we build an inner matcher which + ;; just checks for immediate success, i.e. NEXT-FN is + ;; #'IDENTITY + (let ((inner-matcher (create-matcher-aux regex #'identity))) + (declare (type function inner-matcher)) + (greedy-constant-length-closure + (funcall inner-matcher curr-pos))))))))) + +(defmethod create-greedy-no-zero-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is greedy and the minimal number of repetitions is +zero. It is furthermore assumed that the inner regex of REPETITION can +never match a zero-length string (or instead the maximal number of +repetitions is 1)." + (let ((maximum (maximum repetition)) + ;; REPEAT-MATCHER is part of the closure's environment but it + ;; can only be defined after GREEDY-AUX is defined + repeat-matcher) + (declare (type function next-fn)) + (cond + ((eql maximum 1) + ;; this is essentially like the next case but with a known + ;; MAXIMUM of 1 we can get away without a counter; note that + ;; we always arrive here if CONVERT optimizes <regex>* to + ;; (?:<regex'>*<regex>)? + (setq repeat-matcher + (create-matcher-aux (regex repetition) next-fn)) + (lambda (start-pos) + (declare (type function repeat-matcher)) + (or (funcall repeat-matcher start-pos) + (funcall next-fn start-pos)))) + (maximum + ;; we make a reservation for our slot in *REPEAT-COUNTERS* + ;; because we need to keep track whether we've reached MAXIMUM + ;; repetitions + (let ((rep-num (incf-after *rep-num*))) + (flet ((greedy-aux (start-pos) + (declare (type fixnum start-pos maximum rep-num) + (type function repeat-matcher)) + ;; the actual matcher which first tries to match the + ;; inner regex of REPETITION (if we haven't done so + ;; too often) and on failure calls NEXT-FN + (or (and (< (aref *repeat-counters* rep-num) maximum) + (incf (aref *repeat-counters* rep-num)) + ;; note that REPEAT-MATCHER will call + ;; GREEDY-AUX again recursively + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num)))) + (funcall next-fn start-pos)))) + ;; create a closure to match the inner regex and to + ;; implement backtracking via GREEDY-AUX + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'greedy-aux)) + ;; the closure we return is just a thin wrapper around + ;; GREEDY-AUX to initialize the repetition counter + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0) + (greedy-aux start-pos))))) + (t + ;; easier code because we're not bounded by MAXIMUM, but + ;; basically the same + (flet ((greedy-aux (start-pos) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (or (funcall repeat-matcher start-pos) + (funcall next-fn start-pos)))) + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'greedy-aux)) + #'greedy-aux))))) + +(defmethod create-greedy-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is greedy and the minimal number of repetitions is +zero." + (let ((maximum (maximum repetition)) + ;; we make a reservation for our slot in *LAST-POS-STORES* because + ;; we have to watch out for endless loops as the inner regex might + ;; match zero-length strings + (zero-length-num (incf-after *zero-length-num*)) + ;; REPEAT-MATCHER is part of the closure's environment but it + ;; can only be defined after GREEDY-AUX is defined + repeat-matcher) + (declare (type fixnum zero-length-num) + (type function next-fn)) + (cond + (maximum + ;; we make a reservation for our slot in *REPEAT-COUNTERS* + ;; because we need to keep track whether we've reached MAXIMUM + ;; repetitions + (let ((rep-num (incf-after *rep-num*))) + (flet ((greedy-aux (start-pos) + ;; the actual matcher which first tries to match the + ;; inner regex of REPETITION (if we haven't done so + ;; too often) and on failure calls NEXT-FN + (declare (type fixnum start-pos maximum rep-num) + (type function repeat-matcher)) + (let ((old-last-pos + (svref *last-pos-stores* zero-length-num))) + (when (and old-last-pos + (= (the fixnum old-last-pos) start-pos)) + ;; stop immediately if we've been here before, + ;; i.e. if the last attempt matched a zero-length + ;; string + (return-from greedy-aux (funcall next-fn start-pos))) + ;; otherwise remember this position for the next + ;; repetition + (setf (svref *last-pos-stores* zero-length-num) start-pos) + (or (and (< (aref *repeat-counters* rep-num) maximum) + (incf (aref *repeat-counters* rep-num)) + ;; note that REPEAT-MATCHER will call + ;; GREEDY-AUX again recursively + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num)) + (setf (svref *last-pos-stores* zero-length-num) + old-last-pos))) + (funcall next-fn start-pos))))) + ;; create a closure to match the inner regex and to + ;; implement backtracking via GREEDY-AUX + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'greedy-aux)) + ;; the closure we return is just a thin wrapper around + ;; GREEDY-AUX to initialize the repetition counter and our + ;; slot in *LAST-POS-STORES* + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0 + (svref *last-pos-stores* zero-length-num) nil) + (greedy-aux start-pos))))) + (t + ;; easier code because we're not bounded by MAXIMUM, but + ;; basically the same + (flet ((greedy-aux (start-pos) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (let ((old-last-pos + (svref *last-pos-stores* zero-length-num))) + (when (and old-last-pos + (= (the fixnum old-last-pos) start-pos)) + (return-from greedy-aux (funcall next-fn start-pos))) + (setf (svref *last-pos-stores* zero-length-num) start-pos) + (or (prog1 + (funcall repeat-matcher start-pos) + (setf (svref *last-pos-stores* zero-length-num) old-last-pos)) + (funcall next-fn start-pos))))) + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'greedy-aux)) + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (svref *last-pos-stores* zero-length-num) nil) + (greedy-aux start-pos))))))) + +;; code for non-greedy repetitions with minimum zero + +(defmacro non-greedy-constant-length-closure (check-curr-pos) + "This is the template for simple non-greedy repetitions (where +simple means that the minimum number of repetitions is zero, that the +inner regex to be checked is of fixed length LEN, and that it doesn't +contain registers, i.e. there's no need for backtracking). +CHECK-CURR-POS is a form which checks whether the inner regex of the +repetition matches at CURR-POS." + `(if maximum + (lambda (start-pos) + (declare (type fixnum start-pos maximum)) + ;; because we know LEN we know in advance where to stop at the + ;; latest; we also take into consideration MIN-REST, i.e. the + ;; minimal length of the part behind the repetition + (let ((target-end-pos (min (1+ (- *end-pos* len min-rest)) + (+ start-pos + (the fixnum (* len maximum)))))) + ;; move forward by LEN and always try NEXT-FN first, then + ;; CHECK-CUR-POS + (loop for curr-pos of-type fixnum from start-pos + below target-end-pos + by len + thereis (funcall next-fn curr-pos) + while ,check-curr-pos + finally (return (funcall next-fn curr-pos))))) + ;; basically the same code; it's just a bit easier because we're + ;; not bounded by MAXIMUM + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((target-end-pos (1+ (- *end-pos* len min-rest)))) + (loop for curr-pos of-type fixnum from start-pos + below target-end-pos + by len + thereis (funcall next-fn curr-pos) + while ,check-curr-pos + finally (return (funcall next-fn curr-pos))))))) + +(defmethod create-non-greedy-constant-length-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is non-greedy and the minimal number of repetitions is +zero. It is furthermore assumed that the inner regex of REPETITION is +of fixed length and doesn't contain registers." + (let ((len (len repetition)) + (maximum (maximum repetition)) + (regex (regex repetition)) + (min-rest (min-rest repetition))) + (declare (type fixnum len min-rest) + (type function next-fn)) + (cond ((zerop len) + ;; inner regex has zero-length, so we can discard it + ;; completely + next-fn) + (t + ;; now first try to optimize for a couple of common cases + (typecase regex + (str + (let ((str (str regex))) + (if (= 1 len) + ;; a single character + (let ((chr (schar str 0))) + (if (case-insensitive-p regex) + (non-greedy-constant-length-closure + (char-equal chr (schar *string* curr-pos))) + (non-greedy-constant-length-closure + (char= chr (schar *string* curr-pos))))) + ;; a string + (if (case-insensitive-p regex) + (non-greedy-constant-length-closure + (*string*-equal str curr-pos (+ curr-pos len) 0 len)) + (non-greedy-constant-length-closure + (*string*= str curr-pos (+ curr-pos len) 0 len)))))) + (char-class + ;; a character class + (insert-char-class-tester (regex (schar *string* curr-pos)) + (if (invertedp regex) + (non-greedy-constant-length-closure + (not (char-class-test))) + (non-greedy-constant-length-closure + (char-class-test))))) + (everything + (if (single-line-p regex) + ;; a dot which really can match everything; we rely + ;; on the compiler to optimize this away + (non-greedy-constant-length-closure + t) + ;; a dot which has to watch out for #\Newline + (non-greedy-constant-length-closure + (char/= #\Newline (schar *string* curr-pos))))) + (t + ;; the general case - we build an inner matcher which + ;; just checks for immediate success, i.e. NEXT-FN is + ;; #'IDENTITY + (let ((inner-matcher (create-matcher-aux regex #'identity))) + (declare (type function inner-matcher)) + (non-greedy-constant-length-closure + (funcall inner-matcher curr-pos))))))))) + +(defmethod create-non-greedy-no-zero-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is non-greedy and the minimal number of repetitions is +zero. It is furthermore assumed that the inner regex of REPETITION can +never match a zero-length string (or instead the maximal number of +repetitions is 1)." + (let ((maximum (maximum repetition)) + ;; REPEAT-MATCHER is part of the closure's environment but it + ;; can only be defined after NON-GREEDY-AUX is defined + repeat-matcher) + (declare (type function next-fn)) + (cond + ((eql maximum 1) + ;; this is essentially like the next case but with a known + ;; MAXIMUM of 1 we can get away without a counter + (setq repeat-matcher + (create-matcher-aux (regex repetition) next-fn)) + (lambda (start-pos) + (declare (type function repeat-matcher)) + (or (funcall next-fn start-pos) + (funcall repeat-matcher start-pos)))) + (maximum + ;; we make a reservation for our slot in *REPEAT-COUNTERS* + ;; because we need to keep track whether we've reached MAXIMUM + ;; repetitions + (let ((rep-num (incf-after *rep-num*))) + (flet ((non-greedy-aux (start-pos) + ;; the actual matcher which first calls NEXT-FN and + ;; on failure tries to match the inner regex of + ;; REPETITION (if we haven't done so too often) + (declare (type fixnum start-pos maximum rep-num) + (type function repeat-matcher)) + (or (funcall next-fn start-pos) + (and (< (aref *repeat-counters* rep-num) maximum) + (incf (aref *repeat-counters* rep-num)) + ;; note that REPEAT-MATCHER will call + ;; NON-GREEDY-AUX again recursively + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num))))))) + ;; create a closure to match the inner regex and to + ;; implement backtracking via NON-GREEDY-AUX + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'non-greedy-aux)) + ;; the closure we return is just a thin wrapper around + ;; NON-GREEDY-AUX to initialize the repetition counter + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0) + (non-greedy-aux start-pos))))) + (t + ;; easier code because we're not bounded by MAXIMUM, but + ;; basically the same + (flet ((non-greedy-aux (start-pos) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (or (funcall next-fn start-pos) + (funcall repeat-matcher start-pos)))) + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'non-greedy-aux)) + #'non-greedy-aux))))) + +(defmethod create-non-greedy-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION is non-greedy and the minimal number of repetitions is +zero." + ;; we make a reservation for our slot in *LAST-POS-STORES* because + ;; we have to watch out for endless loops as the inner regex might + ;; match zero-length strings + (let ((zero-length-num (incf-after *zero-length-num*)) + (maximum (maximum repetition)) + ;; REPEAT-MATCHER is part of the closure's environment but it + ;; can only be defined after NON-GREEDY-AUX is defined + repeat-matcher) + (declare (type fixnum zero-length-num) + (type function next-fn)) + (cond + (maximum + ;; we make a reservation for our slot in *REPEAT-COUNTERS* + ;; because we need to keep track whether we've reached MAXIMUM + ;; repetitions + (let ((rep-num (incf-after *rep-num*))) + (flet ((non-greedy-aux (start-pos) + ;; the actual matcher which first calls NEXT-FN and + ;; on failure tries to match the inner regex of + ;; REPETITION (if we haven't done so too often) + (declare (type fixnum start-pos maximum rep-num) + (type function repeat-matcher)) + (let ((old-last-pos + (svref *last-pos-stores* zero-length-num))) + (when (and old-last-pos + (= (the fixnum old-last-pos) start-pos)) + ;; stop immediately if we've been here before, + ;; i.e. if the last attempt matched a zero-length + ;; string + (return-from non-greedy-aux (funcall next-fn start-pos))) + ;; otherwise remember this position for the next + ;; repetition + (setf (svref *last-pos-stores* zero-length-num) start-pos) + (or (funcall next-fn start-pos) + (and (< (aref *repeat-counters* rep-num) maximum) + (incf (aref *repeat-counters* rep-num)) + ;; note that REPEAT-MATCHER will call + ;; NON-GREEDY-AUX again recursively + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num)) + (setf (svref *last-pos-stores* zero-length-num) + old-last-pos))))))) + ;; create a closure to match the inner regex and to + ;; implement backtracking via NON-GREEDY-AUX + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'non-greedy-aux)) + ;; the closure we return is just a thin wrapper around + ;; NON-GREEDY-AUX to initialize the repetition counter and our + ;; slot in *LAST-POS-STORES* + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0 + (svref *last-pos-stores* zero-length-num) nil) + (non-greedy-aux start-pos))))) + (t + ;; easier code because we're not bounded by MAXIMUM, but + ;; basically the same + (flet ((non-greedy-aux (start-pos) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (let ((old-last-pos + (svref *last-pos-stores* zero-length-num))) + (when (and old-last-pos + (= (the fixnum old-last-pos) start-pos)) + (return-from non-greedy-aux (funcall next-fn start-pos))) + (setf (svref *last-pos-stores* zero-length-num) start-pos) + (or (funcall next-fn start-pos) + (prog1 + (funcall repeat-matcher start-pos) + (setf (svref *last-pos-stores* zero-length-num) + old-last-pos)))))) + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'non-greedy-aux)) + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (svref *last-pos-stores* zero-length-num) nil) + (non-greedy-aux start-pos))))))) + +;; code for constant repetitions, i.e. those with a fixed number of repetitions + +(defmacro constant-repetition-constant-length-closure (check-curr-pos) + "This is the template for simple constant repetitions (where simple +means that the inner regex to be checked is of fixed length LEN, and +that it doesn't contain registers, i.e. there's no need for +backtracking) and where constant means that MINIMUM is equal to +MAXIMUM. CHECK-CURR-POS is a form which checks whether the inner regex +of the repetition matches at CURR-POS." + `(lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((target-end-pos (+ start-pos + (the fixnum (* len repetitions))))) + (declare (type fixnum target-end-pos)) + ;; first check if we won't go beyond the end of the string + (and (>= *end-pos* target-end-pos) + ;; then loop through all repetitions step by step + (loop for curr-pos of-type fixnum from start-pos + below target-end-pos + by len + always ,check-curr-pos) + ;; finally call NEXT-FN if we made it that far + (funcall next-fn target-end-pos))))) + +(defmethod create-constant-repetition-constant-length-matcher + ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION has a constant number of repetitions. It is +furthermore assumed that the inner regex of REPETITION is of fixed +length and doesn't contain registers." + (let ((len (len repetition)) + (repetitions (minimum repetition)) + (regex (regex repetition))) + (declare (type fixnum len repetitions) + (type function next-fn)) + (if (zerop len) + ;; if the length is zero it suffices to try once + (create-matcher-aux regex next-fn) + ;; otherwise try to optimize for a couple of common cases + (typecase regex + (str + (let ((str (str regex))) + (if (= 1 len) + ;; a single character + (let ((chr (schar str 0))) + (if (case-insensitive-p regex) + (constant-repetition-constant-length-closure + (and (char-equal chr (schar *string* curr-pos)) + (1+ curr-pos))) + (constant-repetition-constant-length-closure + (and (char= chr (schar *string* curr-pos)) + (1+ curr-pos))))) + ;; a string + (if (case-insensitive-p regex) + (constant-repetition-constant-length-closure + (let ((next-pos (+ curr-pos len))) + (declare (type fixnum next-pos)) + (and (*string*-equal str curr-pos next-pos 0 len) + next-pos))) + (constant-repetition-constant-length-closure + (let ((next-pos (+ curr-pos len))) + (declare (type fixnum next-pos)) + (and (*string*= str curr-pos next-pos 0 len) + next-pos))))))) + (char-class + ;; a character class + (insert-char-class-tester (regex (schar *string* curr-pos)) + (if (invertedp regex) + (constant-repetition-constant-length-closure + (and (not (char-class-test)) + (1+ curr-pos))) + (constant-repetition-constant-length-closure + (and (char-class-test) + (1+ curr-pos)))))) + (everything + (if (single-line-p regex) + ;; a dot which really matches everything - we just have to + ;; advance the index into *STRING* accordingly and check + ;; if we didn't go past the end + (lambda (start-pos) + (declare (type fixnum start-pos)) + (let ((next-pos (+ start-pos repetitions))) + (declare (type fixnum next-pos)) + (or (<= next-pos *end-pos*) + (funcall next-fn next-pos)))) + ;; a dot which is not in single-line-mode - make sure we + ;; don't match #\Newline + (constant-repetition-constant-length-closure + (and (char/= #\Newline (schar *string* curr-pos)) + (1+ curr-pos))))) + (t + ;; the general case - we build an inner matcher which just + ;; checks for immediate success, i.e. NEXT-FN is #'IDENTITY + (let ((inner-matcher (create-matcher-aux regex #'identity))) + (declare (type function inner-matcher)) + (constant-repetition-constant-length-closure + (funcall inner-matcher curr-pos)))))))) + +(defmethod create-constant-repetition-matcher ((repetition repetition) next-fn) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Creates a closure which tries to match REPETITION. It is assumed +that REPETITION has a constant number of repetitions." + (let ((repetitions (minimum repetition)) + ;; we make a reservation for our slot in *REPEAT-COUNTERS* + ;; because we need to keep track of the number of repetitions + (rep-num (incf-after *rep-num*)) + ;; REPEAT-MATCHER is part of the closure's environment but it + ;; can only be defined after NON-GREEDY-AUX is defined + repeat-matcher) + (declare (type fixnum repetitions rep-num) + (type function next-fn)) + (if (zerop (min-len repetition)) + ;; we make a reservation for our slot in *LAST-POS-STORES* + ;; because we have to watch out for needless loops as the inner + ;; regex might match zero-length strings + (let ((zero-length-num (incf-after *zero-length-num*))) + (declare (type fixnum zero-length-num)) + (flet ((constant-aux (start-pos) + ;; the actual matcher which first calls NEXT-FN and + ;; on failure tries to match the inner regex of + ;; REPETITION (if we haven't done so too often) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (let ((old-last-pos + (svref *last-pos-stores* zero-length-num))) + (when (and old-last-pos + (= (the fixnum old-last-pos) start-pos)) + ;; if we've been here before we matched a + ;; zero-length string the last time, so we can + ;; just carry on because we will definitely be + ;; able to do this again often enough + (return-from constant-aux (funcall next-fn start-pos))) + ;; otherwise remember this position for the next + ;; repetition + (setf (svref *last-pos-stores* zero-length-num) start-pos) + (cond ((< (aref *repeat-counters* rep-num) repetitions) + ;; not enough repetitions yet, try it again + (incf (aref *repeat-counters* rep-num)) + ;; note that REPEAT-MATCHER will call + ;; CONSTANT-AUX again recursively + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num)) + (setf (svref *last-pos-stores* zero-length-num) + old-last-pos))) + (t + ;; we're done - call NEXT-FN + (funcall next-fn start-pos)))))) + ;; create a closure to match the inner regex and to + ;; implement backtracking via CONSTANT-AUX + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'constant-aux)) + ;; the closure we return is just a thin wrapper around + ;; CONSTANT-AUX to initialize the repetition counter + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0 + (aref *last-pos-stores* zero-length-num) nil) + (constant-aux start-pos)))) + ;; easier code because we don't have to care about zero-length + ;; matches but basically the same + (flet ((constant-aux (start-pos) + (declare (type fixnum start-pos) + (type function repeat-matcher)) + (cond ((< (aref *repeat-counters* rep-num) repetitions) + (incf (aref *repeat-counters* rep-num)) + (prog1 + (funcall repeat-matcher start-pos) + (decf (aref *repeat-counters* rep-num)))) + (t (funcall next-fn start-pos))))) + (setq repeat-matcher + (create-matcher-aux (regex repetition) #'constant-aux)) + (lambda (start-pos) + (declare (type fixnum start-pos)) + (setf (aref *repeat-counters* rep-num) 0) + (constant-aux start-pos)))))) + +;; the actual CREATE-MATCHER-AUX method for REPETITION objects which +;; utilizes all the functions and macros defined above + +(defmethod create-matcher-aux ((repetition repetition) next-fn) + (with-slots ((minimum minimum) + (maximum maximum) + (len len) + (min-len min-len) + (greedyp greedyp) + (contains-register-p contains-register-p)) + repetition + (cond ((and maximum + (zerop maximum)) + ;; this should have been optimized away by CONVERT but just + ;; in case... + (error "Got REPETITION with MAXIMUM 0 \(should not happen)")) + ((and maximum + (= minimum maximum 1)) + ;; this should have been optimized away by CONVERT but just + ;; in case... + (error "Got REPETITION with MAXIMUM 1 and MINIMUM 1 \(should not happen)")) + ((and (eql minimum maximum) + len + (not contains-register-p)) + (create-constant-repetition-constant-length-matcher repetition next-fn)) + ((eql minimum maximum) + (create-constant-repetition-matcher repetition next-fn)) + ((and greedyp + len + (not contains-register-p)) + (create-greedy-constant-length-matcher repetition next-fn)) + ((and greedyp + (or (plusp min-len) + (eql maximum 1))) + (create-greedy-no-zero-matcher repetition next-fn)) + (greedyp + (create-greedy-matcher repetition next-fn)) + ((and len + (plusp len) + (not contains-register-p)) + (create-non-greedy-constant-length-matcher repetition next-fn)) + ((or (plusp min-len) + (eql maximum 1)) + (create-non-greedy-no-zero-matcher repetition next-fn)) + (t + (create-non-greedy-matcher repetition next-fn))))) Added: vendor/portableaserve/libs/cl-ppcre/scanner.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/scanner.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/scanner.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,519 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/scanner.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Here the scanner for the actual regex as well as utility scanners +;;; for the constant start and end strings are created. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defmacro bmh-matcher-aux (&key case-insensitive-p) + "Auxiliary macro used by CREATE-BMH-MATCHER." + (let ((char-compare (if case-insensitive-p 'char-equal 'char=))) + `(lambda (start-pos) + (declare (type fixnum start-pos)) + (if (> (the fixnum (+ start-pos m)) *end-pos*) + nil + (loop named bmh-matcher + for k of-type fixnum = (+ start-pos m -1) + then (+ k (max 1 (aref skip (char-code (schar *string* k))))) + while (< k *end-pos*) + do (loop for j of-type fixnum downfrom (1- m) + for i of-type fixnum downfrom k + while (and (>= j 0) + (,char-compare (schar *string* i) + (schar pattern j))) + finally (if (minusp j) + (return-from bmh-matcher (1+ i))))))))) + +(defun create-bmh-matcher (pattern case-insensitive-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns a Boyer-Moore-Horspool matcher which searches the (special) +simple-string *STRING* for the first occurence of the substring +PATTERN. The search starts at the position START-POS within *STRING* +and stops before *END-POS* is reached. Depending on the second +argument the search is case-insensitive or not. If the special +variable *USE-BMH-MATCHERS* is NIL, use the standard SEARCH function +instead. (BMH matchers are faster but need much more space.)" + ;; see <http://www-igm.univ-mlv.fr/~lecroq/string/node18.html> for + ;; details + (unless *use-bmh-matchers* + (let ((test (if case-insensitive-p #'char-equal #'char=))) + (return-from create-bmh-matcher + (lambda (start-pos) + (declare (type fixnum start-pos)) + (search pattern + *string* + :start2 start-pos + :end2 *end-pos* + :test test))))) + (let* ((m (length pattern)) + (skip (make-array *regex-char-code-limit* + :element-type 'fixnum + :initial-element m))) + (declare (type fixnum m)) + (loop for k of-type fixnum below m + if case-insensitive-p + do (setf (aref skip (char-code (char-upcase (schar pattern k)))) (- m k 1) + (aref skip (char-code (char-downcase (schar pattern k)))) (- m k 1)) + else + do (setf (aref skip (char-code (schar pattern k))) (- m k 1))) + (if case-insensitive-p + (bmh-matcher-aux :case-insensitive-p t) + (bmh-matcher-aux)))) + +(defmacro char-searcher-aux (&key case-insensitive-p) + "Auxiliary macro used by CREATE-CHAR-SEARCHER." + (let ((char-compare (if case-insensitive-p 'char-equal 'char=))) + `(lambda (start-pos) + (declare (type fixnum start-pos)) + (loop for i of-type fixnum from start-pos below *end-pos* + thereis (and (,char-compare (schar *string* i) chr) i))))) + +(defun create-char-searcher (chr case-insensitive-p) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns a function which searches the (special) simple-string +*STRING* for the first occurence of the character CHR. The search +starts at the position START-POS within *STRING* and stops before +*END-POS* is reached. Depending on the second argument the search is +case-insensitive or not." + (if case-insensitive-p + (char-searcher-aux :case-insensitive-p t) + (char-searcher-aux))) + +(declaim (inline newline-skipper)) + +(defun newline-skipper (start-pos) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum start-pos)) + "Find the next occurence of a character in *STRING* which is behind +a #\Newline." + (loop for i of-type fixnum from start-pos below *end-pos* + thereis (and (char= (schar *string* i) #\Newline) + (1+ i)))) + +(defmacro insert-advance-fn (advance-fn) + "Creates the actual closure returned by CREATE-SCANNER-AUX by +replacing '(ADVANCE-FN-DEFINITION) with a suitable definition for +ADVANCE-FN. This is a utility macro used by CREATE-SCANNER-AUX." + (subst + advance-fn '(advance-fn-definition) + '(lambda (string start end) + (block scan + ;; initialize a couple of special variables used by the + ;; matchers (see file specials.lisp) + (let* ((*string* string) + (*start-pos* start) + (*end-pos* end) + ;; we will search forward for END-STRING if this value + ;; isn't at least as big as POS (see ADVANCE-FN), so it + ;; is safe to start to the left of *START-POS*; note + ;; that this value will _never_ be decremented - this + ;; is crucial to the scanning process + (*end-string-pos* (1- *start-pos*)) + ;; the next five will shadow the variables defined by + ;; DEFPARAMETER; at this point, we don't know if we'll + ;; actually use them, though + (*repeat-counters* *repeat-counters*) + (*last-pos-stores* *last-pos-stores*) + (*reg-starts* *reg-starts*) + (*regs-maybe-start* *regs-maybe-start*) + (*reg-ends* *reg-ends*) + ;; we might be able to optimize the scanning process by + ;; (virtually) shifting *START-POS* to the right + (scan-start-pos *start-pos*) + (starts-with-str (if start-string-test + (str starts-with) + nil)) + ;; we don't need to try further than MAX-END-POS + (max-end-pos (- *end-pos* min-len))) + (declare (type fixnum scan-start-pos) + (type function match-fn)) + ;; definition of ADVANCE-FN will be inserted here by macrology + (labels ((advance-fn-definition)) + (declare (inline advance-fn)) + (when (plusp rep-num) + ;; we have at least one REPETITION which needs to count + ;; the number of repetitions + (setq *repeat-counters* (make-array rep-num + :initial-element 0 + :element-type 'fixnum))) + (when (plusp zero-length-num) + ;; we have at least one REPETITION which needs to watch + ;; out for zero-length repetitions + (setq *last-pos-stores* (make-array zero-length-num + :initial-element nil))) + (when (plusp reg-num) + ;; we have registers in our regular expression + (setq *reg-starts* (make-array reg-num :initial-element nil) + *regs-maybe-start* (make-array reg-num :initial-element nil) + *reg-ends* (make-array reg-num :initial-element nil))) + (when end-anchored-p + ;; the regular expression has a constant end string which + ;; is anchored at the very end of the target string + ;; (perhaps modulo a #\Newline) + (let ((end-test-pos (- *end-pos* (the fixnum end-string-len)))) + (declare (type fixnum end-test-pos) + (type function end-string-test)) + (unless (setq *end-string-pos* (funcall end-string-test + end-test-pos)) + (when (and (= 1 (the fixnum end-anchored-p)) + (char= #\Newline (schar *string* (1- *end-pos*)))) + ;; if we didn't find an end string candidate from + ;; END-TEST-POS and if a #\Newline at the end is + ;; allowed we try it again from one position to the + ;; left + (setq *end-string-pos* (funcall end-string-test + (1- end-test-pos)))))) + (unless (and *end-string-pos* + (<= *start-pos* *end-string-pos*)) + ;; no end string candidate found, so give up + (return-from scan nil)) + (when end-string-offset + ;; if the offset of the constant end string from the + ;; left of the regular expression is known we can start + ;; scanning further to the right; this is similar to + ;; what we might do in ADVANCE-FN + (setq scan-start-pos (max scan-start-pos + (- (the fixnum *end-string-pos*) + (the fixnum end-string-offset)))))) + (cond + (start-anchored-p + ;; we're anchored at the start of the target string, + ;; so no need to try again after first failure + (when (or (/= *start-pos* scan-start-pos) + (< max-end-pos *start-pos*)) + ;; if END-STRING-OFFSET has proven that we don't + ;; need to bother to scan from *START-POS* or if the + ;; minimal length of the regular expression is + ;; longer than the target string we give up + (return-from scan nil)) + (when starts-with-str + (locally + (declare (type fixnum starts-with-len)) + (cond ((and (case-insensitive-p starts-with) + (not (*string*-equal starts-with-str + *start-pos* + (+ *start-pos* + starts-with-len) + 0 starts-with-len))) + ;; the regular expression has a + ;; case-insensitive constant start string + ;; and we didn't find it + (return-from scan nil)) + ((and (not (case-insensitive-p starts-with)) + (not (*string*= starts-with-str + *start-pos* + (+ *start-pos* starts-with-len) + 0 starts-with-len))) + ;; the regular expression has a + ;; case-sensitive constant start string + ;; and we didn't find it + (return-from scan nil)) + (t nil)))) + (when (and end-string-test + (not end-anchored-p)) + ;; the regular expression has a constant end string + ;; which isn't anchored so we didn't check for it + ;; already + (block end-string-loop + ;; we temporarily use *END-STRING-POS* as our + ;; starting position to look for end string + ;; candidates + (setq *end-string-pos* *start-pos*) + (loop + (unless (setq *end-string-pos* + (funcall (the function end-string-test) + *end-string-pos*)) + ;; no end string candidate found, so give up + (return-from scan nil)) + (unless end-string-offset + ;; end string doesn't have an offset so we + ;; can start scanning now + (return-from end-string-loop)) + (let ((maybe-start-pos (- (the fixnum *end-string-pos*) + (the fixnum end-string-offset)))) + (cond ((= maybe-start-pos *start-pos*) + ;; offset of end string into regular + ;; expression matches start anchor - + ;; fine... + (return-from end-string-loop)) + ((and (< maybe-start-pos *start-pos*) + (< (+ *end-string-pos* end-string-len) *end-pos*)) + ;; no match but maybe we find another + ;; one to the right - try again + (incf *end-string-pos*)) + (t + ;; otherwise give up + (return-from scan nil))))))) + ;; if we got here we scan exactly once + (let ((next-pos (funcall match-fn *start-pos*))) + (when next-pos + (values (if next-pos *start-pos* nil) + next-pos + *reg-starts* + *reg-ends*)))) + (t + (loop for pos = (if starts-with-everything + ;; don't jump to the next + ;; #\Newline on the first + ;; iteration + scan-start-pos + (advance-fn scan-start-pos)) + then (advance-fn pos) + ;; give up if the regular expression can't fit + ;; into the rest of the target string + while (and pos + (<= (the fixnum pos) max-end-pos)) + do (let ((next-pos (funcall match-fn pos))) + (when next-pos + (return-from scan (values pos + next-pos + *reg-starts* + *reg-ends*))) + ;; not yet found, increment POS + #-cormanlisp (incf (the fixnum pos)) + #+cormanlisp (incf pos))))))))) + :test #'equalp)) + +(defun create-scanner-aux (match-fn + min-len + start-anchored-p + starts-with + start-string-test + end-anchored-p + end-string-test + end-string-len + end-string-offset + rep-num + zero-length-num + reg-num) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (type fixnum min-len zero-length-num rep-num reg-num)) + "Auxiliary function to create and return a scanner \(which is +actually a closure). Used by CREATE-SCANNER." + (let ((starts-with-len (if (typep starts-with 'str) + (len starts-with))) + (starts-with-everything (typep starts-with 'everything))) + (cond + ;; this COND statement dispatches on the different versions we + ;; have for ADVANCE-FN and creates different closures for each; + ;; note that you see only the bodies of ADVANCE-FN below - the + ;; actual scanner is defined in INSERT-ADVANCE-FN above; (we + ;; could have done this with closures instead of macrology but + ;; would have consed a lot more) + ((and start-string-test end-string-test end-string-offset) + ;; we know that the regular expression has constant start and + ;; end strings and we know the end string's offset (from the + ;; left) + (insert-advance-fn + (advance-fn (pos) + (declare (type fixnum end-string-offset starts-with-len) + (type function start-string-test end-string-test)) + (loop + (unless (setq pos (funcall start-string-test pos)) + ;; give up completely if we can't find a start string + ;; candidate + (return-from scan nil)) + (locally + ;; from here we know that POS is a FIXNUM + (declare (type fixnum pos)) + (when (= pos (- (the fixnum *end-string-pos*) end-string-offset)) + ;; if we already found an end string candidate the + ;; position of which matches the start string + ;; candidate we're done + (return-from advance-fn pos)) + (let ((try-pos (+ pos starts-with-len))) + ;; otherwise try (again) to find an end string + ;; candidate which starts behind the start string + ;; candidate + (loop + (unless (setq *end-string-pos* + (funcall end-string-test try-pos)) + ;; no end string candidate found, so give up + (return-from scan nil)) + ;; NEW-POS is where we should start scanning + ;; according to the end string candidate + (let ((new-pos (- (the fixnum *end-string-pos*) + end-string-offset))) + (declare (type fixnum new-pos *end-string-pos*)) + (cond ((= new-pos pos) + ;; if POS and NEW-POS are equal then the + ;; two candidates agree so we're fine + (return-from advance-fn pos)) + ((> new-pos pos) + ;; if NEW-POS is further to the right we + ;; advance POS and try again, i.e. we go + ;; back to the start of the outer LOOP + (setq pos new-pos) + ;; this means "return from inner LOOP" + (return)) + (t + ;; otherwise NEW-POS is smaller than POS, + ;; so we have to redo the inner LOOP to + ;; find another end string candidate + ;; further to the right + (setq try-pos (1+ *end-string-pos*)))))))))))) + ((and starts-with-everything end-string-test end-string-offset) + ;; we know that the regular expression starts with ".*" (which + ;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends + ;; with a constant end string and we know the end string's + ;; offset (from the left) + (insert-advance-fn + (advance-fn (pos) + (declare (type fixnum end-string-offset) + (type function end-string-test)) + (loop + (unless (setq pos (newline-skipper pos)) + ;; if we can't find a #\Newline we give up immediately + (return-from scan nil)) + (locally + ;; from here we know that POS is a FIXNUM + (declare (type fixnum pos)) + (when (= pos (- (the fixnum *end-string-pos*) end-string-offset)) + ;; if we already found an end string candidate the + ;; position of which matches the place behind the + ;; #\Newline we're done + (return-from advance-fn pos)) + (let ((try-pos pos)) + ;; otherwise try (again) to find an end string + ;; candidate which starts behind the #\Newline + (loop + (unless (setq *end-string-pos* + (funcall end-string-test try-pos)) + ;; no end string candidate found, so we give up + (return-from scan nil)) + ;; NEW-POS is where we should start scanning + ;; according to the end string candidate + (let ((new-pos (- (the fixnum *end-string-pos*) + end-string-offset))) + (declare (type fixnum new-pos *end-string-pos*)) + (cond ((= new-pos pos) + ;; if POS and NEW-POS are equal then the + ;; the end string candidate agrees with + ;; the #\Newline so we're fine + (return-from advance-fn pos)) + ((> new-pos pos) + ;; if NEW-POS is further to the right we + ;; advance POS and try again, i.e. we go + ;; back to the start of the outer LOOP + (setq pos new-pos) + ;; this means "return from inner LOOP" + (return)) + (t + ;; otherwise NEW-POS is smaller than POS, + ;; so we have to redo the inner LOOP to + ;; find another end string candidate + ;; further to the right + (setq try-pos (1+ *end-string-pos*)))))))))))) + ((and start-string-test end-string-test) + ;; we know that the regular expression has constant start and + ;; end strings; similar to the first case but we only need to + ;; check for the end string, it doesn't provide enough + ;; information to advance POS + (insert-advance-fn + (advance-fn (pos) + (declare (type function start-string-test end-string-test)) + (unless (setq pos (funcall start-string-test pos)) + (return-from scan nil)) + (if (<= (the fixnum pos) + (the fixnum *end-string-pos*)) + (return-from advance-fn pos)) + (unless (setq *end-string-pos* (funcall end-string-test pos)) + (return-from scan nil)) + pos))) + ((and starts-with-everything end-string-test) + ;; we know that the regular expression starts with ".*" (which + ;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends + ;; with a constant end string; similar to the second case but we + ;; only need to check for the end string, it doesn't provide + ;; enough information to advance POS + (insert-advance-fn + (advance-fn (pos) + (declare (type function end-string-test)) + (unless (setq pos (newline-skipper pos)) + (return-from scan nil)) + (if (<= (the fixnum pos) + (the fixnum *end-string-pos*)) + (return-from advance-fn pos)) + (unless (setq *end-string-pos* (funcall end-string-test pos)) + (return-from scan nil)) + pos))) + (start-string-test + ;; just check for constant start string candidate + (insert-advance-fn + (advance-fn (pos) + (declare (type function start-string-test)) + (unless (setq pos (funcall start-string-test pos)) + (return-from scan nil)) + pos))) + (starts-with-everything + ;; just advance POS with NEWLINE-SKIPPER + (insert-advance-fn + (advance-fn (pos) + (unless (setq pos (newline-skipper pos)) + (return-from scan nil)) + pos))) + (end-string-test + ;; just check for the next end string candidate if POS has + ;; advanced beyond the last one + (insert-advance-fn + (advance-fn (pos) + (declare (type function end-string-test)) + (if (<= (the fixnum pos) + (the fixnum *end-string-pos*)) + (return-from advance-fn pos)) + (unless (setq *end-string-pos* (funcall end-string-test pos)) + (return-from scan nil)) + pos))) + (t + ;; not enough optimization information about the regular + ;; expression to optimize so we just return POS + (insert-advance-fn + (advance-fn (pos) + pos)))))) \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/specials.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/specials.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/specials.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,105 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/specials.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; globally declared special variables + +;;; Copyright (c) 2002-2003, 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-ppcre) + +;;; special variables used by the lexer/parser combo + +(defvar *extended-mode-p* nil + "Whether the parser will start in extended mode.") +(declaim (type boolean *extended-mode-p*)) + +;;; special variables used by the SCAN function and the matchers + +(defvar *string* "" + "The string which is currently scanned by SCAN. +Will always be coerced to a SIMPLE-STRING.") +(declaim (type simple-string *string*)) + +(defvar *start-pos* 0 + "Where to start scanning within *STRING*.") +(declaim (type fixnum *start-pos*)) + +(defvar *real-start-pos* nil + "The real start of *STRING*. This is for repeated scans and is only used internally.") +(declaim (type (or null fixnum) *real-start-pos*)) + +(defvar *end-pos* 0 + "Where to stop scanning within *STRING*.") +(declaim (type fixnum *end-pos*)) + +(defvar *reg-starts* (make-array 0) + "An array which holds the start positions +of the current register candidates.") +(declaim (type simple-vector *reg-starts*)) + +(defvar *regs-maybe-start* (make-array 0) + "An array which holds the next start positions +of the current register candidates.") +(declaim (type simple-vector *regs-maybe-start*)) + +(defvar *reg-ends* (make-array 0) + "An array which holds the end positions +of the current register candidates.") +(declaim (type simple-vector *reg-ends*)) + +(defvar *end-string-pos* nil + "Start of the next possible end-string candidate.") + +(defvar *rep-num* 0 + "Counts the number of \"complicated\" repetitions while the matchers +are built.") +(declaim (type fixnum *rep-num*)) + +(defvar *zero-length-num* 0 + "Counts the number of repetitions the inner regexes of which may +have zero-length while the matchers are built.") +(declaim (type fixnum *zero-length-num*)) + +(defvar *repeat-counters* (make-array 0 + :initial-element 0 + :element-type 'fixnum) + "An array to keep track of how often +repetitive patterns have been tested already.") +(declaim (type (array fixnum (*)) *repeat-counters*)) + +(defvar *last-pos-stores* (make-array 0) + "An array to keep track of the last positions +where we saw repetitive patterns. +Only used for patterns which might have zero length.") +(declaim (type simple-vector *last-pos-stores*)) + +(defvar *use-bmh-matchers* t + "Whether the scanners created by CREATE-SCANNER should use the \(fast +but large) Boyer-Moore-Horspool matchers.") + +(defvar *allow-quoting* nil + "Whether the parser should support Perl's \\Q and \\E.") \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/testdata =================================================================== --- vendor/portableaserve/libs/cl-ppcre/testdata 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/testdata 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,14287 @@ +(1 "\"the quick brown fox\" =~ /the quick brown fox/" "the quick brown fox" nil nil nil nil "the quick brown fox" nil 1 0 "the quick brown fox" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(2 "\"The quick brown FOX\" =~ /the quick brown fox/" "the quick brown fox" nil nil nil nil "The quick brown FOX" nil 1 0 nil nil) +(3 "\"What do you know about the quick brown fox?\" =~ /the quick brown fox/" "the quick brown fox" nil nil nil nil "What do you know about the quick brown fox?" nil 1 0 "the quick brown fox" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(4 "\"What do you know about THE QUICK BROWN FOX?\" =~ /the quick brown fox/" "the quick brown fox" nil nil nil nil "What do you know about THE QUICK BROWN FOX?" nil 1 0 nil nil) +(5 "\"the quick brown fox\" =~ /The quick brown fox/i" "The quick brown fox" t nil nil nil "the quick brown fox" nil 1 0 "the quick brown fox" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(6 "\"The quick brown FOX\" =~ /The quick brown fox/i" "The quick brown fox" t nil nil nil "The quick brown FOX" nil 1 0 "The quick brown FOX" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(7 "\"What do you know about the quick brown fox?\" =~ /The quick brown fox/i" "The quick brown fox" t nil nil nil "What do you know about the quick brown fox?" nil 1 0 "the quick brown fox" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(8 "\"What do you know about THE QUICK BROWN FOX?\" =~ /The quick brown fox/i" "The quick brown fox" t nil nil nil "What do you know about THE QUICK BROWN FOX?" nil 1 0 "THE QUICK BROWN FOX" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(9 "\"abcd\\t\\n\\r\\f\\a\\e9;\\$\\\\?caxyz\" =~ /abcd\\t\\n\\r\\f\\a\\e\\071\\x3b\\$\\\\\\?caxyz/" "abcd\\t\\n\\r\\f\\a\\e\\071\\x3b\\$\\\\\\?caxyz" nil nil nil nil ("abcd" 9 10 13 12 7 27 "9;$\\?caxyz") nil 1 0 ("abcd" 9 10 13 12 7 27 "9;$\\?caxyz") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(10 "\"abxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzpqrrrabbxyyyypqAzz" nil 1 0 "abxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(11 "\"abxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzpqrrrabbxyyyypqAzz" nil 1 0 "abxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(12 "\"aabxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aabxyzpqrrrabbxyyyypqAzz" nil 1 0 "aabxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(13 "\"aaabxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaabxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(14 "\"aaaabxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaaabxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(15 "\"abcxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abcxyzpqrrrabbxyyyypqAzz" nil 1 0 "abcxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(16 "\"aabcxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aabcxyzpqrrrabbxyyyypqAzz" nil 1 0 "aabcxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(17 "\"aaabcxyzpqrrrabbxyyyypAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(18 "\"aaabcxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(19 "\"aaabcxyzpqrrrabbxyyyypqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(20 "\"aaabcxyzpqrrrabbxyyyypqqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqqqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(21 "\"aaabcxyzpqrrrabbxyyyypqqqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqqqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqqqqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(22 "\"aaabcxyzpqrrrabbxyyyypqqqqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqqqqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqqqqqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(23 "\"aaabcxyzpqrrrabbxyyyypqqqqqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqqqqqAzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypqqqqqqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(24 "\"aaaabcxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaaabcxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(25 "\"abxyzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzzpqrrrabbxyyyypqAzz" nil 1 0 "abxyzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(26 "\"aabxyzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aabxyzzzpqrrrabbxyyyypqAzz" nil 1 0 "aabxyzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(27 "\"aaabxyzzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabxyzzzzpqrrrabbxyyyypqAzz" nil 1 0 "aaabxyzzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(28 "\"aaaabxyzzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabxyzzzzpqrrrabbxyyyypqAzz" nil 1 0 "aaaabxyzzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(29 "\"abcxyzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abcxyzzpqrrrabbxyyyypqAzz" nil 1 0 "abcxyzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(30 "\"aabcxyzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aabcxyzzzpqrrrabbxyyyypqAzz" nil 1 0 "aabcxyzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(31 "\"aaabcxyzzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzzzzpqrrrabbxyyyypqAzz" nil 1 0 "aaabcxyzzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(32 "\"aaaabcxyzzzzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzzzzpqrrrabbxyyyypqAzz" nil 1 0 "aaaabcxyzzzzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(33 "\"aaaabcxyzzzzpqrrrabbbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzzzzpqrrrabbbxyyyypqAzz" nil 1 0 "aaaabcxyzzzzpqrrrabbbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(34 "\"aaaabcxyzzzzpqrrrabbbxyyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzzzzpqrrrabbbxyyyyypqAzz" nil 1 0 "aaaabcxyzzzzpqrrrabbbxyyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(35 "\"aaabcxyzpqrrrabbxyyyypABzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypABzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypABzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(36 "\"aaabcxyzpqrrrabbxyyyypABBzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypABBzz" nil 1 0 "aaabcxyzpqrrrabbxyyyypABBzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(37 "\">>>aaabxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil ">>>aaabxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaabxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(38 "\">aaaabxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil ">aaaabxyzpqrrrabbxyyyypqAzz" nil 1 0 "aaaabxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(39 "\">>>>abcxyzpqrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil ">>>>abcxyzpqrrrabbxyyyypqAzz" nil 1 0 "abcxyzpqrrrabbxyyyypqAzz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(40 "\"abxyzpqrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzpqrrabbxyyyypqAzz" nil 1 0 nil nil) +(41 "\"abxyzpqrrrrabbxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzpqrrrrabbxyyyypqAzz" nil 1 0 nil nil) +(42 "\"abxyzpqrrrabxyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "abxyzpqrrrabxyyyypqAzz" nil 1 0 nil nil) +(43 "\"aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz" nil 1 0 nil nil) +(44 "\"aaaabcxyzzzzpqrrrabbbxyyypqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaaabcxyzzzzpqrrrabbbxyyypqAzz" nil 1 0 nil nil) +(45 "\"aaabcxyzpqrrrabbxyyyypqqqqqqqAzz\" =~ /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/" "a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz" nil nil nil nil "aaabcxyzpqrrrabbxyyyypqqqqqqqAzz" nil 1 0 nil nil) +(46 "\"abczz\" =~ /^(abc){1,2}zz/" "^(abc){1,2}zz" nil nil nil nil "abczz" nil 1 0 "abczz" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(47 "\"abcabczz\" =~ /^(abc){1,2}zz/" "^(abc){1,2}zz" nil nil nil nil "abcabczz" nil 1 0 "abcabczz" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(48 "\"zz\" =~ /^(abc){1,2}zz/" "^(abc){1,2}zz" nil nil nil nil "zz" nil 1 0 nil nil) +(49 "\"abcabcabczz\" =~ /^(abc){1,2}zz/" "^(abc){1,2}zz" nil nil nil nil "abcabcabczz" nil 1 0 nil nil) +(50 "\">>abczz\" =~ /^(abc){1,2}zz/" "^(abc){1,2}zz" nil nil nil nil ">>abczz" nil 1 0 nil nil) +(51 "\"bc\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bc" nil 1 0 "bc" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(52 "\"bbc\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbc" nil 1 0 "bbc" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(53 "\"bbbc\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbbc" nil 1 0 "bbbc" ("bb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(54 "\"bac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bac" nil 1 0 "bac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(55 "\"bbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbac" nil 1 0 "bbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(56 "\"aac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "aac" nil 1 0 "aac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(57 "\"abbbbbbbbbbbc\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "abbbbbbbbbbbc" nil 1 0 "abbbbbbbbbbbc" ("bbbbbbbbbbb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(58 "\"bbbbbbbbbbbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbbbbbbbbbbac" nil 1 0 "bbbbbbbbbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(59 "\"aaac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "aaac" nil 1 0 nil nil) +(60 "\"abbbbbbbbbbbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "abbbbbbbbbbbac" nil 1 0 nil nil) +(61 "\"bc\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bc" nil 1 0 "bc" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(62 "\"bbc\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bbc" nil 1 0 "bbc" ("bb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(63 "\"bbbc\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bbbc" nil 1 0 "bbbc" ("bbb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(64 "\"bac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bac" nil 1 0 "bac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(65 "\"bbac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bbac" nil 1 0 "bbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(66 "\"aac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "aac" nil 1 0 "aac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(67 "\"abbbbbbbbbbbc\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "abbbbbbbbbbbc" nil 1 0 "abbbbbbbbbbbc" ("bbbbbbbbbbb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(68 "\"bbbbbbbbbbbac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "bbbbbbbbbbbac" nil 1 0 "bbbbbbbbbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(69 "\"aaac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "aaac" nil 1 0 nil nil) +(70 "\"abbbbbbbbbbbac\" =~ /^(b+|a){1,2}c/" "^(b+|a){1,2}c" nil nil nil nil "abbbbbbbbbbbac" nil 1 0 nil nil) +(71 "\"bbc\" =~ /^(b+|a){1,2}?bc/" "^(b+|a){1,2}?bc" nil nil nil nil "bbc" nil 1 0 "bbc" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(72 "\"babc\" =~ /^(b*|ba){1,2}?bc/" "^(b*|ba){1,2}?bc" nil nil nil nil "babc" nil 1 0 "babc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(73 "\"bbabc\" =~ /^(b*|ba){1,2}?bc/" "^(b*|ba){1,2}?bc" nil nil nil nil "bbabc" nil 1 0 "bbabc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(74 "\"bababc\" =~ /^(b*|ba){1,2}?bc/" "^(b*|ba){1,2}?bc" nil nil nil nil "bababc" nil 1 0 "bababc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(75 "\"bababbc\" =~ /^(b*|ba){1,2}?bc/" "^(b*|ba){1,2}?bc" nil nil nil nil "bababbc" nil 1 0 nil nil) +(76 "\"babababc\" =~ /^(b*|ba){1,2}?bc/" "^(b*|ba){1,2}?bc" nil nil nil nil "babababc" nil 1 0 nil nil) +(77 "\"babc\" =~ /^(ba|b*){1,2}?bc/" "^(ba|b*){1,2}?bc" nil nil nil nil "babc" nil 1 0 "babc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(78 "\"bbabc\" =~ /^(ba|b*){1,2}?bc/" "^(ba|b*){1,2}?bc" nil nil nil nil "bbabc" nil 1 0 "bbabc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(79 "\"bababc\" =~ /^(ba|b*){1,2}?bc/" "^(ba|b*){1,2}?bc" nil nil nil nil "bababc" nil 1 0 "bababc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(80 "\"bababbc\" =~ /^(ba|b*){1,2}?bc/" "^(ba|b*){1,2}?bc" nil nil nil nil "bababbc" nil 1 0 nil nil) +(81 "\"babababc\" =~ /^(ba|b*){1,2}?bc/" "^(ba|b*){1,2}?bc" nil nil nil nil "babababc" nil 1 0 nil nil) +(82 "\"\\x01\\x01\\e;z\" =~ /^\\ca\\cA\\c[\\c{\\c:/" "^\\ca\\cA\\c[\\c{\\c:" nil nil nil nil ("" 1 1 27 ";z") nil 1 0 ("" 1 1 27 ";z") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(83 "\"athing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "athing" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(84 "\"bthing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "bthing" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(85 "\"]thing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "]thing" nil 1 0 "]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(86 "\"cthing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "cthing" nil 1 0 "c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(87 "\"dthing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "dthing" nil 1 0 "d" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(88 "\"ething\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "ething" nil 1 0 "e" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(89 "\"fthing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "fthing" nil 1 0 nil nil) +(90 "\"[thing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "[thing" nil 1 0 nil nil) +(91 "\"\\\\thing\" =~ /^[ab\\]cde]/" "^[ab\\]cde]" nil nil nil nil "\\thing" nil 1 0 nil nil) +(92 "\"]thing\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "]thing" nil 1 0 "]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(93 "\"cthing\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "cthing" nil 1 0 "c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(94 "\"dthing\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "dthing" nil 1 0 "d" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(95 "\"ething\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "ething" nil 1 0 "e" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(96 "\"athing\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "athing" nil 1 0 nil nil) +(97 "\"fthing\" =~ /^[]cde]/" "^[]cde]" nil nil nil nil "fthing" nil 1 0 nil nil) +(98 "\"fthing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "fthing" nil 1 0 "f" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(99 "\"[thing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "[thing" nil 1 0 "[" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(100 "\"\\\\thing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "\\thing" nil 1 0 "\\" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(101 "\"athing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "athing" nil 1 0 nil nil) +(102 "\"bthing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "bthing" nil 1 0 nil nil) +(103 "\"]thing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "]thing" nil 1 0 nil nil) +(104 "\"cthing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "cthing" nil 1 0 nil nil) +(105 "\"dthing\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "dthing" nil 1 0 nil nil) +(106 "\"ething\" =~ /^[^ab\\]cde]/" "^[^ab\\]cde]" nil nil nil nil "ething" nil 1 0 nil nil) +(107 "\"athing\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "athing" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(108 "\"fthing\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "fthing" nil 1 0 "f" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(109 "\"]thing\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "]thing" nil 1 0 nil nil) +(110 "\"cthing\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "cthing" nil 1 0 nil nil) +(111 "\"dthing\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "dthing" nil 1 0 nil nil) +(112 "\"ething\" =~ /^[^]cde]/" "^[^]cde]" nil nil nil nil "ething" nil 1 0 nil nil) +(113 ("\"" 129 "\" =~ /^\\" 129 "/") "^\\�" nil nil nil nil ("" 129) nil 1 0 ("" 129) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(114 ("\"" 255 "\" =~ /^" 255 "/") "^�" nil nil nil nil ("" 255) nil 1 0 ("" 255) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(115 "\"0\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "0" nil 1 0 "0" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(116 "\"1\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "1" nil 1 0 "1" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(117 "\"2\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "2" nil 1 0 "2" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(118 "\"3\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "3" nil 1 0 "3" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(119 "\"4\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "4" nil 1 0 "4" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(120 "\"5\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "5" nil 1 0 "5" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(121 "\"6\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "6" nil 1 0 "6" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(122 "\"7\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "7" nil 1 0 "7" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(123 "\"8\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "8" nil 1 0 "8" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(124 "\"9\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "9" nil 1 0 "9" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(125 "\"10\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "10" nil 1 0 "10" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(126 "\"100\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "100" nil 1 0 "100" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(127 "\"abc\" =~ /^[0-9]+$/" "^[0-9]+$" nil nil nil nil "abc" nil 1 0 nil nil) +(128 "\"enter\" =~ /^.*nter/" "^.*nter" nil nil nil nil "enter" nil 1 0 "enter" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(129 "\"inter\" =~ /^.*nter/" "^.*nter" nil nil nil nil "inter" nil 1 0 "inter" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(130 "\"uponter\" =~ /^.*nter/" "^.*nter" nil nil nil nil "uponter" nil 1 0 "uponter" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(131 "\"xxx0\" =~ /^xxx[0-9]+$/" "^xxx[0-9]+$" nil nil nil nil "xxx0" nil 1 0 "xxx0" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(132 "\"xxx1234\" =~ /^xxx[0-9]+$/" "^xxx[0-9]+$" nil nil nil nil "xxx1234" nil 1 0 "xxx1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(133 "\"xxx\" =~ /^xxx[0-9]+$/" "^xxx[0-9]+$" nil nil nil nil "xxx" nil 1 0 nil nil) +(134 "\"x123\" =~ /^.+[0-9][0-9][0-9]$/" "^.+[0-9][0-9][0-9]$" nil nil nil nil "x123" nil 1 0 "x123" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(135 "\"xx123\" =~ /^.+[0-9][0-9][0-9]$/" "^.+[0-9][0-9][0-9]$" nil nil nil nil "xx123" nil 1 0 "xx123" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(136 "\"123456\" =~ /^.+[0-9][0-9][0-9]$/" "^.+[0-9][0-9][0-9]$" nil nil nil nil "123456" nil 1 0 "123456" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(137 "\"123\" =~ /^.+[0-9][0-9][0-9]$/" "^.+[0-9][0-9][0-9]$" nil nil nil nil "123" nil 1 0 nil nil) +(138 "\"x1234\" =~ /^.+[0-9][0-9][0-9]$/" "^.+[0-9][0-9][0-9]$" nil nil nil nil "x1234" nil 1 0 "x1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(139 "\"x123\" =~ /^.+?[0-9][0-9][0-9]$/" "^.+?[0-9][0-9][0-9]$" nil nil nil nil "x123" nil 1 0 "x123" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(140 "\"xx123\" =~ /^.+?[0-9][0-9][0-9]$/" "^.+?[0-9][0-9][0-9]$" nil nil nil nil "xx123" nil 1 0 "xx123" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(141 "\"123456\" =~ /^.+?[0-9][0-9][0-9]$/" "^.+?[0-9][0-9][0-9]$" nil nil nil nil "123456" nil 1 0 "123456" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(142 "\"123\" =~ /^.+?[0-9][0-9][0-9]$/" "^.+?[0-9][0-9][0-9]$" nil nil nil nil "123" nil 1 0 nil nil) +(143 "\"x1234\" =~ /^.+?[0-9][0-9][0-9]$/" "^.+?[0-9][0-9][0-9]$" nil nil nil nil "x1234" nil 1 0 "x1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(144 "\"abc!pqr=apquxz.ixr.zzz.ac.uk\" =~ /^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/" "^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" nil nil nil nil "abc!pqr=apquxz.ixr.zzz.ac.uk" nil 1 0 "abc!pqr=apquxz.ixr.zzz.ac.uk" ("abc" "pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(145 "\"!pqr=apquxz.ixr.zzz.ac.uk\" =~ /^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/" "^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" nil nil nil nil "!pqr=apquxz.ixr.zzz.ac.uk" nil 1 0 nil nil) +(146 "\"abc!=apquxz.ixr.zzz.ac.uk\" =~ /^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/" "^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" nil nil nil nil "abc!=apquxz.ixr.zzz.ac.uk" nil 1 0 nil nil) +(147 "\"abc!pqr=apquxz:ixr.zzz.ac.uk\" =~ /^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/" "^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" nil nil nil nil "abc!pqr=apquxz:ixr.zzz.ac.uk" nil 1 0 nil nil) +(148 "\"abc!pqr=apquxz.ixr.zzz.ac.ukk\" =~ /^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/" "^([^!]+)!(.+)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" nil nil nil nil "abc!pqr=apquxz.ixr.zzz.ac.ukk" nil 1 0 nil nil) +(149 "\"Well, we need a colon: somewhere\" =~ /:/" ":" nil nil nil nil "Well, we need a colon: somewhere" nil 1 0 ":" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(150 "\"Fail if we don't\" =~ /:/" ":" nil nil nil nil "Fail if we don't" nil 1 0 nil nil) +(151 "\"0abc\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "0abc" nil 1 0 "0abc" ("0abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(152 "\"abc\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "abc" nil 1 0 "abc" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(153 "\"fed\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "fed" nil 1 0 "fed" ("fed" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(154 "\"E\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "E" nil 1 0 "E" ("E" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(155 "\"::\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "::" nil 1 0 "::" ("::" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(156 "\"5f03:12C0::932e\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "5f03:12C0::932e" nil 1 0 "5f03:12C0::932e" ("5f03:12C0::932e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(157 "\"fed def\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "fed def" nil 1 0 "def" ("def" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(158 "\"Any old stuff\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "Any old stuff" nil 1 0 "ff" ("ff" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(159 "\"0zzz\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "0zzz" nil 1 0 nil nil) +(160 "\"gzzz\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "gzzz" nil 1 0 nil nil) +(161 "\"fed\\x20\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "fed " nil 1 0 nil nil) +(162 "\"Any old rubbish\" =~ /([\\da-f:]+)$/i" "([\\da-f:]+)$" t nil nil nil "Any old rubbish" nil 1 0 nil nil) +(163 "\".1.2.3\" =~ /^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$/" "^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" nil nil nil nil ".1.2.3" nil 1 0 ".1.2.3" ("1" "2" "3" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(164 "\"A.12.123.0\" =~ /^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$/" "^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" nil nil nil nil "A.12.123.0" nil 1 0 "A.12.123.0" ("12" "123" "0" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(165 "\".1.2.3333\" =~ /^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$/" "^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" nil nil nil nil ".1.2.3333" nil 1 0 nil nil) +(166 "\"1.2.3\" =~ /^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$/" "^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" nil nil nil nil "1.2.3" nil 1 0 nil nil) +(167 "\"1234.2.3\" =~ /^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$/" "^.*\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" nil nil nil nil "1234.2.3" nil 1 0 nil nil) +(168 "\"1 IN SOA non-sp1 non-sp2(\" =~ /^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$/" "^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$" nil nil nil nil "1 IN SOA non-sp1 non-sp2(" nil 1 0 "1 IN SOA non-sp1 non-sp2(" ("1" "non-sp1" "non-sp2" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(169 "\"1 IN SOA non-sp1 non-sp2 (\" =~ /^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$/" "^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$" nil nil nil nil "1 IN SOA non-sp1 non-sp2 (" nil 1 0 "1 IN SOA non-sp1 non-sp2 (" ("1" "non-sp1" "non-sp2" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(170 "\"1IN SOA non-sp1 non-sp2(\" =~ /^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$/" "^(\\d+)\\s+IN\\s+SOA\\s+(\\S+)\\s+(\\S+)\\s*\\(\\s*$" nil nil nil nil "1IN SOA non-sp1 non-sp2(" nil 1 0 nil nil) +(171 "\"a.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "a." nil 1 0 "a." (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(172 "\"Z.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "Z." nil 1 0 "Z." (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(173 "\"2.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "2." nil 1 0 "2." (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(174 "\"ab-c.pq-r.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "ab-c.pq-r." nil 1 0 "ab-c.pq-r." (".pq-r" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(175 "\"sxk.zzz.ac.uk.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "sxk.zzz.ac.uk." nil 1 0 "sxk.zzz.ac.uk." (".uk" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(176 "\"x-.y-.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "x-.y-." nil 1 0 "x-.y-." (".y-" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(177 "\"-abc.peq.\" =~ /^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$/" "^[a-zA-Z\\d][a-zA-Z\\d\\-]*(\\.[a-zA-Z\\d][a-zA-z\\d\\-]*)*\\.$" nil nil nil nil "-abc.peq." nil 1 0 nil nil) +(178 "\"*.a\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.a" nil 1 0 "*.a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(179 "\"*.b0-a\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.b0-a" nil 1 0 "*.b0-a" ("0-a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(180 "\"*.c3-b.c\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.c3-b.c" nil 1 0 "*.c3-b.c" ("3-b" ".c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(181 "\"*.c-a.b-c\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.c-a.b-c" nil 1 0 "*.c-a.b-c" ("-a" ".b-c" "-c" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(182 "\"*.0\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.0" nil 1 0 nil nil) +(183 "\"*.a-\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.a-" nil 1 0 nil nil) +(184 "\"*.a-b.c-\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.a-b.c-" nil 1 0 nil nil) +(185 "\"*.c-a.0-c\" =~ /^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$/" "^\\*\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?(\\.[a-z]([a-z\\-\\d]*[a-z\\d]+)?)*$" nil nil nil nil "*.c-a.0-c" nil 1 0 nil nil) +(186 "\"abde\" =~ /^(?=ab(de))(abd)(e)/" "^(?=ab(de))(abd)(e)" nil nil nil nil "abde" nil 1 0 "abde" ("de" "abd" "e" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(187 "\"abdf\" =~ /^(?!(ab)de|x)(abd)(f)/" "^(?!(ab)de|x)(abd)(f)" nil nil nil nil "abdf" nil 1 0 "abdf" (nil "abd" "f" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(188 "\"abcd\" =~ /^(?=(ab(cd)))(ab)/" "^(?=(ab(cd)))(ab)" nil nil nil nil "abcd" nil 1 0 "ab" ("abcd" "cd" "ab" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(189 "\"a.b.c.d\" =~ /^[\\da-f](\\.[\\da-f])*$/i" "^[\\da-f](\\.[\\da-f])*$" t nil nil nil "a.b.c.d" nil 1 0 "a.b.c.d" (".d" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(190 "\"A.B.C.D\" =~ /^[\\da-f](\\.[\\da-f])*$/i" "^[\\da-f](\\.[\\da-f])*$" t nil nil nil "A.B.C.D" nil 1 0 "A.B.C.D" (".D" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(191 "\"a.b.c.1.2.3.C\" =~ /^[\\da-f](\\.[\\da-f])*$/i" "^[\\da-f](\\.[\\da-f])*$" t nil nil nil "a.b.c.1.2.3.C" nil 1 0 "a.b.c.1.2.3.C" (".C" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(192 "\"\\\"1234\\\"\" =~ /^\\\".*\\\"\\s*(;.*)?$/" "^\\\".*\\\"\\s*(;.*)?$" nil nil nil nil "\"1234\"" nil 1 0 "\"1234\"" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(193 "\"\\\"abcd\\\" ;\" =~ /^\\\".*\\\"\\s*(;.*)?$/" "^\\\".*\\\"\\s*(;.*)?$" nil nil nil nil "\"abcd\" ;" nil 1 0 "\"abcd\" ;" (";" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(194 "\"\\\"\\\" ; rhubarb\" =~ /^\\\".*\\\"\\s*(;.*)?$/" "^\\\".*\\\"\\s*(;.*)?$" nil nil nil nil "\"\" ; rhubarb" nil 1 0 "\"\" ; rhubarb" ("; rhubarb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(195 "\"\\\"1234\\\" : things\" =~ /^\\\".*\\\"\\s*(;.*)?$/" "^\\\".*\\\"\\s*(;.*)?$" nil nil nil nil "\"1234\" : things" nil 1 0 nil nil) +(196 "\"\\\" =~ /^$/" "^$" nil nil nil nil "" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(197 "\"ab c\" =~ / ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/x" " ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil t "ab c" nil 1 0 "ab c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(198 "\"abc\" =~ / ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/x" " ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil t "abc" nil 1 0 nil nil) +(199 "\"ab cde\" =~ / ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/x" " ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil t "ab cde" nil 1 0 nil nil) +(200 "\"ab c\" =~ /(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/" "(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil nil "ab c" nil 1 0 "ab c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(201 "\"abc\" =~ /(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/" "(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil nil "abc" nil 1 0 nil nil) +(202 "\"ab cde\" =~ /(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)/" "(?x) ^ a (?# begins with a) b\\sc (?# then b c) $ (?# then end)" nil nil nil nil "ab cde" nil 1 0 nil nil) +(203 "\"a bcd\" =~ /^ a\\ b[c ]d $/x" "^ a\\ b[c ]d $" nil nil nil t "a bcd" nil 1 0 "a bcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(204 "\"a b d\" =~ /^ a\\ b[c ]d $/x" "^ a\\ b[c ]d $" nil nil nil t "a b d" nil 1 0 "a b d" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(205 "\"abcd\" =~ /^ a\\ b[c ]d $/x" "^ a\\ b[c ]d $" nil nil nil t "abcd" nil 1 0 nil nil) +(206 "\"ab d\" =~ /^ a\\ b[c ]d $/x" "^ a\\ b[c ]d $" nil nil nil t "ab d" nil 1 0 nil nil) +(207 "\"abcdefhijklm\" =~ /^(a(b(c)))(d(e(f)))(h(i(j)))(k(l(m)))$/" "^(a(b(c)))(d(e(f)))(h(i(j)))(k(l(m)))$" nil nil nil nil "abcdefhijklm" nil 1 0 "abcdefhijklm" ("abc" "bc" "c" "def" "ef" "f" "hij" "ij" "j" "klm" "lm" "m" nil nil nil nil)) +(208 "\"abcdefhijklm\" =~ /^(?:a(b(c)))(?:d(e(f)))(?:h(i(j)))(?:k(l(m)))$/" "^(?:a(b(c)))(?:d(e(f)))(?:h(i(j)))(?:k(l(m)))$" nil nil nil nil "abcdefhijklm" nil 1 0 "abcdefhijklm" ("bc" "c" "ef" "f" "ij" "j" "lm" "m" nil nil nil nil nil nil nil nil)) +(209 "\"a+ Z0+\\x08\\n\\x1d\\x12\" =~ /^[\\w][\\W][\\s][\\S][\\d][\\D][\\b][\\n][\\c]][\\022]/" "^[\\w][\\W][\\s][\\S][\\d][\\D][\\b][\\n][\\c]][\\022]" nil nil nil nil ("a+ Z0+" 8 10 29 18) nil 1 0 ("a+ Z0+" 8 10 29 18) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(210 "\".^\\$(*+)|{?,?}\" =~ /^[.^$|()*+?{,}]+/" "^[.^$|()*+?{,}]+" nil nil nil nil ".^$(*+)|{?,?}" nil 1 0 ".^$(*+)|{?,?}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(211 "\"z\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "z" nil 1 0 "z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(212 "\"az\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "az" nil 1 0 "az" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(213 "\"aaaz\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "aaaz" nil 1 0 "aaaz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(214 "\"a\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(215 "\"aa\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(216 "\"aaaa\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "aaaa" nil 1 0 "aaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(217 "\"a+\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "a+" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(218 "\"aa+\" =~ /^a*\\w/" "^a*\\w" nil nil nil nil "aa+" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(219 "\"z\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "z" nil 1 0 "z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(220 "\"az\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "az" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(221 "\"aaaz\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "aaaz" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(222 "\"a\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(223 "\"aa\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "aa" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(224 "\"aaaa\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "aaaa" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(225 "\"a+\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "a+" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(226 "\"aa+\" =~ /^a*?\\w/" "^a*?\\w" nil nil nil nil "aa+" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(227 "\"az\" =~ /^a+\\w/" "^a+\\w" nil nil nil nil "az" nil 1 0 "az" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(228 "\"aaaz\" =~ /^a+\\w/" "^a+\\w" nil nil nil nil "aaaz" nil 1 0 "aaaz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(229 "\"aa\" =~ /^a+\\w/" "^a+\\w" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(230 "\"aaaa\" =~ /^a+\\w/" "^a+\\w" nil nil nil nil "aaaa" nil 1 0 "aaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(231 "\"aa+\" =~ /^a+\\w/" "^a+\\w" nil nil nil nil "aa+" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(232 "\"az\" =~ /^a+?\\w/" "^a+?\\w" nil nil nil nil "az" nil 1 0 "az" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(233 "\"aaaz\" =~ /^a+?\\w/" "^a+?\\w" nil nil nil nil "aaaz" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(234 "\"aa\" =~ /^a+?\\w/" "^a+?\\w" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(235 "\"aaaa\" =~ /^a+?\\w/" "^a+?\\w" nil nil nil nil "aaaa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(236 "\"aa+\" =~ /^a+?\\w/" "^a+?\\w" nil nil nil nil "aa+" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(237 "\"1234567890\" =~ /^\\d{8}\\w{2,}/" "^\\d{8}\\w{2,}" nil nil nil nil "1234567890" nil 1 0 "1234567890" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(238 "\"12345678ab\" =~ /^\\d{8}\\w{2,}/" "^\\d{8}\\w{2,}" nil nil nil nil "12345678ab" nil 1 0 "12345678ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(239 "\"12345678__\" =~ /^\\d{8}\\w{2,}/" "^\\d{8}\\w{2,}" nil nil nil nil "12345678__" nil 1 0 "12345678__" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(240 "\"1234567\" =~ /^\\d{8}\\w{2,}/" "^\\d{8}\\w{2,}" nil nil nil nil "1234567" nil 1 0 nil nil) +(241 "\"uoie\" =~ /^[aeiou\\d]{4,5}$/" "^[aeiou\\d]{4,5}$" nil nil nil nil "uoie" nil 1 0 "uoie" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(242 "\"1234\" =~ /^[aeiou\\d]{4,5}$/" "^[aeiou\\d]{4,5}$" nil nil nil nil "1234" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(243 "\"12345\" =~ /^[aeiou\\d]{4,5}$/" "^[aeiou\\d]{4,5}$" nil nil nil nil "12345" nil 1 0 "12345" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(244 "\"aaaaa\" =~ /^[aeiou\\d]{4,5}$/" "^[aeiou\\d]{4,5}$" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(245 "\"123456\" =~ /^[aeiou\\d]{4,5}$/" "^[aeiou\\d]{4,5}$" nil nil nil nil "123456" nil 1 0 nil nil) +(246 "\"uoie\" =~ /^[aeiou\\d]{4,5}?/" "^[aeiou\\d]{4,5}?" nil nil nil nil "uoie" nil 1 0 "uoie" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(247 "\"1234\" =~ /^[aeiou\\d]{4,5}?/" "^[aeiou\\d]{4,5}?" nil nil nil nil "1234" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(248 "\"12345\" =~ /^[aeiou\\d]{4,5}?/" "^[aeiou\\d]{4,5}?" nil nil nil nil "12345" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(249 "\"aaaaa\" =~ /^[aeiou\\d]{4,5}?/" "^[aeiou\\d]{4,5}?" nil nil nil nil "aaaaa" nil 1 0 "aaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(250 "\"123456\" =~ /^[aeiou\\d]{4,5}?/" "^[aeiou\\d]{4,5}?" nil nil nil nil "123456" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(251 "\"abc=abcabc\" =~ /\\A(abc|def)=(\\1){2,3}\\Z/" "\\A(abc|def)=(\\1){2,3}\\Z" nil nil nil nil "abc=abcabc" nil 1 0 "abc=abcabc" ("abc" "abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(252 "\"def=defdefdef\" =~ /\\A(abc|def)=(\\1){2,3}\\Z/" "\\A(abc|def)=(\\1){2,3}\\Z" nil nil nil nil "def=defdefdef" nil 1 0 "def=defdefdef" ("def" "def" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(253 "\"abc=defdef\" =~ /\\A(abc|def)=(\\1){2,3}\\Z/" "\\A(abc|def)=(\\1){2,3}\\Z" nil nil nil nil "abc=defdef" nil 1 0 nil nil) +(254 "\"abcdefghijkcda2\" =~ /^(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\11*(\\3\\4)\\1(?#)2$/" "^(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\11*(\\3\\4)\\1(?#)2$" nil nil nil nil "abcdefghijkcda2" nil 1 0 "abcdefghijkcda2" ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "cd" nil nil nil nil)) +(255 "\"abcdefghijkkkkcda2\" =~ /^(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\11*(\\3\\4)\\1(?#)2$/" "^(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\11*(\\3\\4)\\1(?#)2$" nil nil nil nil "abcdefghijkkkkcda2" nil 1 0 "abcdefghijkkkkcda2" ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "cd" nil nil nil nil)) +(256 "\"cataract cataract23\" =~ /(cat(a(ract|tonic)|erpillar)) \\1()2(3)/" "(cat(a(ract|tonic)|erpillar)) \\1()2(3)" nil nil nil nil "cataract cataract23" nil 1 0 "cataract cataract23" ("cataract" "aract" "ract" "" "3" nil nil nil nil nil nil nil nil nil nil nil)) +(257 "\"catatonic catatonic23\" =~ /(cat(a(ract|tonic)|erpillar)) \\1()2(3)/" "(cat(a(ract|tonic)|erpillar)) \\1()2(3)" nil nil nil nil "catatonic catatonic23" nil 1 0 "catatonic catatonic23" ("catatonic" "atonic" "tonic" "" "3" nil nil nil nil nil nil nil nil nil nil nil)) +(258 "\"caterpillar caterpillar23\" =~ /(cat(a(ract|tonic)|erpillar)) \\1()2(3)/" "(cat(a(ract|tonic)|erpillar)) \\1()2(3)" nil nil nil nil "caterpillar caterpillar23" nil 1 0 "caterpillar caterpillar23" ("caterpillar" "erpillar" nil "" "3" nil nil nil nil nil nil nil nil nil nil nil)) +(259 "\"From abcd Mon Sep 01 12:33:02 1997\" =~ +/^From +([^ ]+) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/" "^From +([^ ]+) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]" nil nil nil nil "From abcd Mon Sep 01 12:33:02 1997" nil 1 0 "From abcd Mon Sep 01 12:33" ("abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(260 "\"From abcd Mon Sep 01 12:33:02 1997\" =~ /^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d/" "^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d" nil nil nil nil "From abcd Mon Sep 01 12:33:02 1997" nil 1 0 "From abcd Mon Sep 01 12:33" ("Sep " nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(261 "\"From abcd Mon Sep 1 12:33:02 1997\" =~ /^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d/" "^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d" nil nil nil nil "From abcd Mon Sep 1 12:33:02 1997" nil 1 0 "From abcd Mon Sep 1 12:33" ("Sep " nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(262 "\"From abcd Sep 01 12:33:02 1997\" =~ /^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d/" "^From\\s+\\S+\\s+([a-zA-Z]{3}\\s+){2}\\d{1,2}\\s+\\d\\d:\\d\\d" nil nil nil nil "From abcd Sep 01 12:33:02 1997" nil 1 0 nil nil) +(263 "\"12\\n34\" =~ /^12.34/s" "^12.34" nil nil t nil "12 +34" nil 1 0 "12 +34" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(264 "\"12\\r34\" =~ /^12.34/s" "^12.34" nil nil t nil ("12" 13 "34") nil 1 0 ("12" 13 "34") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(265 "\"the quick brown\\t fox\" =~ /\\w+(?=\\t)/" "\\w+(?=\\t)" nil nil nil nil ("the quick brown" 9 " fox") nil 1 0 "brown" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(266 "\"foobar is foolish see?\" =~ /foo(?!bar)(.*)/" "foo(?!bar)(.*)" nil nil nil nil "foobar is foolish see?" nil 1 0 "foolish see?" ("lish see?" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(267 "\"foobar crowbar etc\" =~ /(?:(?!foo)...|^.{0,2})bar(.*)/" "(?:(?!foo)...|^.{0,2})bar(.*)" nil nil nil nil "foobar crowbar etc" nil 1 0 "rowbar etc" (" etc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(268 "\"barrel\" =~ /(?:(?!foo)...|^.{0,2})bar(.*)/" "(?:(?!foo)...|^.{0,2})bar(.*)" nil nil nil nil "barrel" nil 1 0 "barrel" ("rel" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(269 "\"2barrel\" =~ /(?:(?!foo)...|^.{0,2})bar(.*)/" "(?:(?!foo)...|^.{0,2})bar(.*)" nil nil nil nil "2barrel" nil 1 0 "2barrel" ("rel" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(270 "\"A barrel\" =~ /(?:(?!foo)...|^.{0,2})bar(.*)/" "(?:(?!foo)...|^.{0,2})bar(.*)" nil nil nil nil "A barrel" nil 1 0 "A barrel" ("rel" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(271 "\"abc456\" =~ /^(\\D*)(?=\\d)(?!123)/" "^(\\D*)(?=\\d)(?!123)" nil nil nil nil "abc456" nil 1 0 "abc" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(272 "\"abc123\" =~ /^(\\D*)(?=\\d)(?!123)/" "^(\\D*)(?=\\d)(?!123)" nil nil nil nil "abc123" nil 1 0 nil nil) +(273 "\"1234\" =~ /^1234(?# test newlines + inside)/" "^1234(?# test newlines + inside)" nil nil nil nil "1234" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(274 "\"1234\" =~ /^1234 #comment in extended re + /x" "^1234 #comment in extended re + " nil nil nil t "1234" nil 1 0 "1234" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(275 "\"abcd\" =~ /#rhubarb + abcd/x" "#rhubarb + abcd" nil nil nil t "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(276 "\"abcd\" =~ /^abcd#rhubarb/x" "^abcd#rhubarb" nil nil nil t "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(277 "\"aaab\" =~ /^(a)\\1{2,3}(.)/" "^(a)\\1{2,3}(.)" nil nil nil nil "aaab" nil 1 0 "aaab" ("a" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(278 "\"aaaab\" =~ /^(a)\\1{2,3}(.)/" "^(a)\\1{2,3}(.)" nil nil nil nil "aaaab" nil 1 0 "aaaab" ("a" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(279 "\"aaaaab\" =~ /^(a)\\1{2,3}(.)/" "^(a)\\1{2,3}(.)" nil nil nil nil "aaaaab" nil 1 0 "aaaaa" ("a" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(280 "\"aaaaaab\" =~ /^(a)\\1{2,3}(.)/" "^(a)\\1{2,3}(.)" nil nil nil nil "aaaaaab" nil 1 0 "aaaaa" ("a" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(281 "\"the abc\" =~ /(?!^)abc/" "(?!^)abc" nil nil nil nil "the abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(282 "\"abc\" =~ /(?!^)abc/" "(?!^)abc" nil nil nil nil "abc" nil 1 0 nil nil) +(283 "\"abc\" =~ /(?=^)abc/" "(?=^)abc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(284 "\"the abc\" =~ /(?=^)abc/" "(?=^)abc" nil nil nil nil "the abc" nil 1 0 nil nil) +(285 "\"aabbbbb\" =~ /^[ab]{1,3}(ab*|b)/" "^[ab]{1,3}(ab*|b)" nil nil nil nil "aabbbbb" nil 1 0 "aabb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(286 "\"aabbbbb\" =~ /^[ab]{1,3}?(ab*|b)/" "^[ab]{1,3}?(ab*|b)" nil nil nil nil "aabbbbb" nil 1 0 "aabbbbb" ("abbbbb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(287 "\"aabbbbb\" =~ /^[ab]{1,3}?(ab*?|b)/" "^[ab]{1,3}?(ab*?|b)" nil nil nil nil "aabbbbb" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(288 "\"aabbbbb\" =~ /^[ab]{1,3}(ab*?|b)/" "^[ab]{1,3}(ab*?|b)" nil nil nil nil "aabbbbb" nil 1 0 "aabb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(289 "\"Alan Other <user\$a)dom.ain>\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "Alan Other <user(a)dom.ain>" nil 1 0 "Alan Other <user(a)dom.ain>" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(290 "\"<user\$a)dom.ain>\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "<user(a)dom.ain>" nil 1 0 "user(a)dom.ain" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(291 "\"user\$a)dom.ain\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "user(a)dom.ain" nil 1 0 "user(a)dom.ain" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(292 "\"\\\"A. Other\\\" <user.1234\$a)dom.ain> (a comment)\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "\"A. Other\" <user.1234(a)dom.ain> (a comment)" nil 1 0 "\"A. Other\" <user.1234(a)dom.ain> (a comment)" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(293 "\"A. Other <user.1234\$a)dom.ain> (a comment)\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "A. Other <user.1234(a)dom.ain> (a comment)" nil 1 0 " Other <user.1234(a)dom.ain> (a comment)" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(294 "\"\\\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\\\"\$a)x400-re.lay\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"@x400-re.lay" nil 1 0 "\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"@x400-re.lay" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(295 "\"A missing angle <user\$a)some.where\" =~ / (?: [\\040\\t] | \\( +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "A missing angle <user(a)some.where" nil 1 0 "user(a)some.where" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(296 "\"The quick brown fox\" =~ / (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +/x" " (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional leading comment +(?: (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] | # atom and space parts, or... +\$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) | # comments, or... + +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +# quoted strings +)* +< (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # leading < +(?: @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* + +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* , (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* )? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) # initial word +(?: (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\" (?: # opening quote... +[^\\\\\\x80-\\xff\\n\\015\"] # Anything except backslash and quote +| # or +\\\\ [^\\x80-\\xff] # Escaped something (something != CR) +)* \" # closing quote +) )* # further okay, if led by a period +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* @ (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # initial subdomain +(?: # +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* \\. # if led by a period... +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* (?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| \\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) # ...further okay +)* +# address spec +(?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* > # trailing > +# name and address +) (?: [\\040\\t] | \$ +(?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] | \\( (?: [^\\\\\\x80-\\xff\\n\\015()] | \\\\ [^\\x80-\\xff] )* \$ )* +\\) )* # optional trailing comment +" nil nil nil t "The quick brown fox" nil 1 0 nil nil) +(297 "\"Alan Other <user\$a)dom.ain>\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "Alan Other <user(a)dom.ain>" nil 1 0 "Alan Other <user(a)dom.ain>" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(298 "\"<user\$a)dom.ain>\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "<user(a)dom.ain>" nil 1 0 "user(a)dom.ain" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(299 "\"user\$a)dom.ain\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "user(a)dom.ain" nil 1 0 "user(a)dom.ain" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(300 "\"\\\"A. Other\\\" <user.1234\$a)dom.ain> (a comment)\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "\"A. Other\" <user.1234(a)dom.ain> (a comment)" nil 1 0 "\"A. Other\" <user.1234(a)dom.ain>" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(301 "\"A. Other <user.1234\$a)dom.ain> (a comment)\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "A. Other <user.1234(a)dom.ain> (a comment)" nil 1 0 " Other <user.1234(a)dom.ain>" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(302 "\"\\\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\\\"\$a)x400-re.lay\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"@x400-re.lay" nil 1 0 "\"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"@x400-re.lay" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(303 "\"A missing angle <user\$a)some.where\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "A missing angle <user(a)some.where" nil 1 0 "user(a)some.where" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(304 "\"The quick brown fox\" =~ /[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x" "[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +# leading word +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # \"normal\" atoms and or spaces +(?: +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +| +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +) # \"special\" comment or quoted string +[^()<>@,;:\".\\\\\\[\\]\\x80-\\xff\\000-\\010\\012-\\037] * # more \"normal\" +)* +< +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +\" # \" +[^\\\\\\x80-\\xff\\n\\015\"] * # normal +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015\"] * )* # ( special normal* )* +\" # \" +# Quoted string +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\\. +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +(?: +[^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]+ # some number of atom characters... +(?![^(\\040)<>@,;:\".\\\\\\[\\]\\000-\\037\\x80-\\xff]) # ..not followed by something that could be part of an atom +| +\\[ # [ +(?: [^\\\\\\x80-\\xff\\n\\015\\[\\]] | \\\\ [^\\x80-\\xff] )* # stuff +\\] # ] +) +[\\040\\t]* # Nab whitespace. +(?: +\$ # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: # ( +(?: \\\\ [^\\x80-\\xff] | +\\( # ( +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +(?: \\\\ [^\\x80-\\xff] [^\\\\\\x80-\\xff\\n\\015()] * )* # (special normal*)* +\$ # ) +) # special +[^\\\\\\x80-\\xff\\n\\015()] * # normal* +)* # )* +\\) # ) +[\\040\\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +" nil nil nil t "The quick brown fox" nil 1 0 nil nil) +(305 "\"abc\\0def\\00pqr\\000xyz\\0000AB\" =~ /abc\\0def\\00pqr\\000xyz\\0000AB/" "abc\\0def\\00pqr\\000xyz\\0000AB" nil nil nil nil ("abc" 0 "def" 0 "pqr" 0 "xyz" 0 "0AB") nil 1 0 ("abc" 0 "def" 0 "pqr" 0 "xyz" 0 "0AB") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(306 "\"abc456 abc\\0def\\00pqr\\000xyz\\0000ABCDE\" =~ /abc\\0def\\00pqr\\000xyz\\0000AB/" "abc\\0def\\00pqr\\000xyz\\0000AB" nil nil nil nil ("abc456 abc" 0 "def" 0 "pqr" 0 "xyz" 0 "0ABCDE") nil 1 0 ("abc" 0 "def" 0 "pqr" 0 "xyz" 0 "0AB") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(307 "\"abc\\x0def\\x00pqr\\x000xyz\\x0000AB\" =~ /abc\\x0def\\x00pqr\\x000xyz\\x0000AB/" "abc\\x0def\\x00pqr\\x000xyz\\x0000AB" nil nil nil nil ("abc" 13 "ef" 0 "pqr" 0 "0xyz" 0 "00AB") nil 1 0 ("abc" 13 "ef" 0 "pqr" 0 "0xyz" 0 "00AB") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(308 "\"abc456 abc\\x0def\\x00pqr\\x000xyz\\x0000ABCDE\" =~ /abc\\x0def\\x00pqr\\x000xyz\\x0000AB/" "abc\\x0def\\x00pqr\\x000xyz\\x0000AB" nil nil nil nil ("abc456 abc" 13 "ef" 0 "pqr" 0 "0xyz" 0 "00ABCDE") nil 1 0 ("abc" 13 "ef" 0 "pqr" 0 "0xyz" 0 "00AB") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(309 "\"\\0A\" =~ /^[\\000-\\037]/" "^[\\000-\\037]" nil nil nil nil ("" 0 "A") nil 1 0 ("" 0) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(310 "\"\\01B\" =~ /^[\\000-\\037]/" "^[\\000-\\037]" nil nil nil nil ("" 1 "B") nil 1 0 ("" 1) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(311 "\"\\037C\" =~ /^[\\000-\\037]/" "^[\\000-\\037]" nil nil nil nil ("" 31 "C") nil 1 0 ("" 31) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(312 "\"\\0\\0\\0\\0\" =~ /\\0*/" "\\0*" nil nil nil nil ("" 0 0 0 0) nil 1 0 ("" 0 0 0 0) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(313 "\"The A\\x0\\x0Z\" =~ /A\\x0{2,3}Z/" "A\\x0{2,3}Z" nil nil nil nil ("The A" 0 0 "Z") nil 1 0 ("A" 0 0 "Z") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(314 "\"An A\\0\\x0\\0Z\" =~ /A\\x0{2,3}Z/" "A\\x0{2,3}Z" nil nil nil nil ("An A" 0 0 0 "Z") nil 1 0 ("A" 0 0 0 "Z") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(315 "\"A\\0Z\" =~ /A\\x0{2,3}Z/" "A\\x0{2,3}Z" nil nil nil nil ("A" 0 "Z") nil 1 0 nil nil) +(316 "\"A\\0\\x0\\0\\x0Z\" =~ /A\\x0{2,3}Z/" "A\\x0{2,3}Z" nil nil nil nil ("A" 0 0 0 0 "Z") nil 1 0 nil nil) +(317 "\"cowcowbell\" =~ /^(cow|)\\1(bell)/" "^(cow|)\\1(bell)" nil nil nil nil "cowcowbell" nil 1 0 "cowcowbell" ("cow" "bell" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(318 "\"bell\" =~ /^(cow|)\\1(bell)/" "^(cow|)\\1(bell)" nil nil nil nil "bell" nil 1 0 "bell" ("" "bell" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(319 "\"cowbell\" =~ /^(cow|)\\1(bell)/" "^(cow|)\\1(bell)" nil nil nil nil "cowbell" nil 1 0 nil nil) +(320 "\"\\040abc\" =~ /^\\s/" "^\\s" nil nil nil nil " abc" nil 1 0 " " (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(321 "\"\\x0cabc\" =~ /^\\s/" "^\\s" nil nil nil nil ("" 12 "abc") nil 1 0 ("" 12) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(322 "\"\\nabc\" =~ /^\\s/" "^\\s" nil nil nil nil " +abc" nil 1 0 " +" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(323 "\"\\rabc\" =~ /^\\s/" "^\\s" nil nil nil nil ("" 13 "abc") nil 1 0 ("" 13) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(324 "\"\\tabc\" =~ /^\\s/" "^\\s" nil nil nil nil ("" 9 "abc") nil 1 0 ("" 9) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(325 "\"abc\" =~ /^\\s/" "^\\s" nil nil nil nil "abc" nil 1 0 nil nil) +(326 ("\"abc\" =~ /^a" 9 "b" 10 " " 13 " " 12 " c/x") "^a b + c" nil nil nil t "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(327 "\"ab\" =~ /^(a|)\\1*b/" "^(a|)\\1*b" nil nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(328 "\"aaaab\" =~ /^(a|)\\1*b/" "^(a|)\\1*b" nil nil nil nil "aaaab" nil 1 0 "aaaab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(329 "\"b\" =~ /^(a|)\\1*b/" "^(a|)\\1*b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(330 "\"acb\" =~ /^(a|)\\1*b/" "^(a|)\\1*b" nil nil nil nil "acb" nil 1 0 nil nil) +(331 "\"aab\" =~ /^(a|)\\1+b/" "^(a|)\\1+b" nil nil nil nil "aab" nil 1 0 "aab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(332 "\"aaaab\" =~ /^(a|)\\1+b/" "^(a|)\\1+b" nil nil nil nil "aaaab" nil 1 0 "aaaab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(333 "\"b\" =~ /^(a|)\\1+b/" "^(a|)\\1+b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(334 "\"ab\" =~ /^(a|)\\1+b/" "^(a|)\\1+b" nil nil nil nil "ab" nil 1 0 nil nil) +(335 "\"ab\" =~ /^(a|)\\1?b/" "^(a|)\\1?b" nil nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(336 "\"aab\" =~ /^(a|)\\1?b/" "^(a|)\\1?b" nil nil nil nil "aab" nil 1 0 "aab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(337 "\"b\" =~ /^(a|)\\1?b/" "^(a|)\\1?b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(338 "\"acb\" =~ /^(a|)\\1?b/" "^(a|)\\1?b" nil nil nil nil "acb" nil 1 0 nil nil) +(339 "\"aaab\" =~ /^(a|)\\1{2}b/" "^(a|)\\1{2}b" nil nil nil nil "aaab" nil 1 0 "aaab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(340 "\"b\" =~ /^(a|)\\1{2}b/" "^(a|)\\1{2}b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(341 "\"ab\" =~ /^(a|)\\1{2}b/" "^(a|)\\1{2}b" nil nil nil nil "ab" nil 1 0 nil nil) +(342 "\"aab\" =~ /^(a|)\\1{2}b/" "^(a|)\\1{2}b" nil nil nil nil "aab" nil 1 0 nil nil) +(343 "\"aaaab\" =~ /^(a|)\\1{2}b/" "^(a|)\\1{2}b" nil nil nil nil "aaaab" nil 1 0 nil nil) +(344 "\"aaab\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "aaab" nil 1 0 "aaab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(345 "\"aaaab\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "aaaab" nil 1 0 "aaaab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(346 "\"b\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(347 "\"ab\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "ab" nil 1 0 nil nil) +(348 "\"aab\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "aab" nil 1 0 nil nil) +(349 "\"aaaaab\" =~ /^(a|)\\1{2,3}b/" "^(a|)\\1{2,3}b" nil nil nil nil "aaaaab" nil 1 0 nil nil) +(350 "\"abbbbc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(351 "\"abbbc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abbbc" nil 1 0 "abbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(352 "\"abbc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abbc" nil 1 0 "abbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(353 "\"abc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abc" nil 1 0 nil nil) +(354 "\"abbbbbc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abbbbbc" nil 1 0 nil nil) +(355 "\"track1.title:TBlah blah blah\" =~ /([^.]*)\\.([^:]*):[T ]+(.*)/" "([^.]*)\\.([^:]*):[T ]+(.*)" nil nil nil nil "track1.title:TBlah blah blah" nil 1 0 "track1.title:TBlah blah blah" ("track1" "title" "Blah blah blah" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(356 "\"track1.title:TBlah blah blah\" =~ /([^.]*)\\.([^:]*):[T ]+(.*)/i" "([^.]*)\\.([^:]*):[T ]+(.*)" t nil nil nil "track1.title:TBlah blah blah" nil 1 0 "track1.title:TBlah blah blah" ("track1" "title" "Blah blah blah" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(357 "\"track1.title:TBlah blah blah\" =~ /([^.]*)\\.([^:]*):[t ]+(.*)/i" "([^.]*)\\.([^:]*):[t ]+(.*)" t nil nil nil "track1.title:TBlah blah blah" nil 1 0 "track1.title:TBlah blah blah" ("track1" "title" "Blah blah blah" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(358 "\"WXY_^abc\" =~ /^[W-c]+$/" "^[W-c]+$" nil nil nil nil "WXY_^abc" nil 1 0 "WXY_^abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(359 "\"wxy\" =~ /^[W-c]+$/" "^[W-c]+$" nil nil nil nil "wxy" nil 1 0 nil nil) +(360 "\"WXY_^abc\" =~ /^[W-c]+$/i" "^[W-c]+$" t nil nil nil "WXY_^abc" nil 1 0 "WXY_^abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(361 "\"wxy_^ABC\" =~ /^[W-c]+$/i" "^[W-c]+$" t nil nil nil "wxy_^ABC" nil 1 0 "wxy_^ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(362 "\"WXY_^abc\" =~ /^[\\x3f-\\x5F]+$/i" "^[\\x3f-\\x5F]+$" t nil nil nil "WXY_^abc" nil 1 0 "WXY_^abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(363 "\"wxy_^ABC\" =~ /^[\\x3f-\\x5F]+$/i" "^[\\x3f-\\x5F]+$" t nil nil nil "wxy_^ABC" nil 1 0 "wxy_^ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(364 "\"abc\" =~ /^abc$/m" "^abc$" nil t nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(365 "\"qqq\\nabc\" =~ /^abc$/m" "^abc$" nil t nil nil "qqq +abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(366 "\"abc\\nzzz\" =~ /^abc$/m" "^abc$" nil t nil nil "abc +zzz" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(367 "\"qqq\\nabc\\nzzz\" =~ /^abc$/m" "^abc$" nil t nil nil "qqq +abc +zzz" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(368 "\"abc\" =~ /^abc$/" "^abc$" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(369 "\"qqq\\nabc\" =~ /^abc$/" "^abc$" nil nil nil nil "qqq +abc" nil 1 0 nil nil) +(370 "\"abc\\nzzz\" =~ /^abc$/" "^abc$" nil nil nil nil "abc +zzz" nil 1 0 nil nil) +(371 "\"qqq\\nabc\\nzzz\" =~ /^abc$/" "^abc$" nil nil nil nil "qqq +abc +zzz" nil 1 0 nil nil) +(372 "\"abc\" =~ /\\Aabc\\Z/m" "\\Aabc\\Z" nil t nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(373 "\"abc\\n\" =~ /\\Aabc\\Z/m" "\\Aabc\\Z" nil t nil nil "abc +" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(374 "\"qqq\\nabc\" =~ /\\Aabc\\Z/m" "\\Aabc\\Z" nil t nil nil "qqq +abc" nil 1 0 nil nil) +(375 "\"abc\\nzzz\" =~ /\\Aabc\\Z/m" "\\Aabc\\Z" nil t nil nil "abc +zzz" nil 1 0 nil nil) +(376 "\"qqq\\nabc\\nzzz\" =~ /\\Aabc\\Z/m" "\\Aabc\\Z" nil t nil nil "qqq +abc +zzz" nil 1 0 nil nil) +(377 "\"abc\\ndef\" =~ /\\A(.)*\\Z/s" "\\A(.)*\\Z" nil nil t nil "abc +def" nil 1 0 "abc +def" ("f" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(378 "\"abc\\ndef\" =~ /\\A(.)*\\Z/m" "\\A(.)*\\Z" nil t nil nil "abc +def" nil 1 0 nil nil) +(379 "\"b::c\" =~ /(?:b)|(?::+)/" "(?:b)|(?::+)" nil nil nil nil "b::c" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(380 "\"c::b\" =~ /(?:b)|(?::+)/" "(?:b)|(?::+)" nil nil nil nil "c::b" nil 1 0 "::" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(381 "\"az-\" =~ /[-az]+/" "[-az]+" nil nil nil nil "az-" nil 1 0 "az-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(382 "\"b\" =~ /[-az]+/" "[-az]+" nil nil nil nil "b" nil 1 0 nil nil) +(383 "\"za-\" =~ /[az-]+/" "[az-]+" nil nil nil nil "za-" nil 1 0 "za-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(384 "\"b\" =~ /[az-]+/" "[az-]+" nil nil nil nil "b" nil 1 0 nil nil) +(385 "\"a-z\" =~ /[a\\-z]+/" "[a\\-z]+" nil nil nil nil "a-z" nil 1 0 "a-z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(386 "\"b\" =~ /[a\\-z]+/" "[a\\-z]+" nil nil nil nil "b" nil 1 0 nil nil) +(387 "\"abcdxyz\" =~ /[a-z]+/" "[a-z]+" nil nil nil nil "abcdxyz" nil 1 0 "abcdxyz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(388 "\"12-34\" =~ /[\\d-]+/" "[\\d-]+" nil nil nil nil "12-34" nil 1 0 "12-34" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(389 "\"aaa\" =~ /[\\d-]+/" "[\\d-]+" nil nil nil nil "aaa" nil 1 0 nil nil) +(390 "\"12-34z\" =~ /[\\d-z]+/" "[\\d-z]+" nil nil nil nil "12-34z" nil 1 0 "12-34z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(391 "\"aaa\" =~ /[\\d-z]+/" "[\\d-z]+" nil nil nil nil "aaa" nil 1 0 nil nil) +(392 "\"\\\\\" =~ /\\x5c/" "\\x5c" nil nil nil nil "\\" nil 1 0 "\\" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(393 "\"the Zoo\" =~ /\\x20Z/" "\\x20Z" nil nil nil nil "the Zoo" nil 1 0 " Z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(394 "\"Zulu\" =~ /\\x20Z/" "\\x20Z" nil nil nil nil "Zulu" nil 1 0 nil nil) +(395 "\"abcabc\" =~ /(abc)\\1/i" "(abc)\\1" t nil nil nil "abcabc" nil 1 0 "abcabc" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(396 "\"ABCabc\" =~ /(abc)\\1/i" "(abc)\\1" t nil nil nil "ABCabc" nil 1 0 "ABCabc" ("ABC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(397 "\"abcABC\" =~ /(abc)\\1/i" "(abc)\\1" t nil nil nil "abcABC" nil 1 0 "abcABC" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(398 "\"ab{3cd\" =~ /ab{3cd/" "ab{3cd" nil nil nil nil "ab{3cd" nil 1 0 "ab{3cd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(399 "\"ab{3,cd\" =~ /ab{3,cd/" "ab{3,cd" nil nil nil nil "ab{3,cd" nil 1 0 "ab{3,cd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(400 "\"ab{3,4a}cd\" =~ /ab{3,4a}cd/" "ab{3,4a}cd" nil nil nil nil "ab{3,4a}cd" nil 1 0 "ab{3,4a}cd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(401 "\"{4,5a}bc\" =~ /{4,5a}bc/" "{4,5a}bc" nil nil nil nil "{4,5a}bc" nil 1 0 "{4,5a}bc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(402 "\"a\\rb\" =~ /^a.b/" "^a.b" nil nil nil nil ("a" 13 "b") nil 1 0 ("a" 13 "b") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(403 "\"a\\nb\" =~ /^a.b/" "^a.b" nil nil nil nil "a +b" nil 1 0 nil nil) +(404 "\"abc\" =~ /abc$/" "abc$" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(405 "\"abc\\n\" =~ /abc$/" "abc$" nil nil nil nil "abc +" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(406 "\"abc\\ndef\" =~ /abc$/" "abc$" nil nil nil nil "abc +def" nil 1 0 nil nil) +(407 "\"abc\\x53\" =~ /(abc)\\123/" "(abc)\\123" nil nil nil nil "abcS" nil 1 0 "abcS" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(408 "\"abc\\x93\" =~ /(abc)\\223/" "(abc)\\223" nil nil nil nil ("abc" 147) nil 1 0 ("abc" 147) ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(409 "\"abc\\xd3\" =~ /(abc)\\323/" "(abc)\\323" nil nil nil nil ("abc" 211) nil 1 0 ("abc" 211) ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(410 "\"abc\\x40\" =~ /(abc)\\500/" "(abc)\\500" nil nil nil nil "abc@" nil 1 0 "abc@" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(411 "\"abc\\100\" =~ /(abc)\\500/" "(abc)\\500" nil nil nil nil "abc@" nil 1 0 "abc@" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(412 "\"abc\\x400\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(413 "\"abc\\x40\\x30\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(414 "\"abc\\1000\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(415 "\"abc\\100\\x30\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(416 "\"abc\\100\\060\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(417 "\"abc\\100\\60\" =~ /(abc)\\5000/" "(abc)\\5000" nil nil nil nil "abc@0" nil 1 0 "abc@0" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(418 "\"abc\\081\" =~ /abc\\81/" "abc\\81" nil nil nil nil ("abc" 0 "81") nil 1 0 ("abc" 0 "81") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(419 "\"abc\\0\\x38\\x31\" =~ /abc\\81/" "abc\\81" nil nil nil nil ("abc" 0 "81") nil 1 0 ("abc" 0 "81") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(420 "\"abc\\091\" =~ /abc\\91/" "abc\\91" nil nil nil nil ("abc" 0 "91") nil 1 0 ("abc" 0 "91") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(421 "\"abc\\0\\x39\\x31\" =~ /abc\\91/" "abc\\91" nil nil nil nil ("abc" 0 "91") nil 1 0 ("abc" 0 "91") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(422 "\"abcdefghijkllS\" =~ /(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)(l)\\12\\123/" "(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)(l)\\12\\123" nil nil nil nil "abcdefghijkllS" nil 1 0 "abcdefghijkllS" ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" nil nil nil nil)) +(423 "\"abcdefghijk\\12S\" =~ /(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\12\\123/" "(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\\12\\123" nil nil nil nil "abcdefghijk +S" nil 1 0 "abcdefghijk +S" ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" nil nil nil nil nil)) +(424 "\"abgdef\" =~ /ab\\gdef/" "ab\\gdef" nil nil nil nil "abgdef" nil 1 0 "abgdef" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(425 "\"bc\" =~ /a{0}bc/" "a{0}bc" nil nil nil nil "bc" nil 1 0 "bc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(426 "\"xyz\" =~ /(a|(bc)){0,0}?xyz/" "(a|(bc)){0,0}?xyz" nil nil nil nil "xyz" nil 1 0 "xyz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(427 "\"abc\\010de\" =~ /abc[\\10]de/" "abc[\\10]de" nil nil nil nil ("abc" 8 "de") nil 1 0 ("abc" 8 "de") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(428 "\"abc\\1de\" =~ /abc[\\1]de/" "abc[\\1]de" nil nil nil nil ("abc" 1 "de") nil 1 0 ("abc" 1 "de") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(429 "\"abc\\1de\" =~ /(abc)[\\1]de/" "(abc)[\\1]de" nil nil nil nil ("abc" 1 "de") nil 1 0 ("abc" 1 "de") ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(430 "\"a\\nb\" =~ /a.b(?s)/" "a.b(?s)" nil nil nil nil "a +b" nil 1 0 nil nil) +(431 "\"baNOTccccd\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "baNOTccccd" nil 1 0 "baNOTcccc" ("b" "a" "NOT" "cccc" nil nil nil nil nil nil nil nil nil nil nil nil)) +(432 "\"baNOTcccd\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "baNOTcccd" nil 1 0 "baNOTccc" ("b" "a" "NOT" "ccc" nil nil nil nil nil nil nil nil nil nil nil nil)) +(433 "\"baNOTccd\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "baNOTccd" nil 1 0 "baNOTcc" ("b" "a" "NO" "Tcc" nil nil nil nil nil nil nil nil nil nil nil nil)) +(434 "\"bacccd\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "bacccd" nil 1 0 "baccc" ("b" "a" "" "ccc" nil nil nil nil nil nil nil nil nil nil nil nil)) +(435 "\"anything\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "anything" nil 1 0 nil nil) +(436 "\"b\\bc\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil ("b" 8 "c") nil 1 0 nil nil) +(437 "\"baccd\" =~ /^([^a])([^\\b])([^c]*)([^d]{3,4})/" "^([^a])([^\\b])([^c]*)([^d]{3,4})" nil nil nil nil "baccd" nil 1 0 nil nil) +(438 "\"Abc\" =~ /[^a]/" "[^a]" nil nil nil nil "Abc" nil 1 0 "A" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(439 "\"Abc\" =~ /[^a]/i" "[^a]" t nil nil nil "Abc" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(440 "\"AAAaAbc\" =~ /[^a]+/" "[^a]+" nil nil nil nil "AAAaAbc" nil 1 0 "AAA" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(441 "\"AAAaAbc\" =~ /[^a]+/i" "[^a]+" t nil nil nil "AAAaAbc" nil 1 0 "bc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(442 "\"bbb\\nccc\" =~ /[^a]+/" "[^a]+" nil nil nil nil "bbb +ccc" nil 1 0 "bbb +ccc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(443 "\"abc\" =~ /[^k]$/" "[^k]$" nil nil nil nil "abc" nil 1 0 "c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(444 "\"abk\" =~ /[^k]$/" "[^k]$" nil nil nil nil "abk" nil 1 0 nil nil) +(445 "\"abc\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(446 "\"kbc\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "kbc" nil 1 0 "bc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(447 "\"kabc\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "kabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(448 "\"abk\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "abk" nil 1 0 nil nil) +(449 "\"akb\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "akb" nil 1 0 nil nil) +(450 "\"akk\" =~ /[^k]{2,3}$/" "[^k]{2,3}$" nil nil nil nil "akk" nil 1 0 nil nil) +(451 "\"12345678\\(a)a.b.c.d\" =~ /^\\d{8,}\\@.+[^k]$/" "^\\d{8,}\\@.+[^k]$" nil nil nil nil "12345678(a)a.b.c.d" nil 1 0 "12345678(a)a.b.c.d" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(452 "\"123456789\\(a)x.y.z\" =~ /^\\d{8,}\\@.+[^k]$/" "^\\d{8,}\\@.+[^k]$" nil nil nil nil "123456789(a)x.y.z" nil 1 0 "123456789(a)x.y.z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(453 "\"12345678\\(a)x.y.uk\" =~ /^\\d{8,}\\@.+[^k]$/" "^\\d{8,}\\@.+[^k]$" nil nil nil nil "12345678(a)x.y.uk" nil 1 0 nil nil) +(454 "\"1234567\\(a)a.b.c.d\" =~ /^\\d{8,}\\@.+[^k]$/" "^\\d{8,}\\@.+[^k]$" nil nil nil nil "1234567(a)a.b.c.d" nil 1 0 nil nil) +(455 "\"aaaaaaaaa\" =~ /(a)\\1{8,}/" "(a)\\1{8,}" nil nil nil nil "aaaaaaaaa" nil 1 0 "aaaaaaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(456 "\"aaaaaaaaaa\" =~ /(a)\\1{8,}/" "(a)\\1{8,}" nil nil nil nil "aaaaaaaaaa" nil 1 0 "aaaaaaaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(457 "\"aaaaaaa\" =~ /(a)\\1{8,}/" "(a)\\1{8,}" nil nil nil nil "aaaaaaa" nil 1 0 nil nil) +(458 "\"aaaabcd\" =~ /[^a]/" "[^a]" nil nil nil nil "aaaabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(459 "\"aaAabcd\" =~ /[^a]/" "[^a]" nil nil nil nil "aaAabcd" nil 1 0 "A" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(460 "\"aaaabcd\" =~ /[^a]/i" "[^a]" t nil nil nil "aaaabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(461 "\"aaAabcd\" =~ /[^a]/i" "[^a]" t nil nil nil "aaAabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(462 "\"aaaabcd\" =~ /[^az]/" "[^az]" nil nil nil nil "aaaabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(463 "\"aaAabcd\" =~ /[^az]/" "[^az]" nil nil nil nil "aaAabcd" nil 1 0 "A" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(464 "\"aaaabcd\" =~ /[^az]/i" "[^az]" t nil nil nil "aaaabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(465 "\"aaAabcd\" =~ /[^az]/i" "[^az]" t nil nil nil "aaAabcd" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(466 "\"\\000\\001\\002\\003\\004\\005\\006\\007\\010\\011\\012\\013\\014\\015\\016\\017\\020\\021\\022\\023\\024\\025\\026\\027\\030\\031\\032\\033\\034\\035\\036\\037\\040\\041\\042\\043\\044\\045\\046\\047\\050\\051\\052\\053\\054\\055\\056\\057\\060\\061\\062\\063\\064\\065\\066\\067\\070\\071\\072\\073\\074\\075\\076\\077\\100\\101\\102\\103\\104\\105\\106\\107\\110\\111\\112\\113\\114\\115\\116\\117\\120\\121\\122\\123\\124\\125\\126\\127\\130\\131\\132\\133\\134\\135\\136\\137\\140\\141\\142\\143\\144\\145\\146\\147\\150\\151\\152\\153\\154\\155\\156\\157\\160\\161\\162\\163\\164\\165\\166\\167\\170\\171\\172\\173\\174\\175\\176\\177\\200\\201\\202\\203\\204\\205\\206\\207\\210\\211\\212\\213\\214\\215\\216\\217\\220\\221\\222\\223\\224\\225\\226\\227\\230\\231\\232\\233\\234\\235\\236\\237\\240\\241\\242\\243\\244\\245\\246\\247\\250\\251\\252\\253\\254\\255\\256\\257\\260\\261\\262\\263\\264\\265\\266\\267\\270\\271\\272\\273\\274\\275\\276\\277\\300\\301\\302\\303\\304\\305\\306\\307\\310\\311\\312\\313\\314\\315\\316\\317\\320\\321\\322\\323\\324\\325\\326\\327\\330\\331\\332\\333\\334\\335\\336\\337\\340\\341\\342\\343\\344\\345\\346\\347\\350\\351\\352\\353\\354\\355\\356\\357\\360\\361\\362\\363\\364\\365\\366\\367\\370\\371\\372\\373\\374\\375\\376\\377\" =~ /\\000\\001\\002\\003\\004\\005\\006\\007\\010\\011\\012\\013\\014\\015\\016\\017\\020\\021\\022\\023\\024\\025\\026\\027\\030\\031\\032\\033\\034\\035\\036\\037\\040\\041\\042\\043\\044\\045\\046\\047\\050\\051\\052\\053\\054\\055\\056\\057\\060\\061\\062\\063\\064\\065\\066\\067\\070\\071\\072\\073\\074\\075\\076\\077\\100\\101\\102\\103\\104\\105\\106\\107\\110\\111\\112\\113\\114\\115\\116\\117\\120\\121\\122\\123\\124\\125\\126\\127\\130\\131\\132\\133\\134\\135\\136\\137\\140\\141\\142\\143\\144\\145\\146\\147\\150\\151\\152\\153\\154\\155\\156\\157\\160\\161\\162\\163\\164\\165\\166\\167\\170\\171\\172\\173\\174\\175\\176\\177\\200\\201\\202\\203\\204\\205\\206\\207\\210\\211\\212\\213\\214\\215\\216\\217\\220\\221\\222\\223\\224\\225\\226\\227\\230\\231\\232\\233\\234\\235\\236\\237\\240\\241\\242\\243\\244\\245\\246\\247\\250\\251\\252\\253\\254\\255\\256\\257\\260\\261\\262\\263\\264\\265\\266\\267\\270\\271\\272\\273\\274\\275\\276\\277\\300\\301\\302\\303\\304\\305\\306\\307\\310\\311\\312\\313\\314\\315\\316\\317\\320\\321\\322\\323\\324\\325\\326\\327\\330\\331\\332\\333\\334\\335\\336\\337\\340\\341\\342\\343\\344\\345\\346\\347\\350\\351\\352\\353\\354\\355\\356\\357\\360\\361\\362\\363\\364\\365\\366\\367\\370\\371\\372\\373\\374\\375\\376\\377/" "\\000\\001\\002\\003\\004\\005\\006\\007\\010\\011\\012\\013\\014\\015\\016\\017\\020\\021\\022\\023\\024\\025\\026\\027\\030\\031\\032\\033\\034\\035\\036\\037\\040\\041\\042\\043\\044\\045\\046\\047\\050\\051\\052\\053\\054\\055\\056\\057\\060\\061\\062\\063\\064\\065\\066\\067\\070\\071\\072\\073\\074\\075\\076\\077\\100\\101\\102\\103\\104\\105\\106\\107\\110\\111\\112\\113\\114\\115\\116\\117\\120\\121\\122\\123\\124\\125\\126\\127\\130\\131\\132\\133\\134\\135\\136\\137\\140\\141\\142\\143\\144\\145\\146\\147\\150\\151\\152\\153\\154\\155\\156\\157\\160\\161\\162\\163\\164\\165\\166\\167\\170\\171\\172\\173\\174\\175\\176\\177\\200\\201\\202\\203\\204\\205\\206\\207\\210\\211\\212\\213\\214\\215\\216\\217\\220\\221\\222\\223\\224\\225\\226\\227\\230\\231\\232\\233\\234\\235\\236\\237\\240\\241\\242\\243\\244\\245\\246\\247\\250\\251\\252\\253\\254\\255\\256\\257\\260\\261\\262\\263\\264\\265\\266\\267\\270\\271\\272\\273\\274\\275\\276\\277\\300\\301\\302\\303\\304\\305\\306\\307\\310\\311\\312\\313\\314\\315\\316\\317\\320\\321\\322\\323\\324\\325\\326\\327\\330\\331\\332\\333\\334\\335\\336\\337\\340\\341\\342\\343\\344\\345\\346\\347\\350\\351\\352\\353\\354\\355\\356\\357\\360\\361\\362\\363\\364\\365\\366\\367\\370\\371\\372\\373\\374\\375\\376\\377" nil nil nil nil ("" 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 " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" 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) nil 1 0 ("" 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 " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" 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) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(467 "\"xxxxxxxxxxxPSTAIREISLLxxxxxxxxx\" =~ /P[^*]TAIRE[^*]{1,6}?LL/" "P[^*]TAIRE[^*]{1,6}?LL" nil nil nil nil "xxxxxxxxxxxPSTAIREISLLxxxxxxxxx" nil 1 0 "PSTAIREISLL" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(468 "\"xxxxxxxxxxxPSTAIREISLLxxxxxxxxx\" =~ /P[^*]TAIRE[^*]{1,}?LL/" "P[^*]TAIRE[^*]{1,}?LL" nil nil nil nil "xxxxxxxxxxxPSTAIREISLLxxxxxxxxx" nil 1 0 "PSTAIREISLL" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(469 "\"1.230003938\" =~ /(\\.\\d\\d[1-9]?)\\d+/" "(\\.\\d\\d[1-9]?)\\d+" nil nil nil nil "1.230003938" nil 1 0 ".230003938" (".23" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(470 "\"1.875000282\" =~ /(\\.\\d\\d[1-9]?)\\d+/" "(\\.\\d\\d[1-9]?)\\d+" nil nil nil nil "1.875000282" nil 1 0 ".875000282" (".875" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(471 "\"1.235\" =~ /(\\.\\d\\d[1-9]?)\\d+/" "(\\.\\d\\d[1-9]?)\\d+" nil nil nil nil "1.235" nil 1 0 ".235" (".23" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(472 "\"1.230003938\" =~ /(\\.\\d\\d((?=0)|\\d(?=\\d)))/" "(\\.\\d\\d((?=0)|\\d(?=\\d)))" nil nil nil nil "1.230003938" nil 1 0 ".23" (".23" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(473 "\"1.875000282\" =~ /(\\.\\d\\d((?=0)|\\d(?=\\d)))/" "(\\.\\d\\d((?=0)|\\d(?=\\d)))" nil nil nil nil "1.875000282" nil 1 0 ".875" (".875" "5" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(474 "\"1.235\" =~ /(\\.\\d\\d((?=0)|\\d(?=\\d)))/" "(\\.\\d\\d((?=0)|\\d(?=\\d)))" nil nil nil nil "1.235" nil 1 0 nil nil) +(475 "\"ab\" =~ /a(?)b/" "a(?)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(476 "\"Food is on the foo table\" =~ /\\b(foo)\\s+(\\w+)/i" "\\b(foo)\\s+(\\w+)" t nil nil nil "Food is on the foo table" nil 1 0 "foo table" ("foo" "table" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(477 "\"The food is under the bar in the barn.\" =~ /foo(.*)bar/" "foo(.*)bar" nil nil nil nil "The food is under the bar in the barn." nil 1 0 "food is under the bar in the bar" ("d is under the bar in the " nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(478 "\"The food is under the bar in the barn.\" =~ /foo(.*?)bar/" "foo(.*?)bar" nil nil nil nil "The food is under the bar in the barn." nil 1 0 "food is under the bar" ("d is under the " nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(479 "\"I have 2 numbers: 53147\" =~ /(.*)(\\d*)/" "(.*)(\\d*)" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: 53147" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(480 "\"I have 2 numbers: 53147\" =~ /(.*)(\\d+)/" "(.*)(\\d+)" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: 5314" "7" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(481 "\"I have 2 numbers: 53147\" =~ /(.*?)(\\d*)/" "(.*?)(\\d*)" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "" ("" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(482 "\"I have 2 numbers: 53147\" =~ /(.*?)(\\d+)/" "(.*?)(\\d+)" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2" ("I have " "2" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(483 "\"I have 2 numbers: 53147\" =~ /(.*)(\\d+)$/" "(.*)(\\d+)$" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: 5314" "7" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(484 "\"I have 2 numbers: 53147\" =~ /(.*?)(\\d+)$/" "(.*?)(\\d+)$" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: " "53147" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(485 "\"I have 2 numbers: 53147\" =~ /(.*)\\b(\\d+)$/" "(.*)\\b(\\d+)$" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: " "53147" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(486 "\"I have 2 numbers: 53147\" =~ /(.*\\D)(\\d+)$/" "(.*\\D)(\\d+)$" nil nil nil nil "I have 2 numbers: 53147" nil 1 0 "I have 2 numbers: 53147" ("I have 2 numbers: " "53147" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(487 "\"ABC123\" =~ /^\\D*(?!123)/" "^\\D*(?!123)" nil nil nil nil "ABC123" nil 1 0 "AB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(488 "\"ABC445\" =~ /^(\\D*)(?=\\d)(?!123)/" "^(\\D*)(?=\\d)(?!123)" nil nil nil nil "ABC445" nil 1 0 "ABC" ("ABC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(489 "\"ABC123\" =~ /^(\\D*)(?=\\d)(?!123)/" "^(\\D*)(?=\\d)(?!123)" nil nil nil nil "ABC123" nil 1 0 nil nil) +(490 "\"W46]789\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "W46]789" nil 1 0 "W46]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(491 "\"-46]789\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "-46]789" nil 1 0 "-46]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(492 "\"Wall\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "Wall" nil 1 0 nil nil) +(493 "\"Zebra\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "Zebra" nil 1 0 nil nil) +(494 "\"42\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "42" nil 1 0 nil nil) +(495 "\"[abcd]\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "[abcd]" nil 1 0 nil nil) +(496 "\"]abcd[\" =~ /^[W-]46]/" "^[W-]46]" nil nil nil nil "]abcd[" nil 1 0 nil nil) +(497 "\"W46]789\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "W46]789" nil 1 0 "W" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(498 "\"Wall\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "Wall" nil 1 0 "W" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(499 "\"Zebra\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "Zebra" nil 1 0 "Z" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(500 "\"Xylophone\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "Xylophone" nil 1 0 "X" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(501 "\"42\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "42" nil 1 0 "4" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(502 "\"[abcd]\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "[abcd]" nil 1 0 "[" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(503 "\"]abcd[\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "]abcd[" nil 1 0 "]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(504 "\"\\\\backslash\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "\\backslash" nil 1 0 "\\" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(505 "\"-46]789\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "-46]789" nil 1 0 nil nil) +(506 "\"well\" =~ /^[W-\\]46]/" "^[W-\\]46]" nil nil nil nil "well" nil 1 0 nil nil) +(507 "\"01/01/2000\" =~ /\\d\\d\\/\\d\\d\\/\\d\\d\\d\\d/" "\\d\\d\\/\\d\\d\\/\\d\\d\\d\\d" nil nil nil nil "01/01/2000" nil 1 0 "01/01/2000" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(508 "\"word cat dog elephant mussel cow horse canary baboon snake shark otherword\" =~ /word (?:[a-zA-Z0-9]+ ){0,10}otherword/" "word (?:[a-zA-Z0-9]+ ){0,10}otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark otherword" nil 1 0 "word cat dog elephant mussel cow horse canary baboon snake shark otherword" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(509 "\"word cat dog elephant mussel cow horse canary baboon snake shark\" =~ /word (?:[a-zA-Z0-9]+ ){0,10}otherword/" "word (?:[a-zA-Z0-9]+ ){0,10}otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark" nil 1 0 nil nil) +(510 "\"word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope\" =~ /word (?:[a-zA-Z0-9]+ ){0,300}otherword/" "word (?:[a-zA-Z0-9]+ ){0,300}otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope" nil 1 0 nil nil) +(511 "\"bcd\" =~ /^(a){0,0}/" "^(a){0,0}" nil nil nil nil "bcd" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(512 "\"abc\" =~ /^(a){0,0}/" "^(a){0,0}" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(513 "\"aab\" =~ /^(a){0,0}/" "^(a){0,0}" nil nil nil nil "aab" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(514 "\"bcd\" =~ /^(a){0,1}/" "^(a){0,1}" nil nil nil nil "bcd" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(515 "\"abc\" =~ /^(a){0,1}/" "^(a){0,1}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(516 "\"aab\" =~ /^(a){0,1}/" "^(a){0,1}" nil nil nil nil "aab" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(517 "\"bcd\" =~ /^(a){0,2}/" "^(a){0,2}" nil nil nil nil "bcd" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(518 "\"abc\" =~ /^(a){0,2}/" "^(a){0,2}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(519 "\"aab\" =~ /^(a){0,2}/" "^(a){0,2}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(520 "\"bcd\" =~ /^(a){0,3}/" "^(a){0,3}" nil nil nil nil "bcd" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(521 "\"abc\" =~ /^(a){0,3}/" "^(a){0,3}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(522 "\"aab\" =~ /^(a){0,3}/" "^(a){0,3}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(523 "\"aaa\" =~ /^(a){0,3}/" "^(a){0,3}" nil nil nil nil "aaa" nil 1 0 "aaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(524 "\"bcd\" =~ /^(a){0,}/" "^(a){0,}" nil nil nil nil "bcd" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(525 "\"abc\" =~ /^(a){0,}/" "^(a){0,}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(526 "\"aab\" =~ /^(a){0,}/" "^(a){0,}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(527 "\"aaa\" =~ /^(a){0,}/" "^(a){0,}" nil nil nil nil "aaa" nil 1 0 "aaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(528 "\"aaaaaaaa\" =~ /^(a){0,}/" "^(a){0,}" nil nil nil nil "aaaaaaaa" nil 1 0 "aaaaaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(529 "\"bcd\" =~ /^(a){1,1}/" "^(a){1,1}" nil nil nil nil "bcd" nil 1 0 nil nil) +(530 "\"abc\" =~ /^(a){1,1}/" "^(a){1,1}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(531 "\"aab\" =~ /^(a){1,1}/" "^(a){1,1}" nil nil nil nil "aab" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(532 "\"bcd\" =~ /^(a){1,2}/" "^(a){1,2}" nil nil nil nil "bcd" nil 1 0 nil nil) +(533 "\"abc\" =~ /^(a){1,2}/" "^(a){1,2}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(534 "\"aab\" =~ /^(a){1,2}/" "^(a){1,2}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(535 "\"bcd\" =~ /^(a){1,3}/" "^(a){1,3}" nil nil nil nil "bcd" nil 1 0 nil nil) +(536 "\"abc\" =~ /^(a){1,3}/" "^(a){1,3}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(537 "\"aab\" =~ /^(a){1,3}/" "^(a){1,3}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(538 "\"aaa\" =~ /^(a){1,3}/" "^(a){1,3}" nil nil nil nil "aaa" nil 1 0 "aaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(539 "\"bcd\" =~ /^(a){1,}/" "^(a){1,}" nil nil nil nil "bcd" nil 1 0 nil nil) +(540 "\"abc\" =~ /^(a){1,}/" "^(a){1,}" nil nil nil nil "abc" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(541 "\"aab\" =~ /^(a){1,}/" "^(a){1,}" nil nil nil nil "aab" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(542 "\"aaa\" =~ /^(a){1,}/" "^(a){1,}" nil nil nil nil "aaa" nil 1 0 "aaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(543 "\"aaaaaaaa\" =~ /^(a){1,}/" "^(a){1,}" nil nil nil nil "aaaaaaaa" nil 1 0 "aaaaaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(544 "\"borfle\\nbib.gif\\nno\" =~ /.*\\.gif/" ".*\\.gif" nil nil nil nil "borfle +bib.gif +no" nil 1 0 "bib.gif" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(545 "\"borfle\\nbib.gif\\nno\" =~ /.{0,}\\.gif/" ".{0,}\\.gif" nil nil nil nil "borfle +bib.gif +no" nil 1 0 "bib.gif" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(546 "\"borfle\\nbib.gif\\nno\" =~ /.*\\.gif/m" ".*\\.gif" nil t nil nil "borfle +bib.gif +no" nil 1 0 "bib.gif" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(547 "\"borfle\\nbib.gif\\nno\" =~ /.*\\.gif/s" ".*\\.gif" nil nil t nil "borfle +bib.gif +no" nil 1 0 "borfle +bib.gif" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(548 "\"borfle\\nbib.gif\\nno\" =~ /.*\\.gif/ms" ".*\\.gif" nil t t nil "borfle +bib.gif +no" nil 1 0 "borfle +bib.gif" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(549 "\"borfle\\nbib.gif\\nno\" =~ /.*$/" ".*$" nil nil nil nil "borfle +bib.gif +no" nil 1 0 "no" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(550 "\"borfle\\nbib.gif\\nno\" =~ /.*$/m" ".*$" nil t nil nil "borfle +bib.gif +no" nil 1 0 "borfle" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(551 "\"borfle\\nbib.gif\\nno\" =~ /.*$/s" ".*$" nil nil t nil "borfle +bib.gif +no" nil 1 0 "borfle +bib.gif +no" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(552 "\"borfle\\nbib.gif\\nno\" =~ /.*$/ms" ".*$" nil t t nil "borfle +bib.gif +no" nil 1 0 "borfle +bib.gif +no" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(553 "\"borfle\\nbib.gif\\nno\\n\" =~ /.*$/" ".*$" nil nil nil nil "borfle +bib.gif +no +" nil 1 0 "no" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(554 "\"borfle\\nbib.gif\\nno\\n\" =~ /.*$/m" ".*$" nil t nil nil "borfle +bib.gif +no +" nil 1 0 "borfle" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(555 "\"borfle\\nbib.gif\\nno\\n\" =~ /.*$/s" ".*$" nil nil t nil "borfle +bib.gif +no +" nil 1 0 "borfle +bib.gif +no +" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(556 "\"borfle\\nbib.gif\\nno\\n\" =~ /.*$/ms" ".*$" nil t t nil "borfle +bib.gif +no +" nil 1 0 "borfle +bib.gif +no +" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(557 "\"abcde\\n1234Xyz\" =~ /(.*X|^B)/" "(.*X|^B)" nil nil nil nil "abcde +1234Xyz" nil 1 0 "1234X" ("1234X" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(558 "\"BarFoo\" =~ /(.*X|^B)/" "(.*X|^B)" nil nil nil nil "BarFoo" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(559 "\"abcde\\nBar\" =~ /(.*X|^B)/" "(.*X|^B)" nil nil nil nil "abcde +Bar" nil 1 0 nil nil) +(560 "\"abcde\\n1234Xyz\" =~ /(.*X|^B)/m" "(.*X|^B)" nil t nil nil "abcde +1234Xyz" nil 1 0 "1234X" ("1234X" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(561 "\"BarFoo\" =~ /(.*X|^B)/m" "(.*X|^B)" nil t nil nil "BarFoo" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(562 "\"abcde\\nBar\" =~ /(.*X|^B)/m" "(.*X|^B)" nil t nil nil "abcde +Bar" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(563 "\"abcde\\n1234Xyz\" =~ /(.*X|^B)/s" "(.*X|^B)" nil nil t nil "abcde +1234Xyz" nil 1 0 "abcde +1234X" ("abcde +1234X" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(564 "\"BarFoo\" =~ /(.*X|^B)/s" "(.*X|^B)" nil nil t nil "BarFoo" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(565 "\"abcde\\nBar\" =~ /(.*X|^B)/s" "(.*X|^B)" nil nil t nil "abcde +Bar" nil 1 0 nil nil) +(566 "\"abcde\\n1234Xyz\" =~ /(.*X|^B)/ms" "(.*X|^B)" nil t t nil "abcde +1234Xyz" nil 1 0 "abcde +1234X" ("abcde +1234X" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(567 "\"BarFoo\" =~ /(.*X|^B)/ms" "(.*X|^B)" nil t t nil "BarFoo" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(568 "\"abcde\\nBar\" =~ /(.*X|^B)/ms" "(.*X|^B)" nil t t nil "abcde +Bar" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(569 "\"abcde\\n1234Xyz\" =~ /(?s)(.*X|^B)/" "(?s)(.*X|^B)" nil nil nil nil "abcde +1234Xyz" nil 1 0 "abcde +1234X" ("abcde +1234X" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(570 "\"BarFoo\" =~ /(?s)(.*X|^B)/" "(?s)(.*X|^B)" nil nil nil nil "BarFoo" nil 1 0 "B" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(571 "\"abcde\\nBar\" =~ /(?s)(.*X|^B)/" "(?s)(.*X|^B)" nil nil nil nil "abcde +Bar" nil 1 0 nil nil) +(572 "\"abcde\\n1234Xyz\" =~ /(?s:.*X|^B)/" "(?s:.*X|^B)" nil nil nil nil "abcde +1234Xyz" nil 1 0 "abcde +1234X" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(573 "\"BarFoo\" =~ /(?s:.*X|^B)/" "(?s:.*X|^B)" nil nil nil nil "BarFoo" nil 1 0 "B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(574 "\"abcde\\nBar\" =~ /(?s:.*X|^B)/" "(?s:.*X|^B)" nil nil nil nil "abcde +Bar" nil 1 0 nil nil) +(575 "\"abc\\nB\" =~ /^.*B/" "^.*B" nil nil nil nil "abc +B" nil 1 0 nil nil) +(576 "\"abc\\nB\" =~ /(?s)^.*B/" "(?s)^.*B" nil nil nil nil "abc +B" nil 1 0 "abc +B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(577 "\"abc\\nB\" =~ /(?m)^.*B/" "(?m)^.*B" nil nil nil nil "abc +B" nil 1 0 "B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(578 "\"abc\\nB\" =~ /(?ms)^.*B/" "(?ms)^.*B" nil nil nil nil "abc +B" nil 1 0 "abc +B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(579 "\"abc\\nB\" =~ /(?ms)^B/" "(?ms)^B" nil nil nil nil "abc +B" nil 1 0 "B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(580 "\"B\\n\" =~ /(?s)B$/" "(?s)B$" nil nil nil nil "B +" nil 1 0 "B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(581 "\"123456654321\" =~ /^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/" "^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" nil nil nil nil "123456654321" nil 1 0 "123456654321" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(582 "\"123456654321\" =~ /^\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d/" "^\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d\\d" nil nil nil nil "123456654321" nil 1 0 "123456654321" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(583 "\"123456654321\" =~ /^[\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d]/" "^[\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d][\\d]" nil nil nil nil "123456654321" nil 1 0 "123456654321" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(584 "\"abcabcabcabc\" =~ /^[abc]{12}/" "^[abc]{12}" nil nil nil nil "abcabcabcabc" nil 1 0 "abcabcabcabc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(585 "\"abcabcabcabc\" =~ /^[a-c]{12}/" "^[a-c]{12}" nil nil nil nil "abcabcabcabc" nil 1 0 "abcabcabcabc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(586 "\"abcabcabcabc\" =~ /^(a|b|c){12}/" "^(a|b|c){12}" nil nil nil nil "abcabcabcabc" nil 1 0 "abcabcabcabc" ("c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(587 "\"n\" =~ /^[abcdefghijklmnopqrstuvwxy0123456789]/" "^[abcdefghijklmnopqrstuvwxy0123456789]" nil nil nil nil "n" nil 1 0 "n" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(588 "\"z\" =~ /^[abcdefghijklmnopqrstuvwxy0123456789]/" "^[abcdefghijklmnopqrstuvwxy0123456789]" nil nil nil nil "z" nil 1 0 nil nil) +(589 "\"abcd\" =~ /abcde{0,0}/" "abcde{0,0}" nil nil nil nil "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(590 "\"abce\" =~ /abcde{0,0}/" "abcde{0,0}" nil nil nil nil "abce" nil 1 0 nil nil) +(591 "\"abe\" =~ /ab[cd]{0,0}e/" "ab[cd]{0,0}e" nil nil nil nil "abe" nil 1 0 "abe" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(592 "\"abcde\" =~ /ab[cd]{0,0}e/" "ab[cd]{0,0}e" nil nil nil nil "abcde" nil 1 0 nil nil) +(593 "\"abd\" =~ /ab(c){0,0}d/" "ab(c){0,0}d" nil nil nil nil "abd" nil 1 0 "abd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(594 "\"abcd\" =~ /ab(c){0,0}d/" "ab(c){0,0}d" nil nil nil nil "abcd" nil 1 0 nil nil) +(595 "\"a\" =~ /a(b*)/" "a(b*)" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(596 "\"ab\" =~ /a(b*)/" "a(b*)" nil nil nil nil "ab" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(597 "\"abbbb\" =~ /a(b*)/" "a(b*)" nil nil nil nil "abbbb" nil 1 0 "abbbb" ("bbbb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(598 "\"bbbbb\" =~ /a(b*)/" "a(b*)" nil nil nil nil "bbbbb" nil 1 0 nil nil) +(599 "\"abe\" =~ /ab\\d{0}e/" "ab\\d{0}e" nil nil nil nil "abe" nil 1 0 "abe" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(600 "\"ab1e\" =~ /ab\\d{0}e/" "ab\\d{0}e" nil nil nil nil "ab1e" nil 1 0 nil nil) +(601 "\"the \\\"quick\\\" brown fox\" =~ /\"([^\\\\\"]+|\\\\.)*\"/" "\"([^\\\\\"]+|\\\\.)*\"" nil nil nil nil "the \"quick\" brown fox" nil 1 0 "\"quick\"" ("quick" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(602 "\"\\\"the \\\\\\\"quick\\\\\\\" brown fox\\\"\" =~ /\"([^\\\\\"]+|\\\\.)*\"/" "\"([^\\\\\"]+|\\\\.)*\"" nil nil nil nil "\"the \\\"quick\\\" brown fox\"" nil 1 0 "\"the \\\"quick\\\" brown fox\"" (" brown fox" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(603 "\"abc\" =~ /.*?/" ".*?" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(604 "\"abc\" =~ /\\b/" "\\b" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(605 "\"abc\" =~ /\\b/" "\\b" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(606 "\"abc\" =~ /(?#)/" "" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(607 "\"<TR BGCOLOR='#DBE9E9'><TD align=left valign=top>43.<a href='joblist.cfm?JobID=94 6735&Keyword='>Word Processor (N-1286)</a></TD><TD align=left valign=top>Lega lstaff.com</TD><TD align=left valign=top>CA - Statewide</TD></TR>\" =~ /<tr([\\w\\W\\s\\d][^<>]{0,})><TD([\\w\\W\\s\\d][^<>]{0,})>([\\d]{0,}\\.)(.*)(( ([\\w\\W\\s\\d][^<>]{0,})|[\\s]{0,}))<\\/a><\\/TD><TD([\\w\\W\\s\\d][^<>]{0,})>([\\w\\W\\s\\d][^<>]{0,})<\\/TD><TD([\\w\\W\\s\\d][^<>]{0,})>([\\w\\W\\s\\d][^<>]{0,})<\\/TD><\\/TR>/is" "<tr([\\w\\W\\s\\d][^<>]{0,})><TD([\\w\\W\\s\\d][^<>]{0,})>([\\d]{0,}\\.)(.*)(( ([\\w\\W\\s\\d][^<>]{0,})|[\\s]{0,}))<\\/a><\\/TD><TD([\\w\\W\\s\\d][^<>]{0,})>([\\w\\W\\s\\d][^<>]{0,})<\\/TD><TD([\\w\\W\\s\\d][^<>]{0,})>([\\w\\W\\s\\d][^<>]{0,})<\\/TD><\\/TR>" t nil t nil "<TR BGCOLOR='#DBE9E9'><TD align=left valign=top>43.<a href='joblist.cfm?JobID=94 6735&Keyword='>Word Processor (N-1286)</a></TD><TD align=left valign=top>Lega lstaff.com</TD><TD align=left valign=top>CA - Statewide</TD></TR>" nil 1 0 "<TR BGCOLOR='#DBE9E9'><TD align=left valign=top>43.<a href='joblist.cfm?JobID=94 6735&Keyword='>Word Processor (N-1286)</a></TD><TD align=left valign=top>Lega lstaff.com</TD><TD align=left valign=top>CA - Statewide</TD></TR>" (" BGCOLOR='#DBE9E9'" " align=left valign=top" "43." "<a href='joblist.cfm?JobID=94 6735&Keyword='>Word Processor (N-1286)" "" "" nil " align=left valign=top" "Lega lstaff.com" " align=left valign=top" "CA - Statewide" nil nil nil nil nil)) +(608 "\"acb\" =~ /a[^a]b/" "a[^a]b" nil nil nil nil "acb" nil 1 0 "acb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(609 "\"a\\nb\" =~ /a[^a]b/" "a[^a]b" nil nil nil nil "a +b" nil 1 0 "a +b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(610 "\"acb\" =~ /a.b/" "a.b" nil nil nil nil "acb" nil 1 0 "acb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(611 "\"a\\nb\" =~ /a.b/" "a.b" nil nil nil nil "a +b" nil 1 0 nil nil) +(612 "\"acb\" =~ /a[^a]b/s" "a[^a]b" nil nil t nil "acb" nil 1 0 "acb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(613 "\"a\\nb\" =~ /a[^a]b/s" "a[^a]b" nil nil t nil "a +b" nil 1 0 "a +b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(614 "\"acb\" =~ /a.b/s" "a.b" nil nil t nil "acb" nil 1 0 "acb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(615 "\"a\\nb\" =~ /a.b/s" "a.b" nil nil t nil "a +b" nil 1 0 "a +b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(616 "\"bac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bac" nil 1 0 "bac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(617 "\"bbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbac" nil 1 0 "bbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(618 "\"bbbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbbac" nil 1 0 "bbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(619 "\"bbbbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbbbac" nil 1 0 "bbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(620 "\"bbbbbac\" =~ /^(b+?|a){1,2}?c/" "^(b+?|a){1,2}?c" nil nil nil nil "bbbbbac" nil 1 0 "bbbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(621 "\"bac\" =~ /^(b+|a){1,2}?c/" "^(b+|a){1,2}?c" nil nil nil nil "bac" nil 1 0 "bac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(622 "\"bbac\" =~ /^(b+|a){1,2}?c/" "^(b+|a){1,2}?c" nil nil nil nil "bbac" nil 1 0 "bbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(623 "\"bbbac\" =~ /^(b+|a){1,2}?c/" "^(b+|a){1,2}?c" nil nil nil nil "bbbac" nil 1 0 "bbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(624 "\"bbbbac\" =~ /^(b+|a){1,2}?c/" "^(b+|a){1,2}?c" nil nil nil nil "bbbbac" nil 1 0 "bbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(625 "\"bbbbbac\" =~ /^(b+|a){1,2}?c/" "^(b+|a){1,2}?c" nil nil nil nil "bbbbbac" nil 1 0 "bbbbbac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(626 "\"x\\nb\\n\" =~ /(?!\\A)x/m" "(?!\\A)x" nil t nil nil "x +b +" nil 1 0 nil nil) +(627 "\"a\\bx\\n\" =~ /(?!\\A)x/m" "(?!\\A)x" nil t nil nil ("a" 8 "x" 10) nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(628 "\"\\0{ab}\" =~ /\\x0{ab}/" "\\x0{ab}" nil nil nil nil ("" 0 "{ab}") nil 1 0 ("" 0 "{ab}") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(629 "\"CD\" =~ /(A|B)*?CD/" "(A|B)*?CD" nil nil nil nil "CD" nil 1 0 "CD" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(630 "\"CD\" =~ /(A|B)*CD/" "(A|B)*CD" nil nil nil nil "CD" nil 1 0 "CD" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(631 "\"ABABAB\" =~ /(AB)*?\\1/" "(AB)*?\\1" nil nil nil nil "ABABAB" nil 1 0 "ABAB" ("AB" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(632 "\"ABABAB\" =~ /(AB)*\\1/" "(AB)*\\1" nil nil nil nil "ABABAB" nil 1 0 "ABABAB" ("AB" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(633 "\"doesn't matter\" =~ /(/" "(" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(634 "\"doesn't matter\" =~ /(x)\\2/" "(x)\\2" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(635 "\"aaaaaaaaaac\" =~ /((a{0,5}){0,5}){0,5}[c]/" "((a{0,5}){0,5}){0,5}[c]" nil nil nil nil "aaaaaaaaaac" nil 1 0 "aaaaaaaaaac" ("" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(636 "\"aaaaaaaaaa\" =~ /((a{0,5}){0,5}){0,5}[c]/" "((a{0,5}){0,5}){0,5}[c]" nil nil nil nil "aaaaaaaaaa" nil 1 0 nil nil) +(637 "\"aaaaaaaaaac\" =~ /((a{0,5}){0,5})*[c]/" "((a{0,5}){0,5})*[c]" nil nil nil nil "aaaaaaaaaac" nil 1 0 "aaaaaaaaaac" ("" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(638 "\"aaaaaaaaaa\" =~ /((a{0,5}){0,5})*[c]/" "((a{0,5}){0,5})*[c]" nil nil nil nil "aaaaaaaaaa" nil 1 0 nil nil) +(639 "\"a\" =~ /(\\b)*a/" "(\\b)*a" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(640 "\"ab\" =~ /(a)*b/" "(a)*b" nil nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(641 "\"ab\" =~ /(a|)*b/" "(a|)*b" nil nil nil nil "ab" nil 1 0 "ab" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(642 "\"b\" =~ /(a|)*b/" "(a|)*b" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(643 "\"x\" =~ /(a|)*b/" "(a|)*b" nil nil nil nil "x" nil 1 0 nil nil) +(644 "\"abab\" =~ /^(?:(a)|(b))*\\1\\2$/" "^(?:(a)|(b))*\\1\\2$" nil nil nil nil "abab" nil 1 0 "abab" ("a" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(645 "\"abcxabcydef\" =~ /abc[^x]def/" "abc[^x]def" nil nil nil nil "abcxabcydef" nil 1 0 "abcydef" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(646 "\"aax\" =~ /^(a|\\1x)*$/" "^(a|\\1x)*$" nil nil nil nil "aax" nil 1 0 "aax" ("ax" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(647 "\"aaxa\" =~ /^(a|\\1x)*$/" "^(a|\\1x)*$" nil nil nil nil "aaxa" nil 1 0 "aaxa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(648 "\"@{['']}\" =~ /(?#)/" "" nil nil nil nil "" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(649 "\"ab\" =~ /^(?:(a)|(b))*$/" "^(?:(a)|(b))*$" nil nil nil nil "ab" nil 1 0 "ab" ("a" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(650 "\"a\" =~ /[\\0]/" "[\\0]" nil nil nil nil "a" nil 1 0 nil nil) +(651 "\"\\0\" =~ /[\\0]/" "[\\0]" nil nil nil nil ("" 0) nil 1 0 ("" 0) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(652 "\"a\" =~ /[\\1]/" "[\\1]" nil nil nil nil "a" nil 1 0 nil nil) +(653 "\"\\1\" =~ /[\\1]/" "[\\1]" nil nil nil nil ("" 1) nil 1 0 ("" 1) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(654 "\"doesn't matter\" =~ /\\10()()()()()()()()()/" "\\10()()()()()()()()()" nil nil nil nil "doesn't matter" nil 1 0 nil nil) +(655 "\"a\" =~ /\\10()()()()()()()()()()/" "\\10()()()()()()()()()()" nil nil nil nil "a" nil 1 0 nil nil) +(656 "\"ab\" =~ /a(?<)b/" "a(?<)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(657 "\"doesn't matter\" =~ /[]/" "[]" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(658 "\"doesn't matter\" =~ /[\\]/" "[\\]" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(659 "\"a\" =~ /()/" "()" nil nil nil nil "a" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(660 "\"x\" =~ /[\\x]/" "[\\x]" nil nil nil nil "x" nil 1 0 nil nil) +(661 "\"\\0\" =~ /[\\x]/" "[\\x]" nil nil nil nil ("" 0) nil 1 0 ("" 0) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(662 "\"a\" =~ /((a)*)*/" "((a)*)*" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(663 "\"a\" =~ /()a\\1/" "()a\\1" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(664 "\"a\" =~ /a\\1()/" "a\\1()" nil nil nil nil "a" nil 1 0 nil nil) +(665 "\"aaa\" =~ /a(?i)a(?-i)a/" "a(?i)a(?-i)a" nil nil nil nil "aaa" nil 1 0 "aaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(666 "\"aAa\" =~ /a(?i)a(?-i)a/" "a(?i)a(?-i)a" nil nil nil nil "aAa" nil 1 0 "aAa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(667 "\"aAA\" =~ /a(?i)a(?-i)a/" "a(?i)a(?-i)a" nil nil nil nil "aAA" nil 1 0 nil nil) +(668 "\"aaaaa\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(669 "\"aAaAa\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "aAaAa" nil 1 0 "aAaAa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(670 "\"AaAaA\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "AaAaA" nil 1 0 nil nil) +(671 "\"aAAAa\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "aAAAa" nil 1 0 nil nil) +(672 "\"AaaaA\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "AaaaA" nil 1 0 nil nil) +(673 "\"AAAAA\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "AAAAA" nil 1 0 nil nil) +(674 "\"aaAAA\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "aaAAA" nil 1 0 nil nil) +(675 "\"AAaaa\" =~ /a(?i)a(?-i)a(?i)a(?-i)a/" "a(?i)a(?-i)a(?i)a(?-i)a" nil nil nil nil "AAaaa" nil 1 0 nil nil) +(676 "\"a\" =~ /\\x/" "\\x" nil nil nil nil "a" nil 1 0 nil nil) +(677 "\"X\" =~ /\\x/" "\\x" nil nil nil nil "X" nil 1 0 nil nil) +(678 "\"\\0\" =~ /\\x/" "\\x" nil nil nil nil ("" 0) nil 1 0 ("" 0) (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(679 "\"a\" =~ /[a-c-e]/" "[a-c-e]" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(680 "\"b\" =~ /[a-c-e]/" "[a-c-e]" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(681 "\"d\" =~ /[a-c-e]/" "[a-c-e]" nil nil nil nil "d" nil 1 0 nil nil) +(682 "\"-\" =~ /[a-c-e]/" "[a-c-e]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(683 "\"b\" =~ /[b-\\d]/" "[b-\\d]" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(684 "\"c\" =~ /[b-\\d]/" "[b-\\d]" nil nil nil nil "c" nil 1 0 nil nil) +(685 "\"d\" =~ /[b-\\d]/" "[b-\\d]" nil nil nil nil "d" nil 1 0 nil nil) +(686 "\"-\" =~ /[b-\\d]/" "[b-\\d]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(687 "\"1\" =~ /[b-\\d]/" "[b-\\d]" nil nil nil nil "1" nil 1 0 "1" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(688 "\"d\" =~ /[\\d-f]/" "[\\d-f]" nil nil nil nil "d" nil 1 0 nil nil) +(689 "\"e\" =~ /[\\d-f]/" "[\\d-f]" nil nil nil nil "e" nil 1 0 nil nil) +(690 "\"f\" =~ /[\\d-f]/" "[\\d-f]" nil nil nil nil "f" nil 1 0 "f" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(691 "\"-\" =~ /[\\d-f]/" "[\\d-f]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(692 "\"1\" =~ /[\\d-f]/" "[\\d-f]" nil nil nil nil "1" nil 1 0 "1" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(693 "\"doesn't matter\" =~ /[/" "[" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(694 "\"]\" =~ /]/" "]" nil nil nil nil "]" nil 1 0 "]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(695 "\"a\" =~ /]/" "]" nil nil nil nil "a" nil 1 0 nil nil) +(696 "\"doesn't matter\" =~ /[]/" "[]" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(697 "\"-\" =~ /[-a-c]/" "[-a-c]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(698 "\"a\" =~ /[-a-c]/" "[-a-c]" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(699 "\"b\" =~ /[-a-c]/" "[-a-c]" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(700 "\"d\" =~ /[-a-c]/" "[-a-c]" nil nil nil nil "d" nil 1 0 nil nil) +(701 "\"-\" =~ /[a-c-]/" "[a-c-]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(702 "\"a\" =~ /[a-c-]/" "[a-c-]" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(703 "\"b\" =~ /[a-c-]/" "[a-c-]" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(704 "\"d\" =~ /[a-c-]/" "[a-c-]" nil nil nil nil "d" nil 1 0 nil nil) +(705 "\"a\" =~ /[-]/" "[-]" nil nil nil nil "a" nil 1 0 nil nil) +(706 "\"-\" =~ /[-]/" "[-]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(707 "\"a\" =~ /[--]/" "[--]" nil nil nil nil "a" nil 1 0 nil nil) +(708 "\"-\" =~ /[--]/" "[--]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(709 "\"a\" =~ /[---]/" "[---]" nil nil nil nil "a" nil 1 0 nil nil) +(710 "\"-\" =~ /[---]/" "[---]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(711 "\"-\" =~ /[--b]/" "[--b]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(712 "\"a\" =~ /[--b]/" "[--b]" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(713 "\"c\" =~ /[--b]/" "[--b]" nil nil nil nil "c" nil 1 0 nil nil) +(714 "\"doesn't matter\" =~ /[b--]/" "[b--]" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(715 "\"a{\" =~ /a{/" "a{" nil nil nil nil "a{" nil 1 0 "a{" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(716 "\"a{}\" =~ /a{}/" "a{}" nil nil nil nil "a{}" nil 1 0 "a{}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(717 "\"a{3\" =~ /a{3/" "a{3" nil nil nil nil "a{3" nil 1 0 "a{3" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(718 "\"a{3,\" =~ /a{3,/" "a{3," nil nil nil nil "a{3," nil 1 0 "a{3," (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(719 "\"a{3,3}\" =~ /a{3, 3}/" "a{3, 3}" nil nil nil nil "a{3,3}" nil 1 0 nil nil) +(720 "\"a{3, 3}\" =~ /a{3, 3}/" "a{3, 3}" nil nil nil nil "a{3, 3}" nil 1 0 "a{3, 3}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(721 "\"aaa\" =~ /a{3, 3}/" "a{3, 3}" nil nil nil nil "aaa" nil 1 0 nil nil) +(722 "\"a{3,3}\" =~ /a{3, 3}/x" "a{3, 3}" nil nil nil t "a{3,3}" nil 1 0 "a{3,3}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(723 "\"a{3, 3}\" =~ /a{3, 3}/x" "a{3, 3}" nil nil nil t "a{3, 3}" nil 1 0 nil nil) +(724 "\"aaa\" =~ /a{3, 3}/x" "a{3, 3}" nil nil nil t "aaa" nil 1 0 nil nil) +(725 "\"a{3,}\" =~ /a{3, }/" "a{3, }" nil nil nil nil "a{3,}" nil 1 0 nil nil) +(726 "\"a{3, }\" =~ /a{3, }/" "a{3, }" nil nil nil nil "a{3, }" nil 1 0 "a{3, }" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(727 "\"aaa\" =~ /a{3, }/" "a{3, }" nil nil nil nil "aaa" nil 1 0 nil nil) +(728 "\"a{3,}\" =~ /a{3, }/x" "a{3, }" nil nil nil t "a{3,}" nil 1 0 "a{3,}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(729 "\"a{3, }\" =~ /a{3, }/x" "a{3, }" nil nil nil t "a{3, }" nil 1 0 nil nil) +(730 "\"aaa\" =~ /a{3, }/x" "a{3, }" nil nil nil t "aaa" nil 1 0 nil nil) +(731 "\"\\0 x\" =~ /\\x x/" "\\x x" nil nil nil nil ("" 0 " x") nil 1 0 ("" 0 " x") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(732 "\"\\0x\" =~ /\\x x/" "\\x x" nil nil nil nil ("" 0 "x") nil 1 0 nil nil) +(733 "\"\\0 x\" =~ /\\x x/x" "\\x x" nil nil nil t ("" 0 " x") nil 1 0 nil nil) +(734 "\"\\0x\" =~ /\\x x/x" "\\x x" nil nil nil t ("" 0 "x") nil 1 0 ("" 0 "x") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(735 "\"\\0003\" =~ /\\x 3/" "\\x 3" nil nil nil nil ("" 0 "3") nil 1 0 nil nil) +(736 "\"\\000 3\" =~ /\\x 3/" "\\x 3" nil nil nil nil ("" 0 " 3") nil 1 0 ("" 0 " 3") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(737 "\"x3\" =~ /\\x 3/" "\\x 3" nil nil nil nil "x3" nil 1 0 nil nil) +(738 "\"x 3\" =~ /\\x 3/" "\\x 3" nil nil nil nil "x 3" nil 1 0 nil nil) +(739 "\"\\0003\" =~ /\\x 3/x" "\\x 3" nil nil nil t ("" 0 "3") nil 1 0 ("" 0 "3") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(740 "\"\\000 3\" =~ /\\x 3/x" "\\x 3" nil nil nil t ("" 0 " 3") nil 1 0 nil nil) +(741 "\"x3\" =~ /\\x 3/x" "\\x 3" nil nil nil t "x3" nil 1 0 nil nil) +(742 "\"x 3\" =~ /\\x 3/x" "\\x 3" nil nil nil t "x 3" nil 1 0 nil nil) +(743 "\"a\" =~ /^a{ 1}$/" "^a{ 1}$" nil nil nil nil "a" nil 1 0 nil nil) +(744 "\"a{ 1}\" =~ /^a{ 1}$/" "^a{ 1}$" nil nil nil nil "a{ 1}" nil 1 0 "a{ 1}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(745 "\"a{1}\" =~ /^a{ 1}$/" "^a{ 1}$" nil nil nil nil "a{1}" nil 1 0 nil nil) +(746 "\"a\" =~ /^a{ 1}$/x" "^a{ 1}$" nil nil nil t "a" nil 1 0 nil nil) +(747 "\"a{ 1}\" =~ /^a{ 1}$/x" "^a{ 1}$" nil nil nil t "a{ 1}" nil 1 0 nil nil) +(748 "\"a{1}\" =~ /^a{ 1}$/x" "^a{ 1}$" nil nil nil t "a{1}" nil 1 0 "a{1}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(749 "\"{}\" =~ /{}/" "{}" nil nil nil nil "{}" nil 1 0 "{}" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(750 "\"a\" =~ /{}/" "{}" nil nil nil nil "a" nil 1 0 nil nil) +(751 "\"doesn't matter\" =~ /{1}/" "{1}" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(752 "\"doesn't matter\" =~ /*/" "*" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(753 "\"x\" =~ /|/" "|" nil nil nil nil "x" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(754 "\"\\0000\" =~ /\\0000/" "\\0000" nil nil nil nil ("" 0 "0") nil 1 0 ("" 0 "0") (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(755 "\"ab\" =~ /a(?<)b/" "a(?<)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(756 "\"ab\" =~ /a(?i)b/" "a(?i)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(757 "\"aB\" =~ /a(?i)b/" "a(?i)b" nil nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(758 "\"Ab\" =~ /a(?i)b/" "a(?i)b" nil nil nil nil "Ab" nil 1 0 nil nil) +(759 "\"doesn't matter\" =~ /a(?i=a)/" "a(?i=a)" nil nil nil nil "doesn't matter" t 1 0 nil nil) +(760 "\"aa\" =~ /a(?<=a){3000}a/" "a(?<=a){3000}a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(761 "\"xa\" =~ /a(?<=a){3000}a/" "a(?<=a){3000}a" nil nil nil nil "xa" nil 1 0 nil nil) +(762 "\"ax\" =~ /a(?<=a){3000}a/" "a(?<=a){3000}a" nil nil nil nil "ax" nil 1 0 nil nil) +(763 "\"aa\" =~ /a(?!=a){3000}a/" "a(?!=a){3000}a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(764 "\"ax\" =~ /a(?!=a){3000}a/" "a(?!=a){3000}a" nil nil nil nil "ax" nil 1 0 nil nil) +(765 "\"xa\" =~ /a(?!=a){3000}a/" "a(?!=a){3000}a" nil nil nil nil "xa" nil 1 0 nil nil) +(766 "\"aa\" =~ /a(){3000}a/" "a(){3000}a" nil nil nil nil "aa" nil 1 0 "aa" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(767 "\"ax\" =~ /a(){3000}a/" "a(){3000}a" nil nil nil nil "ax" nil 1 0 nil nil) +(768 "\"xa\" =~ /a(){3000}a/" "a(){3000}a" nil nil nil nil "xa" nil 1 0 nil nil) +(769 "\"aa\" =~ /a(?:){3000}a/" "a(?:){3000}a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(770 "\"ax\" =~ /a(?:){3000}a/" "a(?:){3000}a" nil nil nil nil "ax" nil 1 0 nil nil) +(771 "\"aa\" =~ /a(?<=a)*a/" "a(?<=a)*a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(772 "\"ax\" =~ /a(?<=a)*a/" "a(?<=a)*a" nil nil nil nil "ax" nil 1 0 nil nil) +(773 "\"xa\" =~ /a(?<=a)*a/" "a(?<=a)*a" nil nil nil nil "xa" nil 1 0 nil nil) +(774 "\"aa\" =~ /a(?!=a)*a/" "a(?!=a)*a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(775 "\"ax\" =~ /a(?!=a)*a/" "a(?!=a)*a" nil nil nil nil "ax" nil 1 0 nil nil) +(776 "\"xa\" =~ /a(?!=a)*a/" "a(?!=a)*a" nil nil nil nil "xa" nil 1 0 nil nil) +(777 "\"aa\" =~ /a()*a/" "a()*a" nil nil nil nil "aa" nil 1 0 "aa" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(778 "\"ax\" =~ /a()*a/" "a()*a" nil nil nil nil "ax" nil 1 0 nil nil) +(779 "\"xa\" =~ /a()*a/" "a()*a" nil nil nil nil "xa" nil 1 0 nil nil) +(780 "\"aa\" =~ /a(?:)*a/" "a(?:)*a" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(781 "\"ax\" =~ /a(?:)*a/" "a(?:)*a" nil nil nil nil "ax" nil 1 0 nil nil) +(782 "\"xa\" =~ /a(?:)*a/" "a(?:)*a" nil nil nil nil "xa" nil 1 0 nil nil) +(783 "\"aa\" =~ /x(?<=a)*a/" "x(?<=a)*a" nil nil nil nil "aa" nil 1 0 nil nil) +(784 "\"xa\" =~ /x(?<=a)*a/" "x(?<=a)*a" nil nil nil nil "xa" nil 1 0 "xa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(785 "\"ax\" =~ /x(?<=a)*a/" "x(?<=a)*a" nil nil nil nil "ax" nil 1 0 nil nil) +(786 "\"aa\" =~ /a(?<=(a))*\\1/" "a(?<=(a))*\\1" nil nil nil nil "aa" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(787 "\"aa\" =~ /a(?<=(a))*?\\1/" "a(?<=(a))*?\\1" nil nil nil nil "aa" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(788 "\"aa\" =~ /(?=(a)\\1)*aa/" "(?=(a)\\1)*aa" nil nil nil nil "aa" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(789 "\"aaaaabbbbb\" =~ /^((a|b){2,5}){2}$/" "^((a|b){2,5}){2}$" nil nil nil nil "aaaaabbbbb" nil 1 0 "aaaaabbbbb" ("bbbbb" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(790 "\"babc\" =~ /^(b*|ba){1,2}bc/" "^(b*|ba){1,2}bc" nil nil nil nil "babc" nil 1 0 "babc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(791 "\"bbabc\" =~ /^(b*|ba){1,2}bc/" "^(b*|ba){1,2}bc" nil nil nil nil "bbabc" nil 1 0 "bbabc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(792 "\"bababc\" =~ /^(b*|ba){1,2}bc/" "^(b*|ba){1,2}bc" nil nil nil nil "bababc" nil 1 0 "bababc" ("ba" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(793 "\"bababbc\" =~ /^(b*|ba){1,2}bc/" "^(b*|ba){1,2}bc" nil nil nil nil "bababbc" nil 1 0 nil nil) +(794 "\"babababc\" =~ /^(b*|ba){1,2}bc/" "^(b*|ba){1,2}bc" nil nil nil nil "babababc" nil 1 0 nil nil) +(795 "\"aaaaac\" =~ /^a{4,5}(?:c|a)c$/" "^a{4,5}(?:c|a)c$" nil nil nil nil "aaaaac" nil 1 0 "aaaaac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(796 "\"aaaaaac\" =~ /^a{4,5}(?:c|a)c$/" "^a{4,5}(?:c|a)c$" nil nil nil nil "aaaaaac" nil 1 0 "aaaaaac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(797 "\"aaaaac\" =~ /^(a|){4,5}(?:c|a)c$/" "^(a|){4,5}(?:c|a)c$" nil nil nil nil "aaaaac" nil 1 0 "aaaaac" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(798 "\"aaaaaac\" =~ /^(a|){4,5}(?:c|a)c$/" "^(a|){4,5}(?:c|a)c$" nil nil nil nil "aaaaaac" nil 1 0 "aaaaaac" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(799 "\"eeexabc\" =~ /(?m:^).abc$/" "(?m:^).abc$" nil nil nil nil "eeexabc" nil 1 0 nil nil) +(800 "\"eee\\nxabc\" =~ /(?m:^).abc$/" "(?m:^).abc$" nil nil nil nil "eee +xabc" nil 1 0 "xabc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(801 "\"abc\" =~ /(?m:^)abc/" "(?m:^)abc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(802 "\"\\nabc\" =~ /(?m:^)abc/" "(?m:^)abc" nil nil nil nil " +abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(803 "\"abc\" =~ +/^abc/" "^abc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(804 "\"\\nabc\" =~ +/^abc/" "^abc" nil nil nil nil " +abc" nil 1 0 nil nil) +(805 "\"abc\" =~ /\\Aabc/" "\\Aabc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(806 "\"\\nabc\" =~ /\\Aabc/" "\\Aabc" nil nil nil nil " +abc" nil 1 0 nil nil) +(807 "\"foo\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(808 "\"catfood\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "catfood" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(809 "\"arfootle\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "arfootle" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(810 "\"rfoosh\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "rfoosh" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(811 "\"barfoo\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "barfoo" nil 1 0 nil nil) +(812 "\"towbarfoo\" =~ /(?<!bar)foo/" "(?<!bar)foo" nil nil nil nil "towbarfoo" nil 1 0 nil nil) +(813 "\"catfood\" =~ /\\w{3}(?<!bar)foo/" "\\w{3}(?<!bar)foo" nil nil nil nil "catfood" nil 1 0 "catfoo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(814 "\"foo\" =~ /\\w{3}(?<!bar)foo/" "\\w{3}(?<!bar)foo" nil nil nil nil "foo" nil 1 0 nil nil) +(815 "\"barfoo\" =~ /\\w{3}(?<!bar)foo/" "\\w{3}(?<!bar)foo" nil nil nil nil "barfoo" nil 1 0 nil nil) +(816 "\"towbarfoo\" =~ /\\w{3}(?<!bar)foo/" "\\w{3}(?<!bar)foo" nil nil nil nil "towbarfoo" nil 1 0 nil nil) +(817 "\"fooabar\" =~ /(?<=(foo)a)bar/" "(?<=(foo)a)bar" nil nil nil nil "fooabar" nil 1 0 "bar" ("foo" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(818 "\"bar\" =~ /(?<=(foo)a)bar/" "(?<=(foo)a)bar" nil nil nil nil "bar" nil 1 0 nil nil) +(819 "\"foobbar\" =~ /(?<=(foo)a)bar/" "(?<=(foo)a)bar" nil nil nil nil "foobbar" nil 1 0 nil nil) +(820 "\"abc\" =~ /\\Aabc\\z/m" "\\Aabc\\z" nil t nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(821 "\"abc\\n\" =~ /\\Aabc\\z/m" "\\Aabc\\z" nil t nil nil "abc +" nil 1 0 nil nil) +(822 "\"qqq\\nabc\" =~ /\\Aabc\\z/m" "\\Aabc\\z" nil t nil nil "qqq +abc" nil 1 0 nil nil) +(823 "\"abc\\nzzz\" =~ /\\Aabc\\z/m" "\\Aabc\\z" nil t nil nil "abc +zzz" nil 1 0 nil nil) +(824 "\"qqq\\nabc\\nzzz\" =~ /\\Aabc\\z/m" "\\Aabc\\z" nil t nil nil "qqq +abc +zzz" nil 1 0 nil nil) +(825 "\"/this/is/a/very/long/line/in/deed/with/very/many/slashes/in/it/you/see/\" =~ \"(?>.*/)foo\"" "(?>.*/)foo" nil nil nil nil "/this/is/a/very/long/line/in/deed/with/very/many/slashes/in/it/you/see/" nil 1 0 nil nil) +(826 "\"/this/is/a/very/long/line/in/deed/with/very/many/slashes/in/and/foo\" =~ \"(?>.*/)foo\"" "(?>.*/)foo" nil nil nil nil "/this/is/a/very/long/line/in/deed/with/very/many/slashes/in/and/foo" nil 1 0 "/this/is/a/very/long/line/in/deed/with/very/many/slashes/in/and/foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(827 "\"1.230003938\" =~ /(?>(\\.\\d\\d[1-9]?))\\d+/" "(?>(\\.\\d\\d[1-9]?))\\d+" nil nil nil nil "1.230003938" nil 1 0 ".230003938" (".23" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(828 "\"1.875000282\" =~ /(?>(\\.\\d\\d[1-9]?))\\d+/" "(?>(\\.\\d\\d[1-9]?))\\d+" nil nil nil nil "1.875000282" nil 1 0 ".875000282" (".875" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(829 "\"1.235\" =~ /(?>(\\.\\d\\d[1-9]?))\\d+/" "(?>(\\.\\d\\d[1-9]?))\\d+" nil nil nil nil "1.235" nil 1 0 nil nil) +(830 "\"now is the time for all good men to come to the aid of the party\" =~ /^((?>\\w+)|(?>\\s+))*$/" "^((?>\\w+)|(?>\\s+))*$" nil nil nil nil "now is the time for all good men to come to the aid of the party" nil 1 0 "now is the time for all good men to come to the aid of the party" ("party" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(831 "\"this is not a line with only words and spaces!\" =~ /^((?>\\w+)|(?>\\s+))*$/" "^((?>\\w+)|(?>\\s+))*$" nil nil nil nil "this is not a line with only words and spaces!" nil 1 0 nil nil) +(832 "\"12345a\" =~ /(\\d+)(\\w)/" "(\\d+)(\\w)" nil nil nil nil "12345a" nil 1 0 "12345a" ("12345" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(833 "\"12345+\" =~ /(\\d+)(\\w)/" "(\\d+)(\\w)" nil nil nil nil "12345+" nil 1 0 "12345" ("1234" "5" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(834 "\"12345a\" =~ /((?>\\d+))(\\w)/" "((?>\\d+))(\\w)" nil nil nil nil "12345a" nil 1 0 "12345a" ("12345" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(835 "\"12345+\" =~ /((?>\\d+))(\\w)/" "((?>\\d+))(\\w)" nil nil nil nil "12345+" nil 1 0 nil nil) +(836 "\"aaab\" =~ /(?>a+)b/" "(?>a+)b" nil nil nil nil "aaab" nil 1 0 "aaab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(837 "\"aaab\" =~ /((?>a+)b)/" "((?>a+)b)" nil nil nil nil "aaab" nil 1 0 "aaab" ("aaab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(838 "\"aaab\" =~ /(?>(a+))b/" "(?>(a+))b" nil nil nil nil "aaab" nil 1 0 "aaab" ("aaa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(839 "\"aaabbbccc\" =~ /(?>b)+/" "(?>b)+" nil nil nil nil "aaabbbccc" nil 1 0 "bbb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(840 "\"aaabbbbccccd\" =~ /(?>a+|b+|c+)*c/" "(?>a+|b+|c+)*c" nil nil nil nil "aaabbbbccccd" nil 1 0 "aaabbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(841 "\"((abc(ade)ufh()()x\" =~ /((?>[^()]+)|\$[^()]*\$)+/" "((?>[^()]+)|\$[^()]*\$)+" nil nil nil nil "((abc(ade)ufh()()x" nil 1 0 "abc(ade)ufh()()x" ("x" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(842 "\"(abc)\" =~ /\$((?>[^()]+)|\\([^()]+\$)+\\)/" "\$((?>[^()]+)|\\([^()]+\$)+\\)" nil nil nil nil "(abc)" nil 1 0 "(abc)" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(843 "\"(abc(def)xyz)\" =~ /\$((?>[^()]+)|\\([^()]+\$)+\\)/" "\$((?>[^()]+)|\\([^()]+\$)+\\)" nil nil nil nil "(abc(def)xyz)" nil 1 0 "(abc(def)xyz)" ("xyz" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(844 "\"((()aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\" =~ /\$((?>[^()]+)|\\([^()]+\$)+\\)/" "\$((?>[^()]+)|\\([^()]+\$)+\\)" nil nil nil nil "((()aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" nil 1 0 nil nil) +(845 "\"ab\" =~ /a(?-i)b/i" "a(?-i)b" t nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(846 "\"Ab\" =~ /a(?-i)b/i" "a(?-i)b" t nil nil nil "Ab" nil 1 0 "Ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(847 "\"aB\" =~ /a(?-i)b/i" "a(?-i)b" t nil nil nil "aB" nil 1 0 nil nil) +(848 "\"AB\" =~ /a(?-i)b/i" "a(?-i)b" t nil nil nil "AB" nil 1 0 nil nil) +(849 "\"a bcd e\" =~ /(a (?x)b c)d e/" "(a (?x)b c)d e" nil nil nil nil "a bcd e" nil 1 0 "a bcd e" ("a bc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(850 "\"a b cd e\" =~ /(a (?x)b c)d e/" "(a (?x)b c)d e" nil nil nil nil "a b cd e" nil 1 0 nil nil) +(851 "\"abcd e\" =~ /(a (?x)b c)d e/" "(a (?x)b c)d e" nil nil nil nil "abcd e" nil 1 0 nil nil) +(852 "\"a bcde\" =~ /(a (?x)b c)d e/" "(a (?x)b c)d e" nil nil nil nil "a bcde" nil 1 0 nil nil) +(853 "\"a bcde f\" =~ /(a b(?x)c d (?-x)e f)/" "(a b(?x)c d (?-x)e f)" nil nil nil nil "a bcde f" nil 1 0 "a bcde f" ("a bcde f" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(854 "\"abcdef\" =~ /(a b(?x)c d (?-x)e f)/" "(a b(?x)c d (?-x)e f)" nil nil nil nil "abcdef" nil 1 0 nil nil) +(855 "\"abc\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "abc" nil 1 0 "abc" ("ab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(856 "\"aBc\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "aBc" nil 1 0 "aBc" ("aB" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(857 "\"abC\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "abC" nil 1 0 nil nil) +(858 "\"aBC\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "aBC" nil 1 0 nil nil) +(859 "\"Abc\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "Abc" nil 1 0 nil nil) +(860 "\"ABc\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "ABc" nil 1 0 nil nil) +(861 "\"ABC\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "ABC" nil 1 0 nil nil) +(862 "\"AbC\" =~ /(a(?i)b)c/" "(a(?i)b)c" nil nil nil nil "AbC" nil 1 0 nil nil) +(863 "\"abc\" =~ /a(?i:b)c/" "a(?i:b)c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(864 "\"aBc\" =~ /a(?i:b)c/" "a(?i:b)c" nil nil nil nil "aBc" nil 1 0 "aBc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(865 "\"ABC\" =~ /a(?i:b)c/" "a(?i:b)c" nil nil nil nil "ABC" nil 1 0 nil nil) +(866 "\"abC\" =~ /a(?i:b)c/" "a(?i:b)c" nil nil nil nil "abC" nil 1 0 nil nil) +(867 "\"aBC\" =~ /a(?i:b)c/" "a(?i:b)c" nil nil nil nil "aBC" nil 1 0 nil nil) +(868 "\"aBc\" =~ /a(?i:b)*c/" "a(?i:b)*c" nil nil nil nil "aBc" nil 1 0 "aBc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(869 "\"aBBc\" =~ /a(?i:b)*c/" "a(?i:b)*c" nil nil nil nil "aBBc" nil 1 0 "aBBc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(870 "\"aBC\" =~ /a(?i:b)*c/" "a(?i:b)*c" nil nil nil nil "aBC" nil 1 0 nil nil) +(871 "\"aBBC\" =~ /a(?i:b)*c/" "a(?i:b)*c" nil nil nil nil "aBBC" nil 1 0 nil nil) +(872 "\"abcd\" =~ /a(?=b(?i)c)\\w\\wd/" "a(?=b(?i)c)\\w\\wd" nil nil nil nil "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(873 "\"abCd\" =~ /a(?=b(?i)c)\\w\\wd/" "a(?=b(?i)c)\\w\\wd" nil nil nil nil "abCd" nil 1 0 "abCd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(874 "\"aBCd\" =~ /a(?=b(?i)c)\\w\\wd/" "a(?=b(?i)c)\\w\\wd" nil nil nil nil "aBCd" nil 1 0 nil nil) +(875 "\"abcD\" =~ /a(?=b(?i)c)\\w\\wd/" "a(?=b(?i)c)\\w\\wd" nil nil nil nil "abcD" nil 1 0 nil nil) +(876 "\"more than million\" =~ /(?s-i:more.*than).*million/i" "(?s-i:more.*than).*million" t nil nil nil "more than million" nil 1 0 "more than million" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(877 "\"more than MILLION\" =~ /(?s-i:more.*than).*million/i" "(?s-i:more.*than).*million" t nil nil nil "more than MILLION" nil 1 0 "more than MILLION" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(878 "\"more \\n than Million\" =~ /(?s-i:more.*than).*million/i" "(?s-i:more.*than).*million" t nil nil nil "more + than Million" nil 1 0 "more + than Million" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(879 "\"MORE THAN MILLION\" =~ /(?s-i:more.*than).*million/i" "(?s-i:more.*than).*million" t nil nil nil "MORE THAN MILLION" nil 1 0 nil nil) +(880 "\"more \\n than \\n million\" =~ /(?s-i:more.*than).*million/i" "(?s-i:more.*than).*million" t nil nil nil "more + than + million" nil 1 0 nil nil) +(881 "\"more than million\" =~ /(?:(?s-i)more.*than).*million/i" "(?:(?s-i)more.*than).*million" t nil nil nil "more than million" nil 1 0 "more than million" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(882 "\"more than MILLION\" =~ /(?:(?s-i)more.*than).*million/i" "(?:(?s-i)more.*than).*million" t nil nil nil "more than MILLION" nil 1 0 "more than MILLION" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(883 "\"more \\n than Million\" =~ /(?:(?s-i)more.*than).*million/i" "(?:(?s-i)more.*than).*million" t nil nil nil "more + than Million" nil 1 0 "more + than Million" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(884 "\"MORE THAN MILLION\" =~ /(?:(?s-i)more.*than).*million/i" "(?:(?s-i)more.*than).*million" t nil nil nil "MORE THAN MILLION" nil 1 0 nil nil) +(885 "\"more \\n than \\n million\" =~ /(?:(?s-i)more.*than).*million/i" "(?:(?s-i)more.*than).*million" t nil nil nil "more + than + million" nil 1 0 nil nil) +(886 "\"abc\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(887 "\"aBbc\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "aBbc" nil 1 0 "aBbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(888 "\"aBBc\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "aBBc" nil 1 0 "aBBc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(889 "\"Abc\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "Abc" nil 1 0 nil nil) +(890 "\"abAb\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "abAb" nil 1 0 nil nil) +(891 "\"abbC\" =~ /(?>a(?i)b+)+c/" "(?>a(?i)b+)+c" nil nil nil nil "abbC" nil 1 0 nil nil) +(892 "\"abc\" =~ /(?=a(?i)b)\\w\\wc/" "(?=a(?i)b)\\w\\wc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(893 "\"aBc\" =~ /(?=a(?i)b)\\w\\wc/" "(?=a(?i)b)\\w\\wc" nil nil nil nil "aBc" nil 1 0 "aBc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(894 "\"Ab\" =~ /(?=a(?i)b)\\w\\wc/" "(?=a(?i)b)\\w\\wc" nil nil nil nil "Ab" nil 1 0 nil nil) +(895 "\"abC\" =~ /(?=a(?i)b)\\w\\wc/" "(?=a(?i)b)\\w\\wc" nil nil nil nil "abC" nil 1 0 nil nil) +(896 "\"aBC\" =~ /(?=a(?i)b)\\w\\wc/" "(?=a(?i)b)\\w\\wc" nil nil nil nil "aBC" nil 1 0 nil nil) +(897 "\"abxxc\" =~ /(?<=a(?i)b)(\\w\\w)c/" "(?<=a(?i)b)(\\w\\w)c" nil nil nil nil "abxxc" nil 1 0 "xxc" ("xx" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(898 "\"aBxxc\" =~ /(?<=a(?i)b)(\\w\\w)c/" "(?<=a(?i)b)(\\w\\w)c" nil nil nil nil "aBxxc" nil 1 0 "xxc" ("xx" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(899 "\"Abxxc\" =~ /(?<=a(?i)b)(\\w\\w)c/" "(?<=a(?i)b)(\\w\\w)c" nil nil nil nil "Abxxc" nil 1 0 nil nil) +(900 "\"ABxxc\" =~ /(?<=a(?i)b)(\\w\\w)c/" "(?<=a(?i)b)(\\w\\w)c" nil nil nil nil "ABxxc" nil 1 0 nil nil) +(901 "\"abxxC\" =~ /(?<=a(?i)b)(\\w\\w)c/" "(?<=a(?i)b)(\\w\\w)c" nil nil nil nil "abxxC" nil 1 0 nil nil) +(902 "\"aA\" =~ /(?:(a)|b)(?(1)A|B)/" "(?:(a)|b)(?(1)A|B)" nil nil nil nil "aA" nil 1 0 "aA" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(903 "\"bB\" =~ /(?:(a)|b)(?(1)A|B)/" "(?:(a)|b)(?(1)A|B)" nil nil nil nil "bB" nil 1 0 "bB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(904 "\"aB\" =~ /(?:(a)|b)(?(1)A|B)/" "(?:(a)|b)(?(1)A|B)" nil nil nil nil "aB" nil 1 0 nil nil) +(905 "\"bA\" =~ /(?:(a)|b)(?(1)A|B)/" "(?:(a)|b)(?(1)A|B)" nil nil nil nil "bA" nil 1 0 nil nil) +(906 "\"aa\" =~ /^(a)?(?(1)a|b)+$/" "^(a)?(?(1)a|b)+$" nil nil nil nil "aa" nil 1 0 "aa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(907 "\"b\" =~ /^(a)?(?(1)a|b)+$/" "^(a)?(?(1)a|b)+$" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(908 "\"bb\" =~ /^(a)?(?(1)a|b)+$/" "^(a)?(?(1)a|b)+$" nil nil nil nil "bb" nil 1 0 "bb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(909 "\"ab\" =~ /^(a)?(?(1)a|b)+$/" "^(a)?(?(1)a|b)+$" nil nil nil nil "ab" nil 1 0 nil nil) +(910 "\"abc:\" =~ /^(?(?=abc)\\w{3}:|\\d\\d)$/" "^(?(?=abc)\\w{3}:|\\d\\d)$" nil nil nil nil "abc:" nil 1 0 "abc:" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(911 "\"12\" =~ /^(?(?=abc)\\w{3}:|\\d\\d)$/" "^(?(?=abc)\\w{3}:|\\d\\d)$" nil nil nil nil "12" nil 1 0 "12" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(912 "\"123\" =~ /^(?(?=abc)\\w{3}:|\\d\\d)$/" "^(?(?=abc)\\w{3}:|\\d\\d)$" nil nil nil nil "123" nil 1 0 nil nil) +(913 "\"xyz\" =~ /^(?(?=abc)\\w{3}:|\\d\\d)$/" "^(?(?=abc)\\w{3}:|\\d\\d)$" nil nil nil nil "xyz" nil 1 0 nil nil) +(914 "\"abc:\" =~ /^(?(?!abc)\\d\\d|\\w{3}:)$/" "^(?(?!abc)\\d\\d|\\w{3}:)$" nil nil nil nil "abc:" nil 1 0 "abc:" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(915 "\"12\" =~ /^(?(?!abc)\\d\\d|\\w{3}:)$/" "^(?(?!abc)\\d\\d|\\w{3}:)$" nil nil nil nil "12" nil 1 0 "12" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(916 "\"123\" =~ /^(?(?!abc)\\d\\d|\\w{3}:)$/" "^(?(?!abc)\\d\\d|\\w{3}:)$" nil nil nil nil "123" nil 1 0 nil nil) +(917 "\"xyz\" =~ /^(?(?!abc)\\d\\d|\\w{3}:)$/" "^(?(?!abc)\\d\\d|\\w{3}:)$" nil nil nil nil "xyz" nil 1 0 nil nil) +(918 "\"foobar\" =~ /(?(?<=foo)bar|cat)/" "(?(?<=foo)bar|cat)" nil nil nil nil "foobar" nil 1 0 "bar" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(919 "\"cat\" =~ /(?(?<=foo)bar|cat)/" "(?(?<=foo)bar|cat)" nil nil nil nil "cat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(920 "\"fcat\" =~ /(?(?<=foo)bar|cat)/" "(?(?<=foo)bar|cat)" nil nil nil nil "fcat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(921 "\"focat\" =~ /(?(?<=foo)bar|cat)/" "(?(?<=foo)bar|cat)" nil nil nil nil "focat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(922 "\"foocat\" =~ /(?(?<=foo)bar|cat)/" "(?(?<=foo)bar|cat)" nil nil nil nil "foocat" nil 1 0 nil nil) +(923 "\"foobar\" =~ /(?(?<!foo)cat|bar)/" "(?(?<!foo)cat|bar)" nil nil nil nil "foobar" nil 1 0 "bar" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(924 "\"cat\" =~ /(?(?<!foo)cat|bar)/" "(?(?<!foo)cat|bar)" nil nil nil nil "cat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(925 "\"fcat\" =~ /(?(?<!foo)cat|bar)/" "(?(?<!foo)cat|bar)" nil nil nil nil "fcat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(926 "\"focat\" =~ /(?(?<!foo)cat|bar)/" "(?(?<!foo)cat|bar)" nil nil nil nil "focat" nil 1 0 "cat" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(927 "\"foocat\" =~ /(?(?<!foo)cat|bar)/" "(?(?<!foo)cat|bar)" nil nil nil nil "foocat" nil 1 0 nil nil) +(928 "\"abcd\" =~ /( \$ )? [^()]+ (?(1) \$ |) /x" "( \$ )? [^()]+ (?(1) \$ |) " nil nil nil t "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(929 "\"(abcd)\" =~ /( \$ )? [^()]+ (?(1) \$ |) /x" "( \$ )? [^()]+ (?(1) \$ |) " nil nil nil t "(abcd)" nil 1 0 "(abcd)" ("(" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(930 "\"the quick (abcd) fox\" =~ /( \$ )? [^()]+ (?(1) \$ |) /x" "( \$ )? [^()]+ (?(1) \$ |) " nil nil nil t "the quick (abcd) fox" nil 1 0 "the quick " (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(931 "\"(abcd\" =~ /( \$ )? [^()]+ (?(1) \$ |) /x" "( \$ )? [^()]+ (?(1) \$ |) " nil nil nil t "(abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(932 "\"abcd\" =~ /( \$ )? [^()]+ (?(1) \$ ) /x" "( \$ )? [^()]+ (?(1) \$ ) " nil nil nil t "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(933 "\"(abcd)\" =~ /( \$ )? [^()]+ (?(1) \$ ) /x" "( \$ )? [^()]+ (?(1) \$ ) " nil nil nil t "(abcd)" nil 1 0 "(abcd)" ("(" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(934 "\"the quick (abcd) fox\" =~ /( \$ )? [^()]+ (?(1) \$ ) /x" "( \$ )? [^()]+ (?(1) \$ ) " nil nil nil t "the quick (abcd) fox" nil 1 0 "the quick " (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(935 "\"(abcd\" =~ /( \$ )? [^()]+ (?(1) \$ ) /x" "( \$ )? [^()]+ (?(1) \$ ) " nil nil nil t "(abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(936 "\"12\" =~ /^(?(2)a|(1)(2))+$/" "^(?(2)a|(1)(2))+$" nil nil nil nil "12" nil 1 0 "12" ("1" "2" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(937 "\"12a\" =~ /^(?(2)a|(1)(2))+$/" "^(?(2)a|(1)(2))+$" nil nil nil nil "12a" nil 1 0 "12a" ("1" "2" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(938 "\"12aa\" =~ /^(?(2)a|(1)(2))+$/" "^(?(2)a|(1)(2))+$" nil nil nil nil "12aa" nil 1 0 "12aa" ("1" "2" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(939 "\"1234\" =~ /^(?(2)a|(1)(2))+$/" "^(?(2)a|(1)(2))+$" nil nil nil nil "1234" nil 1 0 nil nil) +(940 "\"blah blah\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "blah blah" nil 1 0 "blah blah" ("blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(941 "\"BLAH BLAH\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "BLAH BLAH" nil 1 0 "BLAH BLAH" ("BLAH" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(942 "\"Blah Blah\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "Blah Blah" nil 1 0 "Blah Blah" ("Blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(943 "\"blaH blaH\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "blaH blaH" nil 1 0 "blaH blaH" ("blaH" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(944 "\"blah BLAH\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "blah BLAH" nil 1 0 nil nil) +(945 "\"Blah blah\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "Blah blah" nil 1 0 nil nil) +(946 "\"blaH blah\" =~ /((?i)blah)\\s+\\1/" "((?i)blah)\\s+\\1" nil nil nil nil "blaH blah" nil 1 0 nil nil) +(947 "\"blah blah\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "blah blah" nil 1 0 "blah blah" ("blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(948 "\"BLAH BLAH\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "BLAH BLAH" nil 1 0 "BLAH BLAH" ("BLAH" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(949 "\"Blah Blah\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "Blah Blah" nil 1 0 "Blah Blah" ("Blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(950 "\"blaH blaH\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "blaH blaH" nil 1 0 "blaH blaH" ("blaH" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(951 "\"blah BLAH\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "blah BLAH" nil 1 0 "blah BLAH" ("blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(952 "\"Blah blah\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "Blah blah" nil 1 0 "Blah blah" ("Blah" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(953 "\"blaH blah\" =~ /((?i)blah)\\s+(?i:\\1)/" "((?i)blah)\\s+(?i:\\1)" nil nil nil nil "blaH blah" nil 1 0 "blaH blah" ("blaH" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(954 "\"a\" =~ /(?>a*)*/" "(?>a*)*" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(955 "\"aa\" =~ /(?>a*)*/" "(?>a*)*" nil nil nil nil "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(956 "\"aaaa\" =~ /(?>a*)*/" "(?>a*)*" nil nil nil nil "aaaa" nil 1 0 "aaaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(957 "\"abc\" =~ /(abc|)+/" "(abc|)+" nil nil nil nil "abc" nil 1 0 "abc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(958 "\"abcabc\" =~ /(abc|)+/" "(abc|)+" nil nil nil nil "abcabc" nil 1 0 "abcabc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(959 "\"abcabcabc\" =~ /(abc|)+/" "(abc|)+" nil nil nil nil "abcabcabc" nil 1 0 "abcabcabc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(960 "\"xyz\" =~ /(abc|)+/" "(abc|)+" nil nil nil nil "xyz" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(961 "\"a\" =~ /([a]*)*/" "([a]*)*" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(962 "\"aaaaa\" =~ /([a]*)*/" "([a]*)*" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(963 "\"a\" =~ /([ab]*)*/" "([ab]*)*" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(964 "\"b\" =~ /([ab]*)*/" "([ab]*)*" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(965 "\"ababab\" =~ /([ab]*)*/" "([ab]*)*" nil nil nil nil "ababab" nil 1 0 "ababab" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(966 "\"aaaabcde\" =~ /([ab]*)*/" "([ab]*)*" nil nil nil nil "aaaabcde" nil 1 0 "aaaab" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(967 "\"bbbb\" =~ /([ab]*)*/" "([ab]*)*" nil nil nil nil "bbbb" nil 1 0 "bbbb" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(968 "\"b\" =~ /([^a]*)*/" "([^a]*)*" nil nil nil nil "b" nil 1 0 "b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(969 "\"bbbb\" =~ /([^a]*)*/" "([^a]*)*" nil nil nil nil "bbbb" nil 1 0 "bbbb" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(970 "\"aaa\" =~ /([^a]*)*/" "([^a]*)*" nil nil nil nil "aaa" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(971 "\"cccc\" =~ /([^ab]*)*/" "([^ab]*)*" nil nil nil nil "cccc" nil 1 0 "cccc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(972 "\"abab\" =~ /([^ab]*)*/" "([^ab]*)*" nil nil nil nil "abab" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(973 "\"a\" =~ /([a]*?)*/" "([a]*?)*" nil nil nil nil "a" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(974 "\"aaaa\" =~ /([a]*?)*/" "([a]*?)*" nil nil nil nil "aaaa" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(975 "\"a\" =~ /([ab]*?)*/" "([ab]*?)*" nil nil nil nil "a" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(976 "\"b\" =~ /([ab]*?)*/" "([ab]*?)*" nil nil nil nil "b" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(977 "\"abab\" =~ /([ab]*?)*/" "([ab]*?)*" nil nil nil nil "abab" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(978 "\"baba\" =~ /([ab]*?)*/" "([ab]*?)*" nil nil nil nil "baba" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(979 "\"b\" =~ /([^a]*?)*/" "([^a]*?)*" nil nil nil nil "b" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(980 "\"bbbb\" =~ /([^a]*?)*/" "([^a]*?)*" nil nil nil nil "bbbb" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(981 "\"aaa\" =~ /([^a]*?)*/" "([^a]*?)*" nil nil nil nil "aaa" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(982 "\"c\" =~ /([^ab]*?)*/" "([^ab]*?)*" nil nil nil nil "c" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(983 "\"cccc\" =~ /([^ab]*?)*/" "([^ab]*?)*" nil nil nil nil "cccc" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(984 "\"baba\" =~ /([^ab]*?)*/" "([^ab]*?)*" nil nil nil nil "baba" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(985 "\"a\" =~ /(?>a*)*/" "(?>a*)*" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(986 "\"aaabcde\" =~ /(?>a*)*/" "(?>a*)*" nil nil nil nil "aaabcde" nil 1 0 "aaa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(987 "\"aaaaa\" =~ /((?>a*))*/" "((?>a*))*" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(988 "\"aabbaa\" =~ /((?>a*))*/" "((?>a*))*" nil nil nil nil "aabbaa" nil 1 0 "aa" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(989 "\"aaaaa\" =~ /((?>a*?))*/" "((?>a*?))*" nil nil nil nil "aaaaa" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(990 "\"aabbaa\" =~ /((?>a*?))*/" "((?>a*?))*" nil nil nil nil "aabbaa" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(991 "\"12-sep-98\" =~ /(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) /x" "(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) " nil nil nil t "12-sep-98" nil 1 0 "12-sep-98" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(992 "\"12-09-98\" =~ /(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) /x" "(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) " nil nil nil t "12-09-98" nil 1 0 "12-09-98" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(993 "\"sep-12-98\" =~ /(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) /x" "(?(?=[^a-z]+[a-z]) \\d{2}-[a-z]{3}-\\d{2} | \\d{2}-\\d{2}-\\d{2} ) " nil nil nil t "sep-12-98" nil 1 0 nil nil) +(994 "\"foobarfoo\" =~ /(?<=(foo))bar\\1/" "(?<=(foo))bar\\1" nil nil nil nil "foobarfoo" nil 1 0 "barfoo" ("foo" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(995 "\"foobarfootling\" =~ /(?<=(foo))bar\\1/" "(?<=(foo))bar\\1" nil nil nil nil "foobarfootling" nil 1 0 "barfoo" ("foo" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(996 "\"foobar\" =~ /(?<=(foo))bar\\1/" "(?<=(foo))bar\\1" nil nil nil nil "foobar" nil 1 0 nil nil) +(997 "\"barfoo\" =~ /(?<=(foo))bar\\1/" "(?<=(foo))bar\\1" nil nil nil nil "barfoo" nil 1 0 nil nil) +(998 "\"saturday\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "saturday" nil 1 0 "saturday" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(999 "\"sunday\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "sunday" nil 1 0 "sunday" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1000 "\"Saturday\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "Saturday" nil 1 0 "Saturday" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1001 "\"Sunday\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "Sunday" nil 1 0 "Sunday" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1002 "\"SATURDAY\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "SATURDAY" nil 1 0 "SATURDAY" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1003 "\"SUNDAY\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "SUNDAY" nil 1 0 "SUNDAY" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1004 "\"SunDay\" =~ /(?i:saturday|sunday)/" "(?i:saturday|sunday)" nil nil nil nil "SunDay" nil 1 0 "SunDay" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1005 "\"abcx\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "abcx" nil 1 0 "abcx" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1006 "\"aBCx\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "aBCx" nil 1 0 "aBCx" ("aBC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1007 "\"bbx\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "bbx" nil 1 0 "bbx" ("bb" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1008 "\"BBx\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "BBx" nil 1 0 "BBx" ("BB" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1009 "\"abcX\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "abcX" nil 1 0 nil nil) +(1010 "\"aBCX\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "aBCX" nil 1 0 nil nil) +(1011 "\"bbX\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "bbX" nil 1 0 nil nil) +(1012 "\"BBX\" =~ /(a(?i)bc|BB)x/" "(a(?i)bc|BB)x" nil nil nil nil "BBX" nil 1 0 nil nil) +(1013 "\"ac\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "ac" nil 1 0 "ac" ("ac" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1014 "\"aC\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "aC" nil 1 0 "aC" ("aC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1015 "\"bD\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "bD" nil 1 0 "bD" ("bD" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1016 "\"elephant\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "elephant" nil 1 0 "e" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1017 "\"Europe\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "Europe" nil 1 0 "E" ("E" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1018 "\"frog\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "frog" nil 1 0 "f" ("f" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1019 "\"France\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "France" nil 1 0 "F" ("F" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1020 "\"Africa\" =~ /^([ab](?i)[cd]|[ef])/" "^([ab](?i)[cd]|[ef])" nil nil nil nil "Africa" nil 1 0 nil nil) +(1021 "\"ab\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "ab" nil 1 0 "ab" ("ab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1022 "\"aBd\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "aBd" nil 1 0 "aBd" ("aBd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1023 "\"xy\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "xy" nil 1 0 "xy" ("xy" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1024 "\"xY\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "xY" nil 1 0 "xY" ("xY" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1025 "\"zebra\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "zebra" nil 1 0 "z" ("z" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1026 "\"Zambesi\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "Zambesi" nil 1 0 "Z" ("Z" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1027 "\"aCD\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "aCD" nil 1 0 nil nil) +(1028 "\"XY\" =~ /^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/" "^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)" nil nil nil nil "XY" nil 1 0 nil nil) +(1029 "\"foo\\nbar\" =~ /(?<=foo\\n)^bar/m" "(?<=foo\\n)^bar" nil t nil nil "foo +bar" nil 1 0 "bar" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1030 "\"bar\" =~ /(?<=foo\\n)^bar/m" "(?<=foo\\n)^bar" nil t nil nil "bar" nil 1 0 nil nil) +(1031 "\"baz\\nbar\" =~ /(?<=foo\\n)^bar/m" "(?<=foo\\n)^bar" nil t nil nil "baz +bar" nil 1 0 nil nil) +(1032 "\"barbaz\" =~ /(?<=(?<!foo)bar)baz/" "(?<=(?<!foo)bar)baz" nil nil nil nil "barbaz" nil 1 0 "baz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1033 "\"barbarbaz\" =~ /(?<=(?<!foo)bar)baz/" "(?<=(?<!foo)bar)baz" nil nil nil nil "barbarbaz" nil 1 0 "baz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1034 "\"koobarbaz\" =~ /(?<=(?<!foo)bar)baz/" "(?<=(?<!foo)bar)baz" nil nil nil nil "koobarbaz" nil 1 0 "baz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1035 "\"baz\" =~ /(?<=(?<!foo)bar)baz/" "(?<=(?<!foo)bar)baz" nil nil nil nil "baz" nil 1 0 nil nil) +(1036 "\"foobarbaz\" =~ /(?<=(?<!foo)bar)baz/" "(?<=(?<!foo)bar)baz" nil nil nil nil "foobarbaz" nil 1 0 nil nil) +(1037 "\"a\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "a" nil 1 0 nil nil) +(1038 "\"aa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aa" nil 1 0 nil nil) +(1039 "\"aaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaa" nil 1 0 nil nil) +(1040 "\"aaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaa" nil 1 0 "aaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1041 "\"aaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1042 "\"aaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaa" nil 1 0 "aaaaaa" ("aa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1043 "\"aaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaa" nil 1 0 "aaaaaaa" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1044 "\"aaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaa" nil 1 0 nil nil) +(1045 "\"aaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaa" nil 1 0 nil nil) +(1046 "\"aaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaa" nil 1 0 "aaaaaaaaaa" ("aaaa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1047 "\"aaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaa" nil 1 0 nil nil) +(1048 "\"aaaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaaa" nil 1 0 nil nil) +(1049 "\"aaaaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaaaa" nil 1 0 nil nil) +(1050 "\"aaaaaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaaaaa" nil 1 0 nil nil) +(1051 "\"aaaaaaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaaaaaa" nil 1 0 nil nil) +(1052 "\"aaaaaaaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaaaaaaa" nil 1 0 nil nil) +(1053 "\"a\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "a" nil 1 0 nil nil) +(1054 "\"aa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aa" nil 1 0 nil nil) +(1055 "\"aaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaa" nil 1 0 nil nil) +(1056 "\"aaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaa" nil 1 0 "aaaa" ("a" "a" "a" "a" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1057 "\"aaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaa" nil 1 0 "aaaaa" ("a" "aa" "a" "a" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1058 "\"aaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaa" nil 1 0 "aaaaaa" ("a" "aa" "a" "aa" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1059 "\"aaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaa" nil 1 0 "aaaaaaa" ("a" "aa" "aaa" "a" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1060 "\"aaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaa" nil 1 0 nil nil) +(1061 "\"aaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaa" nil 1 0 nil nil) +(1062 "\"aaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaa" nil 1 0 "aaaaaaaaaa" ("a" "aa" "aaa" "aaaa" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1063 "\"aaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaa" nil 1 0 nil nil) +(1064 "\"aaaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaaa" nil 1 0 nil nil) +(1065 "\"aaaaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaaaa" nil 1 0 nil nil) +(1066 "\"aaaaaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaaaaa" nil 1 0 nil nil) +(1067 "\"aaaaaaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaaaaaa" nil 1 0 nil nil) +(1068 "\"aaaaaaaaaaaaaaaa\" =~ /^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$/" "^(a\\1?)(a\\1?)(a\\2?)(a\\3?)$" nil nil nil nil "aaaaaaaaaaaaaaaa" nil 1 0 nil nil) +(1069 "\"abc\" =~ /abc/" "abc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1070 "\"xabcy\" =~ /abc/" "abc" nil nil nil nil "xabcy" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1071 "\"ababc\" =~ /abc/" "abc" nil nil nil nil "ababc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1072 "\"xbc\" =~ /abc/" "abc" nil nil nil nil "xbc" nil 1 0 nil nil) +(1073 "\"axc\" =~ /abc/" "abc" nil nil nil nil "axc" nil 1 0 nil nil) +(1074 "\"abx\" =~ /abc/" "abc" nil nil nil nil "abx" nil 1 0 nil nil) +(1075 "\"abc\" =~ /ab*c/" "ab*c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1076 "\"abc\" =~ /ab*bc/" "ab*bc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1077 "\"abbc\" =~ /ab*bc/" "ab*bc" nil nil nil nil "abbc" nil 1 0 "abbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1078 "\"abbbbc\" =~ /ab*bc/" "ab*bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1079 "\"abbbbc\" =~ /.{1}/" ".{1}" nil nil nil nil "abbbbc" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1080 "\"abbbbc\" =~ /.{3,4}/" ".{3,4}" nil nil nil nil "abbbbc" nil 1 0 "abbb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1081 "\"abbbbc\" =~ /ab{0,}bc/" "ab{0,}bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1082 "\"abbc\" =~ /ab+bc/" "ab+bc" nil nil nil nil "abbc" nil 1 0 "abbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1083 "\"abc\" =~ /ab+bc/" "ab+bc" nil nil nil nil "abc" nil 1 0 nil nil) +(1084 "\"abq\" =~ /ab+bc/" "ab+bc" nil nil nil nil "abq" nil 1 0 nil nil) +(1085 "\"abbbbc\" =~ /ab+bc/" "ab+bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1086 "\"abbbbc\" =~ /ab{1,}bc/" "ab{1,}bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1087 "\"abbbbc\" =~ /ab{1,3}bc/" "ab{1,3}bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1088 "\"abbbbc\" =~ /ab{3,4}bc/" "ab{3,4}bc" nil nil nil nil "abbbbc" nil 1 0 "abbbbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1089 "\"abq\" =~ /ab{4,5}bc/" "ab{4,5}bc" nil nil nil nil "abq" nil 1 0 nil nil) +(1090 "\"abbbbc\" =~ /ab{4,5}bc/" "ab{4,5}bc" nil nil nil nil "abbbbc" nil 1 0 nil nil) +(1091 "\"abbc\" =~ /ab?bc/" "ab?bc" nil nil nil nil "abbc" nil 1 0 "abbc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1092 "\"abc\" =~ /ab?bc/" "ab?bc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1093 "\"abc\" =~ /ab{0,1}bc/" "ab{0,1}bc" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1094 "\"abc\" =~ /ab?c/" "ab?c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1095 "\"abc\" =~ /ab{0,1}c/" "ab{0,1}c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1096 "\"abc\" =~ /^abc$/" "^abc$" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1097 "\"abbbbc\" =~ /^abc$/" "^abc$" nil nil nil nil "abbbbc" nil 1 0 nil nil) +(1098 "\"abcc\" =~ /^abc$/" "^abc$" nil nil nil nil "abcc" nil 1 0 nil nil) +(1099 "\"abcc\" =~ /^abc/" "^abc" nil nil nil nil "abcc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1100 "\"aabc\" =~ /abc$/" "abc$" nil nil nil nil "aabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1101 "\"aabc\" =~ /abc$/" "abc$" nil nil nil nil "aabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1102 "\"aabcd\" =~ /abc$/" "abc$" nil nil nil nil "aabcd" nil 1 0 nil nil) +(1103 "\"abc\" =~ /^/" "^" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1104 "\"abc\" =~ /$/" "$" nil nil nil nil "abc" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1105 "\"abc\" =~ /a.c/" "a.c" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1106 "\"axc\" =~ /a.c/" "a.c" nil nil nil nil "axc" nil 1 0 "axc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1107 "\"axyzc\" =~ /a.*c/" "a.*c" nil nil nil nil "axyzc" nil 1 0 "axyzc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1108 "\"abd\" =~ /a[bc]d/" "a[bc]d" nil nil nil nil "abd" nil 1 0 "abd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1109 "\"axyzd\" =~ /a[bc]d/" "a[bc]d" nil nil nil nil "axyzd" nil 1 0 nil nil) +(1110 "\"abc\" =~ /a[bc]d/" "a[bc]d" nil nil nil nil "abc" nil 1 0 nil nil) +(1111 "\"ace\" =~ /a[b-d]e/" "a[b-d]e" nil nil nil nil "ace" nil 1 0 "ace" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1112 "\"aac\" =~ /a[b-d]/" "a[b-d]" nil nil nil nil "aac" nil 1 0 "ac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1113 "\"a-\" =~ /a[-b]/" "a[-b]" nil nil nil nil "a-" nil 1 0 "a-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1114 "\"a-\" =~ /a[b-]/" "a[b-]" nil nil nil nil "a-" nil 1 0 "a-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1115 "\"a]\" =~ /a]/" "a]" nil nil nil nil "a]" nil 1 0 "a]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1116 "\"a]b\" =~ /a[]]b/" "a[]]b" nil nil nil nil "a]b" nil 1 0 "a]b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1117 "\"aed\" =~ /a[^bc]d/" "a[^bc]d" nil nil nil nil "aed" nil 1 0 "aed" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1118 "\"abd\" =~ /a[^bc]d/" "a[^bc]d" nil nil nil nil "abd" nil 1 0 nil nil) +(1119 "\"abd\" =~ /a[^bc]d/" "a[^bc]d" nil nil nil nil "abd" nil 1 0 nil nil) +(1120 "\"adc\" =~ /a[^-b]c/" "a[^-b]c" nil nil nil nil "adc" nil 1 0 "adc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1121 "\"adc\" =~ /a[^]b]c/" "a[^]b]c" nil nil nil nil "adc" nil 1 0 "adc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1122 "\"a-c\" =~ /a[^]b]c/" "a[^]b]c" nil nil nil nil "a-c" nil 1 0 "a-c" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1123 "\"a]c\" =~ /a[^]b]c/" "a[^]b]c" nil nil nil nil "a]c" nil 1 0 nil nil) +(1124 "\"a-\" =~ /\\ba\\b/" "\\ba\\b" nil nil nil nil "a-" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1125 "\"-a\" =~ /\\ba\\b/" "\\ba\\b" nil nil nil nil "-a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1126 "\"-a-\" =~ /\\ba\\b/" "\\ba\\b" nil nil nil nil "-a-" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1127 "\"xy\" =~ /\\by\\b/" "\\by\\b" nil nil nil nil "xy" nil 1 0 nil nil) +(1128 "\"yz\" =~ /\\by\\b/" "\\by\\b" nil nil nil nil "yz" nil 1 0 nil nil) +(1129 "\"xyz\" =~ /\\by\\b/" "\\by\\b" nil nil nil nil "xyz" nil 1 0 nil nil) +(1130 "\"a-\" =~ /\\Ba\\B/" "\\Ba\\B" nil nil nil nil "a-" nil 1 0 nil nil) +(1131 "\"-a\" =~ /\\Ba\\B/" "\\Ba\\B" nil nil nil nil "-a" nil 1 0 nil nil) +(1132 "\"-a-\" =~ /\\Ba\\B/" "\\Ba\\B" nil nil nil nil "-a-" nil 1 0 nil nil) +(1133 "\"xy\" =~ /\\By\\b/" "\\By\\b" nil nil nil nil "xy" nil 1 0 "y" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1134 "\"yz\" =~ /\\by\\B/" "\\by\\B" nil nil nil nil "yz" nil 1 0 "y" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1135 "\"xyz\" =~ /\\By\\B/" "\\By\\B" nil nil nil nil "xyz" nil 1 0 "y" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1136 "\"a\" =~ /\\w/" "\\w" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1137 "\"-\" =~ /\\W/" "\\W" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1138 "\"-\" =~ /\\W/" "\\W" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1139 "\"a\" =~ /\\W/" "\\W" nil nil nil nil "a" nil 1 0 nil nil) +(1140 "\"a b\" =~ /a\\sb/" "a\\sb" nil nil nil nil "a b" nil 1 0 "a b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1141 "\"a-b\" =~ /a\\Sb/" "a\\Sb" nil nil nil nil "a-b" nil 1 0 "a-b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1142 "\"a-b\" =~ /a\\Sb/" "a\\Sb" nil nil nil nil "a-b" nil 1 0 "a-b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1143 "\"a b\" =~ /a\\Sb/" "a\\Sb" nil nil nil nil "a b" nil 1 0 nil nil) +(1144 "\"1\" =~ /\\d/" "\\d" nil nil nil nil "1" nil 1 0 "1" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1145 "\"-\" =~ /\\D/" "\\D" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1146 "\"-\" =~ /\\D/" "\\D" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1147 "\"1\" =~ /\\D/" "\\D" nil nil nil nil "1" nil 1 0 nil nil) +(1148 "\"a\" =~ /[\\w]/" "[\\w]" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1149 "\"-\" =~ /[\\W]/" "[\\W]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1150 "\"-\" =~ /[\\W]/" "[\\W]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1151 "\"a\" =~ /[\\W]/" "[\\W]" nil nil nil nil "a" nil 1 0 nil nil) +(1152 "\"a b\" =~ /a[\\s]b/" "a[\\s]b" nil nil nil nil "a b" nil 1 0 "a b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1153 "\"a-b\" =~ /a[\\S]b/" "a[\\S]b" nil nil nil nil "a-b" nil 1 0 "a-b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1154 "\"a-b\" =~ /a[\\S]b/" "a[\\S]b" nil nil nil nil "a-b" nil 1 0 "a-b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1155 "\"a b\" =~ /a[\\S]b/" "a[\\S]b" nil nil nil nil "a b" nil 1 0 nil nil) +(1156 "\"1\" =~ /[\\d]/" "[\\d]" nil nil nil nil "1" nil 1 0 "1" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1157 "\"-\" =~ /[\\D]/" "[\\D]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1158 "\"-\" =~ /[\\D]/" "[\\D]" nil nil nil nil "-" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1159 "\"1\" =~ /[\\D]/" "[\\D]" nil nil nil nil "1" nil 1 0 nil nil) +(1160 "\"abc\" =~ /ab|cd/" "ab|cd" nil nil nil nil "abc" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1161 "\"abcd\" =~ /ab|cd/" "ab|cd" nil nil nil nil "abcd" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1162 "\"def\" =~ /()ef/" "()ef" nil nil nil nil "def" nil 1 0 "ef" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1163 "\"a(b\" =~ /a\\(b/" "a\\(b" nil nil nil nil "a(b" nil 1 0 "a(b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1164 "\"ab\" =~ /a\\(*b/" "a\\(*b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1165 "\"a((b\" =~ /a\\(*b/" "a\\(*b" nil nil nil nil "a((b" nil 1 0 "a((b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1166 "\"a\\b\" =~ /a\\\\b/" "a\\\\b" nil nil nil nil ("a" 8) nil 1 0 nil nil) +(1167 "\"abc\" =~ /((a))/" "((a))" nil nil nil nil "abc" nil 1 0 "a" ("a" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1168 "\"abc\" =~ /(a)b(c)/" "(a)b(c)" nil nil nil nil "abc" nil 1 0 "abc" ("a" "c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1169 "\"aabbabc\" =~ /a+b+c/" "a+b+c" nil nil nil nil "aabbabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1170 "\"aabbabc\" =~ /a{1,}b{1,}c/" "a{1,}b{1,}c" nil nil nil nil "aabbabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1171 "\"abcabc\" =~ /a.+?c/" "a.+?c" nil nil nil nil "abcabc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1172 "\"ab\" =~ /(a+|b)*/" "(a+|b)*" nil nil nil nil "ab" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1173 "\"ab\" =~ /(a+|b){0,}/" "(a+|b){0,}" nil nil nil nil "ab" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1174 "\"ab\" =~ /(a+|b)+/" "(a+|b)+" nil nil nil nil "ab" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1175 "\"ab\" =~ /(a+|b){1,}/" "(a+|b){1,}" nil nil nil nil "ab" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1176 "\"ab\" =~ /(a+|b)?/" "(a+|b)?" nil nil nil nil "ab" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1177 "\"ab\" =~ /(a+|b){0,1}/" "(a+|b){0,1}" nil nil nil nil "ab" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1178 "\"cde\" =~ /[^ab]*/" "[^ab]*" nil nil nil nil "cde" nil 1 0 "cde" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1179 "\"b\" =~ /abc/" "abc" nil nil nil nil "b" nil 1 0 nil nil) +(1180 "\"abbbcd\" =~ +/([abc])*d/" "([abc])*d" nil nil nil nil "abbbcd" nil 1 0 "abbbcd" ("c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1181 "\"abcd\" =~ /([abc])*bcd/" "([abc])*bcd" nil nil nil nil "abcd" nil 1 0 "abcd" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1182 "\"e\" =~ /a|b|c|d|e/" "a|b|c|d|e" nil nil nil nil "e" nil 1 0 "e" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1183 "\"ef\" =~ /(a|b|c|d|e)f/" "(a|b|c|d|e)f" nil nil nil nil "ef" nil 1 0 "ef" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1184 "\"abcdefg\" =~ /abcd*efg/" "abcd*efg" nil nil nil nil "abcdefg" nil 1 0 "abcdefg" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1185 "\"xabyabbbz\" =~ /ab*/" "ab*" nil nil nil nil "xabyabbbz" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1186 "\"xayabbbz\" =~ /ab*/" "ab*" nil nil nil nil "xayabbbz" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1187 "\"abcde\" =~ /(ab|cd)e/" "(ab|cd)e" nil nil nil nil "abcde" nil 1 0 "cde" ("cd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1188 "\"hij\" =~ /[abhgefdc]ij/" "[abhgefdc]ij" nil nil nil nil "hij" nil 1 0 "hij" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1189 "\"abcdef\" =~ /(abc|)ef/" "(abc|)ef" nil nil nil nil "abcdef" nil 1 0 "ef" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1190 "\"abcd\" =~ /(a|b)c*d/" "(a|b)c*d" nil nil nil nil "abcd" nil 1 0 "bcd" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1191 "\"abc\" =~ /(ab|ab*)bc/" "(ab|ab*)bc" nil nil nil nil "abc" nil 1 0 "abc" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1192 "\"abc\" =~ /a([bc]*)c*/" "a([bc]*)c*" nil nil nil nil "abc" nil 1 0 "abc" ("bc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1193 "\"abcd\" =~ /a([bc]*)(c*d)/" "a([bc]*)(c*d)" nil nil nil nil "abcd" nil 1 0 "abcd" ("bc" "d" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1194 "\"abcd\" =~ /a([bc]+)(c*d)/" "a([bc]+)(c*d)" nil nil nil nil "abcd" nil 1 0 "abcd" ("bc" "d" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1195 "\"abcd\" =~ /a([bc]*)(c+d)/" "a([bc]*)(c+d)" nil nil nil nil "abcd" nil 1 0 "abcd" ("b" "cd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1196 "\"adcdcde\" =~ /a[bcd]*dcdcde/" "a[bcd]*dcdcde" nil nil nil nil "adcdcde" nil 1 0 "adcdcde" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1197 "\"abcde\" =~ /a[bcd]+dcdcde/" "a[bcd]+dcdcde" nil nil nil nil "abcde" nil 1 0 nil nil) +(1198 "\"adcdcde\" =~ /a[bcd]+dcdcde/" "a[bcd]+dcdcde" nil nil nil nil "adcdcde" nil 1 0 nil nil) +(1199 "\"abc\" =~ /(ab|a)b*c/" "(ab|a)b*c" nil nil nil nil "abc" nil 1 0 "abc" ("ab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1200 "\"abcd\" =~ /((a)(b)c)(d)/" "((a)(b)c)(d)" nil nil nil nil "abcd" nil 1 0 "abcd" ("abc" "a" "b" "d" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1201 "\"alpha\" =~ /[a-zA-Z_][a-zA-Z0-9_]*/" "[a-zA-Z_][a-zA-Z0-9_]*" nil nil nil nil "alpha" nil 1 0 "alpha" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1202 "\"abh\" =~ /^a(bc+|b[eh])g|.h$/" "^a(bc+|b[eh])g|.h$" nil nil nil nil "abh" nil 1 0 "bh" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1203 "\"effgz\" =~ /(bc+d$|ef*g.|h?i(j|k))/" "(bc+d$|ef*g.|h?i(j|k))" nil nil nil nil "effgz" nil 1 0 "effgz" ("effgz" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1204 "\"ij\" =~ /(bc+d$|ef*g.|h?i(j|k))/" "(bc+d$|ef*g.|h?i(j|k))" nil nil nil nil "ij" nil 1 0 "ij" ("ij" "j" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1205 "\"reffgz\" =~ /(bc+d$|ef*g.|h?i(j|k))/" "(bc+d$|ef*g.|h?i(j|k))" nil nil nil nil "reffgz" nil 1 0 "effgz" ("effgz" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1206 "\"effg\" =~ /(bc+d$|ef*g.|h?i(j|k))/" "(bc+d$|ef*g.|h?i(j|k))" nil nil nil nil "effg" nil 1 0 nil nil) +(1207 "\"bcdd\" =~ /(bc+d$|ef*g.|h?i(j|k))/" "(bc+d$|ef*g.|h?i(j|k))" nil nil nil nil "bcdd" nil 1 0 nil nil) +(1208 "\"a\" =~ /((((((((((a))))))))))/" "((((((((((a))))))))))" nil nil nil nil "a" nil 1 0 "a" ("a" "a" "a" "a" "a" "a" "a" "a" "a" "a" nil nil nil nil nil nil)) +(1209 "\"aa\" =~ /((((((((((a))))))))))\\10/" "((((((((((a))))))))))\\10" nil nil nil nil "aa" nil 1 0 "aa" ("a" "a" "a" "a" "a" "a" "a" "a" "a" "a" nil nil nil nil nil nil)) +(1210 "\"a\" =~ /(((((((((a)))))))))/" "(((((((((a)))))))))" nil nil nil nil "a" nil 1 0 "a" ("a" "a" "a" "a" "a" "a" "a" "a" "a" nil nil nil nil nil nil nil)) +(1211 "\"aa\" =~ /multiple words of text/" "multiple words of text" nil nil nil nil "aa" nil 1 0 nil nil) +(1212 "\"uh-uh\" =~ /multiple words of text/" "multiple words of text" nil nil nil nil "uh-uh" nil 1 0 nil nil) +(1213 "\"multiple words, yeah\" =~ /multiple words/" "multiple words" nil nil nil nil "multiple words, yeah" nil 1 0 "multiple words" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1214 "\"abcde\" =~ /(.*)c(.*)/" "(.*)c(.*)" nil nil nil nil "abcde" nil 1 0 "abcde" ("ab" "de" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1215 "\"(a, b)\" =~ /\$(.*), (.*)\$/" "\$(.*), (.*)\$" nil nil nil nil "(a, b)" nil 1 0 "(a, b)" ("a" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1216 "\"abcd\" =~ /abcd/" "abcd" nil nil nil nil "abcd" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1217 "\"abcd\" =~ /a(bc)d/" "a(bc)d" nil nil nil nil "abcd" nil 1 0 "abcd" ("bc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1218 "\"ac\" =~ /a[-]?c/" "a[-]?c" nil nil nil nil "ac" nil 1 0 "ac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1219 "\"abcabc\" =~ /(abc)\\1/" "(abc)\\1" nil nil nil nil "abcabc" nil 1 0 "abcabc" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1220 "\"abcabc\" =~ /([a-c]*)\\1/" "([a-c]*)\\1" nil nil nil nil "abcabc" nil 1 0 "abcabc" ("abc" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1221 "\"a\" =~ /(a)|\\1/" "(a)|\\1" nil nil nil nil "a" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1222 "\"ab\" =~ /(a)|\\1/" "(a)|\\1" nil nil nil nil "ab" nil 1 0 "a" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1223 "\"x\" =~ /(a)|\\1/" "(a)|\\1" nil nil nil nil "x" nil 1 0 nil nil) +(1224 "\"ababbbcbc\" =~ /(([a-c])b*?\\2)*/" "(([a-c])b*?\\2)*" nil nil nil nil "ababbbcbc" nil 1 0 "ababb" ("bb" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1225 "\"ababbbcbc\" =~ /(([a-c])b*?\\2){3}/" "(([a-c])b*?\\2){3}" nil nil nil nil "ababbbcbc" nil 1 0 "ababbbcbc" ("cbc" "c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1226 "\"aaaxabaxbaaxbbax\" =~ /((\\3|b)\\2(a)x)+/" "((\\3|b)\\2(a)x)+" nil nil nil nil "aaaxabaxbaaxbbax" nil 1 0 "bbax" ("bbax" "b" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1227 "\"bbaababbabaaaaabbaaaabba\" =~ /((\\3|b)\\2(a)){2,}/" "((\\3|b)\\2(a)){2,}" nil nil nil nil "bbaababbabaaaaabbaaaabba" nil 1 0 "bbaaaabba" ("bba" "b" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1228 "\"ABC\" =~ /abc/i" "abc" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1229 "\"XABCY\" =~ /abc/i" "abc" t nil nil nil "XABCY" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1230 "\"ABABC\" =~ /abc/i" "abc" t nil nil nil "ABABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1231 "\"aaxabxbaxbbx\" =~ /abc/i" "abc" t nil nil nil "aaxabxbaxbbx" nil 1 0 nil nil) +(1232 "\"XBC\" =~ /abc/i" "abc" t nil nil nil "XBC" nil 1 0 nil nil) +(1233 "\"AXC\" =~ /abc/i" "abc" t nil nil nil "AXC" nil 1 0 nil nil) +(1234 "\"ABX\" =~ /abc/i" "abc" t nil nil nil "ABX" nil 1 0 nil nil) +(1235 "\"ABC\" =~ /ab*c/i" "ab*c" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1236 "\"ABC\" =~ /ab*bc/i" "ab*bc" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1237 "\"ABBC\" =~ /ab*bc/i" "ab*bc" t nil nil nil "ABBC" nil 1 0 "ABBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1238 "\"ABBBBC\" =~ /ab*?bc/i" "ab*?bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1239 "\"ABBBBC\" =~ /ab{0,}?bc/i" "ab{0,}?bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1240 "\"ABBC\" =~ /ab+?bc/i" "ab+?bc" t nil nil nil "ABBC" nil 1 0 "ABBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1241 "\"ABC\" =~ /ab+bc/i" "ab+bc" t nil nil nil "ABC" nil 1 0 nil nil) +(1242 "\"ABQ\" =~ /ab+bc/i" "ab+bc" t nil nil nil "ABQ" nil 1 0 nil nil) +(1243 "\"ABBBBC\" =~ /ab+bc/i" "ab+bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1244 "\"ABBBBC\" =~ /ab{1,}?bc/i" "ab{1,}?bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1245 "\"ABBBBC\" =~ /ab{1,3}?bc/i" "ab{1,3}?bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1246 "\"ABBBBC\" =~ /ab{3,4}?bc/i" "ab{3,4}?bc" t nil nil nil "ABBBBC" nil 1 0 "ABBBBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1247 "\"ABQ\" =~ /ab{4,5}?bc/i" "ab{4,5}?bc" t nil nil nil "ABQ" nil 1 0 nil nil) +(1248 "\"ABBBBC\" =~ /ab{4,5}?bc/i" "ab{4,5}?bc" t nil nil nil "ABBBBC" nil 1 0 nil nil) +(1249 "\"ABBC\" =~ /ab??bc/i" "ab??bc" t nil nil nil "ABBC" nil 1 0 "ABBC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1250 "\"ABC\" =~ /ab??bc/i" "ab??bc" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1251 "\"ABC\" =~ /ab{0,1}?bc/i" "ab{0,1}?bc" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1252 "\"ABC\" =~ /ab??c/i" "ab??c" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1253 "\"ABC\" =~ /ab{0,1}?c/i" "ab{0,1}?c" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1254 "\"ABC\" =~ /^abc$/i" "^abc$" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1255 "\"ABBBBC\" =~ /^abc$/i" "^abc$" t nil nil nil "ABBBBC" nil 1 0 nil nil) +(1256 "\"ABCC\" =~ /^abc$/i" "^abc$" t nil nil nil "ABCC" nil 1 0 nil nil) +(1257 "\"ABCC\" =~ /^abc/i" "^abc" t nil nil nil "ABCC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1258 "\"AABC\" =~ /abc$/i" "abc$" t nil nil nil "AABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1259 "\"ABC\" =~ /^/i" "^" t nil nil nil "ABC" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1260 "\"ABC\" =~ /$/i" "$" t nil nil nil "ABC" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1261 "\"ABC\" =~ /a.c/i" "a.c" t nil nil nil "ABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1262 "\"AXC\" =~ /a.c/i" "a.c" t nil nil nil "AXC" nil 1 0 "AXC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1263 "\"AXYZC\" =~ /a.*?c/i" "a.*?c" t nil nil nil "AXYZC" nil 1 0 "AXYZC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1264 "\"AABC\" =~ /a.*c/i" "a.*c" t nil nil nil "AABC" nil 1 0 "AABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1265 "\"AXYZD\" =~ /a.*c/i" "a.*c" t nil nil nil "AXYZD" nil 1 0 nil nil) +(1266 "\"ABD\" =~ /a[bc]d/i" "a[bc]d" t nil nil nil "ABD" nil 1 0 "ABD" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1267 "\"ACE\" =~ /a[b-d]e/i" "a[b-d]e" t nil nil nil "ACE" nil 1 0 "ACE" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1268 "\"ABC\" =~ /a[b-d]e/i" "a[b-d]e" t nil nil nil "ABC" nil 1 0 nil nil) +(1269 "\"ABD\" =~ /a[b-d]e/i" "a[b-d]e" t nil nil nil "ABD" nil 1 0 nil nil) +(1270 "\"AAC\" =~ /a[b-d]/i" "a[b-d]" t nil nil nil "AAC" nil 1 0 "AC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1271 "\"A-\" =~ /a[-b]/i" "a[-b]" t nil nil nil "A-" nil 1 0 "A-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1272 "\"A-\" =~ /a[b-]/i" "a[b-]" t nil nil nil "A-" nil 1 0 "A-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1273 "\"A]\" =~ /a]/i" "a]" t nil nil nil "A]" nil 1 0 "A]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1274 "\"A]B\" =~ /a[]]b/i" "a[]]b" t nil nil nil "A]B" nil 1 0 "A]B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1275 "\"AED\" =~ /a[^bc]d/i" "a[^bc]d" t nil nil nil "AED" nil 1 0 "AED" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1276 "\"ADC\" =~ /a[^-b]c/i" "a[^-b]c" t nil nil nil "ADC" nil 1 0 "ADC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1277 "\"ABD\" =~ /a[^-b]c/i" "a[^-b]c" t nil nil nil "ABD" nil 1 0 nil nil) +(1278 "\"A-C\" =~ /a[^-b]c/i" "a[^-b]c" t nil nil nil "A-C" nil 1 0 nil nil) +(1279 "\"ADC\" =~ /a[^]b]c/i" "a[^]b]c" t nil nil nil "ADC" nil 1 0 "ADC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1280 "\"ABC\" =~ /ab|cd/i" "ab|cd" t nil nil nil "ABC" nil 1 0 "AB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1281 "\"ABCD\" =~ /ab|cd/i" "ab|cd" t nil nil nil "ABCD" nil 1 0 "AB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1282 "\"DEF\" =~ /()ef/i" "()ef" t nil nil nil "DEF" nil 1 0 "EF" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1283 "\"A]C\" =~ /$b/i" "$b" t nil nil nil "A]C" nil 1 0 nil nil) +(1284 "\"B\" =~ /$b/i" "$b" t nil nil nil "B" nil 1 0 nil nil) +(1285 "\"A(B\" =~ /a\\(b/i" "a\\(b" t nil nil nil "A(B" nil 1 0 "A(B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1286 "\"AB\" =~ /a\\(*b/i" "a\\(*b" t nil nil nil "AB" nil 1 0 "AB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1287 "\"A((B\" =~ /a\\(*b/i" "a\\(*b" t nil nil nil "A((B" nil 1 0 "A((B" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1288 "\"A\\B\" =~ /a\\\\b/i" "a\\\\b" t nil nil nil "AB" nil 1 0 nil nil) +(1289 "\"ABC\" =~ /((a))/i" "((a))" t nil nil nil "ABC" nil 1 0 "A" ("A" "A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1290 "\"ABC\" =~ /(a)b(c)/i" "(a)b(c)" t nil nil nil "ABC" nil 1 0 "ABC" ("A" "C" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1291 "\"AABBABC\" =~ /a+b+c/i" "a+b+c" t nil nil nil "AABBABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1292 "\"AABBABC\" =~ /a{1,}b{1,}c/i" "a{1,}b{1,}c" t nil nil nil "AABBABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1293 "\"ABCABC\" =~ /a.+?c/i" "a.+?c" t nil nil nil "ABCABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1294 "\"ABCABC\" =~ /a.*?c/i" "a.*?c" t nil nil nil "ABCABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1295 "\"ABCABC\" =~ /a.{0,5}?c/i" "a.{0,5}?c" t nil nil nil "ABCABC" nil 1 0 "ABC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1296 "\"AB\" =~ /(a+|b)*/i" "(a+|b)*" t nil nil nil "AB" nil 1 0 "AB" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1297 "\"AB\" =~ /(a+|b){0,}/i" "(a+|b){0,}" t nil nil nil "AB" nil 1 0 "AB" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1298 "\"AB\" =~ /(a+|b)+/i" "(a+|b)+" t nil nil nil "AB" nil 1 0 "AB" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1299 "\"AB\" =~ /(a+|b){1,}/i" "(a+|b){1,}" t nil nil nil "AB" nil 1 0 "AB" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1300 "\"AB\" =~ /(a+|b)?/i" "(a+|b)?" t nil nil nil "AB" nil 1 0 "A" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1301 "\"AB\" =~ /(a+|b){0,1}/i" "(a+|b){0,1}" t nil nil nil "AB" nil 1 0 "A" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1302 "\"AB\" =~ /(a+|b){0,1}?/i" "(a+|b){0,1}?" t nil nil nil "AB" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1303 "\"CDE\" =~ /[^ab]*/i" "[^ab]*" t nil nil nil "CDE" nil 1 0 "CDE" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1304 "\"ABBBCD\" =~ +/([abc])*d/i" "([abc])*d" t nil nil nil "ABBBCD" nil 1 0 "ABBBCD" ("C" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1305 "\"ABCD\" =~ /([abc])*bcd/i" "([abc])*bcd" t nil nil nil "ABCD" nil 1 0 "ABCD" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1306 "\"E\" =~ /a|b|c|d|e/i" "a|b|c|d|e" t nil nil nil "E" nil 1 0 "E" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1307 "\"EF\" =~ /(a|b|c|d|e)f/i" "(a|b|c|d|e)f" t nil nil nil "EF" nil 1 0 "EF" ("E" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1308 "\"ABCDEFG\" =~ /abcd*efg/i" "abcd*efg" t nil nil nil "ABCDEFG" nil 1 0 "ABCDEFG" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1309 "\"XABYABBBZ\" =~ /ab*/i" "ab*" t nil nil nil "XABYABBBZ" nil 1 0 "AB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1310 "\"XAYABBBZ\" =~ /ab*/i" "ab*" t nil nil nil "XAYABBBZ" nil 1 0 "A" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1311 "\"ABCDE\" =~ /(ab|cd)e/i" "(ab|cd)e" t nil nil nil "ABCDE" nil 1 0 "CDE" ("CD" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1312 "\"HIJ\" =~ /[abhgefdc]ij/i" "[abhgefdc]ij" t nil nil nil "HIJ" nil 1 0 "HIJ" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1313 "\"ABCDE\" =~ /^(ab|cd)e/i" "^(ab|cd)e" t nil nil nil "ABCDE" nil 1 0 nil nil) +(1314 "\"ABCDEF\" =~ /(abc|)ef/i" "(abc|)ef" t nil nil nil "ABCDEF" nil 1 0 "EF" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1315 "\"ABCD\" =~ /(a|b)c*d/i" "(a|b)c*d" t nil nil nil "ABCD" nil 1 0 "BCD" ("B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1316 "\"ABC\" =~ /(ab|ab*)bc/i" "(ab|ab*)bc" t nil nil nil "ABC" nil 1 0 "ABC" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1317 "\"ABC\" =~ /a([bc]*)c*/i" "a([bc]*)c*" t nil nil nil "ABC" nil 1 0 "ABC" ("BC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1318 "\"ABCD\" =~ /a([bc]*)(c*d)/i" "a([bc]*)(c*d)" t nil nil nil "ABCD" nil 1 0 "ABCD" ("BC" "D" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1319 "\"ABCD\" =~ /a([bc]+)(c*d)/i" "a([bc]+)(c*d)" t nil nil nil "ABCD" nil 1 0 "ABCD" ("BC" "D" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1320 "\"ABCD\" =~ /a([bc]*)(c+d)/i" "a([bc]*)(c+d)" t nil nil nil "ABCD" nil 1 0 "ABCD" ("B" "CD" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1321 "\"ADCDCDE\" =~ /a[bcd]*dcdcde/i" "a[bcd]*dcdcde" t nil nil nil "ADCDCDE" nil 1 0 "ADCDCDE" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1322 "\"ABC\" =~ /(ab|a)b*c/i" "(ab|a)b*c" t nil nil nil "ABC" nil 1 0 "ABC" ("AB" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1323 "\"ABCD\" =~ /((a)(b)c)(d)/i" "((a)(b)c)(d)" t nil nil nil "ABCD" nil 1 0 "ABCD" ("ABC" "A" "B" "D" nil nil nil nil nil nil nil nil nil nil nil nil)) +(1324 "\"ALPHA\" =~ /[a-zA-Z_][a-zA-Z0-9_]*/i" "[a-zA-Z_][a-zA-Z0-9_]*" t nil nil nil "ALPHA" nil 1 0 "ALPHA" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1325 "\"ABH\" =~ /^a(bc+|b[eh])g|.h$/i" "^a(bc+|b[eh])g|.h$" t nil nil nil "ABH" nil 1 0 "BH" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1326 "\"EFFGZ\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "EFFGZ" nil 1 0 "EFFGZ" ("EFFGZ" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1327 "\"IJ\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "IJ" nil 1 0 "IJ" ("IJ" "J" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1328 "\"REFFGZ\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "REFFGZ" nil 1 0 "EFFGZ" ("EFFGZ" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1329 "\"ADCDCDE\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "ADCDCDE" nil 1 0 nil nil) +(1330 "\"EFFG\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "EFFG" nil 1 0 nil nil) +(1331 "\"BCDD\" =~ /(bc+d$|ef*g.|h?i(j|k))/i" "(bc+d$|ef*g.|h?i(j|k))" t nil nil nil "BCDD" nil 1 0 nil nil) +(1332 "\"A\" =~ /((((((((((a))))))))))/i" "((((((((((a))))))))))" t nil nil nil "A" nil 1 0 "A" ("A" "A" "A" "A" "A" "A" "A" "A" "A" "A" nil nil nil nil nil nil)) +(1333 "\"AA\" =~ /((((((((((a))))))))))\\10/i" "((((((((((a))))))))))\\10" t nil nil nil "AA" nil 1 0 "AA" ("A" "A" "A" "A" "A" "A" "A" "A" "A" "A" nil nil nil nil nil nil)) +(1334 "\"A\" =~ /(((((((((a)))))))))/i" "(((((((((a)))))))))" t nil nil nil "A" nil 1 0 "A" ("A" "A" "A" "A" "A" "A" "A" "A" "A" nil nil nil nil nil nil nil)) +(1335 "\"A\" =~ /(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))/i" "(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))" t nil nil nil "A" nil 1 0 "A" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1336 "\"C\" =~ /(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))/i" "(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))" t nil nil nil "C" nil 1 0 "C" ("C" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1337 "\"AA\" =~ /multiple words of text/i" "multiple words of text" t nil nil nil "AA" nil 1 0 nil nil) +(1338 "\"UH-UH\" =~ /multiple words of text/i" "multiple words of text" t nil nil nil "UH-UH" nil 1 0 nil nil) +(1339 "\"MULTIPLE WORDS, YEAH\" =~ /multiple words/i" "multiple words" t nil nil nil "MULTIPLE WORDS, YEAH" nil 1 0 "MULTIPLE WORDS" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1340 "\"ABCDE\" =~ /(.*)c(.*)/i" "(.*)c(.*)" t nil nil nil "ABCDE" nil 1 0 "ABCDE" ("AB" "DE" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1341 "\"(A, B)\" =~ /\$(.*), (.*)\$/i" "\$(.*), (.*)\$" t nil nil nil "(A, B)" nil 1 0 "(A, B)" ("A" "B" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1342 "\"ABCD\" =~ /abcd/i" "abcd" t nil nil nil "ABCD" nil 1 0 "ABCD" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1343 "\"ABCD\" =~ /a(bc)d/i" "a(bc)d" t nil nil nil "ABCD" nil 1 0 "ABCD" ("BC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1344 "\"AC\" =~ /a[-]?c/i" "a[-]?c" t nil nil nil "AC" nil 1 0 "AC" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1345 "\"ABCABC\" =~ /(abc)\\1/i" "(abc)\\1" t nil nil nil "ABCABC" nil 1 0 "ABCABC" ("ABC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1346 "\"ABCABC\" =~ /([a-c]*)\\1/i" "([a-c]*)\\1" t nil nil nil "ABCABC" nil 1 0 "ABCABC" ("ABC" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1347 "\"abad\" =~ /a(?!b)./" "a(?!b)." nil nil nil nil "abad" nil 1 0 "ad" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1348 "\"abad\" =~ /a(?=d)./" "a(?=d)." nil nil nil nil "abad" nil 1 0 "ad" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1349 "\"abad\" =~ /a(?=c|d)./" "a(?=c|d)." nil nil nil nil "abad" nil 1 0 "ad" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1350 "\"ace\" =~ /a(?:b|c|d)(.)/" "a(?:b|c|d)(.)" nil nil nil nil "ace" nil 1 0 "ace" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1351 "\"ace\" =~ /a(?:b|c|d)*(.)/" "a(?:b|c|d)*(.)" nil nil nil nil "ace" nil 1 0 "ace" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1352 "\"ace\" =~ /a(?:b|c|d)+?(.)/" "a(?:b|c|d)+?(.)" nil nil nil nil "ace" nil 1 0 "ace" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1353 "\"acdbcdbe\" =~ /a(?:b|c|d)+?(.)/" "a(?:b|c|d)+?(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acd" ("d" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1354 "\"acdbcdbe\" =~ /a(?:b|c|d)+(.)/" "a(?:b|c|d)+(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdbe" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1355 "\"acdbcdbe\" =~ /a(?:b|c|d){2}(.)/" "a(?:b|c|d){2}(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1356 "\"acdbcdbe\" =~ /a(?:b|c|d){4,5}(.)/" "a(?:b|c|d){4,5}(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1357 "\"acdbcdbe\" =~ /a(?:b|c|d){4,5}?(.)/" "a(?:b|c|d){4,5}?(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcd" ("d" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1358 "\"foobar\" =~ /((foo)|(bar))*/" "((foo)|(bar))*" nil nil nil nil "foobar" nil 1 0 "foobar" ("bar" "foo" "bar" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1359 "\"acdbcdbe\" =~ /a(?:b|c|d){6,7}(.)/" "a(?:b|c|d){6,7}(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdbe" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1360 "\"acdbcdbe\" =~ /a(?:b|c|d){6,7}?(.)/" "a(?:b|c|d){6,7}?(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdbe" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1361 "\"acdbcdbe\" =~ /a(?:b|c|d){5,6}(.)/" "a(?:b|c|d){5,6}(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdbe" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1362 "\"acdbcdbe\" =~ /a(?:b|c|d){5,6}?(.)/" "a(?:b|c|d){5,6}?(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1363 "\"acdbcdbe\" =~ /a(?:b|c|d){5,7}(.)/" "a(?:b|c|d){5,7}(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdbe" ("e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1364 "\"acdbcdbe\" =~ /a(?:b|c|d){5,7}?(.)/" "a(?:b|c|d){5,7}?(.)" nil nil nil nil "acdbcdbe" nil 1 0 "acdbcdb" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1365 "\"ace\" =~ /a(?:b|(c|e){1,2}?|d)+?(.)/" "a(?:b|(c|e){1,2}?|d)+?(.)" nil nil nil nil "ace" nil 1 0 "ace" ("c" "e" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1366 "\"AB\" =~ /^(.+)?B/" "^(.+)?B" nil nil nil nil "AB" nil 1 0 "AB" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1367 "\".\" =~ /^([^a-z])|(\\^)$/" "^([^a-z])|(\\^)$" nil nil nil nil "." nil 1 0 "." ("." nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1368 "\"<&OUT\" =~ /^[<>]&/" "^[<>]&" nil nil nil nil "<&OUT" nil 1 0 "<&" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1369 "\"aaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaa" nil 1 0 "aaaaaaaaaa" ("aaaa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1370 "\"AB\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "AB" nil 1 0 nil nil) +(1371 "\"aaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaa" nil 1 0 nil nil) +(1372 "\"aaaaaaaaaaa\" =~ /^(a\\1?){4}$/" "^(a\\1?){4}$" nil nil nil nil "aaaaaaaaaaa" nil 1 0 nil nil) +(1373 "\"aaaaaaaaaa\" =~ /^(a(?(1)\\1)){4}$/" "^(a(?(1)\\1)){4}$" nil nil nil nil "aaaaaaaaaa" nil 1 0 "aaaaaaaaaa" ("aaaa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1374 "\"aaaaaaaaa\" =~ /^(a(?(1)\\1)){4}$/" "^(a(?(1)\\1)){4}$" nil nil nil nil "aaaaaaaaa" nil 1 0 nil nil) +(1375 "\"aaaaaaaaaaa\" =~ /^(a(?(1)\\1)){4}$/" "^(a(?(1)\\1)){4}$" nil nil nil nil "aaaaaaaaaaa" nil 1 0 nil nil) +(1376 "\"foobar\" =~ /(?:(f)(o)(o)|(b)(a)(r))*/" "(?:(f)(o)(o)|(b)(a)(r))*" nil nil nil nil "foobar" nil 1 0 "foobar" ("f" "o" "o" "b" "a" "r" nil nil nil nil nil nil nil nil nil nil)) +(1377 "\"ab\" =~ /(?<=a)b/" "(?<=a)b" nil nil nil nil "ab" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1378 "\"cb\" =~ /(?<=a)b/" "(?<=a)b" nil nil nil nil "cb" nil 1 0 nil nil) +(1379 "\"b\" =~ /(?<=a)b/" "(?<=a)b" nil nil nil nil "b" nil 1 0 nil nil) +(1380 "\"ab\" =~ /(?<!c)b/" "(?<!c)b" nil nil nil nil "ab" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1381 "\"b\" =~ /(?<!c)b/" "(?<!c)b" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1382 "\"b\" =~ /(?<!c)b/" "(?<!c)b" nil nil nil nil "b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1383 "\"aba\" =~ /(?:..)*a/" "(?:..)*a" nil nil nil nil "aba" nil 1 0 "aba" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1384 "\"aba\" =~ /(?:..)*?a/" "(?:..)*?a" nil nil nil nil "aba" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1385 "\"abc\" =~ /^(?:b|a(?=(.)))*\\1/" "^(?:b|a(?=(.)))*\\1" nil nil nil nil "abc" nil 1 0 "ab" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1386 "\"abc\" =~ /^(){3,5}/" "^(){3,5}" nil nil nil nil "abc" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1387 "\"aax\" =~ /^(a+)*ax/" "^(a+)*ax" nil nil nil nil "aax" nil 1 0 "aax" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1388 "\"aax\" =~ /^((a|b)+)*ax/" "^((a|b)+)*ax" nil nil nil nil "aax" nil 1 0 "aax" ("a" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1389 "\"aax\" =~ /^((a|bc)+)*ax/" "^((a|bc)+)*ax" nil nil nil nil "aax" nil 1 0 "aax" ("a" "a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1390 "\"cab\" =~ /(a|x)*ab/" "(a|x)*ab" nil nil nil nil "cab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1391 "\"cab\" =~ /(a)*ab/" "(a)*ab" nil nil nil nil "cab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1392 "\"ab\" =~ /(?:(?i)a)b/" "(?:(?i)a)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1393 "\"ab\" =~ /((?i)a)b/" "((?i)a)b" nil nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1394 "\"Ab\" =~ /(?:(?i)a)b/" "(?:(?i)a)b" nil nil nil nil "Ab" nil 1 0 "Ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1395 "\"Ab\" =~ /((?i)a)b/" "((?i)a)b" nil nil nil nil "Ab" nil 1 0 "Ab" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1396 "\"cb\" =~ /(?:(?i)a)b/" "(?:(?i)a)b" nil nil nil nil "cb" nil 1 0 nil nil) +(1397 "\"aB\" =~ /(?:(?i)a)b/" "(?:(?i)a)b" nil nil nil nil "aB" nil 1 0 nil nil) +(1398 "\"ab\" =~ /(?i:a)b/" "(?i:a)b" nil nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1399 "\"ab\" =~ /((?i:a))b/" "((?i:a))b" nil nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1400 "\"Ab\" =~ /(?i:a)b/" "(?i:a)b" nil nil nil nil "Ab" nil 1 0 "Ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1401 "\"Ab\" =~ /((?i:a))b/" "((?i:a))b" nil nil nil nil "Ab" nil 1 0 "Ab" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1402 "\"aB\" =~ /(?i:a)b/" "(?i:a)b" nil nil nil nil "aB" nil 1 0 nil nil) +(1403 "\"aB\" =~ /(?i:a)b/" "(?i:a)b" nil nil nil nil "aB" nil 1 0 nil nil) +(1404 "\"ab\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1405 "\"ab\" =~ /((?-i)a)b/i" "((?-i)a)b" t nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1406 "\"aB\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1407 "\"aB\" =~ /((?-i)a)b/i" "((?-i)a)b" t nil nil nil "aB" nil 1 0 "aB" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1408 "\"aB\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1409 "\"Ab\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "Ab" nil 1 0 nil nil) +(1410 "\"aB\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1411 "\"aB\" =~ /((?-i)a)b/i" "((?-i)a)b" t nil nil nil "aB" nil 1 0 "aB" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1412 "\"Ab\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "Ab" nil 1 0 nil nil) +(1413 "\"AB\" =~ /(?:(?-i)a)b/i" "(?:(?-i)a)b" t nil nil nil "AB" nil 1 0 nil nil) +(1414 "\"ab\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "ab" nil 1 0 "ab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1415 "\"ab\" =~ /((?-i:a))b/i" "((?-i:a))b" t nil nil nil "ab" nil 1 0 "ab" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1416 "\"aB\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1417 "\"aB\" =~ /((?-i:a))b/i" "((?-i:a))b" t nil nil nil "aB" nil 1 0 "aB" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1418 "\"AB\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "AB" nil 1 0 nil nil) +(1419 "\"Ab\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "Ab" nil 1 0 nil nil) +(1420 "\"aB\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "aB" nil 1 0 "aB" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1421 "\"aB\" =~ /((?-i:a))b/i" "((?-i:a))b" t nil nil nil "aB" nil 1 0 "aB" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1422 "\"Ab\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "Ab" nil 1 0 nil nil) +(1423 "\"AB\" =~ /(?-i:a)b/i" "(?-i:a)b" t nil nil nil "AB" nil 1 0 nil nil) +(1424 "\"AB\" =~ /((?-i:a.))b/i" "((?-i:a.))b" t nil nil nil "AB" nil 1 0 nil nil) +(1425 "\"a\\nB\" =~ /((?-i:a.))b/i" "((?-i:a.))b" t nil nil nil "a +B" nil 1 0 nil nil) +(1426 "\"a\\nB\" =~ /((?s-i:a.))b/i" "((?s-i:a.))b" t nil nil nil "a +B" nil 1 0 "a +B" ("a +" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1427 "\"cabbbb\" =~ /(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b)))/" "(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b)))" nil nil nil nil "cabbbb" nil 1 0 "cabbbb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1428 "\"caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\" =~ /(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb)))/" "(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb)))" nil nil nil nil "caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" nil 1 0 "caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1429 "\"Ab4ab\" =~ /(ab)\\d\\1/i" "(ab)\\d\\1" t nil nil nil "Ab4ab" nil 1 0 "Ab4ab" ("Ab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1430 "\"ab4Ab\" =~ /(ab)\\d\\1/i" "(ab)\\d\\1" t nil nil nil "ab4Ab" nil 1 0 "ab4Ab" ("ab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1431 "\"foobar1234baz\" =~ /foo\\w*\\d{4}baz/" "foo\\w*\\d{4}baz" nil nil nil nil "foobar1234baz" nil 1 0 "foobar1234baz" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1432 "\"x~~\" =~ /x(~~)*(?:(?:F)?)?/" "x(~~)*(?:(?:F)?)?" nil nil nil nil "x~~" nil 1 0 "x~~" ("~~" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1433 "\"aaac\" =~ /^a(?#xxx){3}c/" "^a(?#xxx){3}c" nil nil nil nil "aaac" nil 1 0 "aaac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1434 "\"aaac\" =~ /^a(?#xxx)(?#xxx){3}c/" "^a(?#xxx)(?#xxx){3}c" nil nil nil nil "aaac" nil 1 0 "aaac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1435 "\"aaac\" =~ /^a (?#xxx) (?#yyy) {3}c/x" "^a (?#xxx) (?#yyy) {3}c" nil nil nil t "aaac" nil 1 0 "aaac" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1436 "\"B\\nB\" =~ /(?<![cd])b/" "(?<![cd])b" nil nil nil nil "B +B" nil 1 0 nil nil) +(1437 "\"dbcb\" =~ /(?<![cd])b/" "(?<![cd])b" nil nil nil nil "dbcb" nil 1 0 nil nil) +(1438 "\"dbaacb\" =~ /(?<![cd])[ab]/" "(?<![cd])[ab]" nil nil nil nil "dbaacb" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1439 "\"dbaacb\" =~ /(?<!(c|d))[ab]/" "(?<!(c|d))[ab]" nil nil nil nil "dbaacb" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1440 "\"cdaccb\" =~ /(?<!cd)[ab]/" "(?<!cd)[ab]" nil nil nil nil "cdaccb" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1441 "\"dbcb\" =~ /^(?:a?b?)*$/" "^(?:a?b?)*$" nil nil nil nil "dbcb" nil 1 0 nil nil) +(1442 "\"a--\" =~ /^(?:a?b?)*$/" "^(?:a?b?)*$" nil nil nil nil "a--" nil 1 0 nil nil) +(1443 "\"a\\nb\\nc\\n\" =~ /((?s)^a(.))((?m)^b$)/" "((?s)^a(.))((?m)^b$)" nil nil nil nil "a +b +c +" nil 1 0 "a +b" ("a +" " +" "b" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1444 "\"a\\nb\\nc\\n\" =~ /((?m)^b$)/" "((?m)^b$)" nil nil nil nil "a +b +c +" nil 1 0 "b" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1445 "\"a\\nb\\n\" =~ /(?m)^b/" "(?m)^b" nil nil nil nil "a +b +" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1446 "\"a\\nb\\n\" =~ /(?m)^(b)/" "(?m)^(b)" nil nil nil nil "a +b +" nil 1 0 "b" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1447 "\"a\\nb\\n\" =~ /((?m)^b)/" "((?m)^b)" nil nil nil nil "a +b +" nil 1 0 "b" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1448 "\"a\\nb\\n\" =~ /\\n((?m)^b)/" "\\n((?m)^b)" nil nil nil nil "a +b +" nil 1 0 " +b" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1449 "\"a\\nb\\nc\\n\" =~ /((?s).)c(?!.)/" "((?s).)c(?!.)" nil nil nil nil "a +b +c +" nil 1 0 " +c" (" +" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1450 "\"a\\nb\\nc\\n\" =~ /((?s).)c(?!.)/" "((?s).)c(?!.)" nil nil nil nil "a +b +c +" nil 1 0 " +c" (" +" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1451 "\"a\\nb\\nc\\n\" =~ /((?s)b.)c(?!.)/" "((?s)b.)c(?!.)" nil nil nil nil "a +b +c +" nil 1 0 "b +c" ("b +" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1452 "\"a\\nb\\nc\\n\" =~ /((?s)b.)c(?!.)/" "((?s)b.)c(?!.)" nil nil nil nil "a +b +c +" nil 1 0 "b +c" ("b +" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1453 "\"a\\nb\\nc\\n\" =~ /()^b/" "()^b" nil nil nil nil "a +b +c +" nil 1 0 nil nil) +(1454 "\"a\\nb\\nc\\n\" =~ /()^b/" "()^b" nil nil nil nil "a +b +c +" nil 1 0 nil nil) +(1455 "\"a\\nb\\nc\\n\" =~ /((?m)^b)/" "((?m)^b)" nil nil nil nil "a +b +c +" nil 1 0 "b" ("b" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1456 "\"a\" =~ /(?(1)b|a)/" "(?(1)b|a)" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1457 "\"a\" =~ /(x)?(?(1)a|b)/" "(x)?(?(1)a|b)" nil nil nil nil "a" nil 1 0 nil nil) +(1458 "\"a\" =~ /(x)?(?(1)a|b)/" "(x)?(?(1)a|b)" nil nil nil nil "a" nil 1 0 nil nil) +(1459 "\"a\" =~ /(x)?(?(1)b|a)/" "(x)?(?(1)b|a)" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1460 "\"a\" =~ /()?(?(1)b|a)/" "()?(?(1)b|a)" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1461 "\"a\" =~ /()?(?(1)a|b)/" "()?(?(1)a|b)" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1462 "\"(blah)\" =~ /^(\$)?blah(?(1)(\$))$/" "^(\$)?blah(?(1)(\$))$" nil nil nil nil "(blah)" nil 1 0 "(blah)" ("(" ")" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1463 "\"blah\" =~ /^(\$)?blah(?(1)(\$))$/" "^(\$)?blah(?(1)(\$))$" nil nil nil nil "blah" nil 1 0 "blah" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1464 "\"a\" =~ /^(\$)?blah(?(1)(\$))$/" "^(\$)?blah(?(1)(\$))$" nil nil nil nil "a" nil 1 0 nil nil) +(1465 "\"blah)\" =~ /^(\$)?blah(?(1)(\$))$/" "^(\$)?blah(?(1)(\$))$" nil nil nil nil "blah)" nil 1 0 nil nil) +(1466 "\"(blah\" =~ /^(\$)?blah(?(1)(\$))$/" "^(\$)?blah(?(1)(\$))$" nil nil nil nil "(blah" nil 1 0 nil nil) +(1467 "\"(blah)\" =~ /^(\$+)?blah(?(1)(\$))$/" "^(\$+)?blah(?(1)(\$))$" nil nil nil nil "(blah)" nil 1 0 "(blah)" ("(" ")" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1468 "\"blah\" =~ /^(\$+)?blah(?(1)(\$))$/" "^(\$+)?blah(?(1)(\$))$" nil nil nil nil "blah" nil 1 0 "blah" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1469 "\"blah)\" =~ /^(\$+)?blah(?(1)(\$))$/" "^(\$+)?blah(?(1)(\$))$" nil nil nil nil "blah)" nil 1 0 nil nil) +(1470 "\"(blah\" =~ /^(\$+)?blah(?(1)(\$))$/" "^(\$+)?blah(?(1)(\$))$" nil nil nil nil "(blah" nil 1 0 nil nil) +(1471 "\"a\" =~ /(?(?!a)b|a)/" "(?(?!a)b|a)" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1472 "\"a\" =~ /(?(?=a)b|a)/" "(?(?=a)b|a)" nil nil nil nil "a" nil 1 0 nil nil) +(1473 "\"a\" =~ /(?(?=a)b|a)/" "(?(?=a)b|a)" nil nil nil nil "a" nil 1 0 nil nil) +(1474 "\"a\" =~ /(?(?=a)a|b)/" "(?(?=a)a|b)" nil nil nil nil "a" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1475 "\"aaab\" =~ /(?=(a+?))(\\1ab)/" "(?=(a+?))(\\1ab)" nil nil nil nil "aaab" nil 1 0 "aab" ("a" "aab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1476 "\"one:\" =~ /(\\w+:)+/" "(\\w+:)+" nil nil nil nil "one:" nil 1 0 "one:" ("one:" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1477 "\"a\" =~ /$(?<=^(a))/" "$(?<=^(a))" nil nil nil nil "a" nil 1 0 "" ("a" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1478 "\"aaab\" =~ /(?=(a+?))(\\1ab)/" "(?=(a+?))(\\1ab)" nil nil nil nil "aaab" nil 1 0 "aab" ("a" "aab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1479 "\"aaab\" =~ /^(?=(a+?))\\1ab/" "^(?=(a+?))\\1ab" nil nil nil nil "aaab" nil 1 0 nil nil) +(1480 "\"aaab\" =~ /^(?=(a+?))\\1ab/" "^(?=(a+?))\\1ab" nil nil nil nil "aaab" nil 1 0 nil nil) +(1481 "\"abcd\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "abcd" nil 1 0 "abcd" (nil "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1482 "\"xy:z:::abcd\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "xy:z:::abcd" nil 1 0 "xy:z:::abcd" ("xy:z:::" "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1483 "\"aexycd\" =~ /^[^bcd]*(c+)/" "^[^bcd]*(c+)" nil nil nil nil "aexycd" nil 1 0 "aexyc" ("c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1484 "\"caab\" =~ /(a*)b+/" "(a*)b+" nil nil nil nil "caab" nil 1 0 "aab" ("aa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1485 "\"abcd\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "abcd" nil 1 0 "abcd" (nil "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1486 "\"xy:z:::abcd\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "xy:z:::abcd" nil 1 0 "xy:z:::abcd" ("xy:z:::" "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1487 "\"abcd:\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "abcd:" nil 1 0 nil nil) +(1488 "\"abcd:\" =~ /([\\w:]+::)?(\\w+)$/" "([\\w:]+::)?(\\w+)$" nil nil nil nil "abcd:" nil 1 0 nil nil) +(1489 "\"aexycd\" =~ /^[^bcd]*(c+)/" "^[^bcd]*(c+)" nil nil nil nil "aexycd" nil 1 0 "aexyc" ("c" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1490 "\"aaab\" =~ /(?>a+)b/" "(?>a+)b" nil nil nil nil "aaab" nil 1 0 "aaab" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1491 "\"a:[b]:\" =~ /([[:]+)/" "([[:]+)" nil nil nil nil "a:[b]:" nil 1 0 ":[" (":[" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1492 "\"a=[b]=\" =~ /([[=]+)/" "([[=]+)" nil nil nil nil "a=[b]=" nil 1 0 "=[" ("=[" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1493 "\"a.[b].\" =~ /([[.]+)/" "([[.]+)" nil nil nil nil "a.[b]." nil 1 0 ".[" (".[" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1494 "\"aaab\" =~ /((?>a+)b)/" "((?>a+)b)" nil nil nil nil "aaab" nil 1 0 "aaab" ("aaab" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1495 "\"aaab\" =~ /(?>(a+))b/" "(?>(a+))b" nil nil nil nil "aaab" nil 1 0 "aaab" ("aaa" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1496 "\"((abc(ade)ufh()()x\" =~ /((?>[^()]+)|\$[^()]*\$)+/" "((?>[^()]+)|\$[^()]*\$)+" nil nil nil nil "((abc(ade)ufh()()x" nil 1 0 "abc(ade)ufh()()x" ("x" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1497 "\"aaab\" =~ /a\\Z/" "a\\Z" nil nil nil nil "aaab" nil 1 0 nil nil) +(1498 "\"a\\nb\\n\" =~ /a\\Z/" "a\\Z" nil nil nil nil "a +b +" nil 1 0 nil nil) +(1499 "\"a\\nb\\n\" =~ /b\\Z/" "b\\Z" nil nil nil nil "a +b +" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1500 "\"a\\nb\" =~ /b\\Z/" "b\\Z" nil nil nil nil "a +b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1501 "\"a\\nb\" =~ /b\\z/" "b\\z" nil nil nil nil "a +b" nil 1 0 "b" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1502 "\"a\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a" nil 1 0 "a" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1503 "\"abc\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "abc" nil 1 0 "abc" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1504 "\"a-b\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a-b" nil 1 0 "a-b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1505 "\"0-9\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "0-9" nil 1 0 "0-9" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1506 "\"a.b\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a.b" nil 1 0 "a.b" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1507 "\"5.6.7\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "5.6.7" nil 1 0 "5.6.7" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1508 "\"the.quick.brown.fox\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "the.quick.brown.fox" nil 1 0 "the.quick.brown.fox" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1509 "\"a100.b200.300c\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a100.b200.300c" nil 1 0 "a100.b200.300c" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1510 "\"12-ab.1245\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "12-ab.1245" nil 1 0 "12-ab.1245" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1511 "\"\\\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "" nil 1 0 nil nil) +(1512 "\".a\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil ".a" nil 1 0 nil nil) +(1513 "\"-a\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "-a" nil 1 0 nil nil) +(1514 "\"a-\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a-" nil 1 0 nil nil) +(1515 "\"a.\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a." nil 1 0 nil nil) +(1516 "\"a_b\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a_b" nil 1 0 nil nil) +(1517 "\"a.-\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a.-" nil 1 0 nil nil) +(1518 "\"a..\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "a.." nil 1 0 nil nil) +(1519 "\"ab..bc\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "ab..bc" nil 1 0 nil nil) +(1520 "\"the.quick.brown.fox-\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "the.quick.brown.fox-" nil 1 0 nil nil) +(1521 "\"the.quick.brown.fox.\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "the.quick.brown.fox." nil 1 0 nil nil) +(1522 "\"the.quick.brown.fox_\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "the.quick.brown.fox_" nil 1 0 nil nil) +(1523 "\"the.quick.brown.fox+\" =~ /^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$/" "^(?>(?(1)\\.|())[^\\W_](?>[a-z0-9-]*[^\\W_])?)+$" nil nil nil nil "the.quick.brown.fox+" nil 1 0 nil nil) +(1524 "\"alphabetabcd\" =~ /(?>.*)(?<=(abcd|wxyz))/" "(?>.*)(?<=(abcd|wxyz))" nil nil nil nil "alphabetabcd" nil 1 0 "alphabetabcd" ("abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1525 "\"endingwxyz\" =~ /(?>.*)(?<=(abcd|wxyz))/" "(?>.*)(?<=(abcd|wxyz))" nil nil nil nil "endingwxyz" nil 1 0 "endingwxyz" ("wxyz" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1526 "\"a rather long string that doesn't end with one of them\" =~ /(?>.*)(?<=(abcd|wxyz))/" "(?>.*)(?<=(abcd|wxyz))" nil nil nil nil "a rather long string that doesn't end with one of them" nil 1 0 nil nil) +(1527 "\"word cat dog elephant mussel cow horse canary baboon snake shark otherword\" =~ /word (?>(?:(?!otherword)[a-zA-Z0-9]+ ){0,30})otherword/" "word (?>(?:(?!otherword)[a-zA-Z0-9]+ ){0,30})otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark otherword" nil 1 0 "word cat dog elephant mussel cow horse canary baboon snake shark otherword" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1528 "\"word cat dog elephant mussel cow horse canary baboon snake shark\" =~ /word (?>(?:(?!otherword)[a-zA-Z0-9]+ ){0,30})otherword/" "word (?>(?:(?!otherword)[a-zA-Z0-9]+ ){0,30})otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark" nil 1 0 nil nil) +(1529 "\"word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope\" =~ /word (?>[a-zA-Z0-9]+ ){0,30}otherword/" "word (?>[a-zA-Z0-9]+ ){0,30}otherword" nil nil nil nil "word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope" nil 1 0 nil nil) +(1530 "\"999foo\" =~ /(?<=\\d{3}(?!999))foo/" "(?<=\\d{3}(?!999))foo" nil nil nil nil "999foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1531 "\"123999foo\" =~ /(?<=\\d{3}(?!999))foo/" "(?<=\\d{3}(?!999))foo" nil nil nil nil "123999foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1532 "\"123abcfoo\" =~ /(?<=\\d{3}(?!999))foo/" "(?<=\\d{3}(?!999))foo" nil nil nil nil "123abcfoo" nil 1 0 nil nil) +(1533 "\"999foo\" =~ /(?<=(?!...999)\\d{3})foo/" "(?<=(?!...999)\\d{3})foo" nil nil nil nil "999foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1534 "\"123999foo\" =~ /(?<=(?!...999)\\d{3})foo/" "(?<=(?!...999)\\d{3})foo" nil nil nil nil "123999foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1535 "\"123abcfoo\" =~ /(?<=(?!...999)\\d{3})foo/" "(?<=(?!...999)\\d{3})foo" nil nil nil nil "123abcfoo" nil 1 0 nil nil) +(1536 "\"123abcfoo\" =~ /(?<=\\d{3}(?!999)...)foo/" "(?<=\\d{3}(?!999)...)foo" nil nil nil nil "123abcfoo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1537 "\"123456foo\" =~ /(?<=\\d{3}(?!999)...)foo/" "(?<=\\d{3}(?!999)...)foo" nil nil nil nil "123456foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1538 "\"123999foo\" =~ /(?<=\\d{3}(?!999)...)foo/" "(?<=\\d{3}(?!999)...)foo" nil nil nil nil "123999foo" nil 1 0 nil nil) +(1539 "\"123abcfoo\" =~ /(?<=\\d{3}...)(?<!999)foo/" "(?<=\\d{3}...)(?<!999)foo" nil nil nil nil "123abcfoo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1540 "\"123456foo\" =~ /(?<=\\d{3}...)(?<!999)foo/" "(?<=\\d{3}...)(?<!999)foo" nil nil nil nil "123456foo" nil 1 0 "foo" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1541 "\"123999foo\" =~ /(?<=\\d{3}...)(?<!999)foo/" "(?<=\\d{3}...)(?<!999)foo" nil nil nil nil "123999foo" nil 1 0 nil nil) +(1542 "\"<a href=abcd xyz\" =~ /<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=abcd xyz" nil 1 0 "<a href=abcd" (nil nil "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1543 "\"<a href=\\\"abcd xyz pqr\\\" cats\" =~ /<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=\"abcd xyz pqr\" cats" nil 1 0 "<a href=\"abcd xyz pqr\"" ("\"" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1544 "\"<a href=\\'abcd xyz pqr\\' cats\" =~ /<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a[\\s]+href[\\s]*=[\\s]* # find <a href= + ([\\\"\\'])? # find single or double quote + (?(1) (.*?)\\1 | ([^\\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href='abcd xyz pqr' cats" nil 1 0 "<a href='abcd xyz pqr'" ("'" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1545 "\"<a href=abcd xyz\" =~ /<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=abcd xyz" nil 1 0 "<a href=abcd" (nil nil "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1546 "\"<a href=\\\"abcd xyz pqr\\\" cats\" =~ /<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=\"abcd xyz pqr\" cats" nil 1 0 "<a href=\"abcd xyz pqr\"" ("\"" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1547 "\"<a href = \\'abcd xyz pqr\\' cats\" =~ /<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href\\s*=\\s* # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href = 'abcd xyz pqr' cats" nil 1 0 "<a href = 'abcd xyz pqr'" ("'" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1548 "\"<a href=abcd xyz\" =~ /<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=abcd xyz" nil 1 0 "<a href=abcd" (nil nil "abcd" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1549 "\"<a href=\\\"abcd xyz pqr\\\" cats\" =~ /<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href=\"abcd xyz pqr\" cats" nil 1 0 "<a href=\"abcd xyz pqr\"" ("\"" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1550 "\"<a href = \\'abcd xyz pqr\\' cats\" =~ /<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx" "<a\\s+href(?>\\s*)=(?>\\s*) # find <a href= + ([\"'])? # find single or double quote + (?(1) (.*?)\\1 | (\\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +" t nil t t "<a href = 'abcd xyz pqr' cats" nil 1 0 "<a href = 'abcd xyz pqr'" ("'" "abcd xyz pqr" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1551 "\"ZABCDEFG\" =~ /((Z)+|A)*/" "((Z)+|A)*" nil nil nil nil "ZABCDEFG" nil 1 0 "ZA" ("A" "Z" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1552 "\"ZABCDEFG\" =~ /(Z()|A)*/" "(Z()|A)*" nil nil nil nil "ZABCDEFG" nil 1 0 "ZA" ("A" "" nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1553 "\"ZABCDEFG\" =~ /(Z(())|A)*/" "(Z(())|A)*" nil nil nil nil "ZABCDEFG" nil 1 0 "ZA" ("A" "" "" nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1554 "\"ZABCDEFG\" =~ /((?>Z)+|A)*/" "((?>Z)+|A)*" nil nil nil nil "ZABCDEFG" nil 1 0 "ZA" ("A" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1555 "\"ZABCDEFG\" =~ /((?>)+|A)*/" "((?>)+|A)*" nil nil nil nil "ZABCDEFG" nil 1 0 "" ("" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1556 "\"abbab\" =~ /a*/" "a*" nil nil nil nil "abbab" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1557 "\"abcde\" =~ /^[a-\\d]/" "^[a-\\d]" nil nil nil nil "abcde" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1558 "\"-things\" =~ /^[a-\\d]/" "^[a-\\d]" nil nil nil nil "-things" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1559 "\"0digit\" =~ /^[a-\\d]/" "^[a-\\d]" nil nil nil nil "0digit" nil 1 0 "0" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1560 "\"bcdef\" =~ /^[a-\\d]/" "^[a-\\d]" nil nil nil nil "bcdef" nil 1 0 nil nil) +(1561 "\"abcde\" =~ /^[\\d-a]/" "^[\\d-a]" nil nil nil nil "abcde" nil 1 0 "a" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1562 "\"-things\" =~ /^[\\d-a]/" "^[\\d-a]" nil nil nil nil "-things" nil 1 0 "-" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1563 "\"0digit\" =~ /^[\\d-a]/" "^[\\d-a]" nil nil nil nil "0digit" nil 1 0 "0" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1564 "\"bcdef\" =~ /^[\\d-a]/" "^[\\d-a]" nil nil nil nil "bcdef" nil 1 0 nil nil) +(1565 "\"abcdef\" =~ /(?<=abc).*(?=def)/" "(?<=abc).*(?=def)" nil nil nil nil "abcdef" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1566 "\"abcxdef\" =~ /(?<=abc).*(?=def)/" "(?<=abc).*(?=def)" nil nil nil nil "abcxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1567 "\"abcxdefxdef\" =~ /(?<=abc).*(?=def)/" "(?<=abc).*(?=def)" nil nil nil nil "abcxdefxdef" nil 1 0 "xdefx" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1568 "\"abcdef\" =~ /(?<=abc).*?(?=def)/" "(?<=abc).*?(?=def)" nil nil nil nil "abcdef" nil 1 0 "" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1569 "\"abcxdef\" =~ /(?<=abc).*?(?=def)/" "(?<=abc).*?(?=def)" nil nil nil nil "abcxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1570 "\"abcxdefxdef\" =~ /(?<=abc).*?(?=def)/" "(?<=abc).*?(?=def)" nil nil nil nil "abcxdefxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1571 "\"abcdef\" =~ /(?<=abc).+(?=def)/" "(?<=abc).+(?=def)" nil nil nil nil "abcdef" nil 1 0 nil nil) +(1572 "\"abcxdef\" =~ /(?<=abc).+(?=def)/" "(?<=abc).+(?=def)" nil nil nil nil "abcxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1573 "\"abcxdefxdef\" =~ /(?<=abc).+(?=def)/" "(?<=abc).+(?=def)" nil nil nil nil "abcxdefxdef" nil 1 0 "xdefx" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1574 "\"abcdef\" =~ /(?<=abc).+?(?=def)/" "(?<=abc).+?(?=def)" nil nil nil nil "abcdef" nil 1 0 nil nil) +(1575 "\"abcxdef\" =~ /(?<=abc).+?(?=def)/" "(?<=abc).+?(?=def)" nil nil nil nil "abcxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1576 "\"abcxdefxdef\" =~ /(?<=abc).+?(?=def)/" "(?<=abc).+?(?=def)" nil nil nil nil "abcxdefxdef" nil 1 0 "x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1577 "\"-abcdef\" =~ /(?<=\\b)(.*)/" "(?<=\\b)(.*)" nil nil nil nil "-abcdef" nil 1 0 "abcdef" ("abcdef" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1578 "\"abcdef\" =~ /(?<=\\b)(.*)/" "(?<=\\b)(.*)" nil nil nil nil "abcdef" nil 1 0 "abcdef" ("abcdef" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1579 "\"-abcdef\" =~ /(?<=\\B)(.*)/" "(?<=\\B)(.*)" nil nil nil nil "-abcdef" nil 1 0 "-abcdef" ("-abcdef" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1580 "\"abcdef\" =~ /(?<=\\B)(.*)/" "(?<=\\B)(.*)" nil nil nil nil "abcdef" nil 1 0 "bcdef" ("bcdef" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1581 "\"'a'\" =~ /^'[ab]'/" "^'[ab]'" nil nil nil nil "'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1582 "\"'b'\" =~ /^'[ab]'/" "^'[ab]'" nil nil nil nil "'b'" nil 1 0 "'b'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1583 "\"x'a'\" =~ /^'[ab]'/" "^'[ab]'" nil nil nil nil "x'a'" nil 1 0 nil nil) +(1584 "\"'a'x\" =~ /^'[ab]'/" "^'[ab]'" nil nil nil nil "'a'x" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1585 "\"'ab'\" =~ /^'[ab]'/" "^'[ab]'" nil nil nil nil "'ab'" nil 1 0 nil nil) +(1586 "\"'a'\" =~ /^'[ab]'$/" "^'[ab]'$" nil nil nil nil "'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1587 "\"'b'\" =~ /^'[ab]'$/" "^'[ab]'$" nil nil nil nil "'b'" nil 1 0 "'b'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1588 "\"x'a'\" =~ /^'[ab]'$/" "^'[ab]'$" nil nil nil nil "x'a'" nil 1 0 nil nil) +(1589 "\"'a'x\" =~ /^'[ab]'$/" "^'[ab]'$" nil nil nil nil "'a'x" nil 1 0 nil nil) +(1590 "\"'ab'\" =~ /^'[ab]'$/" "^'[ab]'$" nil nil nil nil "'ab'" nil 1 0 nil nil) +(1591 "\"'a'\" =~ /'[ab]'$/" "'[ab]'$" nil nil nil nil "'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1592 "\"'b'\" =~ /'[ab]'$/" "'[ab]'$" nil nil nil nil "'b'" nil 1 0 "'b'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1593 "\"x'a'\" =~ /'[ab]'$/" "'[ab]'$" nil nil nil nil "x'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1594 "\"'a'x\" =~ /'[ab]'$/" "'[ab]'$" nil nil nil nil "'a'x" nil 1 0 nil nil) +(1595 "\"'ab'\" =~ /'[ab]'$/" "'[ab]'$" nil nil nil nil "'ab'" nil 1 0 nil nil) +(1596 "\"'a'\" =~ /'[ab]'/" "'[ab]'" nil nil nil nil "'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1597 "\"'b'\" =~ /'[ab]'/" "'[ab]'" nil nil nil nil "'b'" nil 1 0 "'b'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1598 "\"x'a'\" =~ /'[ab]'/" "'[ab]'" nil nil nil nil "x'a'" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1599 "\"'a'x\" =~ /'[ab]'/" "'[ab]'" nil nil nil nil "'a'x" nil 1 0 "'a'" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1600 "\"'ab'\" =~ /'[ab]'/" "'[ab]'" nil nil nil nil "'ab'" nil 1 0 nil nil) +(1601 "\"abc\" =~ /abc\\E/" "abc\\E" nil nil nil nil "abc" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1602 "\"abcE\" =~ /abc\\E/" "abc\\E" nil nil nil nil "abcE" nil 1 0 "abc" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1603 "\"abcx\" =~ /abc[\\Ex]/" "abc[\\Ex]" nil nil nil nil "abcx" nil 1 0 "abcx" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1604 "\"abcE\" =~ /abc[\\Ex]/" "abc[\\Ex]" nil nil nil nil "abcE" nil 1 0 nil nil) +(1605 "\"a*\" =~ /^\\Qa*\\E$/" "^\\Qa*\\E$" nil nil nil nil "a*" nil 1 0 "a*" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1606 "\"a\" =~ /^\\Qa*\\E$/" "^\\Qa*\\E$" nil nil nil nil "a" nil 1 0 nil nil) +(1607 "\"a*x\" =~ /\\Qa*x\\E/" "\\Qa*x\\E" nil nil nil nil "a*x" nil 1 0 "a*x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1608 "\"a*\" =~ /\\Qa*x\\E/" "\\Qa*x\\E" nil nil nil nil "a*" nil 1 0 nil nil) +(1609 "\"a*x\" =~ /\\Qa*x/" "\\Qa*x" nil nil nil nil "a*x" nil 1 0 "a*x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1610 "\"a*\" =~ /\\Qa*x/" "\\Qa*x" nil nil nil nil "a*" nil 1 0 nil nil) +(1611 "\"a*x\" =~ /\\Q\\Qa*x\\E\\E/" "\\Q\\Qa*x\\E\\E" nil nil nil nil "a*x" nil 1 0 nil nil) +(1612 "\"a\\\\*x\" =~ /\\Q\\Qa*x\\E\\E/" "\\Q\\Qa*x\\E\\E" nil nil nil nil "a\\*x" nil 1 0 "a\\*x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1613 "\"a*x\" =~ /\\Q\\Qa*x\\E/" "\\Q\\Qa*x\\E" nil nil nil nil "a*x" nil 1 0 nil nil) +(1614 "\"a\\\\*x\" =~ /\\Q\\Qa*x\\E/" "\\Q\\Qa*x\\E" nil nil nil nil "a\\*x" nil 1 0 "a\\*x" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1615 "\"a[x]\" =~ /a\\Q[x\\E]/" "a\\Q[x\\E]" nil nil nil nil "a[x]" nil 1 0 "a[x]" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1616 "\"ax\" =~ /a\\Q[x\\E]/" "a\\Q[x\\E]" nil nil nil nil "ax" nil 1 0 nil nil) +(1617 "\"a\" =~ /a#comment\\Q... +{2}/x" "a#comment\\Q... +{2}" nil nil nil t "a" nil 1 0 nil nil) +(1618 "\"aa\" =~ /a#comment\\Q... +{2}/x" "a#comment\\Q... +{2}" nil nil nil t "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1619 "\"a\" =~ /a(?#comment\\Q... +){2}/x" "a(?#comment\\Q... +){2}" nil nil nil t "a" nil 1 0 nil nil) +(1620 "\"aa\" =~ /a(?#comment\\Q... +){2}/x" "a(?#comment\\Q... +){2}" nil nil nil t "aa" nil 1 0 "aa" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1621 "\"a.\" =~ /(?x)a#\\Q +./" "(?x)a#\\Q +." nil nil nil nil "a." nil 1 0 "a." (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1622 "\"aa\" =~ /(?x)a#\\Q +./" "(?x)a#\\Q +." nil nil nil nil "aa" nil 1 0 nil nil) +(1623 "\"abcdxklqj\" =~ /ab(?=.*q)cd/" "ab(?=.*q)cd" nil nil nil nil "abcdxklqj" nil 1 0 "abcd" (nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) +(1624 "\"ab\" =~ /a(?!.*$)b/" "a(?!.*$)b" nil nil nil nil "ab" nil 1 0 nil nil) Added: vendor/portableaserve/libs/cl-ppcre/testinput =================================================================== --- vendor/portableaserve/libs/cl-ppcre/testinput 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/testinput 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,3945 @@ +/the quick brown fox/ + the quick brown fox + The quick brown FOX + What do you know about the quick brown fox? + What do you know about THE QUICK BROWN FOX? + +/The quick brown fox/i + the quick brown fox + The quick brown FOX + What do you know about the quick brown fox? + What do you know about THE QUICK BROWN FOX? + +/abcd\t\n\r\f\a\e\071\x3b\$\\\?caxyz/ + abcd\t\n\r\f\a\e9;\$\\?caxyz + +/a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/ + abxyzpqrrrabbxyyyypqAzz + abxyzpqrrrabbxyyyypqAzz + aabxyzpqrrrabbxyyyypqAzz + aaabxyzpqrrrabbxyyyypqAzz + aaaabxyzpqrrrabbxyyyypqAzz + abcxyzpqrrrabbxyyyypqAzz + aabcxyzpqrrrabbxyyyypqAzz + aaabcxyzpqrrrabbxyyyypAzz + aaabcxyzpqrrrabbxyyyypqAzz + aaabcxyzpqrrrabbxyyyypqqAzz + aaabcxyzpqrrrabbxyyyypqqqAzz + aaabcxyzpqrrrabbxyyyypqqqqAzz + aaabcxyzpqrrrabbxyyyypqqqqqAzz + aaabcxyzpqrrrabbxyyyypqqqqqqAzz + aaaabcxyzpqrrrabbxyyyypqAzz + abxyzzpqrrrabbxyyyypqAzz + aabxyzzzpqrrrabbxyyyypqAzz + aaabxyzzzzpqrrrabbxyyyypqAzz + aaaabxyzzzzpqrrrabbxyyyypqAzz + abcxyzzpqrrrabbxyyyypqAzz + aabcxyzzzpqrrrabbxyyyypqAzz + aaabcxyzzzzpqrrrabbxyyyypqAzz + aaaabcxyzzzzpqrrrabbxyyyypqAzz + aaaabcxyzzzzpqrrrabbbxyyyypqAzz + aaaabcxyzzzzpqrrrabbbxyyyyypqAzz + aaabcxyzpqrrrabbxyyyypABzz + aaabcxyzpqrrrabbxyyyypABBzz + >>>aaabxyzpqrrrabbxyyyypqAzz + >aaaabxyzpqrrrabbxyyyypqAzz + >>>>abcxyzpqrrrabbxyyyypqAzz + abxyzpqrrabbxyyyypqAzz + abxyzpqrrrrabbxyyyypqAzz + abxyzpqrrrabxyyyypqAzz + aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz + aaaabcxyzzzzpqrrrabbbxyyypqAzz + aaabcxyzpqrrrabbxyyyypqqqqqqqAzz + +/^(abc){1,2}zz/ + abczz + abcabczz + zz + abcabcabczz + >>abczz + +/^(b+?|a){1,2}?c/ + bc + bbc + bbbc + bac + bbac + aac + abbbbbbbbbbbc + bbbbbbbbbbbac + aaac + abbbbbbbbbbbac + +/^(b+|a){1,2}c/ + bc + bbc + bbbc + bac + bbac + aac + abbbbbbbbbbbc + bbbbbbbbbbbac + aaac + abbbbbbbbbbbac + +/^(b+|a){1,2}?bc/ + bbc + +/^(b*|ba){1,2}?bc/ + babc + bbabc + bababc + bababbc + babababc + +/^(ba|b*){1,2}?bc/ + babc + bbabc + bababc + bababbc + babababc + +/^\ca\cA\c[\c{\c:/ + \x01\x01\e;z + +/^[ab\]cde]/ + athing + bthing + ]thing + cthing + dthing + ething + fthing + [thing + \\thing + +/^[]cde]/ + ]thing + cthing + dthing + ething + athing + fthing + +/^[^ab\]cde]/ + fthing + [thing + \\thing + athing + bthing + ]thing + cthing + dthing + ething + +/^[^]cde]/ + athing + fthing + ]thing + cthing + dthing + ething + +/^\�/ + � + +/^�/ + � + +/^[0-9]+$/ + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 100 + abc + +/^.*nter/ + enter + inter + uponter + +/^xxx[0-9]+$/ + xxx0 + xxx1234 + xxx + +/^.+[0-9][0-9][0-9]$/ + x123 + xx123 + 123456 + 123 + x1234 + +/^.+?[0-9][0-9][0-9]$/ + x123 + xx123 + 123456 + 123 + x1234 + +/^([^!]+)!(.+)=apquxz\.ixr\.zzz\.ac\.uk$/ + abc!pqr=apquxz.ixr.zzz.ac.uk + !pqr=apquxz.ixr.zzz.ac.uk + abc!=apquxz.ixr.zzz.ac.uk + abc!pqr=apquxz:ixr.zzz.ac.uk + abc!pqr=apquxz.ixr.zzz.ac.ukk + +/:/ + Well, we need a colon: somewhere + Fail if we don't + +/([\da-f:]+)$/i + 0abc + abc + fed + E + :: + 5f03:12C0::932e + fed def + Any old stuff + 0zzz + gzzz + fed\x20 + Any old rubbish + +/^.*\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ + .1.2.3 + A.12.123.0 + .1.2.3333 + 1.2.3 + 1234.2.3 + +/^(\d+)\s+IN\s+SOA\s+(\S+)\s+(\S+)\s*\(\s*$/ + 1 IN SOA non-sp1 non-sp2( + 1 IN SOA non-sp1 non-sp2 ( + 1IN SOA non-sp1 non-sp2( + +/^[a-zA-Z\d][a-zA-Z\d\-]*(\.[a-zA-Z\d][a-zA-z\d\-]*)*\.$/ + a. + Z. + 2. + ab-c.pq-r. + sxk.zzz.ac.uk. + x-.y-. + -abc.peq. + +/^\*\.[a-z]([a-z\-\d]*[a-z\d]+)?(\.[a-z]([a-z\-\d]*[a-z\d]+)?)*$/ + *.a + *.b0-a + *.c3-b.c + *.c-a.b-c + *.0 + *.a- + *.a-b.c- + *.c-a.0-c + +/^(?=ab(de))(abd)(e)/ + abde + +/^(?!(ab)de|x)(abd)(f)/ + abdf + +/^(?=(ab(cd)))(ab)/ + abcd + +/^[\da-f](\.[\da-f])*$/i + a.b.c.d + A.B.C.D + a.b.c.1.2.3.C + +/^\".*\"\s*(;.*)?$/ + \"1234\" + \"abcd\" ; + \"\" ; rhubarb + \"1234\" : things + +/^$/ + \ + +/ ^ a (?# begins with a) b\sc (?# then b c) $ (?# then end)/x + ab c + abc + ab cde + +/(?x) ^ a (?# begins with a) b\sc (?# then b c) $ (?# then end)/ + ab c + abc + ab cde + +/^ a\ b[c ]d $/x + a bcd + a b d + abcd + ab d + +/^(a(b(c)))(d(e(f)))(h(i(j)))(k(l(m)))$/ + abcdefhijklm + +/^(?:a(b(c)))(?:d(e(f)))(?:h(i(j)))(?:k(l(m)))$/ + abcdefhijklm + +/^[\w][\W][\s][\S][\d][\D][\b][\n][\c]][\022]/ + a+ Z0+\x08\n\x1d\x12 + +/^[.^$|()*+?{,}]+/ + .^\$(*+)|{?,?} + +/^a*\w/ + z + az + aaaz + a + aa + aaaa + a+ + aa+ + +/^a*?\w/ + z + az + aaaz + a + aa + aaaa + a+ + aa+ + +/^a+\w/ + az + aaaz + aa + aaaa + aa+ + +/^a+?\w/ + az + aaaz + aa + aaaa + aa+ + +/^\d{8}\w{2,}/ + 1234567890 + 12345678ab + 12345678__ + 1234567 + +/^[aeiou\d]{4,5}$/ + uoie + 1234 + 12345 + aaaaa + 123456 + +/^[aeiou\d]{4,5}?/ + uoie + 1234 + 12345 + aaaaa + 123456 + +/\A(abc|def)=(\1){2,3}\Z/ + abc=abcabc + def=defdefdef + abc=defdef + +/^(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\11*(\3\4)\1(?#)2$/ + abcdefghijkcda2 + abcdefghijkkkkcda2 + +/(cat(a(ract|tonic)|erpillar)) \1()2(3)/ + cataract cataract23 + catatonic catatonic23 + caterpillar caterpillar23 + + +/^From +([^ ]+) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/ + From abcd Mon Sep 01 12:33:02 1997 + +/^From\s+\S+\s+([a-zA-Z]{3}\s+){2}\d{1,2}\s+\d\d:\d\d/ + From abcd Mon Sep 01 12:33:02 1997 + From abcd Mon Sep 1 12:33:02 1997 + From abcd Sep 01 12:33:02 1997 + +/^12.34/s + 12\n34 + 12\r34 + +/\w+(?=\t)/ + the quick brown\t fox + +/foo(?!bar)(.*)/ + foobar is foolish see? + +/(?:(?!foo)...|^.{0,2})bar(.*)/ + foobar crowbar etc + barrel + 2barrel + A barrel + +/^(\D*)(?=\d)(?!123)/ + abc456 + abc123 + +/^1234(?# test newlines + inside)/ + 1234 + +/^1234 #comment in extended re + /x + 1234 + +/#rhubarb + abcd/x + abcd + +/^abcd#rhubarb/x + abcd + +/^(a)\1{2,3}(.)/ + aaab + aaaab + aaaaab + aaaaaab + +/(?!^)abc/ + the abc + abc + +/(?=^)abc/ + abc + the abc + +/^[ab]{1,3}(ab*|b)/ + aabbbbb + +/^[ab]{1,3}?(ab*|b)/ + aabbbbb + +/^[ab]{1,3}?(ab*?|b)/ + aabbbbb + +/^[ab]{1,3}(ab*?|b)/ + aabbbbb + +/ (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* # optional leading comment +(?: (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +) # initial word +(?: (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +) )* # further okay, if led by a period +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* @ (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # initial subdomain +(?: # +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. # if led by a period... +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # ...further okay +)* +# address +| # or +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +) # one word, optionally followed by.... +(?: +[^()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037] | # atom and space parts, or... +$ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) | # comments, or... + +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +# quoted strings +)* +< (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* # leading < +(?: @ (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # initial subdomain +(?: # +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. # if led by a period... +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # ...further okay +)* + +(?: (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* , (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* @ (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # initial subdomain +(?: # +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. # if led by a period... +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # ...further okay +)* +)* # further okay, if led by comma +: # closing colon +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* )? # optional route +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +) # initial word +(?: (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +" (?: # opening quote... +[^\\\x80-\xff\n\015"] # Anything except backslash and quote +| # or +\\ [^\x80-\xff] # Escaped something (something != CR) +)* " # closing quote +) )* # further okay, if led by a period +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* @ (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # initial subdomain +(?: # +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* \. # if led by a period... +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* (?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| \[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) # ...further okay +)* +# address spec +(?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* > # trailing > +# name and address +) (?: [\040\t] | $ +(?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] | \( (?: [^\\\x80-\xff\n\015()] | \\ [^\x80-\xff] )* $ )* +\) )* # optional trailing comment +/x + Alan Other <user$a)dom.ain> + <user\(a)dom.ain> + user\(a)dom.ain + \"A. Other\" <user.1234\(a)dom.ain> (a comment) + A. Other <user.1234\(a)dom.ain> (a comment) + \"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"\(a)x400-re.lay + A missing angle <user\(a)some.where + The quick brown fox + +/[\040\t]* # Nab whitespace. +(?: +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional leading comment +(?: +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +# Quoted string +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +# Quoted string +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address +| # or +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +# Quoted string +) +# leading word +[^()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037] * # "normal" atoms and or spaces +(?: +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +| +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +) # "special" comment or quoted string +[^()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037] * # more "normal" +)* +< +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# < +(?: +@ +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +(?: , +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +@ +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +)* # additional domains +: +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)? # optional route +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +# Quoted string +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +# Atom +| # or +" # " +[^\\\x80-\xff\n\015"] * # normal +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015"] * )* # ( special normal* )* +" # " +# Quoted string +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# additional words +)* +@ +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +(?: +\. +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +(?: +[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+ # some number of atom characters... +(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]) # ..not followed by something that could be part of an atom +| +\[ # [ +(?: [^\\\x80-\xff\n\015\[\]] | \\ [^\x80-\xff] )* # stuff +\] # ] +) +[\040\t]* # Nab whitespace. +(?: +$ # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: # ( +(?: \\ [^\x80-\xff] | +\( # ( +[^\\\x80-\xff\n\015()] * # normal* +(?: \\ [^\x80-\xff] [^\\\x80-\xff\n\015()] * )* # (special normal*)* +$ # ) +) # special +[^\\\x80-\xff\n\015()] * # normal* +)* # )* +\) # ) +[\040\t]* )* # If comment found, allow more spaces. +# optional trailing comments +)* +# address spec +> # > +# name and address +) +/x + Alan Other <user\(a)dom.ain> + <user\(a)dom.ain> + user\(a)dom.ain + \"A. Other\" <user.1234\(a)dom.ain> (a comment) + A. Other <user.1234\(a)dom.ain> (a comment) + \"/s=user/ou=host/o=place/prmd=uu.yy/admd= /c=gb/\"\(a)x400-re.lay + A missing angle <user\(a)some.where + The quick brown fox + +/abc\0def\00pqr\000xyz\0000AB/ + abc\0def\00pqr\000xyz\0000AB + abc456 abc\0def\00pqr\000xyz\0000ABCDE + +/abc\x0def\x00pqr\x000xyz\x0000AB/ + abc\x0def\x00pqr\x000xyz\x0000AB + abc456 abc\x0def\x00pqr\x000xyz\x0000ABCDE + +/^[\000-\037]/ + \0A + \01B + \037C + +/\0*/ + \0\0\0\0 + +/A\x0{2,3}Z/ + The A\x0\x0Z + An A\0\x0\0Z + A\0Z + A\0\x0\0\x0Z + +/^(cow|)\1(bell)/ + cowcowbell + bell + cowbell + +/^\s/ + \040abc + \x0cabc + \nabc + \rabc + \tabc + abc + +/^a b + c/x + abc + +/^(a|)\1*b/ + ab + aaaab + b + acb + +/^(a|)\1+b/ + aab + aaaab + b + ab + +/^(a|)\1?b/ + ab + aab + b + acb + +/^(a|)\1{2}b/ + aaab + b + ab + aab + aaaab + +/^(a|)\1{2,3}b/ + aaab + aaaab + b + ab + aab + aaaaab + +/ab{1,3}bc/ + abbbbc + abbbc + abbc + abc + abbbbbc + +/([^.]*)\.([^:]*):[T ]+(.*)/ + track1.title:TBlah blah blah + +/([^.]*)\.([^:]*):[T ]+(.*)/i + track1.title:TBlah blah blah + +/([^.]*)\.([^:]*):[t ]+(.*)/i + track1.title:TBlah blah blah + +/^[W-c]+$/ + WXY_^abc + wxy + +/^[W-c]+$/i + WXY_^abc + wxy_^ABC + +/^[\x3f-\x5F]+$/i + WXY_^abc + wxy_^ABC + +/^abc$/m + abc + qqq\nabc + abc\nzzz + qqq\nabc\nzzz + +/^abc$/ + abc + qqq\nabc + abc\nzzz + qqq\nabc\nzzz + +/\Aabc\Z/m + abc + abc\n + qqq\nabc + abc\nzzz + qqq\nabc\nzzz + +/\A(.)*\Z/s + abc\ndef + +/\A(.)*\Z/m + abc\ndef + +/(?:b)|(?::+)/ + b::c + c::b + +/[-az]+/ + az- + b + +/[az-]+/ + za- + b + +/[a\-z]+/ + a-z + b + +/[a-z]+/ + abcdxyz + +/[\d-]+/ + 12-34 + aaa + +/[\d-z]+/ + 12-34z + aaa + +/\x5c/ + \\ + +/\x20Z/ + the Zoo + Zulu + +/(abc)\1/i + abcabc + ABCabc + abcABC + +/ab{3cd/ + ab{3cd + +/ab{3,cd/ + ab{3,cd + +/ab{3,4a}cd/ + ab{3,4a}cd + +/{4,5a}bc/ + {4,5a}bc + +/^a.b/ + a\rb + a\nb + +/abc$/ + abc + abc\n + abc\ndef + +/(abc)\123/ + abc\x53 + +/(abc)\223/ + abc\x93 + +/(abc)\323/ + abc\xd3 + +/(abc)\500/ + abc\x40 + abc\100 + +/(abc)\5000/ + abc\x400 + abc\x40\x30 + abc\1000 + abc\100\x30 + abc\100\060 + abc\100\60 + +/abc\81/ + abc\081 + abc\0\x38\x31 + +/abc\91/ + abc\091 + abc\0\x39\x31 + +/(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)(l)\12\123/ + abcdefghijkllS + +/(a)(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)\12\123/ + abcdefghijk\12S + +/ab\gdef/ + abgdef + +/a{0}bc/ + bc + +/(a|(bc)){0,0}?xyz/ + xyz + +/abc[\10]de/ + abc\010de + +/abc[\1]de/ + abc\1de + +/(abc)[\1]de/ + abc\1de + +/a.b(?s)/ + a\nb + +/^([^a])([^\b])([^c]*)([^d]{3,4})/ + baNOTccccd + baNOTcccd + baNOTccd + bacccd + anything + b\bc + baccd + +/[^a]/ + Abc + +/[^a]/i + Abc + +/[^a]+/ + AAAaAbc + +/[^a]+/i + AAAaAbc + +/[^a]+/ + bbb\nccc + +/[^k]$/ + abc + abk + +/[^k]{2,3}$/ + abc + kbc + kabc + abk + akb + akk + +/^\d{8,}\@.+[^k]$/ + 12345678\(a)a.b.c.d + 123456789\(a)x.y.z + 12345678\(a)x.y.uk + 1234567\(a)a.b.c.d + +/(a)\1{8,}/ + aaaaaaaaa + aaaaaaaaaa + aaaaaaa + +/[^a]/ + aaaabcd + aaAabcd + +/[^a]/i + aaaabcd + aaAabcd + +/[^az]/ + aaaabcd + aaAabcd + +/[^az]/i + aaaabcd + aaAabcd + +/\000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057\060\061\062\063\064\065\066\067\070\071\072\073\074\075\076\077\100\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377/ + \000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057\060\061\062\063\064\065\066\067\070\071\072\073\074\075\076\077\100\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377 + +/P[^*]TAIRE[^*]{1,6}?LL/ + xxxxxxxxxxxPSTAIREISLLxxxxxxxxx + +/P[^*]TAIRE[^*]{1,}?LL/ + xxxxxxxxxxxPSTAIREISLLxxxxxxxxx + +/(\.\d\d[1-9]?)\d+/ + 1.230003938 + 1.875000282 + 1.235 + +/(\.\d\d((?=0)|\d(?=\d)))/ + 1.230003938 + 1.875000282 + 1.235 + +/a(?)b/ + ab + +/\b(foo)\s+(\w+)/i + Food is on the foo table + +/foo(.*)bar/ + The food is under the bar in the barn. + +/foo(.*?)bar/ + The food is under the bar in the barn. + +/(.*)(\d*)/ + I have 2 numbers: 53147 + +/(.*)(\d+)/ + I have 2 numbers: 53147 + +/(.*?)(\d*)/ + I have 2 numbers: 53147 + +/(.*?)(\d+)/ + I have 2 numbers: 53147 + +/(.*)(\d+)$/ + I have 2 numbers: 53147 + +/(.*?)(\d+)$/ + I have 2 numbers: 53147 + +/(.*)\b(\d+)$/ + I have 2 numbers: 53147 + +/(.*\D)(\d+)$/ + I have 2 numbers: 53147 + +/^\D*(?!123)/ + ABC123 + +/^(\D*)(?=\d)(?!123)/ + ABC445 + ABC123 + +/^[W-]46]/ + W46]789 + -46]789 + Wall + Zebra + 42 + [abcd] + ]abcd[ + +/^[W-\]46]/ + W46]789 + Wall + Zebra + Xylophone + 42 + [abcd] + ]abcd[ + \\backslash + -46]789 + well + +/\d\d\/\d\d\/\d\d\d\d/ + 01/01/2000 + +/word (?:[a-zA-Z0-9]+ ){0,10}otherword/ + word cat dog elephant mussel cow horse canary baboon snake shark otherword + word cat dog elephant mussel cow horse canary baboon snake shark + +/word (?:[a-zA-Z0-9]+ ){0,300}otherword/ + word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope + +/^(a){0,0}/ + bcd + abc + aab + +/^(a){0,1}/ + bcd + abc + aab + +/^(a){0,2}/ + bcd + abc + aab + +/^(a){0,3}/ + bcd + abc + aab + aaa + +/^(a){0,}/ + bcd + abc + aab + aaa + aaaaaaaa + +/^(a){1,1}/ + bcd + abc + aab + +/^(a){1,2}/ + bcd + abc + aab + +/^(a){1,3}/ + bcd + abc + aab + aaa + +/^(a){1,}/ + bcd + abc + aab + aaa + aaaaaaaa + +/.*\.gif/ + borfle\nbib.gif\nno + +/.{0,}\.gif/ + borfle\nbib.gif\nno + +/.*\.gif/m + borfle\nbib.gif\nno + +/.*\.gif/s + borfle\nbib.gif\nno + +/.*\.gif/ms + borfle\nbib.gif\nno + +/.*$/ + borfle\nbib.gif\nno + +/.*$/m + borfle\nbib.gif\nno + +/.*$/s + borfle\nbib.gif\nno + +/.*$/ms + borfle\nbib.gif\nno + +/.*$/ + borfle\nbib.gif\nno\n + +/.*$/m + borfle\nbib.gif\nno\n + +/.*$/s + borfle\nbib.gif\nno\n + +/.*$/ms + borfle\nbib.gif\nno\n + +/(.*X|^B)/ + abcde\n1234Xyz + BarFoo + abcde\nBar + +/(.*X|^B)/m + abcde\n1234Xyz + BarFoo + abcde\nBar + +/(.*X|^B)/s + abcde\n1234Xyz + BarFoo + abcde\nBar + +/(.*X|^B)/ms + abcde\n1234Xyz + BarFoo + abcde\nBar + +/(?s)(.*X|^B)/ + abcde\n1234Xyz + BarFoo + abcde\nBar + +/(?s:.*X|^B)/ + abcde\n1234Xyz + BarFoo + abcde\nBar + +/^.*B/ + abc\nB + +/(?s)^.*B/ + abc\nB + +/(?m)^.*B/ + abc\nB + +/(?ms)^.*B/ + abc\nB + +/(?ms)^B/ + abc\nB + +/(?s)B$/ + B\n + +/^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/ + 123456654321 + +/^\d\d\d\d\d\d\d\d\d\d\d\d/ + 123456654321 + +/^[\d][\d][\d][\d][\d][\d][\d][\d][\d][\d][\d][\d]/ + 123456654321 + +/^[abc]{12}/ + abcabcabcabc + +/^[a-c]{12}/ + abcabcabcabc + +/^(a|b|c){12}/ + abcabcabcabc + +/^[abcdefghijklmnopqrstuvwxy0123456789]/ + n + z + +/abcde{0,0}/ + abcd + abce + +/ab[cd]{0,0}e/ + abe + abcde + +/ab(c){0,0}d/ + abd + abcd + +/a(b*)/ + a + ab + abbbb + bbbbb + +/ab\d{0}e/ + abe + ab1e + +/"([^\\"]+|\\.)*"/ + the \"quick\" brown fox + \"the \\\"quick\\\" brown fox\" + +/.*?/g+ + abc + +/\b/g+ + abc + +/\b/+g + abc + +//g + abc + +/<tr([\w\W\s\d][^<>]{0,})><TD([\w\W\s\d][^<>]{0,})>([\d]{0,}\.)(.*)(( ([\w\W\s\d][^<>]{0,})|[\s]{0,}))<\/a><\/TD><TD([\w\W\s\d][^<>]{0,})>([\w\W\s\d][^<>]{0,})<\/TD><TD([\w\W\s\d][^<>]{0,})>([\w\W\s\d][^<>]{0,})<\/TD><\/TR>/is + <TR BGCOLOR='#DBE9E9'><TD align=left valign=top>43.<a href='joblist.cfm?JobID=94 6735&Keyword='>Word Processor (N-1286)</a></TD><TD align=left valign=top>Lega lstaff.com</TD><TD align=left valign=top>CA - Statewide</TD></TR> + +/a[^a]b/ + acb + a\nb + +/a.b/ + acb + a\nb + +/a[^a]b/s + acb + a\nb + +/a.b/s + acb + a\nb + +/^(b+?|a){1,2}?c/ + bac + bbac + bbbac + bbbbac + bbbbbac + +/^(b+|a){1,2}?c/ + bac + bbac + bbbac + bbbbac + bbbbbac + +/(?!\A)x/m + x\nb\n + a\bx\n + +/\x0{ab}/ + \0{ab} + +/(A|B)*?CD/ + CD + +/(A|B)*CD/ + CD + +/(AB)*?\1/ + ABABAB + +/(AB)*\1/ + ABABAB + +/(/ + doesn't matter + +/(x)\2/ + doesn't matter + +/((a{0,5}){0,5}){0,5}[c]/ + aaaaaaaaaac + aaaaaaaaaa + +/((a{0,5}){0,5})*[c]/ + aaaaaaaaaac + aaaaaaaaaa + +/(\b)*a/ + a + +/(a)*b/ + ab + +/(a|)*b/ + ab + b + x + +/^(?:(a)|(b))*\1\2$/ + abab + +/abc[^x]def/ + abcxabcydef + +/^(a|\1x)*$/ + aax + aaxa + +// + @{['']} + +/^(?:(a)|(b))*$/ + ab + +/[\0]/ + a + \0 + +/[\1]/ + a + \1 + +/\10()()()()()()()()()/ + doesn't matter + +/\10()()()()()()()()()()/ + a + +/a(?<)b/ + ab + +/[]/ + doesn't matter + +/[\]/ + doesn't matter + +/()/ + a + +/[\x]/ + x + \0 + +/((a)*)*/ + a + +/()a\1/ + a + +/a\1()/ + a + +/a(?i)a(?-i)a/ + aaa + aAa + aAA + +/a(?i)a(?-i)a(?i)a(?-i)a/ + aaaaa + aAaAa + AaAaA + aAAAa + AaaaA + AAAAA + aaAAA + AAaaa + +/\x/ + a + X + \0 + +/[a-c-e]/ + a + b + d + - + +/[b-\d]/ + b + c + d + - + 1 + +/[\d-f]/ + d + e + f + - + 1 + +/[/ + doesn't matter + +/]/ + ] + a + +/[]/ + doesn't matter + +/[-a-c]/ + - + a + b + d + +/[a-c-]/ + - + a + b + d + +/[-]/ + a + - + +/[--]/ + a + - + +/[---]/ + a + - + +/[--b]/ + - + a + c + +/[b--]/ + doesn't matter + +/a{/ + a{ + +/a{}/ + a{} + +/a{3/ + a{3 + +/a{3,/ + a{3, + +/a{3, 3}/ + a{3,3} + a{3, 3} + aaa + +/a{3, 3}/x + a{3,3} + a{3, 3} + aaa + +/a{3, }/ + a{3,} + a{3, } + aaa + +/a{3, }/x + a{3,} + a{3, } + aaa + +/\x x/ + \0 x + \0x + +/\x x/x + \0 x + \0x + +/\x 3/ + \0003 + \000 3 + x3 + x 3 + +/\x 3/x + \0003 + \000 3 + x3 + x 3 + +/^a{ 1}$/ + a + a{ 1} + a{1} + +/^a{ 1}$/x + a + a{ 1} + a{1} + +/{}/ + {} + a + +/{1}/ + doesn't matter + +/*/ + doesn't matter + +/|/ + x + +/\0000/ + \0000 + +/a(?<)b/ + ab + +/a(?i)b/ + ab + aB + Ab + +/a(?i=a)/ + doesn't matter + +/a(?<=a){3000}a/ + aa + xa + ax + +/a(?!=a){3000}a/ + aa + ax + xa + +/a(){3000}a/ + aa + ax + xa + +/a(?:){3000}a/ + aa + ax + +/a(?<=a)*a/ + aa + ax + xa + +/a(?!=a)*a/ + aa + ax + xa + +/a()*a/ + aa + ax + xa + +/a(?:)*a/ + aa + ax + xa + +/x(?<=a)*a/ + aa + xa + ax + +/a(?<=(a))*\1/ + aa + +/a(?<=(a))*?\1/ + aa + +/(?=(a)\1)*aa/ + aa + +/^((a|b){2,5}){2}$/ + aaaaabbbbb + +/^(b*|ba){1,2}bc/ + babc + bbabc + bababc + bababbc + babababc + +/^a{4,5}(?:c|a)c$/ + aaaaac + aaaaaac + +/^(a|){4,5}(?:c|a)c$/ + aaaaac + aaaaaac + +/(?m:^).abc$/ + eeexabc + eee\nxabc + +/(?m:^)abc/ + abc + \nabc + + +/^abc/ + abc + \nabc + +/\Aabc/ + abc + \nabc + +/(?<!bar)foo/ + foo + catfood + arfootle + rfoosh + barfoo + towbarfoo + +/\w{3}(?<!bar)foo/ + catfood + foo + barfoo + towbarfoo + +/(?<=(foo)a)bar/ + fooabar + bar + foobbar + +/\Aabc\z/m + abc + abc\n + qqq\nabc + abc\nzzz + qqq\nabc\nzzz + +"(?>.*/)foo" + /this/is/a/very/long/line/in/deed/with/very/many/slashes/in/it/you/see/ + +"(?>.*/)foo" + /this/is/a/very/long/line/in/deed/with/very/many/slashes/in/and/foo + +/(?>(\.\d\d[1-9]?))\d+/ + 1.230003938 + 1.875000282 + 1.235 + +/^((?>\w+)|(?>\s+))*$/ + now is the time for all good men to come to the aid of the party + this is not a line with only words and spaces! + +/(\d+)(\w)/ + 12345a + 12345+ + +/((?>\d+))(\w)/ + 12345a + 12345+ + +/(?>a+)b/ + aaab + +/((?>a+)b)/ + aaab + +/(?>(a+))b/ + aaab + +/(?>b)+/ + aaabbbccc + +/(?>a+|b+|c+)*c/ + aaabbbbccccd + +/((?>[^()]+)|$[^()]*$)+/ + ((abc(ade)ufh()()x + +/$((?>[^()]+)|\([^()]+$)+\)/ + (abc) + (abc(def)xyz) + ((()aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + +/a(?-i)b/i + ab + Ab + aB + AB + +/(a (?x)b c)d e/ + a bcd e + a b cd e + abcd e + a bcde + +/(a b(?x)c d (?-x)e f)/ + a bcde f + abcdef + +/(a(?i)b)c/ + abc + aBc + abC + aBC + Abc + ABc + ABC + AbC + +/a(?i:b)c/ + abc + aBc + ABC + abC + aBC + +/a(?i:b)*c/ + aBc + aBBc + aBC + aBBC + +/a(?=b(?i)c)\w\wd/ + abcd + abCd + aBCd + abcD + +/(?s-i:more.*than).*million/i + more than million + more than MILLION + more \n than Million + MORE THAN MILLION + more \n than \n million + +/(?:(?s-i)more.*than).*million/i + more than million + more than MILLION + more \n than Million + MORE THAN MILLION + more \n than \n million + +/(?>a(?i)b+)+c/ + abc + aBbc + aBBc + Abc + abAb + abbC + +/(?=a(?i)b)\w\wc/ + abc + aBc + Ab + abC + aBC + +/(?<=a(?i)b)(\w\w)c/ + abxxc + aBxxc + Abxxc + ABxxc + abxxC + +/(?:(a)|b)(?(1)A|B)/ + aA + bB + aB + bA + +/^(a)?(?(1)a|b)+$/ + aa + b + bb + ab + +/^(?(?=abc)\w{3}:|\d\d)$/ + abc: + 12 + 123 + xyz + +/^(?(?!abc)\d\d|\w{3}:)$/ + abc: + 12 + 123 + xyz + +/(?(?<=foo)bar|cat)/ + foobar + cat + fcat + focat + foocat + +/(?(?<!foo)cat|bar)/ + foobar + cat + fcat + focat + foocat + +/( $ )? [^()]+ (?(1) $ |) /x + abcd + (abcd) + the quick (abcd) fox + (abcd + +/( $ )? [^()]+ (?(1) $ ) /x + abcd + (abcd) + the quick (abcd) fox + (abcd + +/^(?(2)a|(1)(2))+$/ + 12 + 12a + 12aa + 1234 + +/((?i)blah)\s+\1/ + blah blah + BLAH BLAH + Blah Blah + blaH blaH + blah BLAH + Blah blah + blaH blah + +/((?i)blah)\s+(?i:\1)/ + blah blah + BLAH BLAH + Blah Blah + blaH blaH + blah BLAH + Blah blah + blaH blah + +/(?>a*)*/ + a + aa + aaaa + +/(abc|)+/ + abc + abcabc + abcabcabc + xyz + +/([a]*)*/ + a + aaaaa + +/([ab]*)*/ + a + b + ababab + aaaabcde + bbbb + +/([^a]*)*/ + b + bbbb + aaa + +/([^ab]*)*/ + cccc + abab + +/([a]*?)*/ + a + aaaa + +/([ab]*?)*/ + a + b + abab + baba + +/([^a]*?)*/ + b + bbbb + aaa + +/([^ab]*?)*/ + c + cccc + baba + +/(?>a*)*/ + a + aaabcde + +/((?>a*))*/ + aaaaa + aabbaa + +/((?>a*?))*/ + aaaaa + aabbaa + +/(?(?=[^a-z]+[a-z]) \d{2}-[a-z]{3}-\d{2} | \d{2}-\d{2}-\d{2} ) /x + 12-sep-98 + 12-09-98 + sep-12-98 + +/(?<=(foo))bar\1/ + foobarfoo + foobarfootling + foobar + barfoo + +/(?i:saturday|sunday)/ + saturday + sunday + Saturday + Sunday + SATURDAY + SUNDAY + SunDay + +/(a(?i)bc|BB)x/ + abcx + aBCx + bbx + BBx + abcX + aBCX + bbX + BBX + +/^([ab](?i)[cd]|[ef])/ + ac + aC + bD + elephant + Europe + frog + France + Africa + +/^(ab|a(?i)[b-c](?m-i)d|x(?i)y|z)/ + ab + aBd + xy + xY + zebra + Zambesi + aCD + XY + +/(?<=foo\n)^bar/m + foo\nbar + bar + baz\nbar + +/(?<=(?<!foo)bar)baz/ + barbaz + barbarbaz + koobarbaz + baz + foobarbaz + +/^(a\1?){4}$/ + a + aa + aaa + aaaa + aaaaa + aaaaaa + aaaaaaa + aaaaaaaa + aaaaaaaaa + aaaaaaaaaa + aaaaaaaaaaa + aaaaaaaaaaaa + aaaaaaaaaaaaa + aaaaaaaaaaaaaa + aaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaa + +/^(a\1?)(a\1?)(a\2?)(a\3?)$/ + a + aa + aaa + aaaa + aaaaa + aaaaaa + aaaaaaa + aaaaaaaa + aaaaaaaaa + aaaaaaaaaa + aaaaaaaaaaa + aaaaaaaaaaaa + aaaaaaaaaaaaa + aaaaaaaaaaaaaa + aaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaa + +/abc/ + abc + xabcy + ababc + xbc + axc + abx + +/ab*c/ + abc + +/ab*bc/ + abc + abbc + abbbbc + +/.{1}/ + abbbbc + +/.{3,4}/ + abbbbc + +/ab{0,}bc/ + abbbbc + +/ab+bc/ + abbc + abc + abq + +/ab{1,}bc/ + +/ab+bc/ + abbbbc + +/ab{1,}bc/ + abbbbc + +/ab{1,3}bc/ + abbbbc + +/ab{3,4}bc/ + abbbbc + +/ab{4,5}bc/ + abq + abbbbc + +/ab?bc/ + abbc + abc + +/ab{0,1}bc/ + abc + +/ab?bc/ + +/ab?c/ + abc + +/ab{0,1}c/ + abc + +/^abc$/ + abc + abbbbc + abcc + +/^abc/ + abcc + +/^abc$/ + +/abc$/ + aabc + aabc + aabcd + +/^/ + abc + +/$/ + abc + +/a.c/ + abc + axc + +/a.*c/ + axyzc + +/a[bc]d/ + abd + axyzd + abc + +/a[b-d]e/ + ace + +/a[b-d]/ + aac + +/a[-b]/ + a- + +/a[b-]/ + a- + +/a]/ + a] + +/a[]]b/ + a]b + +/a[^bc]d/ + aed + abd + abd + +/a[^-b]c/ + adc + +/a[^]b]c/ + adc + a-c + a]c + +/\ba\b/ + a- + -a + -a- + +/\by\b/ + xy + yz + xyz + +/\Ba\B/ + a- + -a + -a- + +/\By\b/ + xy + +/\by\B/ + yz + +/\By\B/ + xyz + +/\w/ + a + +/\W/ + - + - + a + +/a\sb/ + a b + +/a\Sb/ + a-b + a-b + a b + +/\d/ + 1 + +/\D/ + - + - + 1 + +/[\w]/ + a + +/[\W]/ + - + - + a + +/a[\s]b/ + a b + +/a[\S]b/ + a-b + a-b + a b + +/[\d]/ + 1 + +/[\D]/ + - + - + 1 + +/ab|cd/ + abc + abcd + +/()ef/ + def + +/$b/ + +/a\(b/ + a(b + +/a\(*b/ + ab + a((b + +/a\\b/ + a\b + +/((a))/ + abc + +/(a)b(c)/ + abc + +/a+b+c/ + aabbabc + +/a{1,}b{1,}c/ + aabbabc + +/a.+?c/ + abcabc + +/(a+|b)*/ + ab + +/(a+|b){0,}/ + ab + +/(a+|b)+/ + ab + +/(a+|b){1,}/ + ab + +/(a+|b)?/ + ab + +/(a+|b){0,1}/ + ab + +/[^ab]*/ + cde + +/abc/ + b + + +/a*/ + + +/([abc])*d/ + abbbcd + +/([abc])*bcd/ + abcd + +/a|b|c|d|e/ + e + +/(a|b|c|d|e)f/ + ef + +/abcd*efg/ + abcdefg + +/ab*/ + xabyabbbz + xayabbbz + +/(ab|cd)e/ + abcde + +/[abhgefdc]ij/ + hij + +/^(ab|cd)e/ + +/(abc|)ef/ + abcdef + +/(a|b)c*d/ + abcd + +/(ab|ab*)bc/ + abc + +/a([bc]*)c*/ + abc + +/a([bc]*)(c*d)/ + abcd + +/a([bc]+)(c*d)/ + abcd + +/a([bc]*)(c+d)/ + abcd + +/a[bcd]*dcdcde/ + adcdcde + +/a[bcd]+dcdcde/ + abcde + adcdcde + +/(ab|a)b*c/ + abc + +/((a)(b)c)(d)/ + abcd + +/[a-zA-Z_][a-zA-Z0-9_]*/ + alpha + +/^a(bc+|b[eh])g|.h$/ + abh + +/(bc+d$|ef*g.|h?i(j|k))/ + effgz + ij + reffgz + effg + bcdd + +/((((((((((a))))))))))/ + a + +/((((((((((a))))))))))\10/ + aa + +/(((((((((a)))))))))/ + a + +/multiple words of text/ + aa + uh-uh + +/multiple words/ + multiple words, yeah + +/(.*)c(.*)/ + abcde + +/$(.*), (.*)$/ + (a, b) + +/[k]/ + +/abcd/ + abcd + +/a(bc)d/ + abcd + +/a[-]?c/ + ac + +/(abc)\1/ + abcabc + +/([a-c]*)\1/ + abcabc + +/(a)|\1/ + a + ab + x + +/(([a-c])b*?\2)*/ + ababbbcbc + +/(([a-c])b*?\2){3}/ + ababbbcbc + +/((\3|b)\2(a)x)+/ + aaaxabaxbaaxbbax + +/((\3|b)\2(a)){2,}/ + bbaababbabaaaaabbaaaabba + +/abc/i + ABC + XABCY + ABABC + aaxabxbaxbbx + XBC + AXC + ABX + +/ab*c/i + ABC + +/ab*bc/i + ABC + ABBC + +/ab*?bc/i + ABBBBC + +/ab{0,}?bc/i + ABBBBC + +/ab+?bc/i + ABBC + +/ab+bc/i + ABC + ABQ + +/ab{1,}bc/i + +/ab+bc/i + ABBBBC + +/ab{1,}?bc/i + ABBBBC + +/ab{1,3}?bc/i + ABBBBC + +/ab{3,4}?bc/i + ABBBBC + +/ab{4,5}?bc/i + ABQ + ABBBBC + +/ab??bc/i + ABBC + ABC + +/ab{0,1}?bc/i + ABC + +/ab??bc/i + +/ab??c/i + ABC + +/ab{0,1}?c/i + ABC + +/^abc$/i + ABC + ABBBBC + ABCC + +/^abc/i + ABCC + +/^abc$/i + +/abc$/i + AABC + +/^/i + ABC + +/$/i + ABC + +/a.c/i + ABC + AXC + +/a.*?c/i + AXYZC + +/a.*c/i + AABC + AXYZD + +/a[bc]d/i + ABD + +/a[b-d]e/i + ACE + ABC + ABD + +/a[b-d]/i + AAC + +/a[-b]/i + A- + +/a[b-]/i + A- + +/a]/i + A] + +/a[]]b/i + A]B + +/a[^bc]d/i + AED + +/a[^-b]c/i + ADC + ABD + A-C + +/a[^]b]c/i + ADC + +/ab|cd/i + ABC + ABCD + +/()ef/i + DEF + +/$b/i + A]C + B + +/a\(b/i + A(B + +/a\(*b/i + AB + A((B + +/a\\b/i + A\B + +/((a))/i + ABC + +/(a)b(c)/i + ABC + +/a+b+c/i + AABBABC + +/a{1,}b{1,}c/i + AABBABC + +/a.+?c/i + ABCABC + +/a.*?c/i + ABCABC + +/a.{0,5}?c/i + ABCABC + +/(a+|b)*/i + AB + +/(a+|b){0,}/i + AB + +/(a+|b)+/i + AB + +/(a+|b){1,}/i + AB + +/(a+|b)?/i + AB + +/(a+|b){0,1}/i + AB + +/(a+|b){0,1}?/i + AB + +/[^ab]*/i + CDE + +/abc/i + +/a*/i + + +/([abc])*d/i + ABBBCD + +/([abc])*bcd/i + ABCD + +/a|b|c|d|e/i + E + +/(a|b|c|d|e)f/i + EF + +/abcd*efg/i + ABCDEFG + +/ab*/i + XABYABBBZ + XAYABBBZ + +/(ab|cd)e/i + ABCDE + +/[abhgefdc]ij/i + HIJ + +/^(ab|cd)e/i + ABCDE + +/(abc|)ef/i + ABCDEF + +/(a|b)c*d/i + ABCD + +/(ab|ab*)bc/i + ABC + +/a([bc]*)c*/i + ABC + +/a([bc]*)(c*d)/i + ABCD + +/a([bc]+)(c*d)/i + ABCD + +/a([bc]*)(c+d)/i + ABCD + +/a[bcd]*dcdcde/i + ADCDCDE + +/a[bcd]+dcdcde/i + +/(ab|a)b*c/i + ABC + +/((a)(b)c)(d)/i + ABCD + +/[a-zA-Z_][a-zA-Z0-9_]*/i + ALPHA + +/^a(bc+|b[eh])g|.h$/i + ABH + +/(bc+d$|ef*g.|h?i(j|k))/i + EFFGZ + IJ + REFFGZ + ADCDCDE + EFFG + BCDD + +/((((((((((a))))))))))/i + A + +/((((((((((a))))))))))\10/i + AA + +/(((((((((a)))))))))/i + A + +/(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))/i + A + +/(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))/i + C + +/multiple words of text/i + AA + UH-UH + +/multiple words/i + MULTIPLE WORDS, YEAH + +/(.*)c(.*)/i + ABCDE + +/$(.*), (.*)$/i + (A, B) + +/[k]/i + +/abcd/i + ABCD + +/a(bc)d/i + ABCD + +/a[-]?c/i + AC + +/(abc)\1/i + ABCABC + +/([a-c]*)\1/i + ABCABC + +/a(?!b)./ + abad + +/a(?=d)./ + abad + +/a(?=c|d)./ + abad + +/a(?:b|c|d)(.)/ + ace + +/a(?:b|c|d)*(.)/ + ace + +/a(?:b|c|d)+?(.)/ + ace + acdbcdbe + +/a(?:b|c|d)+(.)/ + acdbcdbe + +/a(?:b|c|d){2}(.)/ + acdbcdbe + +/a(?:b|c|d){4,5}(.)/ + acdbcdbe + +/a(?:b|c|d){4,5}?(.)/ + acdbcdbe + +/((foo)|(bar))*/ + foobar + +/a(?:b|c|d){6,7}(.)/ + acdbcdbe + +/a(?:b|c|d){6,7}?(.)/ + acdbcdbe + +/a(?:b|c|d){5,6}(.)/ + acdbcdbe + +/a(?:b|c|d){5,6}?(.)/ + acdbcdbe + +/a(?:b|c|d){5,7}(.)/ + acdbcdbe + +/a(?:b|c|d){5,7}?(.)/ + acdbcdbe + +/a(?:b|(c|e){1,2}?|d)+?(.)/ + ace + +/^(.+)?B/ + AB + +/^([^a-z])|(\^)$/ + . + +/^[<>]&/ + <&OUT + +/^(a\1?){4}$/ + aaaaaaaaaa + AB + aaaaaaaaa + aaaaaaaaaaa + +/^(a(?(1)\1)){4}$/ + aaaaaaaaaa + aaaaaaaaa + aaaaaaaaaaa + +/(?:(f)(o)(o)|(b)(a)(r))*/ + foobar + +/(?<=a)b/ + ab + cb + b + +/(?<!c)b/ + ab + b + b + +/(?:..)*a/ + aba + +/(?:..)*?a/ + aba + +/^(?:b|a(?=(.)))*\1/ + abc + +/^(){3,5}/ + abc + +/^(a+)*ax/ + aax + +/^((a|b)+)*ax/ + aax + +/^((a|bc)+)*ax/ + aax + +/(a|x)*ab/ + cab + +/(a)*ab/ + cab + +/(?:(?i)a)b/ + ab + +/((?i)a)b/ + ab + +/(?:(?i)a)b/ + Ab + +/((?i)a)b/ + Ab + +/(?:(?i)a)b/ + cb + aB + +/((?i)a)b/ + +/(?i:a)b/ + ab + +/((?i:a))b/ + ab + +/(?i:a)b/ + Ab + +/((?i:a))b/ + Ab + +/(?i:a)b/ + aB + aB + +/((?i:a))b/ + +/(?:(?-i)a)b/i + ab + +/((?-i)a)b/i + ab + +/(?:(?-i)a)b/i + aB + +/((?-i)a)b/i + aB + +/(?:(?-i)a)b/i + aB + Ab + +/((?-i)a)b/i + +/(?:(?-i)a)b/i + aB + +/((?-i)a)b/i + aB + +/(?:(?-i)a)b/i + Ab + AB + +/((?-i)a)b/i + +/(?-i:a)b/i + ab + +/((?-i:a))b/i + ab + +/(?-i:a)b/i + aB + +/((?-i:a))b/i + aB + +/(?-i:a)b/i + AB + Ab + +/((?-i:a))b/i + +/(?-i:a)b/i + aB + +/((?-i:a))b/i + aB + +/(?-i:a)b/i + Ab + AB + +/((?-i:a))b/i + +/((?-i:a.))b/i + AB + a\nB + +/((?s-i:a.))b/i + a\nB + +/(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b)))/ + cabbbb + +/(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb)))/ + caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + +/(ab)\d\1/i + Ab4ab + ab4Ab + +/foo\w*\d{4}baz/ + foobar1234baz + +/x(~~)*(?:(?:F)?)?/ + x~~ + +/^a(?#xxx){3}c/ + aaac + +/^a(?#xxx)(?#xxx){3}c/ + aaac + +/^a (?#xxx) (?#yyy) {3}c/x + aaac + +/(?<![cd])b/ + B\nB + dbcb + +/(?<![cd])[ab]/ + dbaacb + +/(?<!(c|d))b/ + +/(?<!(c|d))[ab]/ + dbaacb + +/(?<!cd)[ab]/ + cdaccb + +/^(?:a?b?)*$/ + dbcb + a-- + +/((?s)^a(.))((?m)^b$)/ + a\nb\nc\n + +/((?m)^b$)/ + a\nb\nc\n + +/(?m)^b/ + a\nb\n + +/(?m)^(b)/ + a\nb\n + +/((?m)^b)/ + a\nb\n + +/\n((?m)^b)/ + a\nb\n + +/((?s).)c(?!.)/ + a\nb\nc\n + a\nb\nc\n + +/((?s)b.)c(?!.)/ + a\nb\nc\n + a\nb\nc\n + +/^b/ + +/()^b/ + a\nb\nc\n + a\nb\nc\n + +/((?m)^b)/ + a\nb\nc\n + +/(?(1)a|b)/ + +/(?(1)b|a)/ + a + +/(x)?(?(1)a|b)/ + a + a + +/(x)?(?(1)b|a)/ + a + +/()?(?(1)b|a)/ + a + +/()(?(1)b|a)/ + +/()?(?(1)a|b)/ + a + +/^($)?blah(?(1)($))$/ + (blah) + blah + a + blah) + (blah + +/^($+)?blah(?(1)($))$/ + (blah) + blah + blah) + (blah + +/(?(?!a)a|b)/ + +/(?(?!a)b|a)/ + a + +/(?(?=a)b|a)/ + a + a + +/(?(?=a)a|b)/ + a + +/(?=(a+?))(\1ab)/ + aaab + +/^(?=(a+?))\1ab/ + +/(\w+:)+/ + one: + +/$(?<=^(a))/ + a + +/(?=(a+?))(\1ab)/ + aaab + +/^(?=(a+?))\1ab/ + aaab + aaab + +/([\w:]+::)?(\w+)$/ + abcd + xy:z:::abcd + +/^[^bcd]*(c+)/ + aexycd + +/(a*)b+/ + caab + +/([\w:]+::)?(\w+)$/ + abcd + xy:z:::abcd + abcd: + abcd: + +/^[^bcd]*(c+)/ + aexycd + +/(>a+)ab/ + +/(?>a+)b/ + aaab + +/([[:]+)/ + a:[b]: + +/([[=]+)/ + a=[b]= + +/([[.]+)/ + a.[b]. + +/((?>a+)b)/ + aaab + +/(?>(a+))b/ + aaab + +/((?>[^()]+)|$[^()]*$)+/ + ((abc(ade)ufh()()x + +/a\Z/ + aaab + a\nb\n + +/b\Z/ + a\nb\n + +/b\z/ + +/b\Z/ + a\nb + +/b\z/ + a\nb + +/^(?>(?(1)\.|())[^\W_](?>[a-z0-9-]*[^\W_])?)+$/ + a + abc + a-b + 0-9 + a.b + 5.6.7 + the.quick.brown.fox + a100.b200.300c + 12-ab.1245 + \ + .a + -a + a- + a. + a_b + a.- + a.. + ab..bc + the.quick.brown.fox- + the.quick.brown.fox. + the.quick.brown.fox_ + the.quick.brown.fox+ + +/(?>.*)(?<=(abcd|wxyz))/ + alphabetabcd + endingwxyz + a rather long string that doesn't end with one of them + +/word (?>(?:(?!otherword)[a-zA-Z0-9]+ ){0,30})otherword/ + word cat dog elephant mussel cow horse canary baboon snake shark otherword + word cat dog elephant mussel cow horse canary baboon snake shark + +/word (?>[a-zA-Z0-9]+ ){0,30}otherword/ + word cat dog elephant mussel cow horse canary baboon snake shark the quick brown fox and the lazy dog and several other words getting close to thirty by now I hope + +/(?<=\d{3}(?!999))foo/ + 999foo + 123999foo + 123abcfoo + +/(?<=(?!...999)\d{3})foo/ + 999foo + 123999foo + 123abcfoo + +/(?<=\d{3}(?!999)...)foo/ + 123abcfoo + 123456foo + 123999foo + +/(?<=\d{3}...)(?<!999)foo/ + 123abcfoo + 123456foo + 123999foo + +/<a[\s]+href[\s]*=[\s]* # find <a href= + ([\"\'])? # find single or double quote + (?(1) (.*?)\1 | ([^\s]+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx + <a href=abcd xyz + <a href=\"abcd xyz pqr\" cats + <a href=\'abcd xyz pqr\' cats + +/<a\s+href\s*=\s* # find <a href= + (["'])? # find single or double quote + (?(1) (.*?)\1 | (\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx + <a href=abcd xyz + <a href=\"abcd xyz pqr\" cats + <a href = \'abcd xyz pqr\' cats + +/<a\s+href(?>\s*)=(?>\s*) # find <a href= + (["'])? # find single or double quote + (?(1) (.*?)\1 | (\S+)) # if quote found, match up to next matching + # quote, otherwise match up to next space +/isx + <a href=abcd xyz + <a href=\"abcd xyz pqr\" cats + <a href = \'abcd xyz pqr\' cats + +/((Z)+|A)*/ + ZABCDEFG + +/(Z()|A)*/ + ZABCDEFG + +/(Z(())|A)*/ + ZABCDEFG + +/((?>Z)+|A)*/ + ZABCDEFG + +/((?>)+|A)*/ + ZABCDEFG + +/a*/g + abbab + +/^[a-\d]/ + abcde + -things + 0digit + bcdef + +/^[\d-a]/ + abcde + -things + 0digit + bcdef + +/(?<=abc).*(?=def)/ + abcdef + abcxdef + abcxdefxdef + +/(?<=abc).*?(?=def)/ + abcdef + abcxdef + abcxdefxdef + +/(?<=abc).+(?=def)/ + abcdef + abcxdef + abcxdefxdef + +/(?<=abc).+?(?=def)/ + abcdef + abcxdef + abcxdefxdef + +/(?<=\b)(.*)/ + -abcdef + abcdef + +/(?<=\B)(.*)/ + -abcdef + abcdef + +/^'[ab]'/ + 'a' + 'b' + x'a' + 'a'x + 'ab' + +/^'[ab]'$/ + 'a' + 'b' + x'a' + 'a'x + 'ab' + +/'[ab]'$/ + 'a' + 'b' + x'a' + 'a'x + 'ab' + +/'[ab]'/ + 'a' + 'b' + x'a' + 'a'x + 'ab' + +/abc\E/ + abc + abcE + +/abc[\Ex]/ + abcx + abcE + +/^\Qa*\E$/ + a* + a + +/\Qa*x\E/ + a*x + a* + +/\Qa*x/ + a*x + a* + +/\Q\Qa*x\E\E/ + a*x + a\\*x + +/\Q\Qa*x\E/ + a*x + a\\*x + +/a\Q[x\E]/ + a[x] + ax + +/a#comment\Q... +{2}/x + a + aa + +/a(?#comment\Q... +){2}/x + a + aa + +/(?x)a#\Q +./ + a. + aa + +/ab(?=.*q)cd/ + abcdxklqj + +/a(?!.*$)b/ + ab \ No newline at end of file Added: vendor/portableaserve/libs/cl-ppcre/util.lisp =================================================================== --- vendor/portableaserve/libs/cl-ppcre/util.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/cl-ppcre/util.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,278 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- +;;; $Header: /cvsroot/portableaserve/portableaserve/libs/cl-ppcre/util.lisp,v 1.1 2004/02/16 19:37:17 rudi Exp $ + +;;; Utility functions and constants dealing with the hash-tables +;;; we use to encode character classes + +;;; Hash-tables are treated like sets, i.e. a character C is a member of the +;;; hash-table H iff (GETHASH C H) is true. + +;;; Copyright (c) 2002-2003, 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-ppcre) + +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +(defmacro rebinding (bindings &body body) + "REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *regex-char-code-limit* char-code-limit + "The upper exclusive bound on the char-codes of characters +which can occur in character classes. +Change this value BEFORE creating scanners if you don't need +the full Unicode support of LW, ACL, or CLISP.") + (declaim (type fixnum *regex-char-code-limit*)) + + (defun make-char-hash (test) + (declare (optimize speed space)) + "Returns a hash-table of all characters satisfying test." + (loop with hash = (make-hash-table) + for c of-type fixnum from 0 below char-code-limit + for chr = (code-char c) + if (and chr (funcall test chr)) + do (setf (gethash chr hash) t) + finally (return hash))) + + (declaim (inline word-char-p)) + + (defun word-char-p (chr) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Tests whether a character is a \"word\" character. +In the ASCII charset this is equivalent to a-z, A-Z, 0-9, or _, +i.e. the same as Perl's [\\w]." + (or (alphanumericp chr) + (char= chr #\_))) + + (unless (boundp '+whitespace-char-string+) + (defconstant +whitespace-char-string+ + (coerce + '(#\Space #\Tab #\Linefeed #\Return #\Page) + 'string) + "A string of all characters which are considered to be whitespace. +Same as Perl's [\\s].")) + + (defun whitespacep (chr) + (declare (optimize speed space)) + "Tests whether a character is whitespace, +i.e. whether it would match [\\s] in Perl." + (find chr +whitespace-char-string+ :test #'char=))) + +;; the following DEFCONSTANT statements are wrapped with +;; (UNLESS (BOUNDP ...) ...) to make SBCL happy + +(unless (boundp '+digit-hash+) + (defconstant +digit-hash+ + (make-char-hash (lambda (chr) (char<= #\0 chr #\9))) + "Hash-table containing the digits from 0 to 9.")) + +(unless (boundp '+word-char-hash+) + (defconstant +word-char-hash+ + (make-char-hash #'word-char-p) + "Hash-table containing all \"word\" characters.")) + +(unless (boundp '+whitespace-char-hash+) + (defconstant +whitespace-char-hash+ + (make-char-hash #'whitespacep) + "Hash-table containing all whitespace characters.")) + +(defun merge-hash (hash1 hash2) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns the \"sum\" of two hashes. This is a destructive operation +on HASH1." + (cond ((> (hash-table-count hash2) + *regex-char-code-limit*) + ;; don't walk through, e.g., the whole +WORD-CHAR-HASH+ if + ;; the user has set *REGEX-CHAR-CODE-LIMIT* to a lower value + (loop for c of-type fixnum from 0 below *regex-char-code-limit* + for chr = (code-char c) + if (and chr (gethash chr hash2)) + do (setf (gethash chr hash1) t))) + (t + (loop for chr being the hash-keys of hash2 + do (setf (gethash chr hash1) t)))) + hash1) + +(defun merge-inverted-hash (hash1 hash2) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Returns the \"sum\" of HASH1 and the \"inverse\" of HASH2. This is +a destructive operation on HASH1." + (loop for c of-type fixnum from 0 below *regex-char-code-limit* + for chr = (code-char c) + if (and chr (not (gethash chr hash2))) + do (setf (gethash chr hash1) t)) + hash1) + +(defun create-ranges-from-hash (hash &key downcasep) + (declare (optimize speed + (safety 0) + (space 0) + (debug 0) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + "Tries to identify up to three intervals (with respect to CHAR<) +which together comprise HASH. Returns NIL if this is not possible. +If DOWNCASEP is true it will treat the hash-table as if it represents +both the lower-case and the upper-case variants of its members and +will only return the respective lower-case intervals." + ;; discard empty hash-tables + (unless (and hash (plusp (hash-table-count hash))) + (return-from create-ranges-from-hash nil)) + (loop with min1 and min2 and min3 + and max1 and max2 and max3 + ;; loop through all characters in HASH, sorted by CHAR< + for chr in (sort (the list + (loop for chr being the hash-keys of hash + collect (if downcasep + (char-downcase chr) + chr))) + #'char<) + for code = (char-code chr) + ;; MIN1, MAX1, etc. are _exclusive_ + ;; bounds of the intervals identified so far + do (cond + ((not min1) + ;; this will only happen once, for the first character + (setq min1 (1- code) + max1 (1+ code))) + ((<= (the fixnum min1) code (the fixnum max1)) + ;; we're here as long as CHR fits into the first interval + (setq min1 (min (the fixnum min1) (1- code)) + max1 (max (the fixnum max1) (1+ code)))) + ((not min2) + ;; we need to open a second interval + ;; this'll also happen only once + (setq min2 (1- code) + max2 (1+ code))) + ((<= (the fixnum min2) code (the fixnum max2)) + ;; CHR fits into the second interval + (setq min2 (min (the fixnum min2) (1- code)) + max2 (max (the fixnum max2) (1+ code)))) + ((not min3) + ;; we need to open the third interval + ;; happens only once + (setq min3 (1- code) + max3 (1+ code))) + ((<= (the fixnum min3) code (the fixnum max3)) + ;; CHR fits into the third interval + (setq min3 (min (the fixnum min3) (1- code)) + max3 (max (the fixnum max3) (1+ code)))) + (t + ;; we're out of luck, CHR doesn't fit + ;; into one of the three intervals + (return nil))) + ;; on success return all bounds + ;; make them inclusive bounds before returning + finally (return (values (code-char (1+ min1)) + (code-char (1- max1)) + (and min2 (code-char (1+ min2))) + (and max2 (code-char (1- max2))) + (and min3 (code-char (1+ min3))) + (and max3 (code-char (1- max3))))))) + +(defmacro maybe-coerce-to-simple-string (string) + (with-unique-names (=string=) + `(let ((,=string= ,string)) + (cond ((simple-string-p ,=string=) + ,=string=) + (t + (coerce ,=string= 'simple-string)))))) + +(declaim (inline nsubseq)) +(defun nsubseq (sequence start &optional (end (length sequence))) + "Return a subsequence by pointing to location in original sequence." + (make-array (- end start) + :element-type (array-element-type sequence) + :displaced-to sequence + :displaced-index-offset start)) Added: vendor/portableaserve/libs/puri-1.3.1/.cvsignore =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/.cvsignore 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/.cvsignore 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,17 @@ +*.wfasl +*.ufsl +*.fasl +*.nfasl +*.fas +*.lib +*.x86f +*.sparcf +*.err +*.pfsl +*.dfsl +*.fasla16 +*.faslm16 +*.faslma +*.faslm8 +{arch} +.arch-ids Added: vendor/portableaserve/libs/puri-1.3.1/CVS/Entries =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/CVS/Entries 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,8 @@ +/.cvsignore/1.2/Mon Feb 9 14:11:00 2004// +/LICENSE/1.1/Sun Feb 8 15:44:10 2004// +/README/1.1/Sun Feb 8 15:44:10 2004// +/puri.asd/1.1/Sun Feb 8 15:44:10 2004// +/src.lisp/1.2/Wed Mar 17 01:21:54 2004// +/tests.lisp/1.1/Sun Feb 8 15:44:10 2004// +/uri.html/1.1/Sun Feb 8 15:44:10 2004// +D Added: vendor/portableaserve/libs/puri-1.3.1/CVS/Repository =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/CVS/Repository 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +portableaserve/libs/puri-1.3.1 Added: vendor/portableaserve/libs/puri-1.3.1/CVS/Root =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/CVS/Root 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1 @@ +:pserver:anonymous@cvs.sourceforge.net:/cvsroot/portableaserve Added: vendor/portableaserve/libs/puri-1.3.1/LICENSE =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/LICENSE 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/LICENSE 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,574 @@ +Copyright (c) 1999-2001 Franz, Inc. +Copyright (c) 2003 Kevin Rosenberg +All rights reserved. + +PURI is licensed under the terms of the Lisp Lesser GNU Public +License, known as the LLGPL. The LLGPL consists of a preamble (see +below) and the Lessor GNU Public License 2.1 (LGPL-2.1). Where these +conflict, the preamble takes precedence. PURI is referenced in the +preamble as the "LIBRARY." + +PURI is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. + + + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. + + + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. +^L + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. +^L + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. +^L + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. +^L + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. +^L + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. +^L + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. +^L + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS +^L + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms +of the ordinary General Public License). + + To apply these terms, attach the following notices to the library. +It is safest to attach them to the start of each source file to most +effectively convey the exclusion of warranty; and each file should +have at least the "copyright" line and a pointer to where the full +notice is found. + + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Added: vendor/portableaserve/libs/puri-1.3.1/README =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/README 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/README 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,46 @@ +PURI - Portable URI Library +=========================== + +AUTHORS +------- +Franz, Inc <http://www.franz.com> +Kevin Rosenberg <kevin(a)rosenberg.net> + + +DOWNLOAD +-------- +Puri home: http://files.b9.com/puri/ +Portable tester home: http://files.b9.com/tester/ + + +SUPPORTED PLATFORMS +------------------- + AllegroCL, CLISP, CMUCL, Lispworks, OpenMCL, SBCL + + +OVERVIEW +-------- +This is portable Universal Resource Identifier library for Common Lisp +programs. It parses URI according to the RFC 2396 specification. It's +is based on Franz, Inc's opensource URI package and has been ported to +work other CL implementations. It is licensed under the LLGPL which +is included in this distribution. + +A regression suite is included which uses Franz's open-source tester +library. I've ported that library for use on other CL +implementations. Puri completes 126/126 regression tests successfully. + +Franz's unmodified documentation file is included in the file +uri.html. + + +DIFFERENCES BETWEEN PURI and NET.URI +------------------------------------ + +* Puri uses the package 'puri while NET.URI uses the package 'net.uri + +* To signal an error parsing a URI, Puri uses the condition + :uri-parse-error while NET.URI uses the condition :parse-error. This + divergence occurs because Franz's parse-error condition uses + :format-control and :format-arguments slots which are not in the ANSI + specification for the parse-error condition. Added: vendor/portableaserve/libs/puri-1.3.1/puri.asd =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/puri.asd 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/puri.asd 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,30 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; Programmer: Kevin Rosenberg + + +(in-package #:cl-user) +(defpackage #:puri-system (:use #:cl #:asdf)) +(in-package #:puri-system) + + +(defsystem puri + :name "cl-puri" + :maintainer "Kevin M. Rosenberg <kmr(a)debian.org>" + :licence "GNU Lesser General Public License" + :description "Portable Universal Resource Indentifier Library" + :components + ((:file "src"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri)))) + (oos 'load-op 'puri-tests) + (oos 'test-op 'puri-tests)) + +(defsystem puri-tests + :depends-on (:puri :ptester) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package :puri-tests))) + (error "test-op failed"))) Added: vendor/portableaserve/libs/puri-1.3.1/src.lisp =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/src.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/src.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,1410 @@ +;; -*- mode: common-lisp; package: puri -*- +;; Support for URIs in Allegro. +;; For general URI information see RFC2396. +;; +;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2003 Kevin Rosenberg (porting changes) +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in +;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. +;; +;; Original version from ACL 6.1: +;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer +;; +;; $Id: src.lisp,v 1.2 2004/03/17 01:21:54 kevinrosenberg Exp $ + +(defpackage #:puri + (:use #:cl) + #-allegro (:nicknames #:net.uri) + (:export + #:uri ; the type and a function + #:uri-p + #:copy-uri + + #:uri-scheme ; and slots + #:uri-host #:uri-port + #:uri-path + #:uri-query + #:uri-fragment + #:uri-plist + #:uri-authority ; pseudo-slot accessor + + #:urn ; class + #:urn-nid ; pseudo-slot accessor + #:urn-nss ; pseudo-slot accessor + + #:*strict-parse* + #:parse-uri + #:merge-uris + #:enough-uri + #:uri-parsed-path + #:render-uri + + #:make-uri-space ; interning... + #:uri-space + #:uri= + #:intern-uri + #:unintern-uri + #:do-all-uris + + #:uri-parse-error ;; Added by KMR + )) + +(in-package #:puri) + +(eval-when (:compile-toplevel) (declaim (optimize (speed 3)))) + + +#-allegro +(defun parse-body (forms &optional env) + "Parses a body, returns (VALUES docstring declarations forms)" + (declare (ignore env)) + ;; fixme -- need to add parsing of multiple declarations + (let (docstring declarations) + (when (stringp (car forms)) + (setq docstring (car forms)) + (setq forms (cdr forms))) + (when (and (listp (car forms)) + (symbolp (caar forms)) + (string-equal (symbol-name '#:declare) + (symbol-name (caar forms)))) + (setq declarations (car forms)) + (setq forms (cdr forms))) + (values docstring declarations forms))) + + +(defun shrink-vector (str size) + #+allegro + (excl::.primcall 'sys::shrink-svector str size) + #+sbcl + (sb-kernel:shrink-vector str size) + #+cmu + (lisp::shrink-vector str size) + #+lispworks + (system::shrink-vector$vector str size) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + + +;; KMR: Added new condition to handle cross-implementation variances +;; in the parse-error condition many implementations define + +(define-condition uri-parse-error (parse-error) + ((fmt-control :initarg :fmt-control :accessor fmt-control) + (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) + (:report (lambda (c stream) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) + +(defun .parse-error (fmt &rest args) + (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) + +#-allegro +(defun internal-reader-error (stream fmt &rest args) + (apply #'format stream fmt args)) + +#-allegro (defvar *current-case-mode* :case-insensitive-upper) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(excl:*current-case-mode* + excl:delimited-string-to-list + excl::parse-body + excl::internal-reader-error + excl:if*))) + +#-allegro +(defun position-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (schar string i)) (return i)))) + +#-allegro +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + (declare (optimize (speed 3) (safety 0) (space 0) + (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + +#-allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + + (defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init)))))) + + +(defclass uri () + ( +;;;; external: + (scheme :initarg :scheme :initform nil :accessor uri-scheme) + (host :initarg :host :initform nil :accessor uri-host) + (port :initarg :port :initform nil :accessor uri-port) + (path :initarg :path :initform nil :accessor uri-path) + (query :initarg :query :initform nil :accessor uri-query) + (fragment :initarg :fragment :initform nil :accessor uri-fragment) + (plist :initarg :plist :initform nil :accessor uri-plist) + +;;;; internal: + (escaped + ;; used to prevent unnessary work, looking for chars to escape and + ;; unescape. + :initarg :escaped :initform nil :accessor uri-escaped) + (string + ;; the cached printable representation of the URI. It *might* be + ;; different than the original string, though, because the user might + ;; have escaped non-reserved chars--they won't be escaped when the URI + ;; is printed. + :initarg :string :initform nil :accessor uri-string) + (parsed-path + ;; the cached parsed representation of the URI path. + :initarg :parsed-path + :initform nil + :accessor .uri-parsed-path) + (hashcode + ;; cached sxhash, so we don't have to compute it more than once. + :initarg :hashcode :initform nil :accessor uri-hashcode))) + +(defclass urn (uri) + ((nid :initarg :nid :initform nil :accessor urn-nid) + (nss :initarg :nss :initform nil :accessor urn-nss))) + +(eval-when (:compile-toplevel :execute) + (defmacro clear-caching-on-slot-change (name) + `(defmethod (setf ,name) :around (new-value (self uri)) + (declare (ignore new-value)) + (prog1 (call-next-method) + (setf (uri-string self) nil) + ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) + (setf (uri-hashcode self) nil)))) + ) + +(clear-caching-on-slot-change uri-scheme) +(clear-caching-on-slot-change uri-host) +(clear-caching-on-slot-change uri-port) +(clear-caching-on-slot-change uri-path) +(clear-caching-on-slot-change uri-query) +(clear-caching-on-slot-change uri-fragment) + + +(defmethod make-load-form ((self uri) &optional env) + (declare (ignore env)) + `(make-instance ',(class-name (class-of self)) + :scheme ,(uri-scheme self) + :host ,(uri-host self) + :port ,(uri-port self) + :path ',(uri-path self) + :query ,(uri-query self) + :fragment ,(uri-fragment self) + :plist ',(uri-plist self) + :string ,(uri-string self) + :parsed-path ',(.uri-parsed-path self))) + +(defmethod uri-p ((thing uri)) t) +(defmethod uri-p ((thing t)) nil) + +(defun copy-uri (uri + &key place + (scheme (when uri (uri-scheme uri))) + (host (when uri (uri-host uri))) + (port (when uri (uri-port uri))) + (path (when uri (uri-path uri))) + (parsed-path + (when uri (copy-list (.uri-parsed-path uri)))) + (query (when uri (uri-query uri))) + (fragment (when uri (uri-fragment uri))) + (plist (when uri (copy-list (uri-plist uri)))) + (class (when uri (class-of uri))) + &aux (escaped (when uri (uri-escaped uri)))) + (if* place + then (setf (uri-scheme place) scheme) + (setf (uri-host place) host) + (setf (uri-port place) port) + (setf (uri-path place) path) + (setf (.uri-parsed-path place) parsed-path) + (setf (uri-query place) query) + (setf (uri-fragment place) fragment) + (setf (uri-plist place) plist) + (setf (uri-escaped place) escaped) + (setf (uri-string place) nil) + (setf (uri-hashcode place) nil) + place + elseif (eq 'uri class) + then ;; allow the compiler to optimize the call to make-instance: + (make-instance 'uri + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil) + else (make-instance class + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil))) + +(defmethod uri-parsed-path ((uri uri)) + (when (uri-path uri) + (when (null (.uri-parsed-path uri)) + (setf (.uri-parsed-path uri) + (parse-path (uri-path uri) (uri-escaped uri)))) + (.uri-parsed-path uri))) + +(defmethod (setf uri-parsed-path) (path-list (uri uri)) + (assert (and (consp path-list) + (or (member (car path-list) '(:absolute :relative) + :test #'eq)))) + (setf (uri-path uri) (render-parsed-path path-list t)) + (setf (.uri-parsed-path uri) path-list) + path-list) + +(defun uri-authority (uri) + (when (uri-host uri) + (let ((*print-pretty* nil)) + (format nil "~a~@[:~a~]" (uri-host uri) (uri-port uri))))) + +(defun uri-nid (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-host uri) + else (error "URI is not a URN: ~s." uri))) + +(defun uri-nss (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-path uri) + else (error "URI is not a URN: ~s." uri))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parsing + +(defparameter *excluded-characters* + '(;; `delims' (except #\%, because it's handled specially): + #\< #\> #\" #\space #\# + ;; `unwise': + #\{ #\} #\| #\\ #\^ #\[ #\] #\`)) + +(defun reserved-char-vector (chars &key except) + (do* ((a (make-array 127 :element-type 'bit :initial-element 0)) + (chars chars (cdr chars)) + (c (car chars) (car chars))) + ((null chars) a) + (if* (and except (member c except :test #'char=)) + thenret + else (setf (sbit a (char-int c)) 1)))) + +(defparameter *reserved-characters* + (reserved-char-vector + (append *excluded-characters* + '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%)))) +(defparameter *reserved-authority-characters* + (reserved-char-vector + (append *excluded-characters* '(#\; #\/ #\? #\: #\@)))) +(defparameter *reserved-path-characters* + (reserved-char-vector + (append *excluded-characters* + '(#\; +;;;;The rfc says this should be here, but it doesn't make sense. + ;; #\= + #\/ #\?)))) +(defparameter *reserved-path-characters2* + ;; These are the same characters that are in + ;; *reserved-path-characters*, minus #\/. Why? Because the parsed + ;; representation of the path can contain the %2f converted into a /. + ;; That's the whole point of having the parsed representation, so that + ;; lisp programs can deal with the path element data in the most + ;; convenient form. + (reserved-char-vector + (append *excluded-characters* + '(#\; +;;;;The rfc says this should be here, but it doesn't make sense. + ;; #\= + #\?)))) +(defparameter *reserved-fragment-characters* + (reserved-char-vector (remove #\# *excluded-characters*))) + +(eval-when (:compile-toplevel :execute) +(defun gen-char-range-list (start end) + (do* ((res '()) + (endcode (1+ (char-int end))) + (chcode (char-int start) + (1+ chcode)) + (hyphen nil)) + ((= chcode endcode) + ;; - has to be first, otherwise it signifies a range! + (if* hyphen + then (setq res (nreverse res)) + (push #\- res) + res + else (nreverse res))) + (if* (= #.(char-int #\-) chcode) + then (setq hyphen t) + else (push (code-char chcode) res)))) +) + +(defparameter *valid-nid-characters* + (reserved-char-vector + '#.(nconc (gen-char-range-list #\a #\z) + (gen-char-range-list #\A #\Z) + (gen-char-range-list #\0 #\9) + '(#\- #\. #\+)))) +(defparameter *reserved-nss-characters* + (reserved-char-vector + (append *excluded-characters* '(#\& #\~ #\/ #\?)))) + +(defparameter *illegal-characters* + (reserved-char-vector (remove #\# *excluded-characters*))) +(defparameter *strict-illegal-query-characters* + (reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*)))) +(defparameter *illegal-query-characters* + (reserved-char-vector + *excluded-characters* :except '(#\^ #\| #\#))) + + +(defun parse-uri (thing &key (class 'uri) &aux escape) + (when (uri-p thing) (return-from parse-uri thing)) + + (setq escape (escape-p thing)) + (multiple-value-bind (scheme host port path query fragment) + (parse-uri-string thing) + (when scheme + (setq scheme + (intern (funcall + (case *current-case-mode* + ((:case-insensitive-upper :case-sensitive-upper) + #'string-upcase) + ((:case-insensitive-lower :case-sensitive-lower) + #'string-downcase)) + (decode-escaped-encoding scheme escape)) + (find-package :keyword)))) + + (when (and scheme (eq :urn scheme)) + (return-from parse-uri + (make-instance 'urn :scheme scheme :nid host :nss path))) + + (when host (setq host (decode-escaped-encoding host escape))) + (when port + (setq port (read-from-string port)) + (when (not (numberp port)) (error "port is not a number: ~s." port)) + (when (not (plusp port)) + (error "port is not a positive integer: ~d." port)) + (when (eql port (case scheme + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23))) + (setq port nil))) + (when (or (string= "" path) + (and ;; we canonicalize away a reference to just /: + scheme + (member scheme '(:http :https :ftp) :test #'eq) + (string= "/" path))) + (setq path nil)) + (when path + (setq path + (decode-escaped-encoding path escape *reserved-path-characters*))) + (when query (setq query (decode-escaped-encoding query escape))) + (when fragment + (setq fragment + (decode-escaped-encoding fragment escape + *reserved-fragment-characters*))) + (if* (eq 'uri class) + then ;; allow the compiler to optimize the make-instance call: + (make-instance 'uri + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape) + else ;; do it the slow way: + (make-instance class + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape)))) + +(defmethod uri ((thing uri)) + thing) + +(defmethod uri ((thing string)) + (parse-uri thing)) + +(defmethod uri ((thing t)) + (error "Cannot coerce ~s to a uri." thing)) + +(defvar *strict-parse* t) + +(defun parse-uri-string (string &aux (illegal-chars *illegal-characters*)) + (declare (optimize (speed 3))) + ;; Speed is important, so use a specialized state machine instead of + ;; regular expressions for parsing the URI string. The regexp we are + ;; simulating: + ;; ^(([^:/?#]+):)? + ;; (//([^/?#]*))? + ;; ([^?#]*) + ;; (\?([^#]*))? + ;; (#(.*))? + (let* ((state 0) + (start 0) + (end (length string)) + (tokval nil) + (scheme nil) + (host nil) + (port nil) + (path-components '()) + (query nil) + (fragment nil) + ;; namespace identifier, for urn parsing only: + (nid nil)) + (declare (fixnum state start end)) + (flet ((read-token (kind &optional legal-chars) + (setq tokval nil) + (if* (>= start end) + then :end + else (let ((sindex start) + (res nil) + c) + (declare (fixnum sindex)) + (setq res + (loop + (when (>= start end) (return nil)) + (setq c (schar string start)) + (let ((ci (char-int c))) + (if* legal-chars + then (if* (and (eq :colon kind) (eq c #\:)) + then (return :colon) + elseif (= 0 (sbit legal-chars ci)) + then (.parse-error + "~ +URI ~s contains illegal character ~s at position ~d." + string c start)) + elseif (and (< ci 128) + *strict-parse* + (= 1 (sbit illegal-chars ci))) + then (.parse-error "~ +URI ~s contains illegal character ~s at position ~d." + string c start))) + (case kind + (:path (case c + (#\? (return :question)) + (#\# (return :hash)))) + (:query (case c (#\# (return :hash)))) + (:rest) + (t (case c + (#\: (return :colon)) + (#\? (return :question)) + (#\# (return :hash)) + (#\/ (return :slash))))) + (incf start))) + (if* (> start sindex) + then ;; we found some chars + ;; before we stopped the parse + (setq tokval (subseq string sindex start)) + :string + else ;; immediately stopped at a special char + (incf start) + res)))) + (failure (&optional why) + (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" + string state why)) + (impossible () + (.parse-error "impossible state: ~d [~s]" state string))) + (loop + (case state + (0 ;; starting to parse + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 1)) + (:end (setq state 9)))) + (1 ;; seen <token><special char> + (let ((token tokval)) + (ecase (read-token t) + (:colon (setq scheme token) + (if* (equalp "urn" scheme) + then (setq state 15) + else (setq state 2))) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (push "/" path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (2 ;; seen <scheme>: + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 10)) + (:end (setq state 9)))) + (10 ;; seen <scheme>:<token> + (let ((token tokval)) + (ecase (read-token t) + (:colon (failure)) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (3 ;; seen / or <scheme>:/ + (ecase (read-token t) + (:colon (failure)) + (:question (push "/" path-components) + (setq state 7)) + (:hash (push "/" path-components) + (setq state 8)) + (:slash (setq state 4)) + (:string (push "/" path-components) + (push tokval path-components) + (setq state 6)) + (:end (push "/" path-components) + (setq state 9)))) + (4 ;; seen [<scheme>:]// + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash (failure)) + (:string (setq host tokval) + (setq state 11)) + (:end (failure)))) + (11 ;; seen [<scheme>:]//<host> + (ecase (read-token t) + (:colon (setq state 5)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (5 ;; seen [<scheme>:]//<host>: + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (setq port tokval) + (setq state 12)) + (:end (failure)))) + (12 ;; seen [<scheme>:]//<host>:[<port>] + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (6 ;; seen / + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (push tokval path-components) + (setq state 13)) + (:end (setq state 9)))) + (13 ;; seen path + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (7 ;; seen ? + (setq illegal-chars + (if* *strict-parse* + then *strict-illegal-query-characters* + else *illegal-query-characters*)) + (ecase (prog1 (read-token :query) + (setq illegal-chars *illegal-characters*)) + (:hash (setq state 8)) + (:string (setq query tokval) + (setq state 14)) + (:end (setq state 9)))) + (14 ;; query + (ecase (read-token :query) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (8 ;; seen # + (ecase (read-token :rest) + (:string (setq fragment tokval) + (setq state 9)) + (:end (setq state 9)))) + (9 ;; done + (return + (values + scheme host port + (apply #'concatenate 'simple-string (nreverse path-components)) + query fragment))) + ;; URN parsing: + (15 ;; seen urn:, read nid now + (case (read-token :colon *valid-nid-characters*) + (:string (setq nid tokval) + (setq state 16)) + (t (failure "missing namespace identifier")))) + (16 ;; seen urn:<nid> + (case (read-token t) + (:colon (setq state 17)) + (t (failure "missing namespace specific string")))) + (17 ;; seen urn:<nid>:, rest is nss + (return (values scheme + nid + nil + (progn + (setq illegal-chars *reserved-nss-characters*) + (read-token :rest) + tokval)))) + (t (.parse-error + "internal error in parse engine, wrong state: ~s." state))))))) + +(defun escape-p (string) + (declare (optimize (speed 3))) + (do* ((i 0 (1+ i)) + (max (the fixnum (length string)))) + ((= i max) nil) + (declare (fixnum i max)) + (when (char= #\% (schar string i)) + (return t)))) + +(defun parse-path (path-string escape) + (do* ((xpath-list (delimited-string-to-list path-string #\/)) + (path-list + (progn + (if* (string= "" (car xpath-list)) + then (setf (car xpath-list) :absolute) + else (push :relative xpath-list)) + xpath-list)) + (pl (cdr path-list) (cdr pl)) + segments) + ((null pl) path-list) + (if* (cdr (setq segments (delimited-string-to-list (car pl) #\;))) + then ;; there is a param +;;; (setf (car pl) segments) + (setf (car pl) + (mapcar #'(lambda (s) + (decode-escaped-encoding + s escape *reserved-path-characters2*)) + segments)) + else ;; no param +;;; (setf (car pl) (car segments)) + (setf (car pl) + (decode-escaped-encoding + (car segments) escape *reserved-path-characters2*))))) + +(defun decode-escaped-encoding (string escape + &optional (reserved-chars + *reserved-characters*)) + ;; Return a string with the real characters. + (when (null escape) (return-from decode-escaped-encoding string)) + (do* ((i 0 (1+ i)) + (max (length string)) + (new-string (copy-seq string)) + (new-i 0 (1+ new-i)) + ch ch2 chc chc2) + ((= i max) + (shrink-vector new-string new-i)) + (if* (char= #\% (setq ch (schar string i))) + then (when (> (+ i 3) max) + (.parse-error + "Unsyntactic escaped encoding in ~s." string)) + (setq ch (schar string (incf i))) + (setq ch2 (schar string (incf i))) + (when (not (and (setq chc (digit-char-p ch 16)) + (setq chc2 (digit-char-p ch2 16)))) + (.parse-error + "Non-hexidecimal digits after %: %c%c." ch ch2)) + (let ((ci (+ (* 16 chc) chc2))) + (if* (or (null reserved-chars) + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (setf (schar new-string new-i) + (code-char ci)) + else (setf (schar new-string new-i) #\%) + (setf (schar new-string (incf new-i)) ch) + (setf (schar new-string (incf new-i)) ch2))) + else (setf (schar new-string new-i) ch)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Printing + +(defun render-uri (uri stream + &aux (escape (uri-escaped uri)) + (*print-pretty* nil)) + (when (null (uri-string uri)) + (setf (uri-string uri) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (port (uri-port uri)) + (path (uri-path uri)) + (query (uri-query uri)) + (fragment (uri-fragment uri))) + (concatenate 'simple-string + (when scheme + (encode-escaped-encoding + (string-downcase ;; for upper case lisps + (symbol-name scheme)) + *reserved-characters* escape)) + (when scheme ":") + (when host "//") + (when host + (encode-escaped-encoding + host *reserved-authority-characters* escape)) + (when port ":") + (when port + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) + ) + (when path + (encode-escaped-encoding path + nil + ;;*reserved-path-characters* + escape)) + (when query "?") + (when query (encode-escaped-encoding query nil escape)) + (when fragment "#") + (when fragment (encode-escaped-encoding fragment nil escape)))))) + (if* stream + then (format stream "~a" (uri-string uri)) + else (uri-string uri))) + +(defun render-parsed-path (path-list escape) + (do* ((res '()) + (first (car path-list)) + (pl (cdr path-list) (cdr pl)) + (pe (car pl) (car pl))) + ((null pl) + (when res (apply #'concatenate 'simple-string (nreverse res)))) + (when (or (null first) + (prog1 (eq :absolute first) + (setq first nil))) + (push "/" res)) + (if* (atom pe) + then (push + (encode-escaped-encoding pe *reserved-path-characters* escape) + res) + else ;; contains params + (push (encode-escaped-encoding + (car pe) *reserved-path-characters* escape) + res) + (dolist (item (cdr pe)) + (push ";" res) + (push (encode-escaped-encoding + item *reserved-path-characters* escape) + res))))) + +(defun render-urn (urn stream + &aux (*print-pretty* nil)) + (when (null (uri-string urn)) + (setf (uri-string urn) + (let ((nid (urn-nid urn)) + (nss (urn-nss urn))) + (concatenate 'simple-string "urn:" nid ":" nss)))) + (if* stream + then (format stream "~a" (uri-string urn)) + else (uri-string urn))) + +(defparameter *escaped-encoding* + (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) + +(defun encode-escaped-encoding (string reserved-chars escape) + (when (null escape) (return-from encode-escaped-encoding string)) + ;; Make a string as big as it possibly needs to be (3 times the original + ;; size), and truncate it at the end. + (do* ((max (length string)) + (new-max (* 3 max)) ;; worst case new size + (new-string (make-string new-max)) + (i 0 (1+ i)) + (new-i -1) + c ci) + ((= i max) + (shrink-vector new-string (incf new-i))) + (setq ci (char-int (setq c (schar string i)))) + (if* (or (null reserved-chars) + (> ci 127) + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (incf new-i) + (setf (schar new-string new-i) c) + else ;; need to escape it + (multiple-value-bind (q r) (truncate ci 16) + (setf (schar new-string (incf new-i)) #\%) + (setf (schar new-string (incf new-i)) (elt *escaped-encoding* q)) + (setf (schar new-string (incf new-i)) + (elt *escaped-encoding* r)))))) + +(defmethod print-object ((uri uri) stream) + (if* *print-escape* + then (format stream "#<~a ~a>" 'uri (render-uri uri nil)) + else (render-uri uri stream))) + +(defmethod print-object ((urn urn) stream) + (if* *print-escape* + then (format stream "#<~a ~a>" 'uri (render-urn urn nil)) + else (render-urn urn stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; merging and unmerging + +(defmethod merge-uris ((uri string) (base string) &optional place) + (merge-uris (parse-uri uri) (parse-uri base) place)) + +(defmethod merge-uris ((uri uri) (base string) &optional place) + (merge-uris uri (parse-uri base) place)) + +(defmethod merge-uris ((uri string) (base uri) &optional place) + (merge-uris (parse-uri uri) base place)) + +(defmethod merge-uris ((uri uri) (base uri) &optional place) + ;; The following is from + ;; http://info.internet.isi.edu/in-notes/rfc/files/rfc2396.txt + ;; and is algorithm we use to merge URIs. + ;; + ;; For more information, see section 5.2 of the RFC. + ;; + (tagbody +;;;; step 2 + (when (and (null (uri-parsed-path uri)) + (null (uri-scheme uri)) + (null (uri-host uri)) + (null (uri-port uri)) + (null (uri-query uri))) + (return-from merge-uris + (let ((new (copy-uri base :place place))) + (when (uri-query uri) + (setf (uri-query new) (uri-query uri))) + (when (uri-fragment uri) + (setf (uri-fragment new) (uri-fragment uri))) + new))) + + (setq uri (copy-uri uri :place place)) + +;;;; step 3 + (when (uri-scheme uri) + (return-from merge-uris uri)) + (setf (uri-scheme uri) (uri-scheme base)) + +;;;; step 4 + (when (uri-host uri) (go :done)) + (setf (uri-host uri) (uri-host base)) + (setf (uri-port uri) (uri-port base)) + +;;;; step 5 + (let ((p (uri-parsed-path uri))) + (when (and p (eq :absolute (car p))) + (when (equal '(:absolute "") p) + ;; Canonicalize the way parsing does: + (setf (uri-path uri) nil)) + (go :done))) + +;;;; step 6 + (let* ((base-path + (or (uri-parsed-path base) + ;; needed because we canonicalize away a path of just `/': + '(:absolute ""))) + (path (uri-parsed-path uri)) + new-path-list) + (when (not (eq :absolute (car base-path))) + (error "Cannot merge ~a and ~a, since latter is not absolute." + uri base)) + + ;; steps 6a and 6b: + (setq new-path-list + (append (butlast base-path) + (if* path then (cdr path) else '("")))) + + ;; steps 6c and 6d: + (let ((last (last new-path-list))) + (if* (atom (car last)) + then (when (string= "." (car last)) + (setf (car last) "")) + else (when (string= "." (caar last)) + (setf (caar last) "")))) + (setq new-path-list + (delete "." new-path-list :test #'(lambda (a b) + (if* (atom b) + then (string= a b) + else nil)))) + + ;; steps 6e and 6f: + (let ((npl (cdr new-path-list)) + index tmp fix-tail) + (setq fix-tail + (string= ".." (let ((l (car (last npl)))) + (if* (atom l) + then l + else (car l))))) + (loop + (setq index + (position ".." npl + :test #'(lambda (a b) + (string= a + (if* (atom b) + then b + else (car b)))))) + (when (null index) (return)) + (when (= 0 index) + ;; The RFC says, in 6g, "that the implementation may handle + ;; this error by retaining these components in the resolved + ;; path, by removing them from the resolved path, or by + ;; avoiding traversal of the reference." The examples in C.2 + ;; imply that we should do the first thing (retain them), so + ;; that's what we'll do. + (return)) + (if* (= 1 index) + then (setq npl (cddr npl)) + else (setq tmp npl) + (dotimes (x (- index 2)) (setq tmp (cdr tmp))) + (setf (cdr tmp) (cdddr tmp)))) + (setf (cdr new-path-list) npl) + (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) + + ;; step 6g: + ;; don't complain if new-path-list starts with `..'. See comment + ;; above about this step. + + ;; step 6h: + (when (or (equal '(:absolute "") new-path-list) + (equal '(:absolute) new-path-list)) + (setq new-path-list nil)) + (setf (uri-path uri) + (render-parsed-path new-path-list + ;; don't know, so have to assume: + t))) + +;;;; step 7 + :done + (return-from merge-uris uri))) + +(defmethod enough-uri ((uri string) (base string) &optional place) + (enough-uri (parse-uri uri) (parse-uri base) place)) + +(defmethod enough-uri ((uri uri) (base string) &optional place) + (enough-uri uri (parse-uri base) place)) + +(defmethod enough-uri ((uri string) (base uri) &optional place) + (enough-uri (parse-uri uri) base place)) + +(defmethod enough-uri ((uri uri) (base uri) &optional place) + (let ((new-scheme nil) + (new-host nil) + (new-port nil) + (new-parsed-path nil)) + + (when (or (and (uri-scheme uri) + (not (equalp (uri-scheme uri) (uri-scheme base)))) + (and (uri-host uri) + (not (equalp (uri-host uri) (uri-host base)))) + (not (equalp (uri-port uri) (uri-port base)))) + (return-from enough-uri uri)) + + (when (null (uri-host uri)) + (setq new-host (uri-host base))) + (when (null (uri-port uri)) + (setq new-port (uri-port base))) + + (when (null (uri-scheme uri)) + (setq new-scheme (uri-scheme base))) + + ;; Now, for the hard one, path. + ;; We essentially do here what enough-namestring does. + (do* ((base-path (uri-parsed-path base)) + (path (uri-parsed-path uri)) + (bp base-path (cdr bp)) + (p path (cdr p))) + ((or (null bp) (null p)) + ;; If p is nil, that means we have something like + ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so + ;; new-parsed-path will be nil. + (when (null bp) + (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)))) + (if* (equal (car bp) (car p)) + thenret ;; skip it + else (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)) + (return))) + + (let ((new-path + (when new-parsed-path + (render-parsed-path new-parsed-path + ;; don't know, so have to assume: + t))) + (new-query (uri-query uri)) + (new-fragment (uri-fragment uri)) + (new-plist (copy-list (uri-plist uri)))) + (if* (and (null new-scheme) + (null new-host) + (null new-port) + (null new-path) + (null new-parsed-path) + (null new-query) + (null new-fragment)) + then ;; can't have a completely empty uri! + (copy-uri nil + :class (class-of uri) + :place place + :path "/" + :plist new-plist) + else (copy-uri nil + :class (class-of uri) + :place place + :scheme new-scheme + :host new-host + :port new-port + :path new-path + :parsed-path new-parsed-path + :query new-query + :fragment new-fragment + :plist new-plist))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; support for interning URIs + +(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys) + #+allegro + (apply #'make-hash-table :size size + :hash-function 'uri-hash + :test 'uri= :values nil keys) + #-allegro + (apply #'make-hash-table :size size keys)) + +(defun gethash-uri (uri table) + #+allegro (gethash uri table) + #-allegro + (let* ((hash (uri-hash uri)) + (existing (gethash hash table))) + (dolist (u existing) + (when (uri= u uri) + (return-from gethash-uri (values u t)))) + (values nil nil))) + +(defun puthash-uri (uri table) + #+allegro (excl:puthash-key uri table) + #-allegro + (let ((existing (gethash (uri-hash uri) table))) + (dolist (u existing) + (when (uri= u uri) + (return-from puthash-uri u))) + (setf (gethash (uri-hash uri) table) + (cons uri existing)) + uri)) + + +(defun uri-hash (uri) + (if* (uri-hashcode uri) + thenret + else (setf (uri-hashcode uri) + (sxhash + #+allegro + (render-uri uri nil) + #-allegro + (string-downcase + (render-uri uri nil)))))) + +(defvar *uris* (make-uri-space)) + +(defun uri-space () *uris*) + +(defun (setf uri-space) (new-val) + (setq *uris* new-val)) + +;; bootstrapping (uri= changed from function to method): +(when (fboundp 'uri=) (fmakunbound 'uri=)) + +(defgeneric uri= (uri1 uri2)) +(defmethod uri= ((uri1 uri) (uri2 uri)) + (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) + (return-from uri= nil)) + ;; RFC2396 says: a URL with an explicit ":port", where the port is + ;; the default for the scheme, is the equivalent to one where the + ;; port is elided. Hmmmm. This means that this function has to be + ;; scheme dependent. Grrrr. + (let ((default-port (case (uri-scheme uri1) + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23)))) + (and (equalp (uri-host uri1) (uri-host uri2)) + (eql (or (uri-port uri1) default-port) + (or (uri-port uri2) default-port)) + (string= (uri-path uri1) (uri-path uri2)) + (string= (uri-query uri1) (uri-query uri2)) + (string= (uri-fragment uri1) (uri-fragment uri2))))) + +(defmethod uri= ((urn1 urn) (urn2 urn)) + (when (not (eq (uri-scheme urn1) (uri-scheme urn2))) + (return-from uri= nil)) + (and (equalp (urn-nid urn1) (urn-nid urn2)) + (urn-nss-equal (urn-nss urn1) (urn-nss urn2)))) + +(defun urn-nss-equal (nss1 nss2 &aux len) + ;; Return t iff the nss values are the same. + ;; %2c and %2C are equivalent. + (when (or (null nss1) (null nss2) + (not (= (setq len (length nss1)) + (length nss2)))) + (return-from urn-nss-equal nil)) + (do* ((i 0 (1+ i)) + (state :char) + c1 c2) + ((= i len) t) + (setq c1 (schar nss1 i)) + (setq c2 (schar nss2 i)) + (ecase state + (:char + (if* (and (char= #\% c1) (char= #\% c2)) + then (setq state :percent+1) + elseif (char/= c1 c2) + then (return nil))) + (:percent+1 + (when (char-not-equal c1 c2) (return nil)) + (setq state :percent+2)) + (:percent+2 + (when (char-not-equal c1 c2) (return nil)) + (setq state :char))))) + +(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*)) + (let ((uri (gethash-uri xuri uri-space))) + (if* uri + thenret + else (puthash-uri xuri uri-space)))) + +(defmethod intern-uri ((uri string) &optional (uri-space *uris*)) + (intern-uri (parse-uri uri) uri-space)) + +(defun unintern-uri (uri &optional (uri-space *uris*)) + (if* (eq t uri) + then (clrhash uri-space) + elseif (uri-p uri) + then (remhash uri uri-space) + else (error "bad uri: ~s." uri))) + +(defmacro do-all-uris ((var &optional uri-space result-form) + &rest forms + &environment env) + "do-all-uris (var [[uri-space] result-form]) + {declaration}* {tag | statement}* +Executes the forms once for each uri with var bound to the current uri" + (let ((f (gensym)) + (g-ignore (gensym)) + (g-uri-space (gensym)) + (body (third (parse-body forms env)))) + `(let ((,g-uri-space (or ,uri-space *uris*))) + (prog nil + (flet ((,f (,var &optional ,g-ignore) + (declare (ignore-if-unused ,var ,g-ignore)) + (tagbody ,@body))) + (maphash #',f ,g-uri-space)) + (return ,result-form))))) + +(defun sharp-u (stream chr arg) + (declare (ignore chr arg)) + (let ((arg (read stream nil nil t))) + (if *read-suppress* + nil + (if* (stringp arg) + then (parse-uri arg) + else + + (internal-reader-error + stream + "#u takes a string or list argument: ~s" arg))))) + + +#+allegro +excl:: +#+allegro +(locally (declare (special std-lisp-readtable)) + (let ((*readtable* std-lisp-readtable)) + (set-dispatch-macro-character #\# #\u #'puri::sharp-u))) +#-allegro +(set-dispatch-macro-character #\# #\u #'puri::sharp-u) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide :uri) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; timings +;; (don't run under emacs with M-x fi:common-lisp) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'excl::gc)) + +#-allegro +(defun gc (&rest options) + (declare (ignore options)) + #+sbcl (sb-ext::gc) + #+cmu (ext::gc) + ) + +(defun time-uri-module () + (declare (optimize (speed 3) (safety 0) (debug 0))) + (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo") + (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 1...~%") + (time (dotimes (i 100000) (parse-uri uri))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 2...~%") + (let ((uri (parse-uri uri))) + (time (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri)))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 3...~%") + (time + (progn + (dotimes (i 100000) (parse-uri uri2)) + (let ((uri (parse-uri uri))) + (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri))))))) + +;;******** reference output (ultra, modified 5.0.1): +;;; starting timing testing 1... +; cpu time (non-gc) 13,710 msec user, 0 msec system +; cpu time (gc) 600 msec user, 10 msec system +; cpu time (total) 14,310 msec user, 10 msec system +; real time 14,465 msec +; space allocation: +; 1,804,261 cons cells, 7 symbols, 41,628,832 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,500 msec user, 0 msec system +; cpu time (gc) 280 msec user, 20 msec system +; cpu time (total) 27,780 msec user, 20 msec system +; real time 27,897 msec +; space allocation: +; 1,900,463 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 52,290 msec user, 10 msec system +; cpu time (gc) 1,290 msec user, 30 msec system +; cpu time (total) 53,580 msec user, 40 msec system +; real time 54,062 msec +; space allocation: +; 7,800,205 cons cells, 0 symbols, 81,697,496 other bytes, 0 static bytes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; after improving decode-escaped-encoding/encode-escaped-encoding: + +;;; starting timing testing 1... +; cpu time (non-gc) 14,520 msec user, 0 msec system +; cpu time (gc) 400 msec user, 0 msec system +; cpu time (total) 14,920 msec user, 0 msec system +; real time 15,082 msec +; space allocation: +; 1,800,270 cons cells, 0 symbols, 41,600,160 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,490 msec user, 10 msec system +; cpu time (gc) 300 msec user, 0 msec system +; cpu time (total) 27,790 msec user, 10 msec system +; real time 28,025 msec +; space allocation: +; 1,900,436 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 47,900 msec user, 20 msec system +; cpu time (gc) 920 msec user, 10 msec system +; cpu time (total) 48,820 msec user, 30 msec system +; real time 49,188 msec +; space allocation: +; 3,700,215 cons cells, 0 symbols, 81,707,144 other bytes, 0 static bytes Added: vendor/portableaserve/libs/puri-1.3.1/tests.lisp =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/tests.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/tests.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,416 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2003 Kevin Rosenberg (significant fixes for using +;; tester package) +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in +;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. +;; +;; Original version from ACL 6.1: +;; t-uri.cl,v 1.3.6.3.2.1 2001/08/09 17:42:43 layer +;; +;; $Id: tests.lisp,v 1.1 2004/02/08 15:44:10 rudi Exp $ + + +(defpackage #:puri-tests (:use #:puri #:cl #:ptester)) +(in-package #:puri-tests) + +(unintern-uri t) + +(defmacro gen-test-forms () + (let ((res '()) + (base-uri "http://a/b/c/d;p?q")) + + (dolist (x `(;; (relative-uri result base-uri compare-function) +;;;; RFC Appendix C.1 (normal examples) + ("g:h" "g:h" ,base-uri) + ("g" "http://a/b/c/g" ,base-uri) + ("./g" "http://a/b/c/g" ,base-uri) + ("g/" "http://a/b/c/g/" ,base-uri) + ("/g" "http://a/g" ,base-uri) + ("//g" "http://g" ,base-uri) + ("?y" "http://a/b/c/?y" ,base-uri) + ("g?y" "http://a/b/c/g?y" ,base-uri) + ("#s" "http://a/b/c/d;p?q#s" ,base-uri) + ("g#s" "http://a/b/c/g#s" ,base-uri) + ("g?y#s" "http://a/b/c/g?y#s" ,base-uri) + (";x" "http://a/b/c/;x" ,base-uri) + ("g;x" "http://a/b/c/g;x" ,base-uri) + ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri) + ("." "http://a/b/c/" ,base-uri) + ("./" "http://a/b/c/" ,base-uri) + (".." "http://a/b/" ,base-uri) + ("../" "http://a/b/" ,base-uri) + ("../g" "http://a/b/g" ,base-uri) + ("../.." "http://a/" ,base-uri) + ("../../" "http://a/" ,base-uri) + ("../../g" "http://a/g" ,base-uri) +;;;; RFC Appendix C.2 (abnormal examples) + ("" "http://a/b/c/d;p?q" ,base-uri) + ("../../../g" "http://a/../g" ,base-uri) + ("../../../../g" "http://a/../../g" ,base-uri) + ("/./g" "http://a/./g" ,base-uri) + ("/../g" "http://a/../g" ,base-uri) + ("g." "http://a/b/c/g." ,base-uri) + (".g" "http://a/b/c/.g" ,base-uri) + ("g.." "http://a/b/c/g.." ,base-uri) + ("..g" "http://a/b/c/..g" ,base-uri) + ("./../g" "http://a/b/g" ,base-uri) + ("./g/." "http://a/b/c/g/" ,base-uri) + ("g/./h" "http://a/b/c/g/h" ,base-uri) + ("g/../h" "http://a/b/c/h" ,base-uri) + ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri) + ("g;x=1/../y" "http://a/b/c/y" ,base-uri) + ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri) + ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) + ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri) + ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) + ("http:g" "http:g" ,base-uri) + + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/c.htm") + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/") + ("foo/bar/baz.htm#foo" + "http://a/foo/bar/baz.htm#foo" + "http://a/b") + ("foo/bar;x;y/bam.htm" + "http://a/b/c/foo/bar;x;y/bam.htm" + "http://a/b/c/"))) + (push `(test (intern-uri ,(second x)) + (intern-uri (merge-uris (intern-uri ,(first x)) + (intern-uri ,(third x)))) + :test 'uri=) + res)) + +;;;; intern tests + (dolist (x '(;; default port and specifying the default port are + ;; supposed to compare the same: + ("http://www.franz.com:80" "http://www.franz.com") + ("http://www.franz.com:80" "http://www.franz.com" eq) + ;; make sure they're `eq': + ("http://www.franz.com:80" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com" eq) + ("http://www.franz.com/foo" "http://www.franz.com/foo" eq) + ("http://www.franz.com/foo?bar" + "http://www.franz.com/foo?bar" eq) + ("http://www.franz.com/foo?bar#baz" + "http://www.franz.com/foo?bar#baz" eq) + ("http://WWW.FRANZ.COM" "http://www.franz.com" eq) + ("http://www.FRANZ.com" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com/" eq) + (;; %72 is "r", %2f is "/", %3b is ";" + "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/" + "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq))) + (push `(test (intern-uri ,(second x)) + (intern-uri ,(first x)) + :test ',(if (third x) + (third x) + 'uri=)) + res)) + +;;;; parsing and equivalence tests + (push `(test + (parse-uri "http://foo+bar?baz=b%26lob+bof") + (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'uri=) + res) + (push '(test + (parse-uri "http://www.foo.com") + (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end + :test 'uri=) + res) + (push `(test + "baz=b%26lob+bof" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'string=) + res) + (push `(test + "baz=b%26lob+bof%3d" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d")) + :test 'string=) + res) + (push + `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=) + res) + (push + `(test "A" (uri-query (parse-uri "xxx?%41")) :test 'string=) + res) + + (push `(test-error (parse-uri " ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri " foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "<foo") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo>") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "<foo>") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "%") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo%xyr") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "\"foo\"") + :condition-type 'uri-parse-error) + res) + (push `(test "%20" (format nil "~a" (parse-uri "%20")) + :test 'string=) + res) + (push `(test "&" (format nil "~a" (parse-uri "%26")) + :test 'string=) + res) + (push + `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar" + (format nil "~a" (parse-uri "foo%23bar#foobar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar#baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%23baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar/baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz")) + :test 'string=) + res) + (push `(test-error (parse-uri "foobar??") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foobar?foo?") + :condition-type 'uri-parse-error) + res) + (push `(test "foobar?%3f" + (format nil "~a" (parse-uri "foobar?%3f")) + :test 'string=) + res) + (push `(test + "http://foo/bAr;3/baz?baf=3" + (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3")) + :test 'string=) + res) + (push `(test + '(:absolute ("/bAr" "3") "baz") + (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")) + :test 'equal) + res) + (push `(test + "/%2fbAr;3/baz" + (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))) + (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz")) + (uri-path u)) + :test 'string=) + res) + (push `(test + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25" + (format nil "~a" + (parse-uri + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25")) + :test 'string=) + res) + (push `(test + "ftp://parcftp.xerox.com/pub/pcl/mop/" + (format nil "~a" + (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) + :test 'string=) + res) + +;;;; enough-uri tests + (dolist (x `(("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar/" + "baz.htm") + ("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar" + "baz.htm") + ("http://www.franz.com:80/foo/bar/baz.htm" + "http://www.franz.com:80/foo/bar" + "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar" "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo") + ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo") + + ("http://www.dnai.com/~layer/foo.htm" + "http://www.known.net" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com/~layer/foo.htm" + "http://www.dnai.com:8000/~layer/" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com:8000/~layer/foo.htm" + "http://www.dnai.com/~layer/" + "http://www.dnai.com:8000/~layer/foo.htm") + ("http://www.franz.com" + "http://www.franz.com" + "/"))) + (push `(test (parse-uri ,(third x)) + (enough-uri (parse-uri ,(first x)) + (parse-uri ,(second x))) + :test 'uri=) + res)) + +;;;; urn tests, ideas of which are from rfc2141 + (let ((urn "urn:com:foo-the-bar")) + (push `(test "com" (urn-nid (parse-uri ,urn)) + :test #'string=) + res) + (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn)) + :test #'string=) + res)) + (push `(test-error (parse-uri "urn:") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo$") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo_") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo:foo&bar") + :condition-type 'uri-parse-error) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:foo:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "urn:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123%2C456") + :test #'uri=) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "URN:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + + (push `(test t + (uri= (parse-uri "foo") (parse-uri "foo#"))) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://foo.com/bar?a=zip|zop"))) + res) + (push + '(test-error + (puri:parse-uri "http://foo.com/bar?a=zip|zop") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041"))) + res) + (push + '(test-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_…"))) + res) + (push + '(test-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_…") + :condition-type 'uri-parse-error) + res) + + `(progn ,@(nreverse res)))) + +(defun do-tests () + (let ((*break-on-test-failures* t)) + (with-tests (:name "puri") + (gen-test-forms))) + t) + + Added: vendor/portableaserve/libs/puri-1.3.1/uri.html =================================================================== --- vendor/portableaserve/libs/puri-1.3.1/uri.html 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/libs/puri-1.3.1/uri.html 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,408 @@ +<html> + +<head> +<title>URI support in Allegro CL</title> +</head> + +<body> + +<h1>URI support in Allegro CL</h1> + +This document contains the following sections: +<a href="#uri-intro-1"> + +1.0 Introduction</a> +<a href="#uri-api-1">2.0 The URI API definition</a> +<a href="#parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a> +<a href="#interning-uris-1">4.0 Interning URIs</a> +<a href="#acl-implementation-1">5.0 Allegro CL implementation notes</a> +<a href="#examples-1">6.0 Examples</a> + + +This version of the Allegro CL URI support documentation is for distribution with the +Open Source version of the URI code. Links to Allegro CL documentation other than +URI-specific files have been supressed. To see Allegro CL documentation, see <a +href="http://www.franz.com/support/documentation/">http://www.franz.com/support/documentation/</a>, +which is the Allegro CL documentation page of the franz inc. website. Links to Allegro CL +documentation can be found on that page. + +<hr> + +<hr> + +<h2><a name="uri-intro-1">1.0 Introduction</a></h2> + +URI stands for Universal Resource Identifier. For a description of +URIs, see RFC2396, which can be found in several places, including the IETF web site (<a +href="http://www.ietf.org/rfc/rfc2396.txt">http://www.ietf.org/rfc/rfc2396.txt</a>) and +the UCI/ICS web site (<a href="http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt">http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt</a>). +We prefer the UCI/ICS one as it has more examples. + +URIs are a superset in functionality and syntax to URLs (Universal Resource Locators) +and URNs (Universal Resource Names). That is, RFC2396 updates and merges RFC1738 and +RFC1808 into a single syntax, called the URI. It does exclude some portions of RFC1738 +that define specific syntax of individual URL schemes. + +In URL slang, the scheme is usually called the `protocol', but it is called +scheme in RFC1738. A URL `host' corresponds to the URI `authority.' The URL slang +`bookmark' or `anchor' is `fragment' in URI lingo. + +The URI facility was available as a patch to Allegro CL 5.0.1 and is included with +release 6.0. the URI facility might not be in an Allegro CL image. Evaluate <code>(require +:uri)</code> to ensure the facility is loaded (that form returns <code>nil</code> if the +URI module is already loaded). + +Broadly, the URI facility creates a Lisp object that represents a URI, and provides +setters and accessors to fields in the URI object. The URI object can also be interned, +much like symbols in CL are. This document describes the facility and the related +operators. + +Aside from the obvious slots which are called out in the RFC, URIs also have a property +list. With interning, this is another similarity between URIs and CL symbols. + +<hr> + +<hr> + +<h2><a name="uri-api-1">2.0 The URI API definition</a></h2> + +Symbols naming objects (functions, variables, etc.) in the uri module are +exported from the <code>net.uri</code> package. + +URIs are represented by CLOS objects. Their slots are: + +<pre> +scheme +host +port +path +query +fragment +plist +</pre> + +The <code>host</code> and <code>port</code> slots together correspond to the <code>authority</code> +(see RFC2396). There is an accessor-like function, <a href="operators/uri-authority.htm">uri-authority</a>, +that can be used to extract the authority from a URI. See the RFC2396 specifications +pointed to at the beginning of the <a href="#uri-intro-1">1.0 Introduction</a> for details +of all the slots except <code>plist</code>. The <code>plist</code> slot contains a +standard Common Lisp property list. + +All symbols are external in the <code>net.uri</code> package, unless otherwise noted. +Brief descriptions are given in this document, with complete descriptions in the +individual pages. + +<ul> + <li><a href="classes/uri.htm"><code>uri</code></a>: the class of URI objects. </li> + <li><a href="classes/urn.htm"><code>urn</code></a>: the class of URN objects. </li> + <li><a href="operators/uri-p.htm">uri-p</a> Arguments: object + Returns true if object is an instance of class <a href="classes/uri.htm"><code>uri</code></a>. + + </li> + <li><a href="operators/copy-uri.htm">copy-uri</a> Arguments: uri &key + place scheme host port path query fragment plist + Copies the specified URI object. See the description page for information on the + keyword arguments. + </li> + <li><a href="operators/uri-scheme.htm">uri-scheme</a> + <a href="operators/uri-host.htm">uri-host</a> + <a href="operators/uri-port.htm">uri-port</a> + <a href="operators/uri-path.htm">uri-path</a> + <a href="operators/uri-query.htm">uri-query</a> + <a href="operators/uri-fragment.htm">uri-fragment</a> + <a href="operators/uri-plist.htm">uri-plist</a> + Arguments: uri-object + These accessors return the value of the associated slots of the uri-object + </li> + <li><a href="operators/uri-authority.htm">uri-authority</a> Arguments: uri-object + + Returns the authority of uri-object. The authority combines the host and port. + </li> + <li><a href="operators/render-uri.htm">render-uri</a> Arguments: uri + stream + Print to stream the printed representation of uri. + </li> + <li><a href="operators/parse-uri.htm">parse-uri</a> Arguments: string &key + (class 'uri) + Parse string into a URI object. + </li> + <li><a href="operators/merge-uris.htm">merge-uris</a> Arguments: uri + base-uri &optional place + Return an absolute URI, based on uri, which can be relative, and base-uri + which must be absolute. + </li> + <li><a href="operators/enough-uri.htm">enough-uri</a> Arguments: uri + base + Converts uri into a relative URI using base as the base URI. + </li> + <li><a href="operators/uri-parsed-path.htm">uri-parsed-path</a> Arguments: uri + + Return the parsed representation of the path. + </li> + <li><a href="operators/uri.htm">uri</a> Arguments: object + Defined methods: if argument is a uri object, return it; create a uri object if + possible and return it, or error if not possible. + </li> +</ul> + +<hr> + +<hr> + +<h2><a name="parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a></h2> + +The method <a href="operators/uri-path.htm">uri-path</a> returns the path +portion of the URI, in string form. The method <a href="operators/uri-parsed-path.htm">uri-parsed-path</a> +returns the path portion of the URI, in list form. This list form is discussed below, +after a discussion of decoding/encoding. + +RFC2396 lays out a method for inserting into URIs reserved characters. You do +this by escaping the character. An escaped character is defined like this: + +<pre> +escaped = "%" hex hex + +hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | "a" | "b" | "c" | "d" | "e" | "f" +</pre> + +In addition, the RFC defines excluded characters: + +<pre> +"<" | ">" | "#" | "%" | <"> | "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" +</pre> + +The set of reserved characters are: + +<pre> +";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | "$" | "," +</pre> + +with the following exceptions: + +<ul> + <li>within the authority component, the characters ";", ":", + "@", "?", and "/" are reserved. </li> + <li>within a path segment, the characters "/", ";", "=", and + "?" are reserved. </li> + <li>within a query component, the characters ";", "/", "?", + ":", "@", "&", "=", "+", + ",", and "$" are reserved. </li> +</ul> + +From the RFC, there are two important rules about escaping and unescaping (encoding and +decoding): + +<ul> + <li>decoding should only happen when the URI is parsed into component parts;</li> + <li>encoding can only occur when a URI is made from component parts (ie, rendered for + printing). </li> +</ul> + +The implication of this is that to decode the URI, it must be in a parsed state. That +is, you can't convert %2f (the escaped form of +"/") until the path has been parsed into its component parts. Another important +desire is for the application viewing the component parts to see the decoded values of the +components. For example, consider: + +<pre> +http://www.franz.com/calculator/3%2f2 +</pre> + +This might be the implementation of a calculator, and how someone would execute 3/2. +Clearly, the application that implements this would want to see path components of +"calculator" and "3/2". "3%2f2" would not be useful to the +calculator application. + +For the reasons given above, a parsed version of the path is available and has the +following form: + +<pre> +([:absolute | :relative] component1 [component2...]) +</pre> + +where components are: + +<pre> +element | (element param1 [param2 ...]) +</pre> + +and element is a path element, and the param's are path element parameters. +For example, the result of + +<pre> +(uri-parsed-path (parse-uri "foo;10/bar:x;y;z/baz.htm")) +</pre> + +is + +<pre> +(:relative ("foo" "10") ("bar:x" "y" "z") "baz.htm") +</pre> + +There is a certain amount of canonicalization that occurs when parsing: + +<ul> + <li>A path of <code>(:absolute)</code> or <code>(:absolute "")</code> is + equivalent to a <code>nil</code> path. That is, <code>http://a/</code> is parsed with a <code>nil</code> + path and printed as <code>http://a</code>. </li> + <li>Escaped characters that are not reserved are not escaped upon printing. For example, <code>"foob%61r"</code> + is parsed into <code>"foobar"</code> and appears as <code>"foobar"</code> + when the URI is printed. </li> +</ul> + +<hr> + +<hr> + +<h2><a name="interning-uris-1">4.0 Interning URIs</a></h2> + +This section describes how to intern URIs. Interning is not mandatory. URIs can be used +perfectly well without interning them. + +Interned URIs in Allegro are like symbols. That is, a string representing a URI, when +parsed and interned, will always yield an eq object. For example: + +<pre> +(eq (intern-uri "http://www.franz.com") + (intern-uri "http://www.franz.com")) +</pre> + +is always true. (Two strings with identical contents may or may not be eq +in Common Lisp, note.) + +The functions associated with interning are: + +<ul> + <li><a href="operators/make-uri-space.htm">make-uri-space</a> Arguments: &key + size + Make a new hash-table object to contain interned URIs. + </li> + <li><a href="operators/uri-space.htm">uri-space</a> Arguments: + Return the object into which URIs are currently being interned. + </li> + <li><a href="operators/uri_eq.htm">uri=</a> Arguments: uri1 uri2 + Returns true if uri1 and uri2 are equivalent. + </li> + <li><a href="operators/intern-uri.htm">intern-uri</a> Arguments: uri-name + &optional uri-space + Intern the uri object specified in the uri-space specified. Methods exist for strings + and uri objects. + </li> + <li><a href="operators/unintern-uri.htm">unintern-uri</a> Arguments: uri + &optional uri-space + Unintern the uri object specified or all uri objects (in uri-space if specified) + if uri is <code>t</code>. + </li> + <li><a href="operators/do-all-uris.htm">do-all-uris</a> Arguments: (var &optional + uri-space result) &body body + Bind var to all currently defined uris (in uri-space if specified) and + evaluate body. + </li> +</ul> + +<hr> + +<hr> + +<h2><a name="acl-implementation-1">5.0 Allegro CL implementation notes</a></h2> + +<ol> + <li>The following are true: + <code>(uri= (parse-uri "http://www.franz.com/")</code> +     <code>(parse-uri "http://www.franz.com"))</code> + <code>(eq (intern-uri "http://www.franz.com/")</code> +    <code>(intern-uri "http://www.franz.com"))</code> + </li> + <li>The following is true: + <code>(eq (intern-uri "http://www.franz.com:80/foo/bar.htm")</code> +     <code>(intern-uri "http://www.franz.com/foo/bar.htm"))</code> + (I.e. specifying the default port is the same as specifying no port at all. This is + specific in RFC2396.) </li> + <li>The scheme and authority are case-insensitive. In Allegro CL, the + scheme is a keyword that appears in the normal case for the Lisp in which you are + executing. </li> + <li><code>#u"..."</code> is shorthand for <code>(parse-uri "...")</code> + but if an existing <code>#u</code> dispatch macro definition exists, it will not be + overridden. </li> + <li>The interaction between setting the scheme, host, port, path, query, and fragment slots + of URI objects, in conjunction with interning URIs will have very bad and unpredictable + results. </li> + <li>The printable representation of URIs is cached, for efficiency. This caching is undone + when the above slots are changed. That is, when you create a URI the printed + representation is cached. When you change one of the above mentioned slots, the printed + representation is cleared and calculated when the URI is next printed. For example: </li> +</ol> + +<pre> +user(10): (setq u #u"http://foo.bar.com/foo/bar") +#<uri http://foo.bar.com/foo/bar> +user(11): (setf (net.uri:uri-host u) "foo.com") +"foo.com" +user(12): u +#<uri http://foo.com/foo/bar> +user(13): +</pre> + +This allows URIs behavior to follow the principle of least surprise. + +<hr> + +<hr> + +<h2><a name="examples-1">6.0 Examples</a></h2> + +<pre> +uri(10): (use-package :net.uri) +t +uri(11): (parse-uri "foo") +#<uri foo> +uri(12): #u"foo" +#<uri foo> +uri(13): (setq base (intern-uri "http://www.franz.com/foo/bar/")) +#<uri http://www.franz.com/foo/bar/> +uri(14): (merge-uris (parse-uri "foo.htm") base) +#<uri http://www.franz.com/foo/bar/foo.htm> +uri(15): (merge-uris (parse-uri "?foo") base) +#<uri http://www.franz.com/foo/bar/?foo> +uri(16): (setq base (intern-uri "http://www.franz.com/foo/bar/baz.htm")) +#<uri http://www.franz.com/foo/bar/baz.htm> +uri(17): (merge-uris (parse-uri "foo.htm") base) +#<uri http://www.franz.com/foo/bar/foo.htm> +uri(18): (merge-uris #u"?foo" base) +#<uri http://www.franz.com/foo/bar/?foo> +uri(19): (describe #u"http://www.franz.com") +#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>: + The following slots have :instance allocation: + scheme :http + host "www.franz.com" + port nil + path nil + query nil + fragment nil + plist nil + escaped nil + string "http://www.franz.com" + parsed-path nil + hashcode nil +uri(20): (describe #u"http://www.franz.com/") +#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>: + The following slots have :instance allocation: + scheme :http + host "www.franz.com" + port nil + path nil + query nil + fragment nil + plist nil + escaped nil + string "http://www.franz.com" + parsed-path nil + hashcode nil +uri(21): #u"foobar#baz%23xxx" +#<uri foobar#baz#xxx> +</pre> + +Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved. +Created 2001.8.16. +</body> +</html> Added: vendor/portableaserve/logical-hostnames.lisp =================================================================== --- vendor/portableaserve/logical-hostnames.lisp 2006-02-18 09:34:15 UTC (rev 1845) +++ vendor/portableaserve/logical-hostnames.lisp 2006-02-18 10:02:10 UTC (rev 1846) @@ -0,0 +1,56 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- + +(in-package "CL-USER") + +(setf (logical-pathname-translations "ACL-COMPAT") + `((#-mcl "*.*.*" #+mcl "**;*.*.*" ;mcl gives recording source-file error when redefining anything loaded with this + ;; e.g., "/home/jsc/lisp/src/aserve/acl-compat-lw/" + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative "acl-compat" #+mcl :wild-inferiors) + :name :wild + :type :wild + :version :wild +; :case :common +) + *load-truename*)))) + +#+lispworks +(setf (logical-pathname-translations "CL-SSL") + `(("*.*.*" + ;; e.g., "/home/jsc/lisp/src/aserve/acl-compat-lw/cl-ssl/" + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative "acl-compat-lw" "cl-ssl") + :name :wild + :type :wild + :version :wild +; :case :common +) + *load-truename*)))) + + +(setf (logical-pathname-translations "ASERVE") + `(("**;*.lisp.*" ;,(logical-pathname "**;*.cl.*") + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative "aserve" + :wild-inferiors) + :name :wild + :type "cl" + :version :wild) + *load-truename* + )) + ("**;*.*.*" + ;; e.g., "/home/jsc/lisp/src/aserve/aserve-lw/**/" + ,(merge-pathnames + (make-pathname :host (pathname-host *load-truename*) + :directory '(:relative "aserve" + :wild-inferiors) + :name :wild + :type :wild + :version :wild + ;:case :common + ) + *load-truename*)))) +

1 0

[bknr-cvs] r1845 - / vendor vendor/cxml vendor/cxml/CVS vendor/cxml/sax-tests vendor/cxml/sax-tests/CVS
by bknr＠bknr.net 18 Feb '06

18 Feb '06

Author: hhubner Date: 2006-02-18 03:34:15 -0600 (Sat, 18 Feb 2006) New Revision: 1845 Added: vendor/ vendor/cxml/ vendor/cxml/CVS/ vendor/cxml/CVS/Entries vendor/cxml/CVS/Entries.Log vendor/cxml/CVS/Repository vendor/cxml/CVS/Root vendor/cxml/CVS/Template vendor/cxml/catalog.lisp vendor/cxml/characters.lisp vendor/cxml/package.lisp vendor/cxml/recoder.lisp vendor/cxml/sax-handler.lisp vendor/cxml/sax-proxy.lisp vendor/cxml/sax-tests/ vendor/cxml/sax-tests/CVS/ vendor/cxml/sax-tests/CVS/Entries vendor/cxml/sax-tests/CVS/Repository vendor/cxml/sax-tests/CVS/Root vendor/cxml/sax-tests/CVS/Template vendor/cxml/sax-tests/event-collecting-handler.lisp vendor/cxml/sax-tests/package.lisp vendor/cxml/sax-tests/tests.lisp vendor/cxml/space-normalizer.lisp vendor/cxml/split-sequence.lisp vendor/cxml/unparse.lisp vendor/cxml/util.lisp vendor/cxml/xml-name-rune-p.lisp vendor/cxml/xml-parse.lisp vendor/cxml/xmlns-normalizer.lisp vendor/cxml/xmls-compat.lisp Log: importing current cxml Added: vendor/cxml/CVS/Entries =================================================================== --- vendor/cxml/CVS/Entries 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,15 @@ +/catalog.lisp/1.4/Mon Jan 23 21:49:42 2006// +/characters.lisp/1.2/Mon Nov 28 22:33:47 2005// +/package.lisp/1.11/Thu Dec 29 00:31:36 2005// +/recoder.lisp/1.5/Thu Dec 29 00:31:36 2005// +/sax-handler.lisp/1.4/Thu Dec 29 00:31:36 2005// +/sax-proxy.lisp/1.4/Thu Dec 29 00:31:36 2005// +/space-normalizer.lisp/1.2/Thu Dec 29 00:39:25 2005// +/split-sequence.lisp/1.1.1.1/Sun Mar 13 18:02:35 2005// +/unparse.lisp/1.9/Fri Feb 17 12:53:19 2006// +/util.lisp/1.2/Mon Nov 28 22:33:47 2005// +/xml-name-rune-p.lisp/1.6/Mon Nov 28 22:33:47 2005// +/xml-parse.lisp/1.59/Mon Jan 23 21:45:48 2006// +/xmlns-normalizer.lisp/1.2/Tue Dec 27 20:01:32 2005// +/xmls-compat.lisp/1.2/Mon Nov 28 22:33:47 2005// +D Added: vendor/cxml/CVS/Entries.Log =================================================================== --- vendor/cxml/CVS/Entries.Log 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/CVS/Entries.Log 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1 @@ +A D/sax-tests//// Added: vendor/cxml/CVS/Repository =================================================================== --- vendor/cxml/CVS/Repository 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1 @@ +cxml/xml Added: vendor/cxml/CVS/Root =================================================================== --- vendor/cxml/CVS/Root 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1 @@ +:pserver:anonymous@common-lisp.net:/project/cxml/cvsroot Added: vendor/cxml/CVS/Template =================================================================== Added: vendor/cxml/catalog.lisp =================================================================== --- vendor/cxml/catalog.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/catalog.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,348 @@ +;;;; catalogs.lisp -- XML Catalogs -*- Mode: Lisp; readtable: runes -*- +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +(in-package :cxml) + +;;; http://www.oasis-open.org/committees/entity/spec.html +;;; +;;; Bugs: +;;; - We validate using the Catalog DTD while parsing, which is too strict +;;; and will will fail to parse files using other parser's extensions. +;;; (Jedenfalls behauptet das die Spec.) +;;; A long-term solution might be an XML Schema validator. + +(defvar *prefer* :public) +(defvar *default-catalog* + '(;; libxml standard + "/etc/xml/catalog" + ;; FreeBSD + "/usr/local/share/xml/catalog.ports")) + +(defstruct (catalog (:constructor %make-catalog ())) + main-files + (dtd-cache (make-dtd-cache)) + (file-table (puri:make-uri-space))) + +(defstruct (entry-file (:conc-name "")) + (system-entries) ;extid 2 + (rewrite-system-entries) ; 3 + (delegate-system-entries) ; 4 + (public-entries) ; 5 + (delegate-public-entries) ; 6 + (uri-entries) ;uri 2 + (rewrite-uri-entries) ; 3 + (delegate-uri-entries) ; 4 + (next-catalog-entries) ; 5/7 + ) + +(defun starts-with-p (string prefix) + (let ((mismatch (mismatch string prefix))) + (or (null mismatch) (= mismatch (length prefix))))) + +(defun normalize-public (str) + (setf str (rod-to-utf8-string (rod str))) + (flet ((whitespacep (c) + (find c #.(map 'string #'code-char '(#x9 #xa #xd #x20))))) + (let ((start (position-if-not #'whitespacep str)) + (end (position-if-not #'whitespacep str :from-end t)) + (spacep nil)) + (with-output-to-string (out) + (when start + (loop for i from start to end do + (let ((c (char str i))) + (cond + ((whitespacep c) + (unless spacep + (setf spacep t) + (write-char #\space out))) + (t + (setf spacep nil) + (write-char c out)))))))))) + +(defun normalize-uri (str) + (when (typep str 'puri:uri) + (setf str (puri:render-uri str nil))) + (setf str (rod-to-utf8-string (rod str))) + (with-output-to-string (out) + (loop for ch across str do + (let ((c (char-code ch))) + (if (< c 15) + (write-string (string-upcase (format nil "%~2,'0X" c)) out) + (write-char ch out)))))) + +(defun unwrap-publicid (str) + (normalize-public + (with-output-to-string (out) + (let ((i (length "urn:publicid:")) + (n (length str))) + (while (< i n) + (let ((c (char str i))) + (case c + (#\+ (write-char #\space out)) + (#\: (write-string "//" out)) + (#\; (write-string "::" out)) + (#\% + (let ((code + (parse-integer str + :start (+ i 1) + :end (+ i 3) + :radix 16))) + (write-char (code-char code) out)) + (incf i 2)) + (t (write-char c out)))) + (incf i)))))) + +(defun match-exact (key table &optional check-prefer) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (equal key from) (or (not check-prefer) (eq prefer :public))) + (return to))))) + +(defun match-prefix/rewrite (key table &optional check-prefer) + (let ((match nil) + (match-length -1)) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (or (not check-prefer) (eq prefer :public)) + (starts-with-p key from) + (> (length from) match-length)) + (setf match-length (length from)) + (setf match to)))) + (if match + (concatenate 'string + match + (subseq key match-length)) + nil))) + +(defun match-prefix/sorted (key table &optional check-prefer) + (let ((result '())) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (or (not check-prefer) (eq prefer :public)) + (starts-with-p key from)) + (push (cons (length from) to) result)))) + (mapcar #'cdr (sort result #'> :key #'car)))) + +(defun resolve-extid (public system catalog) + (when public (setf public (normalize-public public))) + (when system (setf system (normalize-uri system))) + (when (and system (starts-with-p system "urn:publicid:")) + (let ((new-public (unwrap-publicid system))) + (assert (or (null public) (equal public new-public))) + (setf public new-public + system nil))) + (let ((files (catalog-main-files catalog)) + (seen '())) + (while files + (let ((file (pop files)) + (delegates nil)) + (unless (typep file 'entry-file) + (setf file (find-catalog-file file catalog))) + (unless (or (null file) (member file seen)) + (push file seen) + (when system + (let ((result + (or (match-exact system (system-entries file)) + (match-prefix/rewrite + system + (rewrite-system-entries file))))) + (when result + (return result)) + (setf delegates + (match-prefix/sorted + system + (delegate-system-entries file))))) + (when (and public (not delegates)) + (let* ((check-prefer (and system t)) + (result + (match-exact public + (public-entries file) + check-prefer))) + (when result + (return result)) + (setf delegates + (match-prefix/sorted + public + (delegate-public-entries file) + check-prefer)))) + (if delegates + (setf files delegates) + (setf files (append (next-catalog-entries file) files)))))))) + +(defun resolve-uri (uri catalog) + (setf uri (normalize-uri uri)) + (when (starts-with-p uri "urn:publicid:") + (return-from resolve-uri + (resolve-extid (unwrap-publicid uri) nil catalog))) + (let ((files (catalog-main-files catalog)) + (seen '())) + (while files + (let ((file (pop files))) + (unless (typep file 'entry-file) + (setf file (find-catalog-file file catalog))) + (unless (or (null file) (member file seen)) + (push file seen) + (let ((result + (or (match-exact uri (uri-entries file)) + (match-prefix/rewrite uri (rewrite-uri-entries file))))) + (when result + (return result)) + (let* ((delegate-entries + (delegate-uri-entries file)) + (delegates + (match-prefix/sorted uri delegate-entries))) + (if delegates + (setf files delegates) + (setf files (append (next-catalog-entries file) files)))))))))) + +(defun find-catalog-file (uri catalog) + (setf uri (if (stringp uri) (safe-parse-uri uri) uri)) + (let* ((*dtd-cache* (catalog-dtd-cache catalog)) + (*cache-all-dtds* t) + (file (parse-catalog-file uri))) + (when file + (let ((interned (puri:intern-uri uri (catalog-file-table catalog)))) + (setf (getf (puri:uri-plist interned) 'catalog) file))) + file)) + +(defun make-catalog (&optional (uris *default-catalog*)) + (let ((result (%make-catalog))) + (setf (catalog-main-files result) + (loop + for uri in uris + for file = (find-catalog-file uri result) + when file collect file)) + result)) + +(defun parse-catalog-file (uri) + (handler-case + (parse-catalog-file/strict uri) + ((or file-error xml-parse-error) (c) + (warn "ignoring catalog error: ~A" c)))) + +(defparameter *catalog-dtd* + (let* ((cxml + (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)) + (dtd (merge-pathnames "catalog.dtd" cxml))) + (with-open-file (s dtd :element-type '(unsigned-byte 8)) + (let ((bytes + (make-array (file-length s) :element-type '(unsigned-byte 8)))) + (read-sequence bytes s) + bytes)))) + +(defun parse-catalog-file/strict (uri) + (let* ((*catalog* nil) + (dtd-sysid + (puri:parse-uri "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"))) + (flet ((entity-resolver (public system) + (declare (ignore public)) + (if (puri:uri= system dtd-sysid) + (make-octet-input-stream *catalog-dtd*) + nil))) + (with-open-stream (s (open (uri-to-pathname uri) + :element-type '(unsigned-byte 8) + :direction :input)) + (parse-stream s + (make-instance 'catalog-parser :uri uri) + :validate nil + :dtd (make-extid nil dtd-sysid) + :root #"catalog" + :entity-resolver #'entity-resolver))))) + +(defclass catalog-parser () + ((result :initform (make-entry-file) :accessor result) + (next :initform '() :accessor next) + (prefer-stack :initform (list *prefer*) :accessor prefer-stack) + (base-stack :accessor base-stack))) + +(defmethod initialize-instance :after + ((instance catalog-parser) &key uri) + (setf (base-stack instance) (list uri))) + +(defmethod prefer ((handler catalog-parser)) + (car (prefer-stack handler))) + +(defmethod base ((handler catalog-parser)) + (car (base-stack handler))) + +(defun get-attribute/lname (name attributes) + (let ((a (find name attributes + :key (lambda (a) + (or (sax:attribute-local-name a) + (sax:attribute-qname a))) + :test #'string=))) + (and a (sax:attribute-value a)))) + +(defmethod sax:start-element ((handler catalog-parser) uri lname qname attrs) + (declare (ignore uri)) + (setf lname (or lname qname)) + ;; we can dispatch on lnames only because we validate against the DTD, + ;; which disallows other namespaces. + (push (let ((new (get-attribute/lname "prefer" attrs))) + (cond + ((equal new "public") :public) + ((equal new "system") :system) + ((null new) (prefer handler)))) + (prefer-stack handler)) + (push (string-or (get-attribute/lname "base" attrs) (base handler)) + (base-stack handler)) + (flet ((geturi (lname) + (puri:merge-uris + (safe-parse-uri (get-attribute/lname lname attrs)) + (base handler)))) + (cond + ((string= lname "public") + (push (list (normalize-public (get-attribute/lname "publicId" attrs)) + (geturi "uri") + (prefer handler)) + (public-entries (result handler)))) + ((string= lname "system") + (push (list (normalize-uri (get-attribute/lname "systemId" attrs)) + (geturi "uri")) + (system-entries (result handler)))) + ((string= lname "uri") + (push (list (normalize-uri (get-attribute/lname "name" attrs)) + (geturi "uri")) + (uri-entries (result handler)))) + ((string= lname "rewriteSystem") + (push (list (normalize-uri + (get-attribute/lname "systemIdStartString" attrs)) + (get-attribute/lname "rewritePrefix" attrs)) + (rewrite-system-entries (result handler)))) + ((string= lname "rewriteURI") + (push (list (normalize-uri + (get-attribute/lname "uriStartString" attrs)) + (get-attribute/lname "rewritePrefix" attrs)) + (rewrite-uri-entries (result handler)))) + ((string= lname "delegatePublic") + (push (list (normalize-public + (get-attribute/lname "publicIdStartString" attrs)) + (geturi "catalog") + (prefer handler)) + (delegate-public-entries (result handler)))) + ((string= lname "delegateSystem") + (push (list (normalize-uri + (get-attribute/lname "systemIdStartString" attrs)) + (geturi "catalog")) + (delegate-system-entries (result handler)))) + ((string= lname "delegateURI") + (push (list (normalize-uri + (get-attribute/lname "uriStartString" attrs)) + (geturi "catalog")) + (delegate-uri-entries (result handler)))) + ((string= lname "nextCatalog") + (push (geturi "catalog") + (next-catalog-entries (result handler))))))) + +(defmethod sax:end-element ((handler catalog-parser) uri lname qname) + (declare (ignore uri lname qname)) + (pop (base-stack handler)) + (pop (prefer-stack handler))) + +(defmethod sax:end-document ((handler catalog-parser)) + (result handler)) Added: vendor/cxml/characters.lisp =================================================================== --- vendor/cxml/characters.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/characters.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,145 @@ +;;;; characters.lisp -- character class definitions +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: David Lichteblau +;;;; Copyright (C) 2004 knowledgeTools Int. GmbH + +;;; XXX xml-name-rune-p.lisp habe ich erst nach dem Schreiben dieses +;;; Files gefunden... + +;;; XXX wird derzeit in DOM:CREATE-ATTRIBUTE verwendet. Muesste aber +;;; wohl vom Parser auch schon geprueft werden (oder tut der das +;;; schon?). Vorher sollte man allerdings die Geschwindigkeit der Sache +;;; mal untersuchen. + +(in-package :cxml) + +(defparameter *base-char-ranges* + #((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6) + (#x00F8 #x00FF) (#x0100 #x0131) (#x0134 #x013E) (#x0141 #x0148) + (#x014A #x017E) (#x0180 #x01C3) (#x01CD #x01F0) (#x01F4 #x01F5) + (#x01FA #x0217) (#x0250 #x02A8) (#x02BB #x02C1) (#x0386 #x0386) + (#x0388 #x038A) (#x038C #x038C) (#x038E #x03A1) (#x03A3 #x03CE) + (#x03D0 #x03D6) (#x03DA #x03DA) (#x03DC #x03DC) (#x03DE #x03DE) + (#x03E0 #x03E0) (#x03E2 #x03F3) (#x0401 #x040C) (#x040E #x044F) + (#x0451 #x045C) (#x045E #x0481) (#x0490 #x04C4) (#x04C7 #x04C8) + (#x04CB #x04CC) (#x04D0 #x04EB) (#x04EE #x04F5) (#x04F8 #x04F9) + (#x0531 #x0556) (#x0559 #x0559) (#x0561 #x0586) (#x05D0 #x05EA) + (#x05F0 #x05F2) (#x0621 #x063A) (#x0641 #x064A) (#x0671 #x06B7) + (#x06BA #x06BE) (#x06C0 #x06CE) (#x06D0 #x06D3) (#x06D5 #x06D5) + (#x06E5 #x06E6) (#x0905 #x0939) (#x093D #x093D) (#x0958 #x0961) + (#x0985 #x098C) (#x098F #x0990) (#x0993 #x09A8) (#x09AA #x09B0) + (#x09B2 #x09B2) (#x09B6 #x09B9) (#x09DC #x09DD) (#x09DF #x09E1) + (#x09F0 #x09F1) (#x0A05 #x0A0A) (#x0A0F #x0A10) (#x0A13 #x0A28) + (#x0A2A #x0A30) (#x0A32 #x0A33) (#x0A35 #x0A36) (#x0A38 #x0A39) + (#x0A59 #x0A5C) (#x0A5E #x0A5E) (#x0A72 #x0A74) (#x0A85 #x0A8B) + (#x0A8D #x0A8D) (#x0A8F #x0A91) (#x0A93 #x0AA8) (#x0AAA #x0AB0) + (#x0AB2 #x0AB3) (#x0AB5 #x0AB9) (#x0ABD #x0ABD) (#x0AE0 #x0AE0) + (#x0B05 #x0B0C) (#x0B0F #x0B10) (#x0B13 #x0B28) (#x0B2A #x0B30) + (#x0B32 #x0B33) (#x0B36 #x0B39) (#x0B3D #x0B3D) (#x0B5C #x0B5D) + (#x0B5F #x0B61) (#x0B85 #x0B8A) (#x0B8E #x0B90) (#x0B92 #x0B95) + (#x0B99 #x0B9A) (#x0B9C #x0B9C) (#x0B9E #x0B9F) (#x0BA3 #x0BA4) + (#x0BA8 #x0BAA) (#x0BAE #x0BB5) (#x0BB7 #x0BB9) (#x0C05 #x0C0C) + (#x0C0E #x0C10) (#x0C12 #x0C28) (#x0C2A #x0C33) (#x0C35 #x0C39) + (#x0C60 #x0C61) (#x0C85 #x0C8C) (#x0C8E #x0C90) (#x0C92 #x0CA8) + (#x0CAA #x0CB3) (#x0CB5 #x0CB9) (#x0CDE #x0CDE) (#x0CE0 #x0CE1) + (#x0D05 #x0D0C) (#x0D0E #x0D10) (#x0D12 #x0D28) (#x0D2A #x0D39) + (#x0D60 #x0D61) (#x0E01 #x0E2E) (#x0E30 #x0E30) (#x0E32 #x0E33) + (#x0E40 #x0E45) (#x0E81 #x0E82) (#x0E84 #x0E84) (#x0E87 #x0E88) + (#x0E8A #x0E8A) (#x0E8D #x0E8D) (#x0E94 #x0E97) (#x0E99 #x0E9F) + (#x0EA1 #x0EA3) (#x0EA5 #x0EA5) (#x0EA7 #x0EA7) (#x0EAA #x0EAB) + (#x0EAD #x0EAE) (#x0EB0 #x0EB0) (#x0EB2 #x0EB3) (#x0EBD #x0EBD) + (#x0EC0 #x0EC4) (#x0F40 #x0F47) (#x0F49 #x0F69) (#x10A0 #x10C5) + (#x10D0 #x10F6) (#x1100 #x1100) (#x1102 #x1103) (#x1105 #x1107) + (#x1109 #x1109) (#x110B #x110C) (#x110E #x1112) (#x113C #x113C) + (#x113E #x113E) (#x1140 #x1140) (#x114C #x114C) (#x114E #x114E) + (#x1150 #x1150) (#x1154 #x1155) (#x1159 #x1159) (#x115F #x1161) + (#x1163 #x1163) (#x1165 #x1165) (#x1167 #x1167) (#x1169 #x1169) + (#x116D #x116E) (#x1172 #x1173) (#x1175 #x1175) (#x119E #x119E) + (#x11A8 #x11A8) (#x11AB #x11AB) (#x11AE #x11AF) (#x11B7 #x11B8) + (#x11BA #x11BA) (#x11BC #x11C2) (#x11EB #x11EB) (#x11F0 #x11F0) + (#x11F9 #x11F9) (#x1E00 #x1E9B) (#x1EA0 #x1EF9) (#x1F00 #x1F15) + (#x1F18 #x1F1D) (#x1F20 #x1F45) (#x1F48 #x1F4D) (#x1F50 #x1F57) + (#x1F59 #x1F59) (#x1F5B #x1F5B) (#x1F5D #x1F5D) (#x1F5F #x1F7D) + (#x1F80 #x1FB4) (#x1FB6 #x1FBC) (#x1FBE #x1FBE) (#x1FC2 #x1FC4) + (#x1FC6 #x1FCC) (#x1FD0 #x1FD3) (#x1FD6 #x1FDB) (#x1FE0 #x1FEC) + (#x1FF2 #x1FF4) (#x1FF6 #x1FFC) (#x2126 #x2126) (#x212A #x212B) + (#x212E #x212E) (#x2180 #x2182) (#x3041 #x3094) (#x30A1 #x30FA) + (#x3105 #x312C) (#xAC00 #xD7A3))) + +(defparameter *ideographic-ranges* + #((#x3007 #x3007) (#x3021 #x3029)(#x4E00 #x9FA5))) + +(defparameter *combining-char-ranges* + #((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1) + (#x05A3 #x05B9) (#x05BB #x05BD) (#x05BF #x05BF) (#x05C1 #x05C2) + (#x05C4 #x05C4) (#x064B #x0652) (#x0670 #x0670) (#x06D6 #x06DC) + (#x06DD #x06DF) (#x06E0 #x06E4) (#x06E7 #x06E8) (#x06EA #x06ED) + (#x0901 #x0903) (#x093C #x093C) (#x093E #x094C) (#x094D #x094D) + (#x0951 #x0954) (#x0962 #x0963) (#x0981 #x0983) (#x09BC #x09BC) + (#x09BE #x09BE) (#x09BF #x09BF) (#x09C0 #x09C4) (#x09C7 #x09C8) + (#x09CB #x09CD) (#x09D7 #x09D7) (#x09E2 #x09E3) (#x0A02 #x0A02) + (#x0A3C #x0A3C) (#x0A3E #x0A3E) (#x0A3F #x0A3F) (#x0A40 #x0A42) + (#x0A47 #x0A48) (#x0A4B #x0A4D) (#x0A70 #x0A71) (#x0A81 #x0A83) + (#x0ABC #x0ABC) (#x0ABE #x0AC5) (#x0AC7 #x0AC9) (#x0ACB #x0ACD) + (#x0B01 #x0B03) (#x0B3C #x0B3C) (#x0B3E #x0B43) (#x0B47 #x0B48) + (#x0B4B #x0B4D) (#x0B56 #x0B57) (#x0B82 #x0B83) (#x0BBE #x0BC2) + (#x0BC6 #x0BC8) (#x0BCA #x0BCD) (#x0BD7 #x0BD7) (#x0C01 #x0C03) + (#x0C3E #x0C44) (#x0C46 #x0C48) (#x0C4A #x0C4D) (#x0C55 #x0C56) + (#x0C82 #x0C83) (#x0CBE #x0CC4) (#x0CC6 #x0CC8) (#x0CCA #x0CCD) + (#x0CD5 #x0CD6) (#x0D02 #x0D03) (#x0D3E #x0D43) (#x0D46 #x0D48) + (#x0D4A #x0D4D) (#x0D57 #x0D57) (#x0E31 #x0E31) (#x0E34 #x0E3A) + (#x0E47 #x0E4E) (#x0EB1 #x0EB1) (#x0EB4 #x0EB9) (#x0EBB #x0EBC) + (#x0EC8 #x0ECD) (#x0F18 #x0F19) (#x0F35 #x0F35) (#x0F37 #x0F37) + (#x0F39 #x0F39) (#x0F3E #x0F3E) (#x0F3F #x0F3F) (#x0F71 #x0F84) + (#x0F86 #x0F8B) (#x0F90 #x0F95) (#x0F97 #x0F97) (#x0F99 #x0FAD) + (#x0FB1 #x0FB7) (#x0FB9 #x0FB9) (#x20D0 #x20DC) (#x20E1 #x20E1) + (#x302A #x302F) (#x3099 #x3099) (#x309A #x309A))) + +(defparameter *digit-ranges* + #((#x0030 #x0039) (#x0660 #x0669) (#x06F0 #x06F9) (#x0966 #x096F) + (#x09E6 #x09EF) (#x0A66 #x0A6F) (#x0AE6 #x0AEF) (#x0B66 #x0B6F) + (#x0BE7 #x0BEF) (#x0C66 #x0C6F) (#x0CE6 #x0CEF) (#x0D66 #x0D6F) + (#x0E50 #x0E59) (#x0ED0 #x0ED9) (#x0F20 #x0F29))) + +(defparameter *extender-ranges* + #((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387) + (#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005) + (#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE))) + +(defun valid-name-p (rod) + (and (not (zerop (length rod))) + (let ((initial (elt rod 0))) + (or (rune-in-range-p initial *base-char-ranges*) + (rune-in-range-p initial *ideographic-ranges*) + (rune= initial #/_) + (eql initial #/:))) + (every #'rune-name-char-p rod))) + +(defun valid-nmtoken-p (rod) + (and (not (zerop (length rod))) + (every #'rune-name-char-p rod))) + +(defun rune-name-char-p (rune) + (or (rune-in-range-p rune *base-char-ranges*) + (rune-in-range-p rune *ideographic-ranges*) + (rune-in-range-p rune *digit-ranges*) + (eql rune #/.) + (eql rune #/-) + (eql rune #/_) + (eql rune #/:) + (rune-in-range-p rune *combining-char-ranges*) + (rune-in-range-p rune *extender-ranges*))) + +(defun rune-in-range-p (rune range) + ;; XXX FIXME, das geht doch besser + (let ((code (rune-code rune))) + (block nil + (map nil (lambda (range) + (when (< code (car range)) + (return nil)) + (when (<= code (cadr range)) + (return t))) + range)))) Added: vendor/cxml/package.lisp =================================================================== --- vendor/cxml/package.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/package.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,82 @@ +;;;; package.lisp -- Paketdefinition +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. + +(in-package :cl-user) + +(defpackage :cxml + (:use :cl :runes :runes-encoding :trivial-gray-streams) + (:export + ;; xstreams + #:make-xstream + #:make-rod-xstream + #:close-xstream + #:read-rune + #:peek-rune + #:unread-rune + #:fread-rune + #:fpeek-rune + #:xstream-position + #:xstream-line-number + #:xstream-column-number + #:xstream-plist + #:xstream-encoding + + ;; xstream controller protocol + #:read-octects + #:xstream/close + + #:attribute-namespace-uri + #:attribute-local-name + #:attribute-qname + #:attribute-value + + #:parse-file + #:parse-stream + #:parse-rod + #:parse-octets + + #:make-octet-vector-sink + #:make-octet-stream-sink + #:make-rod-sink + #+rune-is-character #:make-string-sink + #+rune-is-character #:make-character-stream-sink + #-rune-is-character #:make-string-sink/utf8 + #-rune-is-character #:make-character-stream-sink/utf8 + + #:with-xml-output + #:with-element + #:attribute + #:cdata + #:text + + #:xml-parse-error + #:well-formedness-violation + #:validity-error + + #:parse-dtd-file + #:parse-dtd-stream + #:make-validator + + #:*cache-all-dtds* + #:*dtd-cache* + #:getdtd + #:remdtd + #:make-dtd-cache + #:clear-dtd-cache + #:make-extid + + #:*catalog* + #:*prefer* + #:make-catalog + #:resolve-uri + #:resolve-extid + + #:make-recoder + #:sax-proxy + #:proxy-chained-handler + #:make-namespace-normalizer + #:make-whitespace-normalizer + #:rod-to-utf8-string + #:utf8-string-to-rod)) Added: vendor/cxml/recoder.lisp =================================================================== --- vendor/cxml/recoder.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/recoder.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,125 @@ +;;;; recoder.lisp -- SAX handler for string conversion +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +(in-package :cxml) + +(defclass recoder () + ((recoder :initarg :recoder :accessor recoder) + (chained-handler :initarg :chained-handler :accessor chained-handler))) + +(defun make-recoder (chained-handler recoder-fn) + (make-instance 'recoder + :recoder recoder-fn + :chained-handler chained-handler)) + +(macrolet ((%string (rod) + `(let ((rod ,rod)) + (if (typep rod '(or rod string)) + (funcall (recoder handler) rod) + rod))) + (defwrapper (name (&rest args) &rest forms) + `(defmethod ,name ((handler recoder) ,@args) + (,name (chained-handler handler) ,@forms)))) + (defwrapper sax:start-document ()) + + (defwrapper sax:start-element + (namespace-uri local-name qname attributes) + (%string namespace-uri) + (%string local-name) + (%string qname) + (mapcar (lambda (attr) + (sax:make-attribute + :namespace-uri (%string (sax:attribute-namespace-uri attr)) + :local-name (%string (sax:attribute-local-name attr)) + :qname (%string (sax:attribute-qname attr)) + :value (%string (sax:attribute-value attr)) + :specified-p (sax:attribute-specified-p attr))) + attributes)) + + (defwrapper sax:start-prefix-mapping (prefix uri) + (%string prefix) + (%string uri)) + + (defwrapper sax:characters (data) + (%string data)) + + (defwrapper sax:processing-instruction (target data) + (%string target) + (%string data)) + + (defwrapper sax:end-prefix-mapping (prefix) + (%string prefix)) + + (defwrapper sax:end-element (namespace-uri local-name qname) + (%string namespace-uri) + (%string local-name) + (%string qname)) + + (defwrapper sax:end-document ()) + + (defwrapper sax:comment (data) + (%string data)) + + (defwrapper sax:start-cdata ()) + + (defwrapper sax:end-cdata ()) + + (defwrapper sax:start-dtd (name public-id system-id) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:start-internal-subset ()) + (defwrapper sax:end-internal-subset ()) + + (defwrapper sax:end-dtd ()) + + (defwrapper sax:unparsed-entity-declaration + (name public-id system-id notation-name) + (%string name) + (%string public-id) + (%string system-id) + (%string notation-name)) + + (defwrapper sax:external-entity-declaration + (kind name public-id system-id) + (%string kind) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:internal-entity-declaration + (kind name value) + kind + (%string name) + (%string value)) + + (defwrapper sax:notation-declaration + (name public-id system-id) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:element-declaration (name model) + (%string name) + model) + + (defwrapper sax:attribute-declaration + (element-name attribute-name type default) + (%string element-name) + (%string attribute-name) + (%string type) + (%string default)) + + (defwrapper sax:entity-resolver + (resolver) + resolver) + + (defwrapper sax::dtd + (dtd) + dtd)) Added: vendor/cxml/sax-handler.lisp =================================================================== --- vendor/cxml/sax-handler.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-handler.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,354 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: A SAX2-like API for the xml parser +;;; Created: 2003-06-30 +;;; Author: Henrik Motakef <hmot(a)henrik-motakef.de> +;;; Author: David Lichteblau (DTD-related changes) +;;; License: BSD +;;; --------------------------------------------------------------------------- +;;; � copyright 2003 by Henrik Motakef +;;; � copyright 2004 knowledgeTools Int. GmbH + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are +;;; met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution +;;; +;;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED +;;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. + +;;; TODO/ Open Questions: + +;; o Should there be a predefined "handler" class, or even several +;; (like Java SAX' ContentHandler, DTDHandler, LexicalHandler etc? I +;; don't really see why. +;; o Missing stuff from Java SAX2: +;; * ignorable-whitespace +;; * document-locator/(setf document-locator) +;; (probably implies a handler class with an appropriate slot) +;; * skipped-entity +;; * The whole ErrorHandler class, this is better handled using +;; conditions (but isn't yet) +;; * The LexicalHandler (start-cdata etc) would be nice [-- partly done] + +(defpackage :sax + (:use :common-lisp) + (:export #:*namespace-processing* + #:*include-xmlns-attributes* + #:*use-xmlns-namespace* + + #:make-attribute + #:find-attribute + #:find-attribute-ns + #:attribute-namespace-uri + #:attribute-local-name + #:attribute-qname + #:attribute-value + #:attribute-specified-p + + #:start-document + #:start-prefix-mapping + #:start-element + #:characters + #:processing-instruction + #:end-element + #:end-prefix-mapping + #:end-document + #:comment + #:start-cdata + #:end-cdata + #:start-dtd + #:end-dtd + #:start-internal-subset + #:end-internal-subset + #:unparsed-entity-declaration + #:external-entity-declaration + #:internal-entity-declaration + #:notation-declaration + #:element-declaration + #:attribute-declaration + #:entity-resolver)) + +(in-package :sax) + +;; The http://xml.org/sax/features/namespaces property +(defvar *namespace-processing* t + "If non-nil (the default), namespace processing is enabled. + +See also `start-element' and `end-element' for a detailed description +of the consequences of modifying this variable, and +`*include-xmlns-attributes*' and `*use-xmlns-namespace*' for further +related options.") + +;; The http://xml.org/sax/features/namespace-prefixes property. +(defvar *include-xmlns-attributes* t + "If non-nil, namespace declarations are reported as normal +attributes. + +This variable has no effect unless `*namespace-processing*' is +non-nil. + +See also `*use-xmlns-namespace*', and `start-element' for a detailed +description of the consequences of setting this variable.") + +(defvar *use-xmlns-namespace* t + "If this variable is nil (the default), attributes with a name like +'xmlns:x' are not considered to be in a namespace, following the +'Namespaces in XML' specification. + +If it is non-nil, such attributes are considered to be in a namespace +with the URI 'http://www.w3.org/2000/xmlns/', following an +incompatible change silently introduced in the errata to that spec, +and adopted by some W3C standards. + +For example, an attribute like xmlns:ex='http://example.com' would be +reported like this: + +*use-xmlns-namespace*: nil +namespace-uri: nil +local-name: nil +qname: #\"xmlns:ex\" + +*use-xmlns-namespace*: t +namespace-uri: #\"http://www.w3.org/2000/xmlns/\" +local-name: #\"ex\" +qname: #\"xmlns:ex\" + +Setting this variable has no effect unless both +`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.") + +(defstruct attribute + namespace-uri + local-name + qname + value + specified-p) + +(defun %rod= (x y) + ;; allow rods *and* strings *and* null + (cond + ((zerop (length x)) (zerop (length y))) + ((zerop (length y)) nil) + ((stringp x) (string= x y)) + (t (runes:rod= x y)))) + +(defun find-attribute (qname attrs) + (find qname attrs :key #'attribute-qname :test #'%rod=)) + +(defun find-attribute-ns (uri lname attrs) + (find-if (lambda (attr) + (and (%rod= uri (sax:attribute-namespace-uri attr)) + (%rod= lname (sax:attribute-local-name attr)))) + attrs)) + +(defgeneric start-document (handler) + (:documentation "Called at the beginning of the parsing process, +before any element, processing instruction or comment is reported. + +Handlers that need to maintain internal state may use this to perform +any neccessary initializations.") + (:method ((handler t)) nil)) + +(defgeneric start-element (handler namespace-uri local-name qname attributes) + (:documentation "Called to report the beginning of an element. + +There will always be a corresponding call to end-element, even in the +case of an empty element (i.e. <foo/>). + +If the value of *namespaces* is non-nil, namespace-uri, local-name and +qname are rods. If it is nil, namespace-uri and local-name are always +nil, and it is not an error if the qname is not a well-formed +qualified element name (for example, if it contains more than one +colon). + +The attributes parameter is a list (in arbitrary order) of instances +of the `attribute' structure class. The for their namespace-uri and +local-name properties, the same rules as for the element name +apply. Additionally, namespace-declaring attributes (those whose name +is \"xmlns\" or starts with \"xmlns:\") are only included if +*namespace-prefixes* is non-nil.") + (:method ((handler t) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri local-name qname attributes)) + nil)) + +(defgeneric start-prefix-mapping (handler prefix uri) + (:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins. + +This will always be called immediatly before the `start-element' event +for the element on which the namespaces are declared. + +Clients don't usually have to implement this except under special +circumstances, for example when they have to deal with qualified names +in textual content. The parser will handle namespaces of elements and +attributes on its own.") + (:method ((handler t) prefix uri) (declare (ignore prefix uri)) nil)) + +(defgeneric characters (handler data) + (:documentation "Called for textual element content. + +The data is passed as a rod, with all entity references resolved. +It is possible that the character content of an element is reported +via multiple subsequent calls to this generic function.") + (:method ((handler t) data) (declare (ignore data)) nil)) + +(defgeneric processing-instruction (handler target data) + (:documentation "Called when a processing instruction is read. + +Both target and data are rods.") + (:method ((handler t) target data) (declare (ignore target data)) nil)) + +(defgeneric end-prefix-mapping (handler prefix) + (:documentation "Called when a prefix -> namespace-uri mapping goes out of scope. + +This will always be called immediatly after the `end-element' event +for the element on which the namespace is declared. The order of the +end-prefix-mapping events is otherwise not guaranteed. + +Clients don't usually have to implement this except under special +circumstances, for example when they have to deal with qualified names +in textual content. The parser will handle namespaces of elements and +attributes on its own.") + (:method ((handler t) prefix) prefix nil)) + +(defgeneric end-element (handler namespace-uri local-name qname) + (:documentation "Called to report the end of an element. + +See the documentation for `start-element' for a description of the +parameters.") + (:method ((handler t) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name qname)) + nil)) + +(defgeneric end-document (handler) + (:documentation "Called at the end of parsing a document. +This is always the last function called in the parsing process. + +In contrast to all of the other methods, the return value of this gf +is significant, it will be returned by the parse-file/stream/string function.") + (:method ((handler t)) nil)) + +;; LexicalHandler + +(defgeneric comment (handler data) + (:method ((handler t) data) data nil)) + +(defgeneric start-cdata (handler) + (:documentation "Called at the beginning of parsing a CDATA section. + +Handlers only have to implement this if they are interested in the +lexical structure of the parsed document. The content of the CDATA +section is reported via the `characters' generic function like all +other textual content.") + (:method ((handler t)) nil)) + +(defgeneric end-cdata (handler) + (:documentation "Called at the end of parsing a CDATA section. + +Handlers only have to implement this if they are interested in the +lexical structure of the parsed document. The content of the CDATA +section is reported via the `characters' generic function like all +other textual content.") + (:method ((handler t)) nil)) + +(defgeneric start-dtd (handler name public-id system-id) + (:documentation "Called at the beginning of parsing a DTD.") + (:method ((handler t) name public-id system-id) + (declare (ignore name public-id system-id)) + nil)) + +(defgeneric end-dtd (handler) + (:documentation "Called at the end of parsing a DTD.") + (:method ((handler t)) nil)) + +(defgeneric start-internal-subset (handler) + (:documentation "Reports that an internal subset is present. Called before +any definition from the internal subset is reported.") + (:method ((handler t)) nil)) + +(defgeneric end-internal-subset (handler) + (:documentation "Called after processing of the internal subset has +finished, if present.") + (:method ((handler t)) nil)) + +(defgeneric unparsed-entity-declaration + (handler name public-id system-id notation-name) + (:documentation + "Called when an unparsed entity declaration is seen in a DTD.") + (:method ((handler t) name public-id system-id notation-name) + (declare (ignore name public-id system-id notation-name)) + nil)) + +(defgeneric external-entity-declaration + (handler kind name public-id system-id) + (:documentation + "Called when a parsed external entity declaration is seen in a DTD.") + (:method ((handler t) kind name public-id system-id) + (declare (ignore kind name public-id system-id)) + nil)) + +(defgeneric internal-entity-declaration + (handler kind name value) + (:documentation + "Called when an internal entity declaration is seen in a DTD.") + (:method ((handler t) kind name value) + (declare (ignore kind name value)) + nil)) + +(defgeneric notation-declaration + (handler name public-id system-id) + (:documentation + "Called when a notation declaration is seen while parsing a DTD.") + (:method ((handler t) name public-id system-id) + (declare (ignore name public-id system-id)) + nil)) + +(defgeneric element-declaration (handler name model) + (:documentation + "Called when a element declaration is seen in a DTD. Model is not a string, + but a nested list, with *, ?, +, OR, and AND being the operators, rods + as names, :EMPTY and :PCDATA as special tokens. (AND represents + sequences.)") + (:method ((handler t) name model) + (declare (ignore name model)) + nil)) + +(defgeneric attribute-declaration + (handler element-name attribute-name type default) + (:documentation + "Called when an attribute declaration is seen in a DTD. + type one of :CDATA, :ID, :IDREF, :IDREFS, + :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS, + (:NOTATION <name>*), or (:ENUMERATION <name>*) + default :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)") + (:method ((handler t) element-name attribute-name type value) + (declare (ignore element-name attribute-name type value)) + nil)) + +(defgeneric entity-resolver + (handler resolver) + (:documentation + "Called between sax:end-dtd and sax:end-document to register an entity + resolver, a function of two arguments: An entity name and SAX handler. + When called, the resolver function will parse the named entity's data.") + (:method ((handler t) resolver) + (declare (ignore resolver)) + nil)) + +;; internal for now +(defgeneric dtd (handler dtd) + (:method ((handler t) dtd) (declare (ignore dtd)) nil)) Added: vendor/cxml/sax-proxy.lisp =================================================================== --- vendor/cxml/sax-proxy.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-proxy.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,41 @@ +;;;; sax-proxy.lisp +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2004 David Lichteblau +;;;; Author: David Lichteblau + +(in-package :cxml) + +(defclass sax-proxy () + ((chained-handler :initform nil + :initarg :chained-handler + :accessor proxy-chained-handler))) + +(macrolet ((define-proxy-method (name (&rest args)) + `(defmethod ,name ((handler sax-proxy) ,@args) + (,name (proxy-chained-handler handler) ,@args)))) + (define-proxy-method sax:start-document ()) + (define-proxy-method sax:start-element (uri lname qname attributes)) + (define-proxy-method sax:start-prefix-mapping (prefix uri)) + (define-proxy-method sax:characters (data)) + (define-proxy-method sax:processing-instruction (target data)) + (define-proxy-method sax:end-prefix-mapping (prefix)) + (define-proxy-method sax:end-element (namespace-uri local-name qname)) + (define-proxy-method sax:end-document ()) + (define-proxy-method sax:comment (data)) + (define-proxy-method sax:start-cdata ()) + (define-proxy-method sax:end-cdata ()) + (define-proxy-method sax:start-dtd (name public-id system-id)) + (define-proxy-method sax:end-dtd ()) + (define-proxy-method sax:start-internal-subset ()) + (define-proxy-method sax:end-internal-subset ()) + (define-proxy-method sax:unparsed-entity-declaration (name pub sys not)) + (define-proxy-method sax:external-entity-declaration (kind name pub sys)) + (define-proxy-method sax:internal-entity-declaration (kind name value)) + (define-proxy-method sax:notation-declaration (name public-id system-id)) + (define-proxy-method sax:element-declaration (name model)) + (define-proxy-method sax:attribute-declaration (elt attr type default)) + (define-proxy-method sax:entity-resolver (resolver)) + (define-proxy-method sax::dtd (dtd))) Added: vendor/cxml/sax-tests/CVS/Entries =================================================================== --- vendor/cxml/sax-tests/CVS/Entries 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/CVS/Entries 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,4 @@ +/event-collecting-handler.lisp/1.1.1.1/Sun Mar 13 18:02:10 2005// +/package.lisp/1.1.1.1/Sun Mar 13 18:02:10 2005// +/tests.lisp/1.2/Wed Dec 28 23:18:07 2005// +D Added: vendor/cxml/sax-tests/CVS/Repository =================================================================== --- vendor/cxml/sax-tests/CVS/Repository 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/CVS/Repository 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1 @@ +cxml/xml/sax-tests Added: vendor/cxml/sax-tests/CVS/Root =================================================================== --- vendor/cxml/sax-tests/CVS/Root 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/CVS/Root 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1 @@ +:pserver:anonymous@common-lisp.net:/project/cxml/cvsroot Added: vendor/cxml/sax-tests/CVS/Template =================================================================== Added: vendor/cxml/sax-tests/event-collecting-handler.lisp =================================================================== --- vendor/cxml/sax-tests/event-collecting-handler.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/event-collecting-handler.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,37 @@ +(in-package :sax-tests) + +(defclass event-collecting-handler () + ((event-list :initform '() :accessor event-list))) + +(defmethod start-document ((handler event-collecting-handler)) + (push (list :start-document) (event-list handler))) + +(defmethod start-element ((handler event-collecting-handler) ns-uri local-name qname attrs) + (push (list :start-element ns-uri local-name qname attrs) + (event-list handler))) + +(defmethod start-prefix-mapping ((handler event-collecting-handler) prefix uri) + (push (list :start-prefix-mapping prefix uri) + (event-list handler))) + +(defmethod characters ((handler event-collecting-handler) data) + (push (list :characters data) + (event-list handler))) + +(defmethod processing-instruction ((handler event-collecting-handler) target data) + (push (list :processing-instruction target data) + (event-list handler))) + +(defmethod end-prefix-mapping ((handler event-collecting-handler) prefix) + (push (list :end-prefix-mapping prefix) + (event-list handler))) + +(defmethod end-element ((handler event-collecting-handler) namespace-uri local-name qname) + (push (list :end-element namespace-uri local-name qname) + (event-list handler))) + +(defmethod end-document ((handler event-collecting-handler)) + (push (list :end-document) + (event-list handler)) + + (nreverse (event-list handler))) \ No newline at end of file Added: vendor/cxml/sax-tests/package.lisp =================================================================== --- vendor/cxml/sax-tests/package.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/package.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,4 @@ +(defpackage :sax-tests + (:use :cl :xml :sax :glisp :rt) + (:export #:event-collecting-handler)) + Added: vendor/cxml/sax-tests/tests.lisp =================================================================== --- vendor/cxml/sax-tests/tests.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/sax-tests/tests.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,330 @@ +(in-package :sax-tests) + +(defun first-start-element-event (string) + (let ((events (cxml:parse-rod string (make-instance 'event-collecting-handler)))) + (find :start-element events :key #'car))) + + +;;; Attribute handling + +(deftest no-default-namespace-for-attributes + (let* ((evt (first-start-element-event "<x xmlns='http://example.com' a='b'/>")) + (attr (car (fifth evt)))) + (values + (attribute-namespace-uri attr) + (attribute-local-name attr))) + nil nil) + +(deftest attribute-uniqueness-1 + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest attribute-uniqueness-2 + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t)) + t) + +(deftest attribute-uniqueness-3 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +;;; Namespace undeclaring + +(deftest undeclare-default-namespace-1 + (let* ((evts (cxml:parse-rod "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>" + (make-instance 'event-collecting-handler))) + (start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car)) + (evt1 (first start-elt-events)) + (evt2 (second start-elt-events ))) + (values + (rod= #"http://example.com" (second evt1)) + (second evt2) + (third evt2))) + t nil nil) + +(deftest undeclare-other-namespace + (handler-case + (cxml:parse-rod "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + + +;;; Require names otherwise totally out of scope of the xmlns rec to be NcNames for no reason + +(deftest pi-names-are-ncnames-when-namespace-processing-1 + (handler-case + (cxml:parse-rod "<?a:b c?><x/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest pi-names-are-ncnames-when-namespace-processing-2 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<?a:b c?><x/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-1 + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-2 + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-3 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-4 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +;;; Inclusion of xmlns attributes + +(deftest xmlns-attr-include-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (length attrs)) + 1) + +(deftest xmlns-attr-discard-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (length attrs)) + 0) + +;;; Namespace of xmlns attributes + +(deftest xmlns-attr-ns-uri-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-3 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"http://www.w3.org/2000/xmlns/" (attribute-namespace-uri (car attrs)))) + t) + +(deftest xmlns-attr-ns-local-name-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-3 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"foo" (attribute-local-name (car attrs)))) + t) + +(deftest xmlns-attr-qname-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns:foo" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns:foo" (attribute-qname (car attrs)))) + t) + + +;;; Predefined Namespaces + +(deftest redefine-xml-namespace-1 + (handler-case + (cxml:parse-rod "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t)) + t) + +(deftest redefine-xml-namespace-2 + (handler-case + (cxml:parse-rod "<x xmlns:xml='http://example.com/wrong-uri'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xml-namespace-3 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xml-namespace-4 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-1 + (handler-case + (cxml:parse-rod "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-2 + (handler-case + (cxml:parse-rod "<x xmlns:xmlns='http://example.com/wrong-ns'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-3 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-4 + (handler-case + (cxml:parse-rod "<x xmlns='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) Added: vendor/cxml/space-normalizer.lisp =================================================================== --- vendor/cxml/space-normalizer.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/space-normalizer.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,62 @@ +;;;; space-normalizer.lisp -- whitespace removal +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +(in-package :cxml) + +(defclass whitespace-normalizer (sax-proxy) + ((attributes :initform '(t) :accessor xml-space-attributes) + (models :initform nil :accessor xml-space-models) + (dtd :initarg :dtd :accessor xml-space-dtd))) + +(defun make-whitespace-normalizer (chained-handler &optional dtd) + (make-instance 'whitespace-normalizer + :dtd dtd + :chained-handler chained-handler)) + +(defmethod sax::dtd ((handler whitespace-normalizer) dtd) + (unless (xml-space-dtd handler) + (setf (xml-space-dtd handler) dtd))) + +(defmethod sax:start-element + ((handler whitespace-normalizer) uri lname qname attrs) + (declare (ignore uri lname)) + (let ((dtd (xml-space-dtd handler))) + (when dtd + (let ((xml-space + (sax:find-attribute (if (stringp qname) "xml:space" #"xml:space") + attrs))) + (push (if xml-space + (rod= (rod (sax:attribute-value xml-space)) #"default") + (car (xml-space-attributes handler))) + (xml-space-attributes handler))) + (let* ((e (cxml::find-element (rod qname) dtd)) + (cspec (when e (cxml::elmdef-content e)))) + (push (and (consp cspec) + (not (and (eq (car cspec) '*) + (let ((subspec (second cspec))) + (and (eq (car subspec) 'or) + (eq (cadr subspec) :PCDATA)))))) + (xml-space-models handler))))) + (call-next-method)) + +(defmethod sax:characters ((handler whitespace-normalizer) data) + (cond + ((and (xml-space-dtd handler) + (car (xml-space-attributes handler)) + (car (xml-space-models handler))) + (unless (every #'white-space-rune-p (rod data)) + (warn "non-whitespace character data in element content") + (call-next-method))) + (t + (call-next-method)))) + +(defmethod sax:end-element ((handler whitespace-normalizer) uri lname qname) + (declare (ignore uri lname qname)) + (when (xml-space-dtd handler) + (pop (xml-space-attributes handler)) + (pop (xml-space-models handler))) + (call-next-method)) Added: vendor/cxml/split-sequence.lisp =================================================================== --- vendor/cxml/split-sequence.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/split-sequence.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,44 @@ +;;; This code was based on Arthur Lemmens' in +;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; + +(in-package :cxml) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) Added: vendor/cxml/unparse.lisp =================================================================== --- vendor/cxml/unparse.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/unparse.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,569 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Unparse XML +;;; Title: (including support for canonic XML according to J.Clark) +;;; Created: 1999-09-09 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; Author: David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; �� copyright 1999 by Gilbert Baumann +;;; �� copyright 2004 by knowledgeTools Int. GmbH +;;; �� copyright 2004 by David Lichteblau (for headcraft.de) + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :cxml) + +;; +;; | Canonical XML +;; | ============= +;; | +;; | This document defines a subset of XML called canonical XML. The +;; | intended use of canonical XML is in testing XML processors, as a +;; | representation of the result of parsing an XML document. +;; | +;; | Every well-formed XML document has a unique structurally equivalent +;; | canonical XML document. Two structurally equivalent XML documents have +;; | a byte-for-byte identical canonical XML document. Canonicalizing an +;; | XML document requires only information that an XML processor is +;; | required to make available to an application. +;; | +;; | A canonical XML document conforms to the following grammar: +;; | +;; | CanonXML ::= Pi* element Pi* +;; | element ::= Stag (Datachar | Pi | element)* Etag +;; | Stag ::= '<' Name Atts '>' +;; | Etag ::= '</' Name '>' +;; | Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>' +;; | Atts ::= (' ' Name '=' '"' Datachar* '"')* +;; | Datachar ::= '&' | '<' | '>' | '"' +;; | | '	'| '
'| '' +;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD)) +;; | Name ::= (see XML spec) +;; | Char ::= (see XML spec) +;; | S ::= (see XML spec) +;; | +;; | Attributes are in lexicographical order (in Unicode bit order). +;; | +;; | A canonical XML document is encoded in UTF-8. +;; | +;; | Ignorable white space is considered significant and is treated +;; | equivalently to data. +;; +;; -- James Clark (jjc(a)jclark.com) + + +;;;; SINK: an xml output sink + +(defclass sink () + ((ystream :initarg :ystream :accessor sink-ystream) + (width :initform 79 :initarg :width :accessor width) + (canonical :initform t :initarg :canonical :accessor canonical) + (indentation :initform nil :initarg :indentation :accessor indentation) + (current-indentation :initform 0 :accessor current-indentation) + (notations :initform (make-buffer :element-type t) :accessor notations) + (name-for-dtd :accessor name-for-dtd) + (previous-notation :initform nil :accessor previous-notation) + (have-doctype :initform nil :accessor have-doctype) + (stack :initform nil :accessor stack))) + +(defmethod initialize-instance :after ((instance sink) &key) + (when (eq (canonical instance) t) + (setf (canonical instance) 1)) + (unless (member (canonical instance) '(nil 1 2)) + (error "Invalid canonical form: ~A" (canonical instance))) + (when (and (canonical instance) (indentation instance)) + (error "Cannot indent XML in canonical mode"))) + +(defun make-buffer (&key (element-type '(unsigned-byte 8))) + (make-array 1 + :element-type element-type + :adjustable t + :fill-pointer 0)) + +;; total haesslich, aber die ystreams will ich im moment eigentlich nicht +;; dokumentieren +(macrolet ((define-maker (make-sink make-ystream &rest args) + `(defun ,make-sink (,@args &rest initargs) + (apply #'make-instance + 'sink + :ystream (,make-ystream ,@args) + initargs)))) + (define-maker make-octet-vector-sink make-octet-vector-ystream) + (define-maker make-octet-stream-sink make-octet-stream-ystream stream) + (define-maker make-rod-sink make-rod-ystream) + + #+rune-is-character + (define-maker make-character-stream-sink make-character-stream-ystream stream) + + #-rune-is-character + (define-maker make-string-sink/utf8 make-string-ystream/utf8) + + #-rune-is-character + (define-maker make-character-stream-sink/utf8 + make-character-stream-ystream/utf8 + stream)) + +#+rune-is-character +(defun make-string-sink (&rest args) (apply #'make-rod-sink args)) + + +(defmethod sax:end-document ((sink sink)) + (close-ystream (sink-ystream sink))) + + +;;;; doctype and notations + +(defmethod sax:start-document ((sink sink)) + (unless (canonical sink) + (%write-rod #"<?xml version=\"1.0\" encoding=\"UTF-8\"?>" sink) + (%write-rune #/U+000A sink))) + +(defmethod sax:start-dtd ((sink sink) name public-id system-id) + (setf (name-for-dtd sink) name) + (unless (canonical sink) + (ensure-doctype sink public-id system-id))) + +(defun ensure-doctype (sink &optional public-id system-id) + (unless (have-doctype sink) + (setf (have-doctype sink) t) + (%write-rod #"<!DOCTYPE " sink) + (%write-rod (name-for-dtd sink) sink) + (cond + (public-id + (%write-rod #" PUBLIC \"" sink) + (unparse-string public-id sink) + (%write-rod #"\" \"" sink) + (unparse-string system-id sink) + (%write-rod #"\"" sink)) + (system-id + (%write-rod #" SYSTEM \"" sink) + (unparse-string public-id sink) + (%write-rod #"\"" sink))))) + +(defmethod sax:start-internal-subset ((sink sink)) + (ensure-doctype sink) + (%write-rod #" [" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:end-internal-subset ((sink sink)) + (ensure-doctype sink) + (%write-rod #"]" sink)) + +(defmethod sax:notation-declaration ((sink sink) name public-id system-id) + (let ((prev (previous-notation sink))) + (when (and (and (canonical sink) (>= (canonical sink) 2)) + prev + (not (rod< prev name))) + (error "misordered notations; cannot unparse canonically")) + (setf (previous-notation sink) name)) + (%write-rod #"<!NOTATION " sink) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rune #/' sink)) + (t + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rod #"' '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:unparsed-entity-declaration + ((sink sink) name public-id system-id notation-name) + (unless (and (canonical sink) (< (canonical sink) 3)) + (%write-rod #"<!ENTITY " sink) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rune #/' sink)) + (t + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rod #"' '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink))) + (%write-rod #" NDATA " sink) + (%write-rod notation-name sink) + (%write-rune #/> sink) + (%write-rune #/U+000A sink))) + +(defmethod sax:external-entity-declaration + ((sink sink) kind name public-id system-id) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #"<!ENTITY " sink) + (when (eq kind :parameter) + (%write-rod #" % " sink)) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rune #/' sink)) + (t + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rod #"' '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:internal-entity-declaration ((sink sink) kind name value) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #"<!ENTITY " sink) + (when (eq kind :parameter) + (%write-rod #" % " sink)) + (%write-rod name sink) + (%write-rune #/U+0020 sink) + (%write-rune #/\" sink) + (unparse-string value sink) + (%write-rune #/\" sink) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:element-declaration ((sink sink) name model) + (when (canonical sink) + (error "cannot serialize element type declarations in canonical mode")) + (%write-rod #"<!ELEMENT " sink) + (%write-rod name sink) + (%write-rune #/U+0020 sink) + (labels ((walk (m) + (cond + ((eq m :EMPTY) + (%write-rod "EMPTY" sink)) + ((eq m :PCDATA) + (%write-rod "#PCDATA" sink)) + ((atom m) + (unparse-string m sink)) + (t + (ecase (car m) + (and + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr m) do + (walk n) + (when rest + (%write-rune #\, sink))) + (%write-rune #/$ sink)) + (or + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr m) do + (walk n) + (when rest + (%write-rune #\| sink))) + (%write-rune #/$ sink)) + (* + (walk (second m)) + (%write-rod #/* sink)) + (+ + (walk (second m)) + (%write-rod #/+ sink)) + (? + (walk (second m)) + (%write-rod #/? sink))))))) + (walk model)) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:attribute-declaration ((sink sink) ename aname type default) + (when (canonical sink) + (error "cannot serialize attribute type declarations in canonical mode")) + (%write-rod #"<!ATTLIST " sink) + (%write-rod ename sink) + (%write-rune #/U+0020 sink) + (%write-rod aname sink) + (%write-rune #/U+0020 sink) + (cond + ((atom type) + (%write-rod (rod (string-upcase (symbol-name type))) sink)) + (t + (when (eq :NOTATION (car type)) + (%write-rod #"NOTATION " sink)) + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr type) do + (%write-rod n sink) + (when rest + (%write-rune #\| sink))) + (%write-rune #/$ sink))) + (cond + ((atom default) + (%write-rune #/# sink) + (%write-rod (rod (string-upcase (symbol-name default))) sink)) + (t + (when (eq :FIXED (car default)) + (%write-rod #"#FIXED " sink)) + (%write-rune #/\" sink) + (unparse-string (second default) sink) + (%write-rune #/\" sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:end-dtd ((sink sink)) + (when (have-doctype sink) + (%write-rod #">" sink) + (%write-rune #/U+000A sink))) + + +;;;; elements + +(defstruct (tag (:constructor make-tag (name))) + name + (n-children 0) + (have-gt nil)) + +(defun sink-fresh-line (sink) + (unless (zerop (ystream-column (sink-ystream sink))) + (%write-rune #/U+000A sink) ;newline + (indent sink))) + +(defun maybe-close-tag (sink) + (let ((tag (car (stack sink)))) + (when (and (tag-p tag) (not (tag-have-gt tag))) + (setf (tag-have-gt tag) t) + (%write-rune #/> sink)))) + +(defmethod sax:start-element + ((sink sink) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri local-name)) + (maybe-close-tag sink) + (when (stack sink) + (incf (tag-n-children (first (stack sink))))) + (push (make-tag qname) (stack sink)) + (when (indentation sink) + (sink-fresh-line sink) + (start-indentation-block sink)) + (%write-rune #/< sink) + (%write-rod qname sink) + (let ((atts (sort (copy-list attributes) #'rod< :key #'sax:attribute-qname))) + (dolist (a atts) + (%write-rune #/space sink) + (%write-rod (sax:attribute-qname a) sink) + (%write-rune #/= sink) + (%write-rune #/\" sink) + (unparse-string (sax:attribute-value a) sink) + (%write-rune #/\" sink))) + (when (canonical sink) + (maybe-close-tag sink))) + +(defmethod sax:end-element + ((sink sink) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name)) + (let ((tag (pop (stack sink)))) + (unless (tag-p tag) + (error "output does not nest: not in an element")) + (unless (rod= (tag-name tag) qname) + (error "output does not nest: expected ~A but got ~A" + (rod qname) (rod (tag-name tag)))) + (when (indentation sink) + (end-indentation-block sink) + (unless (zerop (tag-n-children tag)) + (sink-fresh-line sink))) + (cond + ((tag-have-gt tag) + (%write-rod '#.(string-rod "</") sink) + (%write-rod qname sink) + (%write-rod '#.(string-rod ">") sink)) + (t + (%write-rod #"/>" sink))))) + +(defmethod sax:processing-instruction ((sink sink) target data) + (maybe-close-tag sink) + (unless (rod-equal target '#.(string-rod "xml")) + (%write-rod '#.(string-rod "<?") sink) + (%write-rod target sink) + (when data + (%write-rune #/space sink) + (%write-rod data sink)) + (%write-rod '#.(string-rod "?>") sink))) + +(defmethod sax:start-cdata ((sink sink)) + (maybe-close-tag sink) + (push :cdata (stack sink))) + +(defmethod sax:characters ((sink sink) data) + (maybe-close-tag sink) + (cond + ((and (eq (car (stack sink)) :cdata) + (not (canonical sink)) + (not (search #"]]" data))) + (when (indentation sink) + (sink-fresh-line sink)) + (%write-rod #"<![CDATA[" sink) + ;; XXX signal error if body is unprintable? + (map nil (lambda (c) (%write-rune c sink)) data) + (%write-rod #"]]>" sink)) + (t + (if (indentation sink) + (unparse-indented-text data sink) + (let ((y (sink-ystream sink))) + (if (canonical sink) + (loop for c across data do (unparse-datachar c y)) + (loop for c across data do (unparse-datachar-readable c y)))))))) + +(defmethod sax:end-cdata ((sink sink)) + (unless (eq (pop (stack sink)) :cdata) + (error "output does not nest: not in a cdata section"))) + +(defun indent (sink) + (dotimes (x (current-indentation sink)) + (%write-rune #/U+0020 sink))) ; space + +(defun start-indentation-block (sink) + (incf (current-indentation sink) (indentation sink))) + +(defun end-indentation-block (sink) + (decf (current-indentation sink) (indentation sink))) + +(defun unparse-indented-text (data sink) + (flet ((whitespacep (x) + (or (rune= x #/U+000A) (rune= x #/U+0020)))) + (let* ((n (length data)) + (pos (position-if-not #'whitespacep data)) + (need-whitespace-p nil)) + (cond + ((zerop n)) + (pos + (sink-fresh-line sink) + (while (< pos n) + (let* ((w (or (position-if #'whitespacep data :start (1+ pos)) n)) + (next (or (position-if-not #'whitespacep data :start w) n))) + (when need-whitespace-p + (if (< (+ (ystream-column (sink-ystream sink)) w (- pos)) + (width sink)) + (%write-rune #/U+0020 sink) + (sink-fresh-line sink))) + (loop + with y = (sink-ystream sink) + for i from pos below w do + (unparse-datachar-readable (elt data i) y)) + (setf need-whitespace-p (< w n)) + (setf pos next)))) + (t + (%write-rune #/U+0020 sink)))))) + +(defun unparse-string (str sink) + (let ((y (sink-ystream sink))) + (loop for rune across str do (unparse-datachar rune y)))) + +(defun unparse-datachar (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + ((rune= c #/U+0009) (write-rod '#.(string-rod "	") ystream)) + ((rune= c #/U+000A) (write-rod '#.(string-rod "
") ystream)) + ((rune= c #/U+000D) (write-rod '#.(string-rod "") ystream)) + (t + (write-rune c ystream)))) + +(defun unparse-datachar-readable (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + (t + (write-rune c ystream)))) + +(defun %write-rune (c sink) + (write-rune c (sink-ystream sink))) + +(defun %write-rod (r sink) + (write-rod r (sink-ystream sink))) + + +;;;; convenience functions for DOMless XML serialization + +(defvar *current-element*) +(defvar *sink*) + +(defmacro with-xml-output (sink &body body) + `(invoke-with-xml-output (lambda () ,@body) ,sink)) + +(defun invoke-with-xml-output (fn sink) + (let ((*sink* sink) + (*current-element* nil)) + (sax:start-document *sink*) + (funcall fn) + (sax:end-document *sink*))) + +(defmacro with-element (qname &body body) + `(invoke-with-element (lambda () ,@body) ,qname)) + +(defun maybe-emit-start-tag () + (when *current-element* + ;; starting child node, need to emit opening tag of parent first: + (destructuring-bind (qname &rest attributes) *current-element* + (sax:start-element *sink* nil nil qname (reverse attributes))) + (setf *current-element* nil))) + +(defun invoke-with-element (fn qname) + (setf qname (rod qname)) + (maybe-emit-start-tag) + (let ((*current-element* (list qname))) + (multiple-value-prog1 + (funcall fn) + (maybe-emit-start-tag) + (sax:end-element *sink* nil nil qname)))) + +(defun attribute (name value) + (push (sax:make-attribute :qname (rod name) :value (rod value)) + (cdr *current-element*)) + value) + +(defun cdata (data) + (sax:start-cdata *sink*) + (sax:characters *sink* (rod data)) + (sax:end-cdata *sink*) + data) + +(defun text (data) + (maybe-emit-start-tag) + (sax:characters *sink* (rod data)) + data) + +(defun rod-to-utf8-string (rod) + (let ((out (make-buffer :element-type 'character))) + (runes-to-utf8/adjustable-string out rod (length rod)) + out)) + +(defun utf8-string-to-rod (str) + (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)) + (buffer (make-array (length bytes) :element-type '(unsigned-byte 16))) + (n (decode-sequence :utf-8 bytes 0 (length bytes) buffer 0 0 nil)) + (result (make-array n :element-type 'rune))) + (map-into result #'code-rune buffer) + result)) Added: vendor/cxml/util.lisp =================================================================== --- vendor/cxml/util.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/util.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,73 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Some common utilities for the Closure browser +;;; Created: 1997-12-27 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1997-1999 by Gilbert Baumann + +;;; This code is free software; you can redistribute it and/or modify it +;;; under the terms of the version 2.1 of the GNU Lesser General Public +;;; License as published by the Free Software Foundation, as clarified +;;; by the "Preamble to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; This code is distributed in the hope that it will be useful, +;;; but without any warranty; without even the implied warranty of +;;; merchantability or fitness for a particular purpose. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of +;; subforms +;; + +(in-package :cxml) + +;;; -------------------------------------------------------------------------------- +;;; Meta functions + +(defun curry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append args more)))) + +(defun rcurry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append more args)))) + +(defun compose (f g) + #'(lambda (&rest args) + (funcall f (apply g args)))) + +;;; -------------------------------------------------------------------------------- +;;; while and until + +(defmacro while (test &body body) + `(until (not ,test) ,@body)) + +(defmacro until (test &body body) + `(do () (,test) ,@body)) + +;; prime numbers + +(defun primep (n) + "Returns true, iff `n' is prime." + (and (> n 2) + (do ((i 2 (+ i 1))) + ((> (* i i) n) t) + (cond ((zerop (mod n i)) (return nil)))))) + +(defun nearest-greater-prime (n) + "Returns the smallest prime number no less than `n'." + (cond ((primep n) n) + ((nearest-greater-prime (+ n 1))))) Added: vendor/cxml/xml-name-rune-p.lisp =================================================================== --- vendor/cxml/xml-name-rune-p.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/xml-name-rune-p.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,227 @@ +;;;; xml-name-rune-p -- character class definitions +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> + +(in-package :cxml) + +#.(funcall + (compile + nil + '(lambda () + (let ((+max+ #xD800)) + (labels + ((name-start-rune-p (rune) + (or (letter-rune-p rune) + (= #.(char-code #\_) rune) + (= #.(char-code #\:) rune))) + + (name-rune-p (rune) + (or (letter-rune-p rune) + (digit-rune-p* rune) + (= rune #.(char-code #\.)) + (= rune #.(char-code #\-)) + (= rune #.(char-code #\_)) + (= rune #.(char-code #\:)) + (combining-rune-p rune) + (extender-rune-p rune))) + + (letter-rune-p (rune) + (or (base-rune-p rune) + (ideographic-rune-p rune))) + + (digit-rune-p* (rune) + (or (<= 48 rune 57) + (<= 1632 rune 1641) + (<= 1776 rune 1785) + (<= 2406 rune 2415) + (<= 2534 rune 2543) + (<= 2662 rune 2671) + (<= 2790 rune 2799) + (<= 2918 rune 2927) + (<= 3047 rune 3055) + (<= 3174 rune 3183) + (<= 3302 rune 3311) + (<= 3430 rune 3439) + (<= 3664 rune 3673) + (<= 3792 rune 3801) + (<= 3872 rune 3881))) + + + (combining-rune-p (rune) + (or (<= 768 rune 837) + (<= 864 rune 865) + (<= 1155 rune 1158) + (<= 1425 rune 1441) + (<= 1443 rune 1465) + (<= 1467 rune 1469) + (= 1471 rune) + (<= 1473 rune 1474) + (= 1476 rune) + (<= 1611 rune 1618) + (= 1648 rune) + (<= 1750 rune 1756) + (<= 1757 rune 1759) + (<= 1760 rune 1764) + (<= 1767 rune 1768) + (<= 1770 rune 1773) + (<= 2305 rune 2307) + (= 2364 rune) + (<= 2366 rune 2380) + (= 2381 rune) + (<= 2385 rune 2388) + (<= 2402 rune 2403) + (<= 2433 rune 2435) + (= 2492 rune) + (= 2494 rune) + (= 2495 rune) + (<= 2496 rune 2500) + (<= 2503 rune 2504) + (<= 2507 rune 2509) + (= 2519 rune) + (<= 2530 rune 2531) + (= 2562 rune) + (= 2620 rune) + (= 2622 rune) + (= 2623 rune) + (<= 2624 rune 2626) + (<= 2631 rune 2632) + (<= 2635 rune 2637) + (<= 2672 rune 2673) + (<= 2689 rune 2691) + (= 2748 rune) + (<= 2750 rune 2757) + (<= 2759 rune 2761) + (<= 2763 rune 2765) + (<= 2817 rune 2819) + (= 2876 rune) + (<= 2878 rune 2883) + (<= 2887 rune 2888) + (<= 2891 rune 2893) + (<= 2902 rune 2903) + (<= 2946 rune 2947) + (<= 3006 rune 3010) + (<= 3014 rune 3016) + (<= 3018 rune 3021) + (= 3031 rune) + (<= 3073 rune 3075) + (<= 3134 rune 3140) + (<= 3142 rune 3144) + (<= 3146 rune 3149) + (<= 3157 rune 3158) + (<= 3202 rune 3203) + (<= 3262 rune 3268) + (<= 3270 rune 3272) + (<= 3274 rune 3277) + (<= 3285 rune 3286) + (<= 3330 rune 3331) + (<= 3390 rune 3395) + (<= 3398 rune 3400) + (<= 3402 rune 3405) + (= 3415 rune) + (= 3633 rune) + (<= 3636 rune 3642) + (<= 3655 rune 3662) + (= 3761 rune) + (<= 3764 rune 3769) + (<= 3771 rune 3772) + (<= 3784 rune 3789) + (<= 3864 rune 3865) + (= 3893 rune) + (= 3895 rune) + (= 3897 rune) + (= 3902 rune) + (= 3903 rune) + (<= 3953 rune 3972) + (<= 3974 rune 3979) + (<= 3984 rune 3989) + (= 3991 rune) + (<= 3993 rune 4013) + (<= 4017 rune 4023) + (= 4025 rune) + (<= 8400 rune 8412) + (= 8417 rune) + (<= 12330 rune 12335) + (= 12441 rune) + (= 12442 rune))) + + (extender-rune-p (rune) + (or + (= 183 rune) + (= 720 rune) + (= 721 rune) + (= 903 rune) + (= 1600 rune) + (= 3654 rune) + (= 3782 rune) + (= 12293 rune) + (<= 12337 rune 12341) + (<= 12445 rune 12446) + (<= 12540 rune 12542))) + + (base-rune-p (rune) + ;; split into two ORs for LispWorks... + (or + (or (<= 65 rune 90) (<= 97 rune 122) (<= 192 rune 214) (<= 216 rune 246) (<= 248 rune 255) (<= 256 rune 305) + (<= 308 rune 318) (<= 321 rune 328) (<= 330 rune 382) (<= 384 rune 451) (<= 461 rune 496) (<= 500 rune 501) + (<= 506 rune 535) (<= 592 rune 680) (<= 699 rune 705) (= 902 rune) (<= 904 rune 906) (= 908 rune) + (<= 910 rune 929) (<= 931 rune 974) (<= 976 rune 982) (= 986 rune) (= 988 rune) (= 990 rune) (= 992 rune) + (<= 994 rune 1011) (<= 1025 rune 1036) (<= 1038 rune 1103) (<= 1105 rune 1116) (<= 1118 rune 1153) + (<= 1168 rune 1220) (<= 1223 rune 1224) (<= 1227 rune 1228) (<= 1232 rune 1259) (<= 1262 rune 1269) + (<= 1272 rune 1273) (<= 1329 rune 1366) (= 1369 rune) (<= 1377 rune 1414) (<= 1488 rune 1514) + (<= 1520 rune 1522) (<= 1569 rune 1594) (<= 1601 rune 1610) (<= 1649 rune 1719) (<= 1722 rune 1726) + (<= 1728 rune 1742) (<= 1744 rune 1747) (= 1749 rune) (<= 1765 rune 1766) (<= 2309 rune 2361) (= 2365 rune) + (<= 2392 rune 2401) (<= 2437 rune 2444) (<= 2447 rune 2448) (<= 2451 rune 2472) (<= 2474 rune 2480) + (= 2482 rune) (<= 2486 rune 2489) (<= 2524 rune 2525) (<= 2527 rune 2529) (<= 2544 rune 2545) + (<= 2565 rune 2570) (<= 2575 rune 2576) (<= 2579 rune 2600) (<= 2602 rune 2608) (<= 2610 rune 2611) + (<= 2613 rune 2614) (<= 2616 rune 2617) (<= 2649 rune 2652) (= 2654 rune) (<= 2674 rune 2676) + (<= 2693 rune 2699) (= 2701 rune) (<= 2703 rune 2705) (<= 2707 rune 2728) (<= 2730 rune 2736) + (<= 2738 rune 2739) (<= 2741 rune 2745) (= 2749 rune) (= 2784 rune) (<= 2821 rune 2828) (<= 2831 rune 2832) + (<= 2835 rune 2856) (<= 2858 rune 2864) (<= 2866 rune 2867) (<= 2870 rune 2873) (= 2877 rune) + (<= 2908 rune 2909) (<= 2911 rune 2913) (<= 2949 rune 2954) (<= 2958 rune 2960) (<= 2962 rune 2965) + (<= 2969 rune 2970) (= 2972 rune)) + (or (<= 2974 rune 2975) (<= 2979 rune 2980) (<= 2984 rune 2986) + (<= 2990 rune 2997) (<= 2999 rune 3001) (<= 3077 rune 3084) (<= 3086 rune 3088) (<= 3090 rune 3112) + (<= 3114 rune 3123) (<= 3125 rune 3129) (<= 3168 rune 3169) (<= 3205 rune 3212) (<= 3214 rune 3216) + (<= 3218 rune 3240) (<= 3242 rune 3251) (<= 3253 rune 3257) (= 3294 rune) (<= 3296 rune 3297) + (<= 3333 rune 3340) (<= 3342 rune 3344) (<= 3346 rune 3368) (<= 3370 rune 3385) (<= 3424 rune 3425) + (<= 3585 rune 3630) (= 3632 rune) (<= 3634 rune 3635) (<= 3648 rune 3653) (<= 3713 rune 3714) (= 3716 rune) + (<= 3719 rune 3720) (= 3722 rune) (= 3725 rune) (<= 3732 rune 3735) (<= 3737 rune 3743) (<= 3745 rune 3747) + (= 3749 rune) (= 3751 rune) (<= 3754 rune 3755) (<= 3757 rune 3758) (= 3760 rune) (<= 3762 rune 3763) (= 3773 rune) + (<= 3776 rune 3780) (<= 3904 rune 3911) (<= 3913 rune 3945) (<= 4256 rune 4293) (<= 4304 rune 4342) + (= 4352 rune) (<= 4354 rune 4355) (<= 4357 rune 4359) (= 4361 rune) (<= 4363 rune 4364) (<= 4366 rune 4370) + (= 4412 rune) (= 4414 rune) (= 4416 rune) (= 4428 rune) (= 4430 rune) (= 4432 rune) (<= 4436 rune 4437) (= 4441 rune) + (<= 4447 rune 4449) (= 4451 rune) (= 4453 rune) (= 4455 rune) (= 4457 rune) (<= 4461 rune 4462) (<= 4466 rune 4467) + (= 4469 rune) (= 4510 rune) (= 4520 rune) (= 4523 rune) (<= 4526 rune 4527) (<= 4535 rune 4536) (= 4538 rune) + (<= 4540 rune 4546) (= 4587 rune) (= 4592 rune) (= 4601 rune) (<= 7680 rune 7835) (<= 7840 rune 7929) + (<= 7936 rune 7957) (<= 7960 rune 7965) (<= 7968 rune 8005) (<= 8008 rune 8013) (<= 8016 rune 8023) + (= 8025 rune) (= 8027 rune) (= 8029 rune) (<= 8031 rune 8061) (<= 8064 rune 8116) (<= 8118 rune 8124) (= 8126 rune) + (<= 8130 rune 8132) (<= 8134 rune 8140) (<= 8144 rune 8147) (<= 8150 rune 8155) (<= 8160 rune 8172) + (<= 8178 rune 8180) (<= 8182 rune 8188) (= 8486 rune) (<= 8490 rune 8491) (= 8494 rune) (<= 8576 rune 8578) + (<= 12353 rune 12436) (<= 12449 rune 12538) (<= 12549 rune 12588) (<= 44032 rune 55203)))) + + (ideographic-rune-p (rune) + (or (<= 19968 rune 40869) (= 12295 rune) (<= 12321 rune 12329))) + + + (predicate-to-bv (p) + (let ((r (make-array +max+ :element-type 'bit :initial-element 0))) + (dotimes (i #x10000 r) + (when (funcall p i) + (setf (aref r i) 1))))) ) + + `(progn + (DEFINLINE NAME-RUNE-P (RUNE) + (SETF RUNE (RUNE-CODE RUNE)) + (AND (<= 0 RUNE ,+max+) + (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) + (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) + (THE FIXNUM RUNE)))))) + (DEFINLINE NAME-START-RUNE-P (RUNE) + (SETF RUNE (RUNE-CODE RUNE)) + (AND (<= 0 RUNE ,+MAX+) + (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) + (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) + (THE FIXNUM RUNE)))))))) )))) Added: vendor/cxml/xml-parse.lisp =================================================================== --- vendor/cxml/xml-parse.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/xml-parse.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,3544 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; -*- +;;; --------------------------------------------------------------------------- +;;; Title: XML parser +;;; Created: 1999-07-17 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; Author: Henrik Motakef <hmot(a)henrik-motakef.de> +;;; Author: David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; © copyright 1999 by Gilbert Baumann +;;; © copyright 2003 by Henrik Motakef +;;; © copyright 2004 knowledgeTools Int. GmbH +;;; © copyright 2004 David Lichteblau +;;; © copyright 2005 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +;;; Streams + +;;; xstreams + +;; For reading runes, I defined my own streams, called xstreams, +;; because we want to be fast. A function call or even a method call +;; per character is not acceptable, instead of that we define a +;; buffered stream with and advertised buffer layout, so that we +;; could use the trick stdio uses: READ-RUNE and PEEK-RUNE are macros, +;; directly accessing the buffer and only calling some underflow +;; handler in case of stream underflows. This will yield to quite a +;; performance boost vs calling READ-BYTE per character. + +;; Also we need to do encoding t conversion on ; this better done at large chunks of data rather than on a character +;; by character basis. This way we need a dispatch on the active +;; encoding only once in a while, instead of for each character. This +;; allows us to use a CLOS interface to do the underflow handling. + +;;; zstreams + +;; Now, for reading tokens, we define another kind of streams, called +;; zstreams. These zstreams also maintain an input stack to implement +;; inclusion of external entities. This input stack contains xstreams +;; or the special marker :STOP. Such a :STOP marker indicates, that +;; input should not continue there, but well stop; that is simulate an +;; EOF. The user is then responsible to pop this marker off the input +;; stack. +;; +;; This input stack is also used to detect circular entity inclusion. + +;; The zstream tokenizer recognizes the following types of tokens and +;; is controlled by the *DATA-BEHAVIOUR* flag. (Which should become a +;; slot of zstreams instead). + +;; Common +;; :xml-decl (<target> . <content>) ;processing-instruction starting with "<?xml" +;; :pi (<target> . <content>) ;processing-instruction +;; :stag (<name> . <atts>) ;start tag +;; :etag (<name> . <atts>) ;end tag +;; :ztag (<name> . <atts>) ;empty tag +;; :<!element +;; :<!entity +;; :<!attlist +;; :<!notation +;; :<!doctype +;; :<![ +;; :comment <content> + +;; *data-behaviour* = :DTD +;; +;; :nmtoken <interned-rod> +;; :#required +;; :#implied +;; :#fixed +;; :#pcdata +;; :s +;; :\[ :\] :$ :$ :|\ :\> :\" :\' :\, :\? :\* :\+ + +;; *data-behaviour* = :DOC +;; +;; :entity-ref <interned-rod> +;; :cdata <rod> + + +;;; TODO +;; +;; o provide for a faster DOM +;; +;; o morph zstream into a context object and thus also get rid of +;; special variables. Put the current DTD there too. +;; [partly done] + +;; o the *scratch-pad* hack should become something much more +;; reentrant, we could either define a system-wide resource +;; or allocate some scratch-pads per context. +;; [for thread-safety reasons the array are allocated per context now, +;; reentrancy is still open] + +;; o CR handling in utf-16 deocders +;; +;; o UCS-4 reader +;; +;; o max depth together with circle detection +;; (or proof, that our circle detection is enough). +;; [gemeint ist zstream-push--david] +;; +;; o better extensibility wrt character representation, one may want to +;; have +;; - UCS-4 in vectoren +;; +;; o xstreams auslagern, documententieren und dann auch in SGML und +;; CSS parser verwenden. (halt alles was zeichen liest). +;; [ausgelagert sind sie; dokumentiert "so la la"; die Reintegration +;; in Closure ist ein ganz anderes Thema] +;; +;; o recording of source locations for nodes. +;; +;; o based on the DTD and xml:space attribute implement HTML white +;; space rules. +;; +;; o on a parser option, do not expand external entities. + +;;;; Validity constraints: +;;;; (00) Root Element Type like (03), c.f. MAKE-ROOT-MODEL +;;;; (01) Proper Declaration/PE Nesting P/MARKUP-DECL +;;;; (02) Standalone Document Declaration all over the place [*] +;;;; (03) Element Valid VALIDATE-*-ELEMENT, -CHARACTERS +;;;; (04) Attribute Value Type VALIDATE-ATTRIBUTE +;;;; (05) Unique Element Type Declaration DEFINE-ELEMENT +;;;; (06) Proper Group/PE Nesting P/CSPEC +;;;; (07) No Duplicate Types LEGAL-CONTENT-MODEL-P +;;;; (08) ID VALIDATE-ATTRIBUTE +;;;; (09) One ID per Element Type DEFINE-ATTRIBUTE +;;;; (10) ID Attribute Default DEFINE-ATTRIBUTE +;;;; (11) IDREF VALIDATE-ATTRIBUTE, P/DOCUMENT +;;;; (12) Entity Name VALIDATE-ATTRIBUTE +;;;; (13) Name Token VALIDATE-ATTRIBUTE +;;;; (14) Notation Attributes VALIDATE-ATTRIBUTE, P/ATT-TYPE +;;;; (15) One Notation Per Element Type DEFINE-ATTRIBUTE +;;;; (16) No Notation on Empty Element DEFINE-ELEMENT, -ATTRIBUTE +;;;; (17) Enumeration VALIDATE-ATTRIBUTE +;;;; (18) Required Attribute PROCESS-ATTRIBUTES +;;;; (19) Attribute Default Legal DEFINE-ATTRIBUTE +;;;; (20) Fixed Attribute Default VALIDATE-ATTRIBUTE +;;;; (21) Proper Conditional Section/PE Nesting P/CONDITIONAL-SECT, ... +;;;; (22) Entity Declared [**] +;;;; (23) Notation Declared P/ENTITY-DEF, P/DOCUMENT +;;;; (24) Unique Notation Name DEFINE-NOTATION +;;;; +;;;; [*] Perhaps we could revert the explicit checks of (02), if we did +;;;; _not_ read external subsets of standalone documents when parsing in +;;;; validating mode. Violations of VC (02) constraints would then appear as +;;;; wellformedness violations, right? +;;;; +;;;; [**] Although I haven't investigated this properly yet, I believe that +;;;; we check this VC together with the WFC even in non-validating mode. + +(in-package :cxml) + +#+allegro +(setf (excl:named-readtable :runes) *readtable*) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *fast* '(optimize (speed 3) (safety 0))) + ;;(defparameter *fast* '(optimize (speed 2) (safety 3))) + ) + +;;; parser context + +(defvar *ctx* nil) + +(defstruct (context (:conc-name nil)) + handler + (dtd nil) + model-stack + (referenced-notations '()) + (id-table (%make-rod-hash-table)) + ;; FIXME: Wofuer ist name-hashtable da? Will man das wissen? + (name-hashtable (make-rod-hashtable :size 2000)) + (standalone-p nil) + (entity-resolver nil) + (disallow-internal-subset nil) + main-zstream) + +(defvar *expand-pe-p* nil) + +(defparameter *namespace-bindings* + '((#"" . nil) + (#"xmlns" . #"http://www.w3.org/2000/xmlns/") + (#"xml" . #"http://www.w3.org/XML/1998/namespace"))) + +;;;; --------------------------------------------------------------------------- +;;;; xstreams +;;;; + + +(defstruct (stream-name + (:print-function print-stream-name)) + entity-name + entity-kind + uri) + +(defun print-stream-name (object stream depth) + (declare (ignore depth)) + (format stream "[~A ~S ~A]" + (rod-string (stream-name-entity-name object)) + (stream-name-entity-kind object) + (stream-name-uri object))) + +(deftype read-element () 'rune) + +(defun call-with-open-xstream (fn stream) + (unwind-protect + (funcall fn stream) + (close-xstream stream))) + +(defmacro with-open-xstream ((var value) &body body) + `(call-with-open-xstream (lambda (,var) ,@body) ,value)) + +(defun call-with-open-xfile (continuation &rest open-args) + (let ((input (apply #'open (car open-args) :element-type '(unsigned-byte 8) (cdr open-args)))) + (unwind-protect + (progn + (funcall continuation (make-xstream input))) + (close input)))) + +(defmacro with-open-xfile ((stream &rest open-args) &body body) + `(call-with-open-xfile (lambda (,stream) .,body) .,open-args)) + +;;;; ------------------------------------------------------------------- +;;;; Rechnen mit Runen +;;;; + +;; Let us first define fast fixnum arithmetric get rid of type +;; checks. (After all we know what we do here). + +(defmacro fx-op (op &rest xs) + `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) +(defmacro fx-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) + +(defmacro %+ (&rest xs) `(fx-op + ,@xs)) +(defmacro %- (&rest xs) `(fx-op - ,@xs)) +(defmacro %* (&rest xs) `(fx-op * ,@xs)) +(defmacro %/ (&rest xs) `(fx-op floor ,@xs)) +(defmacro %and (&rest xs) `(fx-op logand ,@xs)) +(defmacro %ior (&rest xs) `(fx-op logior ,@xs)) +(defmacro %xor (&rest xs) `(fx-op logxor ,@xs)) +(defmacro %ash (&rest xs) `(fx-op ash ,@xs)) +(defmacro %mod (&rest xs) `(fx-op mod ,@xs)) + +(defmacro %= (&rest xs) `(fx-pred = ,@xs)) +(defmacro %<= (&rest xs) `(fx-pred <= ,@xs)) +(defmacro %>= (&rest xs) `(fx-pred >= ,@xs)) +(defmacro %< (&rest xs) `(fx-pred < ,@xs)) +(defmacro %> (&rest xs) `(fx-pred > ,@xs)) + +;;; XXX Geschwindigkeit dieser Definitionen untersuchen! + +(defmacro rune-op (op &rest xs) + `(code-rune (,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs)))) +(defmacro rune-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs))) + +(defmacro %rune+ (&rest xs) `(rune-op + ,@xs)) +(defmacro %rune- (&rest xs) `(rune-op - ,@xs)) +(defmacro %rune* (&rest xs) `(rune-op * ,@xs)) +(defmacro %rune/ (&rest xs) `(rune-op floor ,@xs)) +(defmacro %rune-and (&rest xs) `(rune-op logand ,@xs)) +(defmacro %rune-ior (&rest xs) `(rune-op logior ,@xs)) +(defmacro %rune-xor (&rest xs) `(rune-op logxor ,@xs)) +(defmacro %rune-ash (a b) `(code-rune (ash (rune-code ,a) ,b))) +(defmacro %rune-mod (&rest xs) `(rune-op mod ,@xs)) + +(defmacro %rune= (&rest xs) `(rune-pred = ,@xs)) +(defmacro %rune<= (&rest xs) `(rune-pred <= ,@xs)) +(defmacro %rune>= (&rest xs) `(rune-pred >= ,@xs)) +(defmacro %rune< (&rest xs) `(rune-pred < ,@xs)) +(defmacro %rune> (&rest xs) `(rune-pred > ,@xs)) + +;;;; --------------------------------------------------------------------------- +;;;; rod hashtable +;;;; + +;;; make-rod-hashtable +;;; rod-hash-get hashtable rod &optional start end -> value ; successp +;;; (setf (rod-hash-get hashtable rod &optional start end) new-value +;;; + +(defstruct (rod-hashtable (:constructor make-rod-hashtable/low)) + size ;size of table + table ; + ) + +(defun make-rod-hashtable (&key (size 200)) + (setf size (nearest-greater-prime size)) + (make-rod-hashtable/low + :size size + :table (make-array size :initial-element nil))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +fixnum-bits+ + (1- (integer-length most-positive-fixnum)) + "Pessimistic approximation of the number of bits of fixnums.") + + (defconstant +fixnum-mask+ + (1- (expt 2 +fixnum-bits+)) + "Pessimistic approximation of the largest bit-mask, still being a fixnum.")) + +(definline stir (a b) + (%and +fixnum-mask+ + (%xor (%ior (%ash (%and a #.(ash +fixnum-mask+ -5)) 5) + (%ash a #.(- 5 +fixnum-bits+))) + b))) + +(definline rod-hash (rod start end) + "Compute a hash code out of a rod." + (let ((res (%- end start))) + (do ((i start (%+ i 1))) + ((%= i end)) + (declare (type fixnum i)) + (setf res (stir res (rune-code (%rune rod i))))) + res)) + +(definline rod=* (x y &key (start1 0) (end1 (length x)) + (start2 0) (end2 (length y))) + (and (%= (%- end1 start1) (%- end2 start2)) + (do ((i start1 (%+ i 1)) + (j start2 (%+ j 1))) + ((%= i end1) + t) + (unless (rune= (%rune x i) (%rune y j)) + (return nil))))) + +(definline rod=** (x y start1 end1 start2 end2) + (and (%= (%- end1 start1) (%- end2 start2)) + (do ((i start1 (%+ i 1)) + (j start2 (%+ j 1))) + ((%= i end1) + t) + (unless (rune= (%rune x i) (%rune y j)) + (return nil))))) + +(defun rod-hash-get (hashtable rod &optional (start 0) (end (length rod))) + (declare (type (simple-array rune (*)) rod)) + (let ((j (%mod (rod-hash rod start end) + (rod-hashtable-size hashtable)))) + (dolist (q (svref (rod-hashtable-table hashtable) j) + (values nil nil nil)) + (declare (type cons q)) + (when (rod=** (car q) rod 0 (length (the (simple-array rune (*)) (car q))) start end) + (return (values (cdr q) t (car q))))))) + +(defun rod-hash-set (new-value hashtable rod &optional (start 0) (end (length rod))) + (let ((j (%mod (rod-hash rod start end) + (rod-hashtable-size hashtable))) + (key nil)) + (dolist (q (svref (rod-hashtable-table hashtable) j) + (progn + (setf key (rod-subseq* rod start end)) + (push (cons key new-value) + (aref (rod-hashtable-table hashtable) j)))) + (when (rod=* (car q) rod :start2 start :end2 end) + (setf key (car q)) + (setf (cdr q) new-value) + (return))) + (values new-value key))) + +#-rune-is-character +(defun rod-subseq* (source start &optional (end (length source))) + (unless (and (typep start 'fixnum) (>= start 0)) + (error "~S is not a non-negative fixnum." start)) + (unless (and (typep end 'fixnum) (>= end start)) + (error "END argument, ~S, is not a fixnum no less than START, ~S." end start)) + (when (> start (length source)) + (error "START argument, ~S, should be no greater than length of rod." start)) + (when (> end (length source)) + (error "END argument, ~S, should be no greater than length of rod." end)) + (locally + (declare (type fixnum start end)) + (let ((res (make-rod (- end start)))) + (declare (type rod res)) + (do ((i (- (- end start) 1) (the fixnum (- i 1)))) + ((< i 0) res) + (declare (type fixnum i)) + (setf (%rune res i) (aref source (the fixnum (+ i start)))))))) + +#+rune-is-character +(defun rod-subseq* (source start &optional (end (length source))) + (subseq source start end)) + +(deftype ufixnum () `(unsigned-byte ,(integer-length most-positive-fixnum))) + +#-rune-is-character +(defun rod-subseq** (source start &optional (end (length source))) + (declare (type (simple-array rune (*)) source) + (type ufixnum start) + (type ufixnum end) + (optimize (speed 3) (safety 0))) + (let ((res (make-array (%- end start) :element-type 'rune))) + (declare (type (simple-array rune (*)) res)) + (let ((i (%- end start))) + (declare (type ufixnum i)) + (loop + (setf i (- i 1)) + (when (= i 0) + (return)) + (setf (%rune res i) (%rune source (the ufixnum (+ i start)))))) + res)) + +#+rune-is-character +(defun rod-subseq** (source start &optional (end (length source))) + (subseq source start end)) + +(defun (setf rod-hash-get) (new-value hashtable rod &optional (start 0) (end (length rod))) + (rod-hash-set new-value hashtable rod start end)) + +(defun intern-name (rod &optional (start 0) (end (length rod))) + (multiple-value-bind (value successp key) (rod-hash-get (name-hashtable *ctx*) rod start end) + (declare (ignore value)) + (if successp + key + (nth-value 1 (rod-hash-set t (name-hashtable *ctx*) rod start end))))) + +;;;; --------------------------------------------------------------------------- +;;;; +;;;; rod collector +;;;; + +(defvar *scratch-pad*) +(defvar *scratch-pad-2*) +(defvar *scratch-pad-3*) +(defvar *scratch-pad-4*) + +(declaim (type (simple-array rune (*)) + *scratch-pad* *scratch-pad-2* *scratch-pad-3* *scratch-pad-4*)) + +(defmacro with-scratch-pads ((&optional) &body body) + `(let ((*scratch-pad* (make-array 1024 :element-type 'rune)) + (*scratch-pad-2* (make-array 1024 :element-type 'rune)) + (*scratch-pad-3* (make-array 1024 :element-type 'rune)) + (*scratch-pad-4* (make-array 1024 :element-type 'rune))) + ,@body)) + +(defmacro %put-unicode-char (code-var put) + `(progn + (cond ((%> ,code-var #xFFFF) + (,put (the rune (code-rune (%+ #xD7C0 (%ash ,code-var -10))))) + (,put (the rune (code-rune (%ior #xDC00 (%and ,code-var #x03FF)))))) + (t + (,put (code-rune ,code-var)))))) + +(defun adjust-array-by-copying (old-array new-size) + "Adjust an array by copying and thus ensures, that result is a SIMPLE-ARRAY." + (let ((res (make-array new-size :element-type (array-element-type old-array)))) + (replace res old-array + :start1 0 :end1 (length old-array) + :start2 0 :end2 (length old-array)) + res)) + +(defmacro with-rune-collector-aux (scratch collect body mode) + (let ((rod (gensym)) + (n (gensym)) + (i (gensym)) + (b (gensym))) + `(let ((,n (length ,scratch)) + (,i 0) + (,b ,scratch)) + (declare (type fixnum ,n ,i)) + (macrolet + ((,collect (x) + `((lambda (x) + (locally + (declare #.*fast*) + (when (%>= ,',i ,',n) + (setf ,',n (* 2 ,',n)) + (setf ,',b + (setf ,',scratch + (adjust-array-by-copying ,',scratch ,',n)))) + (setf (aref (the (simple-array rune (*)) ,',b) ,',i) x) + (incf ,',i))) + ,x))) + ,@body + ,(ecase mode + (:intern + `(intern-name ,b 0 ,i)) + (:copy + `(let ((,rod (make-rod ,i))) + (while (not (%= ,i 0)) + (setf ,i (%- ,i 1)) + (setf (%rune ,rod ,i) + (aref (the (simple-array rune (*)) ,b) ,i))) + ,rod)) + (:raw + `(values ,b 0 ,i)) + ))))) + +'(defmacro with-rune-collector-aux (scratch collect body mode) + (let ((rod (gensym)) + (n (gensym)) + (i (gensym)) + (b (gensym))) + `(let ((,n (length ,scratch)) + (,i 0)) + (declare (type fixnum ,n ,i)) + (macrolet + ((,collect (x) + `((lambda (x) + (locally + (declare #.*fast*) + (when (%>= ,',i ,',n) + (setf ,',n (* 2 ,',n)) + (setf ,',scratch + (setf ,',scratch + (adjust-array-by-copying ,',scratch ,',n)))) + (setf (aref (the (simple-array rune (*)) ,',scratch) ,',i) x) + (incf ,',i))) + ,x))) + ,@body + ,(ecase mode + (:intern + `(intern-name ,scratch 0 ,i)) + (:copy + `(let ((,rod (make-rod ,i))) + (while (%> ,i 0) + (setf ,i (%- ,i 1)) + (setf (%rune ,rod ,i) + (aref (the (simple-array rune (*)) ,scratch) ,i))) + ,rod)) + (:raw + `(values ,scratch 0 ,i)) + ))))) + +(defmacro with-rune-collector ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :copy)) + +(defmacro with-rune-collector-2 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-2* ,collect ,body :copy)) + +(defmacro with-rune-collector-3 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-3* ,collect ,body :copy)) + +(defmacro with-rune-collector-4 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-4* ,collect ,body :copy)) + +(defmacro with-rune-collector/intern ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :intern)) + +(defmacro with-rune-collector/raw ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :raw)) + +#| +(defmacro while-reading-runes ((reader stream-in) &rest body) + ;; Thou shalt not leave body via a non local exit + (let ((stream (make-symbol "STREAM")) + (rptr (make-symbol "RPTR")) + (fptr (make-symbol "FPTR")) + (buf (make-symbol "BUF")) ) + `(let* ((,stream ,stream-in) + (,rptr (xstream-read-ptr ,stream)) + (,fptr (xstream-fill-ptr ,stream)) + (,buf (xstream-buffer ,stream))) + (declare (type fixnum ,rptr ,fptr) + (type xstream ,stream)) + (macrolet ((,reader (res-var) + `(cond ((%= ,',rptr ,',fptr) + (setf (xstream-read-ptr ,',stream) ,',rptr) + (setf ,res-var (xstream-underflow ,',stream)) + (setf ,',rptr (xstream-read-ptr ,',stream)) + (setf ,',fptr (xstream-fill-ptr ,',stream)) + (setf ,',buf (xstream-buffer ,',stream))) + (t + (setf ,res-var + (aref (the (simple-array read-element (*)) ,',buf) + (the fixnum ,',rptr))) + (setf ,',rptr (%+ ,',rptr 1)))))) + (prog1 + (let () .,body) + (setf (xstream-read-ptr ,stream) ,rptr) ))))) +|# + +;;;; --------------------------------------------------------------------------- +;;;; DTD +;;;; + +(define-condition xml-parse-error (simple-error) ()) +(define-condition well-formedness-violation (xml-parse-error) ()) +(define-condition validity-error (xml-parse-error) ()) + +;; We make some effort to signal end of file as a special condition, but we +;; don't actually try very hard. Not sure whether we should. Right now I +;; would prefer not to document this class. +(define-condition end-of-xstream (well-formedness-violation) ()) + +(defun describe-xstream (x s) + (format s " Line ~D, column ~D in ~A~%" + (xstream-line-number x) + (xstream-column-number x) + (let ((name (xstream-name x))) + (cond + ((null name) + "<anonymous stream>") + ((eq :main (stream-name-entity-kind name)) + (stream-name-uri name)) + (t + name))))) + +(defun %error (class stream message) + (let* ((zmain (if *ctx* (main-zstream *ctx*) nil)) + (zstream (if (zstream-p stream) stream zmain)) + (xstream (if (xstream-p stream) stream nil)) + (s (make-string-output-stream))) + (write-line message s) + (when xstream + (write-line "Location:" s) + (describe-xstream xstream s)) + (when zstream + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zstream))))) + (when stack + (write-line "Context:" s) + (dolist (x stack) + (describe-xstream x s))))) + (when (and zmain (not (eq zstream zmain))) + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zmain))))) + (when stack + (write-line "Context in main document:" s) + (dolist (x stack) + (describe-xstream x s))))) + (error class + :format-control "~A" + :format-arguments (list (get-output-stream-string s))))) + +(defun validity-error (fmt &rest args) + (%error 'validity-error + nil + (format nil "Document not valid: ~?" fmt args))) + +(defun wf-error (stream fmt &rest args) + (%error 'well-formedness-violation + stream + (format nil "Document not well-formed: ~?" fmt args))) + +(defun eox (stream &optional x &rest args) + (%error 'end-of-xstream + stream + (format nil "End of file~@[: ~?~]" x args))) + +(defvar *validate* t) +(defvar *external-subset-p* nil) + +(defun validate-start-element (ctx name) + (when *validate* + (let* ((pair (car (model-stack ctx))) + (newval (funcall (car pair) name))) + (unless newval + (validity-error "(03) Element Valid: ~A" (rod-string name))) + (setf (car pair) newval) + (let ((e (find-element name (dtd ctx)))) + (unless e + (validity-error "(03) Element Valid: no definition for ~A" + (rod-string name))) + (maybe-compile-cspec e) + (push (copy-cons (elmdef-compiled-cspec e)) (model-stack ctx)))))) + +(defun copy-cons (x) + (cons (car x) (cdr x))) + +(defun validate-end-element (ctx name) + (when *validate* + (let ((pair (car (model-stack ctx)))) + (unless (eq (funcall (car pair) nil) t) + (validity-error "(03) Element Valid: ~A" (rod-string name))) + (pop (model-stack ctx))))) + +(defun validate-characters (ctx rod) + (when *validate* + (let ((pair (car (model-stack ctx)))) + (unless (funcall (cdr pair) rod) + (validity-error "(03) Element Valid: unexpected PCDATA"))))) + +(defun standalone-check-necessary-p (def) + (and *validate* + (standalone-p *ctx*) + (etypecase def + (elmdef (elmdef-external-p def)) + (attdef (attdef-external-p def))))) + +;; attribute validation, defaulting, and normalization -- except for for +;; uniqueness checks, which are done after namespaces have been declared +(defun process-attributes (ctx name attlist) + (let ((e (find-element name (dtd ctx)))) + (cond + (e + (dolist (ad (elmdef-attributes e)) ;handle default values + (unless (get-attribute (attdef-name ad) attlist) + (case (attdef-default ad) + (:IMPLIED) + (:REQUIRED + (when *validate* + (validity-error "(18) Required Attribute: ~S not specified" + (rod-string (attdef-name ad))))) + (t + (when (standalone-check-necessary-p ad) + (validity-error "(02) Standalone Document Declaration: missing attribute value")) + (push (sax:make-attribute :qname (attdef-name ad) + :value (cadr (attdef-default ad)) + :specified-p nil) + attlist))))) + (dolist (a attlist) ;normalize non-CDATA values + (let* ((qname (sax:attribute-qname a)) + (adef (find-attribute e qname))) + (when adef + (when (and *validate* + sax:*namespace-processing* + (eq (attdef-type adef) :ID) + (find #/: (sax:attribute-value a))) + (validity-error "colon in ID attribute")) + (unless (eq (attdef-type adef) :CDATA) + (let ((canon (canon-not-cdata-attval (sax:attribute-value a)))) + (when (and (standalone-check-necessary-p adef) + (not (rod= (sax:attribute-value a) canon))) + (validity-error "(02) Standalone Document Declaration: attribute value not normalized")) + (setf (sax:attribute-value a) canon)))))) + (when *validate* ;maybe validate attribute values + (dolist (a attlist) + (validate-attribute ctx e a)))) + ((and *validate* attlist) + (validity-error "(04) Attribute Value Type: no definition for element ~A" + (rod-string name))))) + attlist) + +(defun get-attribute (name attributes) + (member name attributes :key #'sax:attribute-qname :test #'rod=)) + +(defun validate-attribute (ctx e a) + (when (sax:attribute-specified-p a) ;defaults checked by DEFINE-ATTRIBUTE + (let* ((qname (sax:attribute-qname a)) + (adef + (or (find-attribute e qname) + (validity-error "(04) Attribute Value Type: not declared: ~A" + (rod-string qname))))) + (validate-attribute* ctx adef (sax:attribute-value a))))) + +(defun validate-attribute* (ctx adef value) + (let ((type (attdef-type adef)) + (default (attdef-default adef))) + (when (and (listp default) + (eq (car default) :FIXED) + (not (rod= value (cadr default)))) + (validity-error "(20) Fixed Attribute Default: expected ~S but got ~S" + (rod-string (cadr default)) + (rod-string value))) + (ecase (if (listp type) (car type) type) + (:ID + (unless (valid-name-p value) + (validity-error "(08) ID: not a name: ~S" (rod-string value))) + (when (eq (gethash value (id-table ctx)) t) + (validity-error "(08) ID: ~S not unique" (rod-string value))) + (setf (gethash value (id-table ctx)) t)) + (:IDREF + (validate-idref ctx value)) + (:IDREFS + (let ((names (split-names value))) + (unless names + (validity-error "(11) IDREF: malformed names")) + (mapc (curry #'validate-idref ctx) names))) + (:NMTOKEN + (validate-nmtoken value)) + (:NMTOKENS + (let ((tokens (split-names value))) + (unless tokens + (validity-error "(13) Name Token: malformed NMTOKENS")) + (mapc #'validate-nmtoken tokens))) + (:ENUMERATION + (unless (member value (cdr type) :test #'rod=) + (validity-error "(17) Enumeration: value not declared: ~S" + (rod-string value)))) + (:NOTATION + (unless (member value (cdr type) :test #'rod=) + (validity-error "(14) Notation Attributes: ~S" (rod-string value)))) + (:ENTITY + (validate-entity value)) + (:ENTITIES + (let ((names (split-names value))) + (unless names + (validity-error "(13) Name Token: malformed NMTOKENS")) + (mapc #'validate-entity names))) + (:CDATA)))) + +(defun validate-idref (ctx value) + (unless (valid-name-p value) + (validity-error "(11) IDREF: not a name: ~S" (rod-string value))) + (unless (gethash value (id-table ctx)) + (setf (gethash value (id-table ctx)) nil))) + +(defun validate-nmtoken (value) + (unless (valid-nmtoken-p value) + (validity-error "(13) Name Token: not a NMTOKEN: ~S" + (rod-string value)))) + +(defstruct (entdef (:constructor))) + +(defstruct (internal-entdef + (:include entdef) + (:constructor make-internal-entdef (value)) + (:conc-name #:entdef-)) + (value (error "missing argument") :type rod) + (expansion nil) + (external-subset-p *external-subset-p*)) + +(defstruct (external-entdef + (:include entdef) + (:constructor make-external-entdef (extid ndata)) + (:conc-name #:entdef-)) + (extid (error "missing argument") :type extid) + (ndata nil :type (or rod null))) + +(defun validate-entity (value) + (unless (valid-name-p value) + (validity-error "(12) Entity Name: not a name: ~S" (rod-string value))) + (let ((def (let ((*validate* + ;; Similarly the entity refs are internal and + ;; don't need normalization ... the unparsed + ;; entities (and entities) aren't "references" + ;; -- sun/valid/sa03.xml + nil)) + (get-entity-definition value :general (dtd *ctx*))))) + (unless (and (typep def 'external-entdef) (entdef-ndata def)) + ;; unparsed entity + (validity-error "(12) Entity Name: ~S" (rod-string value))))) + +(defun split-names (rod) + (flet ((whitespacep (x) + (or (rune= x #/U+0009) + (rune= x #/U+000A) + (rune= x #/U+000D) + (rune= x #/U+0020)))) + (if (let ((n (length rod))) + (and (not (zerop n)) + (or (whitespacep (rune rod 0)) + (whitespacep (rune rod (1- n)))))) + nil + (split-sequence-if #'whitespacep rod :remove-empty-subseqs t)))) + +(defun zstream-base-sysid (zstream) + (let ((base-sysid + (dolist (k (zstream-input-stack zstream)) + (let ((base-sysid (stream-name-uri (xstream-name k)))) + (when base-sysid (return base-sysid)))))) + base-sysid)) + +(defun absolute-uri (sysid source-stream) + (let ((base-sysid (zstream-base-sysid source-stream))) + ;; XXX is the IF correct? + (if base-sysid + (puri:merge-uris sysid base-sysid) + sysid))) + +(defstruct (extid (:constructor make-extid (public system))) + (public nil :type (or rod null)) + (system (error "missing argument") :type (or puri:uri null))) + +(defun absolute-extid (source-stream extid) + (let ((sysid (extid-system extid)) + (result (copy-extid extid))) + (setf (extid-system result) (absolute-uri sysid source-stream)) + result)) + +(defun define-entity (source-stream name kind def) + (setf name (intern-name name)) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error source-stream "colon in entity name")) + (let ((table + (ecase kind + (:general (dtd-gentities (dtd *ctx*))) + (:parameter (dtd-pentities (dtd *ctx*)))))) + (unless (gethash name table) + (when (and source-stream (handler *ctx*)) + (report-entity (handler *ctx*) kind name def)) + (when (typep def 'external-entdef) + (setf (entdef-extid def) + (absolute-extid source-stream (entdef-extid def)))) + (setf (gethash name table) + (cons *external-subset-p* def))))) + +(defun get-entity-definition (entity-name kind dtd) + (unless dtd + (wf-error nil "entity not defined: ~A" (rod-string entity-name))) + (destructuring-bind (extp &rest def) + (gethash entity-name + (ecase kind + (:general (dtd-gentities dtd)) + (:parameter (dtd-pentities dtd))) + '(nil)) + (when (and *validate* (standalone-p *ctx*) extp) + (validity-error "(02) Standalone Document Declaration: entity reference: ~S" + (rod-string entity-name))) + def)) + +(defun entity->xstream (zstream entity-name kind &optional internalp) + ;; `zstream' is for error messages + (let ((def (get-entity-definition entity-name kind (dtd *ctx*)))) + (unless def + (wf-error zstream "Entity '~A' is not defined." (rod-string entity-name))) + (let (r) + (etypecase def + (internal-entdef + (when (and (standalone-p *ctx*) + (entdef-external-subset-p def)) + (wf-error + zstream + "entity declared in external subset, but document is standalone")) + (setf r (make-rod-xstream (entdef-value def))) + (setf (xstream-name r) + (make-stream-name :entity-name entity-name + :entity-kind kind + :uri nil))) + (external-entdef + (when internalp + (wf-error zstream + "entity not internal: ~A" (rod-string entity-name))) + (when (entdef-ndata def) + (wf-error zstream + "reference to unparsed entity: ~A" + (rod-string entity-name))) + (setf r (xstream-open-extid (extid-using-catalog (entdef-extid def)))) + (setf (stream-name-entity-name (xstream-name r)) entity-name + (stream-name-entity-kind (xstream-name r)) kind))) + r))) + +(defun checked-get-entdef (name type) + (let ((def (get-entity-definition name type (dtd *ctx*)))) + (unless def + (wf-error nil "Entity '~A' is not defined." (rod-string name))) + def)) + +(defun xstream-open-extid (extid) + (let* ((sysid (extid-system extid)) + (stream + (or (funcall (or (entity-resolver *ctx*) (constantly nil)) + (extid-public extid) + (extid-system extid)) + (open (uri-to-pathname sysid) + :element-type '(unsigned-byte 8) + :direction :input)))) + (make-xstream stream + :name (make-stream-name :uri sysid) + :initial-speed 1))) + +(defun call-with-entity-expansion-as-stream (zstream cont name kind internalp) + ;; `zstream' is for error messages + (let ((in (entity->xstream zstream name kind internalp))) + (unwind-protect + (funcall cont in) + (close-xstream in)))) + +(defun ensure-dtd () + (unless (dtd *ctx*) + (setf (dtd *ctx*) (make-dtd)) + (define-default-entities))) + +(defun define-default-entities () + (define-entity nil #"lt" :general (make-internal-entdef #"<")) + (define-entity nil #"gt" :general (make-internal-entdef #">")) + (define-entity nil #"amp" :general (make-internal-entdef #"&")) + (define-entity nil #"apos" :general (make-internal-entdef #"'")) + (define-entity nil #"quot" :general (make-internal-entdef #"\""))) + +(defstruct attdef + ;; an attribute definition + element ;name of element this attribute belongs to + name ;name of attribute + type ;type of attribute; either one of :CDATA, :ID, :IDREF, :IDREFS, + ; :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS, or + ; (:NOTATION <name>*) + ; (:ENUMERATION <name>*) + default ;default value of attribute: + ; :REQUIRED, :IMPLIED, (:FIXED content) or (:DEFAULT content) + (external-p *external-subset-p*) + ) + +(defstruct elmdef + ;; an element definition + name ;name of the element + content ;content model [*] + attributes ;list of defined attributes + compiled-cspec ;cons of validation function for contentspec + (external-p *external-subset-p*) + ) + +;; [*] in XML it is possible to define attributes before the element +;; itself is defined and since we hang attribute definitions into the +;; relevant element definitions, the `content' slot indicates whether an +;; element was actually defined. It is NIL until set to a content model +;; when the element type declaration is processed. + +(defun %make-rod-hash-table () + ;; XXX with portable hash tables, this is the only way to case-sensitively + ;; use rods. However, EQUALP often has horrible performance! Most Lisps + ;; provide extensions for user-defined equality, we should use them! There + ;; is also a home-made hash table for rods defined below, written by + ;; Gilbert (I think). We could also use that one, but I would prefer the + ;; first method, even if it's unportable. + (make-hash-table :test + #+rune-is-character 'equal + #-rune-is-character 'equalp)) + +(defstruct dtd + (elements (%make-rod-hash-table)) ;elmdefs + (gentities (%make-rod-hash-table)) ;general entities + (pentities (%make-rod-hash-table)) ;parameter entities + (notations (%make-rod-hash-table))) + +(defun make-dtd-cache () + (puri:make-uri-space)) + +(defvar *cache-all-dtds* nil) +(defvar *dtd-cache* (make-dtd-cache)) + +(defun remdtd (uri dtd-cache) + (setf uri (puri:intern-uri uri dtd-cache)) + (prog1 + (and (getf (puri:uri-plist uri) 'dtd) t) + (puri:unintern-uri uri dtd-cache))) + +(defun clear-dtd-cache (dtd-cache) + (puri:unintern-uri t dtd-cache)) + +(defun getdtd (uri dtd-cache) + (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd)) + +(defun (setf getdtd) (newval uri dtd-cache) + (setf (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd) newval) + newval) + + +;;;; + +(defun find-element (name dtd) + (gethash name (dtd-elements dtd))) + +(defun define-element (dtd element-name &optional content-model) + (let ((e (find-element element-name dtd))) + (cond + ((null e) + (setf (gethash element-name (dtd-elements dtd)) + (make-elmdef :name element-name :content content-model))) + ((null content-model) + e) + (t + (when *validate* + (when (elmdef-content e) + (validity-error "(05) Unique Element Type Declaration")) + (when (eq content-model :EMPTY) + (dolist (ad (elmdef-attributes e)) + (let ((type (attdef-type ad))) + (when (and (listp type) (eq (car type) :NOTATION)) + (validity-error "(16) No Notation on Empty Element: ~S" + (rod-string element-name))))))) + (sax:element-declaration (handler *ctx*) element-name content-model) + (setf (elmdef-content e) content-model) + (setf (elmdef-external-p e) *external-subset-p*) + e)))) + +(defvar *redefinition-warning* nil) + +(defun define-attribute (dtd element name type default) + (let ((adef (make-attdef :element element + :name name + :type type + :default default)) + (e (or (find-element element dtd) + (define-element dtd element)))) + (when (and *validate* (listp default)) + (unless (eq (attdef-type adef) :CDATA) + (setf (second default) (canon-not-cdata-attval (second default)))) + (validate-attribute* *ctx* adef (second default))) + (cond ((find-attribute e name) + (when *redefinition-warning* + (warn "Attribute \"~A\" of \"~A\" not redefined." + (rod-string name) + (rod-string element)))) + (t + (when *validate* + (when (eq type :ID) + (when (find :ID (elmdef-attributes e) :key #'attdef-type) + (validity-error "(09) One ID per Element Type: element ~A" + (rod-string element))) + (unless (member default '(:REQUIRED :IMPLIED)) + (validity-error "(10) ID Attribute Default: ~A" + (rod-string element)))) + (flet ((notationp (type) + (and (listp type) (eq (car type) :NOTATION)))) + (when (notationp type) + (when (find-if #'notationp (elmdef-attributes e) + :key #'attdef-type) + (validity-error "(15) One Notation Per Element Type: ~S" + (rod-string element))) + (when (eq (elmdef-content e) :EMPTY) + (validity-error "(16) No Notation on Empty Element: ~S" + (rod-string element)))))) + (sax:attribute-declaration (handler *ctx*) element name type default) + (push adef (elmdef-attributes e)))))) + +(defun find-attribute (elmdef name) + (find name (elmdef-attributes elmdef) :key #'attdef-name :test #'rod=)) + +(defun define-notation (dtd name id) + (let ((ns (dtd-notations dtd))) + (when (gethash name ns) + (validity-error "(24) Unique Notation Name: ~S" (rod-string name))) + (setf (gethash name ns) id))) + +(defun find-notation (name dtd) + (gethash name (dtd-notations dtd))) + +;;;; --------------------------------------------------------------------------- +;;;; z streams and lexer +;;;; + +(defstruct zstream + token-category + token-semantic + input-stack) + +(defun read-token (input) + (cond ((zstream-token-category input) + (multiple-value-prog1 + (values (zstream-token-category input) + (zstream-token-semantic input)) + (setf (zstream-token-category input) nil + (zstream-token-semantic input) nil))) + (t + (read-token-2 input)))) + +(defun peek-token (input) + (cond ((zstream-token-category input) + (values + (zstream-token-category input) + (zstream-token-semantic input))) + (t + (multiple-value-bind (c s) (read-token input) + (setf (zstream-token-category input) c + (zstream-token-semantic input) s)) + (values (zstream-token-category input) + (zstream-token-semantic input))))) + +(defun read-token-2 (input) + (cond ((null (zstream-input-stack input)) + (values :eof nil)) + (t + (let ((c (peek-rune (car (zstream-input-stack input))))) + (cond ((eq c :eof) + (cond ((eq (cadr (zstream-input-stack input)) :stop) + (values :eof nil)) + (t + (close-xstream (pop (zstream-input-stack input))) + (if (null (zstream-input-stack input)) + (values :eof nil) + (values :S nil) ;fake #x20 after PE expansion + )))) + (t + (read-token-3 input))))))) + +(defvar *data-behaviour* + ) ;either :DTD or :DOC + +(defun read-token-3 (zinput) + (let ((input (car (zstream-input-stack zinput)))) + ;; PI Comment + (let ((c (read-rune input))) + (cond + ;; first the common tokens + ((rune= #/< c) + (read-token-after-|<| zinput input)) + ;; now dispatch + (t + (ecase *data-behaviour* + (:DTD + (cond ((rune= #/\[ c) :\[) + ((rune= #/\] c) :\]) + ((rune= #/$ c) :\() + ((rune= #/$ c) :\)) + ((rune= #/\| c) :\|) + ((rune= #/\> c) :\>) + ((rune= #/\" c) :\") + ((rune= #/\' c) :\') + ((rune= #/\, c) :\,) + ((rune= #/\? c) :\?) + ((rune= #/\* c) :\*) + ((rune= #/\+ c) :\+) + ((name-rune-p c) + (unread-rune c input) + (values :nmtoken (read-name-token input))) + ((rune= #/# c) + (let ((q (read-name-token input))) + (cond ((rod= q '#.(string-rod "REQUIRED")) :|#REQUIRED|) + ((rod= q '#.(string-rod "IMPLIED")) :|#IMPLIED|) + ((rod= q '#.(string-rod "FIXED")) :|#FIXED|) + ((rod= q '#.(string-rod "PCDATA")) :|#PCDATA|) + (t + (wf-error zinput "Unknown token: ~S." q))))) + ((or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000D) + (rune= c #/U+000A)) + (values :S nil)) + ((rune= #/% c) + (cond ((name-start-rune-p (peek-rune input)) + ;; an entity reference + (read-pe-reference zinput)) + (t + (values :%)))) + (t + (wf-error zinput "Unexpected character ~S." c)))) + (:DOC + (cond + ((rune= c #/&) + (multiple-value-bind (kind data) (read-entity-like input) + (cond ((eq kind :ENTITY-REFERENCE) + (values :ENTITY-REF data)) + ((eq kind :CHARACTER-REFERENCE) + (values :CDATA + (with-rune-collector (collect) + (%put-unicode-char data collect))))))) + (t + (unread-rune c input) + (values :CDATA (read-cdata input))))))))))) + +(definline check-rune (input actual expected) + (unless (eql actual expected) + (wf-error input "expected #/~A but found #/~A" + (rune-char expected) + (rune-char actual)))) + +(defun read-pe-reference (zinput) + (let* ((input (car (zstream-input-stack zinput))) + (nam (read-name-token input))) + (check-rune input #/\; (read-rune input)) + (cond (*expand-pe-p* + ;; no external entities here! + (let ((i2 (entity->xstream zinput nam :parameter))) + (zstream-push i2 zinput)) + (values :S nil) ;space before inserted PE expansion. + ) + (t + (values :PE-REFERENCE nam)) ))) + +(defun read-token-after-|<| (zinput input) + (let ((d (read-rune input))) + (cond ((eq d :eof) + (eox input "EOF after '<'")) + ((rune= #/! d) + (read-token-after-|<!| input)) + ((rune= #/? d) + (multiple-value-bind (target content) (read-pi input) + (cond ((rod= target '#.(string-rod "xml")) + (values :xml-decl (cons target content))) + ((rod-equal target '#.(string-rod "XML")) + (wf-error zinput + "You lost -- no XML processing instructions.")) + ((and sax:*namespace-processing* (position #/: target)) + (wf-error zinput + "Processing instruction target ~S is not a ~ + valid NcName." + (mu target))) + (t + (values :PI (cons target content)))))) + ((rune= #// d) + (let ((c (peek-rune input))) + (cond ((name-start-rune-p c) + (read-tag-2 zinput input :etag)) + (t + (wf-error zinput + "Expecting name start rune after \"</\"."))))) + ((name-start-rune-p d) + (unread-rune d input) + (read-tag-2 zinput input :stag)) + (t + (wf-error zinput "Expected '!' or '?' after '<' in DTD."))))) + +(defun read-token-after-|<!| (input) + (let ((d (read-rune input))) + (cond ((eq d :eof) + (eox input "EOF after \"<!\".")) + ((name-start-rune-p d) + (unread-rune d input) + (let ((name (read-name-token input))) + (cond ((rod= name '#.(string-rod "ELEMENT")) :|<!ELEMENT|) + ((rod= name '#.(string-rod "ENTITY")) :|<!ENTITY|) + ((rod= name '#.(string-rod "ATTLIST")) :|<!ATTLIST|) + ((rod= name '#.(string-rod "NOTATION")) :|<!NOTATION|) + ((rod= name '#.(string-rod "DOCTYPE")) :|<!DOCTYPE|) + (t + (wf-error input"`<!~A' unknown." (rod-string name)))))) + ((rune= #/\[ d) + (values :|<![| nil)) + ((rune= #/- d) + (setf d (read-rune input)) + (cond ((rune= #/- d) + (values + :COMMENT + (read-comment-content input))) + (t + (wf-error input"Bad character ~S after \"<!-\"" d)))) + (t + (wf-error input "Bad character ~S after \"<!\"" d))))) + +(definline read-S? (input) + (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) + :test #'eql) + (consume-rune input))) + +(defun read-attribute-list (zinput input imagine-space-p) + (cond ((or imagine-space-p + (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (space-rune-p c)))) + (read-S? input) + (cond ((eq (peek-rune input) :eof) + nil) + ((name-start-rune-p (peek-rune input)) + (cons (read-attribute zinput input) + (read-attribute-list zinput input nil))) + (t + nil))) + (t + nil))) + +(defun read-entity-like (input) + "Read an entity reference off the xstream `input'. Returns two values: + either :ENTITY-REFERENCE <interned-rod> in case of a named entity + or :CHARACTER-REFERENCE <integer> in case of character references. + The initial #\\& is considered to be consumed already." + (let ((c (peek-rune input))) + (cond ((eq c :eof) + (eox input "EOF after '&'")) + ((rune= c #/#) + (values :CHARACTER-REFERENCE (read-character-reference input))) + (t + (unless (name-start-rune-p (peek-rune input)) + (wf-error input "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (unless (rune= c #/\;) + (wf-error input "Expected \";\".")) + (values :ENTITY-REFERENCE name)))))) + +(defun read-tag-2 (zinput input kind) + (let ((name (read-name-token input)) + (atts nil)) + (setf atts (read-attribute-list zinput input nil)) + + ;; check for double attributes + (do ((q atts (cdr q))) + ((null q)) + (cond ((find (caar q) (cdr q) :key #'car) + (wf-error zinput "Attribute ~S has two definitions in element ~S." + (rod-string (caar q)) + (rod-string name))))) + + (cond ((eq (peek-rune input) #/>) + (consume-rune input) + (values kind (cons name atts))) + ((eq (peek-rune input) #//) + (consume-rune input) + (check-rune input #/> (read-rune input)) + (values :ztag (cons name atts))) + (t + (wf-error zinput "syntax error in read-tag-2.")) ))) + +(defun read-attribute (zinput input) + (unless (name-start-rune-p (peek-rune input)) + (wf-error zinput "Expected name.")) + ;; arg thanks to the post mortem nature of name space declarations, + ;; we could only process the attribute values post mortem. + (let ((name (read-name-token input))) + (while (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000A) + (rune= c #/U+000D)))) + (consume-rune input)) + (unless (eq (read-rune input) #/=) + (wf-error zinput "Expected \"=\".")) + (while (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000A) + (rune= c #/U+000D)))) + (consume-rune input)) + (cons name (read-att-value-2 input)))) + +(defun canon-not-cdata-attval (value) + ;; | If the declared value is not CDATA, then the XML processor must + ;; | further process the normalized attribute value by discarding any + ;; | leading and trailing space (#x20) characters, and by replacing + ;; | sequences of space (#x20) characters by a single space (#x20) + ;; | character. + (with-rune-collector (collect) + (let ((gimme-20 nil) + (anything-seen-p nil)) + (map nil (lambda (c) + (cond ((rune= c #/u+0020) + (setf gimme-20 t)) + (t + (when (and anything-seen-p gimme-20) + (collect #/u+0020)) + (setf gimme-20 nil) + (setf anything-seen-p t) + (collect c)))) + value)))) + +(definline data-rune-p (rune) + ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. + ;; + ;; FIXME: das halte ich fuer verkehrt. Surrogates als Unicode-Zeichen + ;; sind verboten. Das liegt hier aber nicht vor, denn wir arbeiten + ;; ja tatsaechlich mit UTF-16. Verboten ist es nur, wenn wir ein + ;; solches Zeichen beim Dekodieren finden, das wird aber eben + ;; in encodings.lisp bereits geprueft. --david + (let ((c (rune-code rune))) + (or (= c #x9) (= c #xA) (= c #xD) + (<= #x20 c #xD7FF) + (<= #xE000 c #xFFFD) + (<= #xD800 c #xDBFF) + (<= #xDC00 c #xDFFF)))) + +(defun read-att-value (zinput input mode &optional canon-space-p (delim nil)) + (with-rune-collector-2 (collect) + (labels ((muffle (input delim) + (let (c) + (loop + (setf c (read-rune input)) + (cond ((eql delim c) + (return)) + ((eq c :eof) + (eox input "EOF")) + ((rune= c #/&) + (setf c (peek-rune input)) + (cond ((eql c :eof) + (eox input)) + ((rune= c #/#) + (let ((c (read-character-reference input))) + (%put-unicode-char c collect))) + (t + (unless (name-start-rune-p (peek-rune input)) + (wf-error zinput "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (ecase mode + (:ATT + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput)) + :eof)) + t)) + (:ENT + ;; bypass, but never the less we + ;; need to check for legal + ;; syntax. + ;; Must it be defined? + ;; allerdings: unparsed sind verboten + (collect #/&) + (map nil (lambda (x) (collect x)) name) + (collect #/\; ))))))) + ((and (eq mode :ENT) (rune= c #/%)) + (let ((d (peek-rune input))) + (when (eq d :eof) + (eox input)) + (unless (name-start-rune-p d) + (wf-error zinput "Expecting name after %."))) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (cond (*expand-pe-p* + (recurse-on-entity + zinput name :parameter + (lambda (zinput) + (muffle (car (zstream-input-stack zinput)) + :eof)))) + (t + (wf-error zinput "No PE here."))))) + ((and (eq mode :ATT) (rune= c #/<)) + (wf-error zinput "unexpected #\/<")) + ((and canon-space-p (space-rune-p c)) + (collect #/space)) + ((not (data-rune-p c)) + (wf-error zinput "illegal char: ~S." c)) + (t + (collect c))))))) + (declare (dynamic-extent #'muffle)) + (muffle input (or delim + (let ((delim (read-rune input))) + (unless (member delim '(#/\" #/\') :test #'eql) + (wf-error zinput "invalid attribute delimiter")) + delim)))))) + +(defun read-character-reference (input) + ;; The #/& is already read + (let ((res + (let ((c (read-rune input))) + (check-rune input c #/#) + (setq c (read-rune input)) + (cond ((eql c :eof) + (eox input)) + ((eql c #/x) + ;; hexadecimal + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (unless (digit-rune-p c 16) + (wf-error input "garbage in character reference")) + (prog1 + (parse-integer + (with-output-to-string (sink) + (write-char (rune-char c) sink) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (digit-rune-p c 16)) + (write-char (rune-char c) sink))) + :radix 16) + (check-rune input c #/\;))) + ((rune<= #/0 c #/9) + ;; decimal + (prog1 + (parse-integer + (with-output-to-string (sink) + (write-char (rune-char c) sink) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (rune<= #/0 c #/9)) + (write-char (rune-char c) sink))) + :radix 10) + (check-rune input c #/\;))) + (t + (wf-error input "Bad char in numeric character entity.")))))) + (unless (code-data-char-p res) + (wf-error + input + "expansion of numeric character reference (#x~X) is no data char." + res)) + res)) + +(defun read-pi (input) + ;; "<?" is already read + (let (name) + (let ((c (peek-rune input))) + (unless (name-start-rune-p c) + (wf-error input "Expecting name after '<?'")) + (setf name (read-name-token input))) + (cond + ((member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) + :test #'eql) + (values name (read-pi-content input))) + (t + (unless (and (eql (read-rune input) #/?) + (eql (read-rune input) #/>)) + (wf-error input "malformed processing instruction")) + (values name ""))))) + +(defun read-pi-content (input) + (read-S? input) + (let (d) + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/?) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/? seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (when (rune= d #/?) + (collect #/?) + (go state-2)) + (collect #/?) + (collect d) + (go state-1)))))) + +(defun read-comment-content (input &aux d) + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-3)) + (collect #/-) + (collect d) + (go state-1) + state-3 ;; #/- #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (wf-error input "'--' not allowed in a comment") + (when (rune= d #/-) + (collect #/-) + (go state-3)) + (collect #/-) + (collect #/-) + (collect d) + (go state-1))))) + +(defun read-cdata-sect (input &aux d) + ;; <![CDATA[ is already read + ;; read anything up to ]]> + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/\]) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/] seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/\]) (go state-3)) + (collect #/\]) + (collect d) + (go state-1) + state-3 ;; #/\] #/\] seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) + (return)) + (when (rune= d #/\]) + (collect #/\]) + (go state-3)) + (collect #/\]) + (collect #/\]) + (collect d) + (go state-1))))) + +;; some character categories + +(defun space-rune-p (rune) + (declare (type rune rune)) + (or (rune= rune #/U+0020) + (rune= rune #/U+0009) + (rune= rune #/U+000A) + (rune= rune #/U+000D))) + +(defun code-data-char-p (c) + ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. + (or (= c #x9) (= c #xA) (= c #xD) + (<= #x20 c #xD7FF) + (<= #xE000 c #xFFFD) + (<= #x10000 c #x10FFFF))) + +(defun pubid-char-p (c) + (or (rune= c #/u+0020) (rune= c #/u+000D) (rune= c #/u+000A) + (rune<= #/a c #/z) + (rune<= #/A c #/Z) + (rune<= #/0 c #/9) + (member c '(#/- #/' #/$ #/$ #/+ #/, #/. #// + #/: #/= #/? #/\; #/! #/* #/# + #/@ #/$ #/_ #/%)))) + + +(defun expect (input category) + (multiple-value-bind (cat sem) (read-token input) + (unless (eq cat category) + (wf-error input "Expected ~S saw ~S [~S]" category cat sem)) + (values cat sem))) + +(defun consume-token (input) + (read-token input)) + +;;;; --------------------------------------------------------------------------- +;;;; Parser +;;;; + +(defun p/S (input) + ;; S ::= (#x20 | #x9 | #xD | #xA)+ + (expect input :S) + (while (eq (peek-token input) :S) + (consume-token input))) + +(defun p/S? (input) + ;; S ::= (#x20 | #x9 | #xD | #xA)+ + (while (eq (peek-token input) :S) + (consume-token input))) + +(defun p/nmtoken (input) + (nth-value 1 (expect input :nmtoken))) + +(defun p/name (input) + (let ((result (p/nmtoken input))) + (unless (name-start-rune-p (elt result 0)) + (wf-error input "Expected name.")) + result)) + +(defun p/attlist-decl (input) + ;; [52] AttlistDecl ::= '<!ATTLIST' S Name (S AttDef)* S? '>' + (let (elm-name) + (expect input :|<!ATTLIST|) + (p/S input) + (setf elm-name (p/nmtoken input)) + (loop + (let ((tok (read-token input))) + (case tok + (:S + (p/S? input) + (cond ((eq (peek-token input) :>) + (consume-token input) + (return)) + (t + (multiple-value-bind (name type default) (p/attdef input) + (define-attribute (dtd *ctx*) elm-name name type default)) ))) + (:> + (return)) + (otherwise + (wf-error input + "Expected either another AttDef or end of \"<!ATTLIST\". -- saw ~S." + tok))))))) + +(defun p/attdef (input) + ;; [53] AttDef ::= Name S AttType S DefaultDecl + (let (name type default) + (setf name (p/nmtoken input)) + (p/S input) + (setf type (p/att-type input)) + (p/S input) + (setf default (p/default-decl input)) + (values name type default))) + +(defun p/list (input item-parser delimiter) + ;; Parse something like S? <item> (S? <delimiter> <item>)* S? + ;; + (declare (type function item-parser)) + (let (res) + (p/S? input) + (setf res (list (funcall item-parser input))) + (loop + (p/S? input) + (cond ((eq (peek-token input) delimiter) + (consume-token input) + (p/S? input) + (push (funcall item-parser input) res)) + (t + (return)))) + (p/S? input) + (reverse res))) + +(defun p/att-type (input) + ;; [54] AttType ::= StringType | TokenizedType | EnumeratedType + ;; [55] StringType ::= 'CDATA' + ;; [56] TokenizedType ::= 'ID' /*VC: ID */ + ;; /*VC: One ID per Element Type */ + ;; /*VC: ID Attribute Default */ + ;; | 'IDREF' /*VC: IDREF */ + ;; | 'IDREFS' /*VC: IDREF */ + ;; | 'ENTITY' /*VC: Entity Name */ + ;; | 'ENTITIES' /*VC: Entity Name */ + ;; | 'NMTOKEN' /*VC: Name Token */ + ;; | 'NMTOKENS' /*VC: Name Token */ + ;; [57] EnumeratedType ::= NotationType | Enumeration + ;; [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' + ;; /* VC: Notation Attributes */ + ;; [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' /* VC: Enumeration */ + (multiple-value-bind (cat sem) (read-token input) + (cond ((eq cat :nmtoken) + (cond ((rod= sem '#.(string-rod "CDATA")) :CDATA) + ((rod= sem '#.(string-rod "ID")) :ID) + ((rod= sem '#.(string-rod "IDREF")) :IDREFS) + ((rod= sem '#.(string-rod "IDREFS")) :IDREFS) + ((rod= sem '#.(string-rod "ENTITY")) :ENTITY) + ((rod= sem '#.(string-rod "ENTITIES")) :ENTITIES) + ((rod= sem '#.(string-rod "NMTOKEN")) :NMTOKEN) + ((rod= sem '#.(string-rod "NMTOKENS")) :NMTOKENS) + ((rod= sem '#.(string-rod "NOTATION")) + (let (names) + (p/S input) + (expect input :$) + (setf names (p/list input #'p/nmtoken :\| )) + (expect input :$) + (when *validate* + (setf (referenced-notations *ctx*) + (append names (referenced-notations *ctx*)))) + (cons :NOTATION names))) + (t + (wf-error input "In p/att-type: ~S ~S." cat sem)))) + ((eq cat :$) + ;; XXX Die Nmtoken-Syntax pruefen wir derzeit nur beim Validieren. + (let (names) + ;;(expect input :\() + (setf names (p/list input #'p/nmtoken :\| )) + (expect input :$) + (cons :ENUMERATION names))) + (t + (wf-error input "In p/att-type: ~S ~S." cat sem)) ))) + +(defun p/default-decl (input) + ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' + ;; | (('#FIXED' S)? AttValue) /* VC: Required Attribute */ + ;; + ;; /* VC: Attribute Default Legal */ + ;; /* WFC: No < in Attribute Values */ + ;; /* VC: Fixed Attribute Default */ + (multiple-value-bind (cat sem) (peek-token input) + (cond ((eq cat :|#REQUIRED|) + (consume-token input) :REQUIRED) + ((eq cat :|#IMPLIED|) + (consume-token input) :IMPLIED) + ((eq cat :|#FIXED|) + (consume-token input) + (p/S input) + (list :FIXED (p/att-value input))) + ((or (eq cat :\') (eq cat :\")) + (list :DEFAULT (p/att-value input))) + (t + (wf-error input "p/default-decl: ~S ~S." cat sem)) ))) +;;;; + +;; [70] EntityDecl ::= GEDecl | PEDecl +;; [71] GEDecl ::= '<!ENTITY' S Name S EntityDef S? '>' +;; [72] PEDecl ::= '<!ENTITY' S '%' S Name S PEDef S? '>' +;; [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) +;; [74] PEDef ::= EntityValue | ExternalID +;; [75] ExternalID ::= 'SYSTEM' S SystemLiteral +;; | 'PUBLIC' S PubidLiteral S SystemLiteral +;; [76] NDataDecl ::= S 'NDATA' S Name /* VC: Notation Declared */ + +(defun p/entity-decl (input) + (let (name def kind) + (expect input :|<!ENTITY|) + (p/S input) + (cond ((eq (peek-token input) :%) + (setf kind :parameter) + (consume-token input) + (p/S input)) + (t + (setf kind :general))) + (setf name (p/name input)) + (p/S input) + (setf def (p/entity-def input kind)) + (define-entity input name kind def) + (p/S? input) + (expect input :\>))) + +(defun report-entity (h kind name def) + (etypecase def + (external-entdef + (let ((extid (entdef-extid def)) + (ndata (entdef-ndata def))) + (if ndata + (sax:unparsed-entity-declaration h + name + (extid-public extid) + (uri-rod (extid-system extid)) + ndata) + (sax:external-entity-declaration h + kind + name + (extid-public extid) + (uri-rod (extid-system extid)))))) + (internal-entdef + (sax:internal-entity-declaration h kind name (entdef-value def))))) + +(defun p/entity-def (input kind) + (multiple-value-bind (cat sem) (peek-token input) + (cond ((member cat '(:\" :\')) + (make-internal-entdef (p/entity-value input))) + ((and (eq cat :nmtoken) + (or (rod= sem '#.(string-rod "SYSTEM")) + (rod= sem '#.(string-rod "PUBLIC")))) + (let (extid ndata) + (setf extid (p/external-id input nil)) + (when (eq kind :general) ;NDATA allowed at all? + (cond ((eq (peek-token input) :S) + (p/S? input) + (when (and (eq (peek-token input) :nmtoken) + (rod= (nth-value 1 (peek-token input)) + '#.(string-rod "NDATA"))) + (consume-token input) + (p/S input) + (setf ndata (p/nmtoken input)) + (when *validate* + (push ndata (referenced-notations *ctx*))))))) + (make-external-entdef extid ndata))) + (t + (wf-error input "p/entity-def: ~S / ~S." cat sem)) ))) + +(defun p/entity-value (input) + (let ((delim (if (eq (read-token input) :\") #/\" #/\'))) + (read-att-value input + (car (zstream-input-stack input)) + :ENT + nil + delim))) + +(defun p/att-value (input) + (let ((delim (if (eq (read-token input) :\") #/\" #/\'))) + (read-att-value input + (car (zstream-input-stack input)) + :ATT + t + delim))) + +(defun p/external-id (input &optional (public-only-ok-p nil)) + ;; xxx public-only-ok-p + (multiple-value-bind (cat sem) (read-token input) + (cond ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "SYSTEM"))) + (p/S input) + (make-extid nil (p/system-literal input))) + ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "PUBLIC"))) + (let (pub sys) + (p/S input) + (setf pub (p/pubid-literal input)) + (when (eq (peek-token input) :S) + (p/S input) + (when (member (peek-token input) '(:\" :\')) + (setf sys (p/system-literal input)))) + (when (and (not public-only-ok-p) + (null sys)) + (wf-error input "System identifier needed for this PUBLIC external identifier.")) + (make-extid pub sys))) + (t + (wf-error input "Expected external-id: ~S / ~S." cat sem))))) + + +;; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") +;; [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" +;; [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] +;; | [-'()+,./:=?;!*#@$_%] + +(defun p/id (input) + (multiple-value-bind (cat) (read-token input) + (cond ((member cat '(:\" :\')) + (let ((delim (if (eq cat :\") #/\" #/\'))) + (with-rune-collector (collect) + (loop + (let ((c (read-rune (car (zstream-input-stack input))))) + (cond ((eq c :eof) + (eox input "EOF in system literal.")) + ((rune= c delim) + (return)) + (t + (collect c)))))))) + (t + (wf-error input "Expect either \" or \'."))))) + +;; it is important to cache the orginal URI rod, since the re-serialized +;; uri-string can be different from the one parsed originally. +(defun uri-rod (uri) + (if uri + (or (getf (puri:uri-plist uri) 'original-rod) + (rod (puri:render-uri uri nil))) + nil)) + +(defun safe-parse-uri (str) + ;; puri doesn't like strings starting with file:///, although that is a very + ;; common is practise. Cut it away, we don't distinguish between scheme + ;; :FILE and NIL anway. + (when (eql (search "file://" str) 0) + (setf str (subseq str (length "file://")))) + (puri:parse-uri (coerce str 'simple-string))) + +(defun p/system-literal (input) + (let* ((rod (p/id input)) + (result (safe-parse-uri (rod-string rod)))) + (setf (getf (puri:uri-plist result) 'original-rod) rod) + result)) + +(defun p/pubid-literal (input) + (let ((result (p/id input))) + (unless (every #'pubid-char-p result) + (wf-error input "Illegal pubid: ~S." (rod-string result))) + result)) + + +;;;; + +(defun p/element-decl (input) + (let (name content) + (expect input :|<!ELEMENT|) + (p/S input) + (setf name (p/nmtoken input)) + (p/S input) + (setf content (normalize-mixed-cspec (p/cspec input))) + (unless (legal-content-model-p content *validate*) + (wf-error input "Malformed or invalid content model: ~S." (mu content))) + (p/S? input) + (expect input :\>) + (when *validate* + (define-element (dtd *ctx*) name content)) + (list :element name content))) + +(defun maybe-compile-cspec (e) + (or (elmdef-compiled-cspec e) + (setf (elmdef-compiled-cspec e) + (let ((cspec (elmdef-content e))) + (unless cspec + (validity-error "(03) Element Valid: no definition for ~A" + (rod-string (elmdef-name e)))) + (multiple-value-call #'cons + (compile-cspec cspec (standalone-check-necessary-p e))))))) + +(defun make-root-model (name) + (cons (lambda (actual-name) + (if (rod= actual-name name) + (constantly :dummy) + nil)) + (constantly t))) + +;;; content spec validation: +;;; +;;; Given a `contentspec', COMPILE-CSPEC returns as multiple values two +;;; functions A and B of one argument to be called for every +;;; A. child element +;;; B. text child node +;;; +;;; Function A will be called with +;;; - the element name rod as its argument. If that element may appear +;;; at the current position, a new function to be called for the next +;;; child is returned. Otherwise NIL is returned. +;;; - argument NIL at the end of the element, it must then return T or NIL +;;; to indicate whether the end tag is valid. +;;; +;;; Function B will be called with the character data rod as its argument, it +;;; returns a boolean indicating whether this text node is allowed. +;;; +;;; That is, if one of the functions ever returns NIL, the node is +;;; rejected as invalid. + +(defun cmodel-done (actual-value) + (null actual-value)) + +(defun compile-cspec (cspec &optional standalone-check) + (cond + ((atom cspec) + (ecase cspec + (:EMPTY (values #'cmodel-done (constantly nil))) + (:PCDATA (values #'cmodel-done (constantly t))) + (:ANY + (values (labels ((doit (name) (if name #'doit t))) #'doit) + (constantly t))))) + ((and (eq (car cspec) '*) + (let ((subspec (second cspec))) + (and (eq (car subspec) 'or) (eq (cadr subspec) :PCDATA)))) + (values (compile-mixed (second cspec)) + (constantly t))) + (t + (values (compile-content-model cspec) + (lambda (rod) + (when standalone-check + (validity-error "(02) Standalone Document Declaration: whitespace")) + (every #'white-space-rune-p rod)))))) + +(defun compile-mixed (cspec) + ;; das koennten wir theoretisch auch COMPILE-CONTENT-MODEL erledigen lassen + (let ((allowed-names (cddr cspec))) + (labels ((doit (actual-name) + (cond + ((null actual-name) t) + ((member actual-name allowed-names :test #'rod=) #'doit) + (t nil)))) + #'doit))) + +(defun compile-content-model (cspec &optional (continuation #'cmodel-done)) + (if (vectorp cspec) + (lambda (actual-name) + (if (and actual-name (rod= cspec actual-name)) + continuation + nil)) + (ecase (car cspec) + (and + (labels ((traverse (seq) + (compile-content-model (car seq) + (if (cdr seq) + (traverse (cdr seq)) + continuation)))) + (traverse (cdr cspec)))) + (or + (let ((options (mapcar (rcurry #'compile-content-model continuation) + (cdr cspec)))) + (lambda (actual-name) + (some (rcurry #'funcall actual-name) options)))) + (? + (let ((maybe (compile-content-model (second cspec) continuation))) + (lambda (actual-name) + (or (funcall maybe actual-name) + (funcall continuation actual-name))))) + (* + (let (maybe-continuation) + (labels ((recurse (actual-name) + (if (null actual-name) + (funcall continuation actual-name) + (or (funcall maybe-continuation actual-name) + (funcall continuation actual-name))))) + (setf maybe-continuation + (compile-content-model (second cspec) #'recurse)) + #'recurse))) + (+ + (let ((it (cadr cspec))) + (compile-content-model `(and ,it (* ,it)) continuation)))))) + +(defun setp (list &key (test 'eql)) + (equal list (remove-duplicates list :test test))) + +(defun legal-content-model-p (cspec &optional validate) + (or (eq cspec :PCDATA) + (eq cspec :ANY) + (eq cspec :EMPTY) + (and (consp cspec) + (eq (car cspec) '*) + (consp (cadr cspec)) + (eq (car (cadr cspec)) 'or) + (eq (cadr (cadr cspec)) :PCDATA) + (every #'vectorp (cddr (cadr cspec))) + (if (and validate (not (setp (cddr (cadr cspec)) :test #'rod=))) + (validity-error "VC: No Duplicate Types (07)") + t)) + (labels ((walk (x) + (cond ((member x '(:PCDATA :ANY :EMPTY)) + nil) + ((atom x) t) + ((and (walk (car x)) + (walk (cdr x))))))) + (walk cspec)))) + +;; wir fahren besser, wenn wir machen: + +;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' +;; | Name +;; | cs +;; cs ::= '(' S? cspec ( S? '|' S? cspec)* S? ')' ('?' | '*' | '+')? +;; und eine post factum analyse + +(defun p/cspec (input &optional recursivep) + (let ((term + (let ((names nil) op-cat op res stream) + (multiple-value-bind (cat sem) (peek-token input) + (cond ((eq cat :nmtoken) + (consume-token input) + (cond ((rod= sem '#.(string-rod "EMPTY")) + :EMPTY) + ((rod= sem '#.(string-rod "ANY")) + :ANY) + ((not recursivep) + (wf-error input "invalid content spec")) + (t + sem))) + ((eq cat :\#PCDATA) + (consume-token input) + :PCDATA) + ((eq cat :$) + (setf stream (car (zstream-input-stack input))) + (consume-token input) + (p/S? input) + (setq names (list (p/cspec input t))) + (p/S? input) + (cond ((member (peek-token input) '(:\| :\,)) + (setf op-cat (peek-token input)) + (setf op (if (eq op-cat :\,) 'and 'or)) + (while (eq (peek-token input) op-cat) + (consume-token input) + (p/S? input) + (push (p/cspec input t) names) + (p/S? input)) + (setf res (cons op (reverse names)))) + (t + (setf res (cons 'and names)))) + (p/S? input) + (expect input :$) + (when *validate* + (unless (eq stream (car (zstream-input-stack input))) + (validity-error "(06) Proper Group/PE Nesting"))) + res) + (t + (wf-error input "p/cspec - ~s / ~s" cat sem))))))) + (cond ((eq (peek-token input) :?) (consume-token input) (list '? term)) + ((eq (peek-token input) :+) (consume-token input) (list '+ term)) + ((eq (peek-token input) :*) (consume-token input) (list '* term)) + (t + term)))) + +(defun normalize-mixed-cspec (cspec) + ;; der Parser oben funktioniert huebsch fuer die children-Regel, aber + ;; fuer Mixed ist das Ergebnis nicht praktisch, denn dort wollen wir + ;; eigentlich auf eine Liste von Namen in einheitlichem Format hinaus. + ;; Dazu normalisieren wir einfach in eine der beiden folgenden Formen: + ;; (* (or :PCDATA ...rods...)) -- und zwar exakt so! + ;; :PCDATA -- sonst ganz trivial + (flet ((trivialp (c) + (and (consp c) + (and (eq (car c) 'and) + (eq (cadr c) :PCDATA) + (null (cddr c)))))) + (if (or (trivialp cspec) ;(and PCDATA) + (and (consp cspec) ;(* (and PCDATA)) + (and (eq (car cspec) '*) + (null (cddr cspec)) + (trivialp (cadr cspec))))) + :PCDATA + cspec))) + +;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>' + + +;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDefs S? '>' +;; [52] AttlistDecl ::= '<!ATTLIST' S Name S? '>' +;; [53] AttDefs ::= S Name S AttType S DefaultDecl AttDefs +;; [53] AttDefs ::= + +(defun p/notation-decl (input) + (let (name id) + (expect input :|<!NOTATION|) + (p/S input) + (setf name (p/name input)) + (p/S input) + (setf id (p/external-id input t)) + (p/S? input) + (expect input :\>) + (sax:notation-declaration (handler *ctx*) + name + (if (extid-public id) + (normalize-public-id (extid-public id)) + nil) + (uri-rod (extid-system id))) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error input "colon in notation name")) + (when *validate* + (define-notation (dtd *ctx*) name id)) + (list :notation-decl name id))) + +(defun normalize-public-id (rod) + (with-rune-collector (collect) + (let ((gimme-20 nil) + (anything-seen-p nil)) + (map nil (lambda (c) + (cond + ((or (rune= c #/u+0009) + (rune= c #/u+000A) + (rune= c #/u+000D) + (rune= c #/u+0020)) + (setf gimme-20 t)) + (t + (when (and anything-seen-p gimme-20) + (collect #/u+0020)) + (setf gimme-20 nil) + (setf anything-seen-p t) + (collect c)))) + rod)))) + +;;; + +(defun p/conditional-sect (input) + (expect input :<!\[ ) + (let ((stream (car (zstream-input-stack input)))) + (p/S? input) + (multiple-value-bind (cat sem) (read-token input) + (cond ((and (eq cat :nmtoken) + (rod= sem '#.(string-rod "INCLUDE"))) + (p/include-sect input stream)) + ((and (eq cat :nmtoken) + (rod= sem '#.(string-rod "IGNORE"))) + (p/ignore-sect input stream)) + (t + (wf-error input "Expected INCLUDE or IGNORE after \"<![\".")))))) + +(defun p/cond-expect (input cat initial-stream) + (expect input cat) + (when *validate* + (unless (eq (car (zstream-input-stack input)) initial-stream) + (validity-error "(21) Proper Conditional Section/PE Nesting")))) + +(defun p/include-sect (input initial-stream) + ;; <![INCLUDE is already read. + (p/S? input) + (p/cond-expect input :\[ initial-stream) + (p/ext-subset-decl input) + (p/cond-expect input :\] initial-stream) + (p/cond-expect input :\] initial-stream) + (p/cond-expect input :\> initial-stream)) + +(defun p/ignore-sect (input initial-stream) + ;; <![IGNORE is already read. + ;; XXX Is VC 21 being checked for nested sections? + (p/S? input) + (p/cond-expect input :\[ initial-stream) + (let ((input (car (zstream-input-stack input)))) + (let ((level 0)) + (do ((c1 (read-rune input) (read-rune input)) + (c2 #/U+0000 c1) + (c3 #/U+0000 c2)) + ((= level -1)) + (declare (type fixnum level)) + (cond ((eq c1 :eof) + (eox input "EOF in <![IGNORE ... >"))) + (cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[)) + (incf level))) + (cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>)) + (decf level))) ))) + (unless (eq (car (zstream-input-stack input)) initial-stream) + (validity-error "(21) Proper Conditional Section/PE Nesting"))) + +(defun p/ext-subset-decl (input) + ;; ( markupdecl | conditionalSect | S )* + (loop + (case (let ((*expand-pe-p* nil)) (peek-token input)) + (:|<![| (let ((*expand-pe-p* t)) (p/conditional-sect input))) + (:S (consume-token input)) + (:eof (return)) + ((:|<!ELEMENT| :|<!ATTLIST| :|<!ENTITY| :|<!NOTATION| :PI :COMMENT) + (let ((*expand-pe-p* t) + (*external-subset-p* t)) + (p/markup-decl input))) + ((:PE-REFERENCE) + (let ((name (nth-value 1 (read-token input)))) + (recurse-on-entity input name :parameter + (lambda (input) + (etypecase (checked-get-entdef name :parameter) + (external-entdef + (p/ext-subset input)) + (internal-entdef + (p/ext-subset-decl input))) + (unless (eq :eof (peek-token input)) + (wf-error input "Trailing garbage.")))))) + (otherwise (return)))) ) + +(defun p/markup-decl (input) + (peek-token input) + (let ((stream (car (zstream-input-stack input)))) + (multiple-value-prog1 + (p/markup-decl-unsafe input) + (when *validate* + (unless (eq stream (car (zstream-input-stack input))) + (validity-error "(01) Proper Declaration/PE Nesting")))))) + +(defun p/markup-decl-unsafe (input) + ;; markupdecl ::= elementdecl | AttlistDecl /* VC: Proper Declaration/PE Nesting */ + ;; | EntityDecl | NotationDecl + ;; | PI | Comment /* WFC: PEs in Internal Subset */ + (let ((token (peek-token input)) + (*expand-pe-p* (and *expand-pe-p* *external-subset-p*))) + (case token + (:|<!ELEMENT| (p/element-decl input)) + (:|<!ATTLIST| (p/attlist-decl input)) + (:|<!ENTITY| (p/entity-decl input)) + (:|<!NOTATION| (p/notation-decl input)) + (:PI + (let ((sem (nth-value 1 (read-token input)))) + (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)))) + (:COMMENT (consume-token input)) + (otherwise + (wf-error input "p/markup-decl ~S" (peek-token input)))))) + +(defun setup-encoding (input xml-header) + (when (xml-header-encoding xml-header) + (let ((enc (find-encoding (xml-header-encoding xml-header)))) + (cond (enc + (setf (xstream-encoding (car (zstream-input-stack input))) + enc)) + (t + (warn "There is no such encoding: ~S." (xml-header-encoding xml-header))))))) + +(defun set-full-speed (input) + (let ((xstream (car (zstream-input-stack input)))) + (when xstream + (set-to-full-speed xstream)))) + +(defun p/ext-subset (input) + (cond ((eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) + (setup-encoding input hd)) + (consume-token input))) + (set-full-speed input) + (p/ext-subset-decl input) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage - ~S." (peek-token input)))) + +(defvar *catalog* nil) + +(defun extid-using-catalog (extid) + (if *catalog* + (let ((sysid + (resolve-extid (extid-public extid) + (extid-system extid) + *catalog*))) + (if sysid + (make-extid nil sysid) + extid)) + extid)) + +(defun p/doctype-decl (input &optional dtd-extid) + (let () + (let ((*expand-pe-p* nil) + name extid) + (expect input :|<!DOCTYPE|) + (p/S input) + (setq name (p/nmtoken input)) + (when *validate* + (setf (model-stack *ctx*) (list (make-root-model name)))) + (when (eq (peek-token input) :S) + (p/S input) + (unless (or (eq (peek-token input) :\[ ) + (eq (peek-token input) :\> )) + (setf extid (p/external-id input t)))) + (when dtd-extid + (setf extid dtd-extid)) + (p/S? input) + (sax:start-dtd (handler *ctx*) + name + (and extid (extid-public extid)) + (and extid (uri-rod (extid-system extid)))) + (when (eq (peek-token input) :\[ ) + (when (disallow-internal-subset *ctx*) + (wf-error input "document includes an internal subset")) + (ensure-dtd) + (consume-token input) + (sax:start-internal-subset (handler *ctx*)) + (while (progn (p/S? input) + (not (eq (peek-token input) :\] ))) + (if (eq (peek-token input) :PE-REFERENCE) + (let ((name (nth-value 1 (read-token input)))) + (recurse-on-entity input name :parameter + (lambda (input) + (etypecase (checked-get-entdef name :parameter) + (external-entdef + (p/ext-subset input)) + (internal-entdef + (p/ext-subset-decl input))) + (unless (eq :eof (peek-token input)) + (wf-error input "Trailing garbage."))))) + (let ((*expand-pe-p* t)) + (p/markup-decl input)))) + (consume-token input) + (sax:end-internal-subset (handler *ctx*)) + (p/S? input)) + (expect input :>) + (when extid + (let* ((effective-extid + (extid-using-catalog (absolute-extid input extid))) + (sysid (extid-system effective-extid)) + (fresh-dtd-p (null (dtd *ctx*))) + (cached-dtd + (and fresh-dtd-p + (not (standalone-p *ctx*)) + (getdtd sysid *dtd-cache*)))) + (cond + (cached-dtd + (setf (dtd *ctx*) cached-dtd) + (report-cached-dtd cached-dtd)) + (t + (let* ((xi2 (xstream-open-extid effective-extid)) + (zi2 (make-zstream :input-stack (list xi2)))) + (ensure-dtd) + (p/ext-subset zi2) + (when (and fresh-dtd-p + *cache-all-dtds* + *validate* + (not (standalone-p *ctx*))) + (setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))))))) + (sax:end-dtd (handler *ctx*)) + (let ((dtd (dtd *ctx*))) + (sax:entity-resolver + (handler *ctx*) + (lambda (name handler) (resolve-entity name handler dtd))) + (sax::dtd (handler *ctx*) dtd)) + (list :DOCTYPE name extid)))) + +(defun report-cached-dtd (dtd) + (maphash (lambda (k v) + (report-entity (handler *ctx*) :general k (cdr v))) + (dtd-gentities dtd)) + (maphash (lambda (k v) + (report-entity (handler *ctx*) :parameter k (cdr v))) + (dtd-pentities dtd)) + (maphash (lambda (k v) + (sax:notation-declaration + (handler *ctx*) + k + (if (extid-public v) + (normalize-public-id (extid-public v)) + nil) + (uri-rod (extid-system v)))) + (dtd-notations dtd))) + +(defun p/misc*-2 (input) + ;; Misc* + (while (member (peek-token input) '(:COMMENT :PI :S)) + (case (peek-token input) + (:COMMENT + (sax:comment (handler *ctx*) (nth-value 1 (peek-token input)))) + (:PI + (sax:processing-instruction + (handler *ctx*) + (car (nth-value 1 (peek-token input))) + (cdr (nth-value 1 (peek-token input)))))) + (consume-token input))) + +(defun p/document + (input handler + &key validate dtd root entity-resolver disallow-internal-subset + (recode t)) + ;; check types of user-supplied arguments for better error messages: + (check-type validate boolean) + (check-type recode boolean) + (check-type dtd (or null extid)) + (check-type root (or null rod)) + (check-type entity-resolver (or null function symbol)) + (check-type disallow-internal-subset boolean) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'rod-to-utf8-string))) + (let ((*ctx* + (make-context :handler handler + :main-zstream input + :entity-resolver entity-resolver + :disallow-internal-subset disallow-internal-subset)) + (*validate* validate)) + (sax:start-document handler) + ;; document ::= XMLDecl? Misc* (doctypedecl Misc*)? element Misc* + ;; Misc ::= Comment | PI | S + ;; xmldecl::='<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>' + ;; sddecl::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) + ;; + ;; we will use the attribute-value parser for the xml decl. + (let ((*data-behaviour* :DTD)) + ;; optional XMLDecl? + (cond ((eq (peek-token input) :xml-decl) + (let ((hd (parse-xml-decl (cdr (nth-value 1 (peek-token input)))))) + (setf (standalone-p *ctx*) (eq (xml-header-standalone-p hd) :yes)) + (setup-encoding input hd)) + (read-token input))) + (set-full-speed input) + ;; Misc* + (p/misc*-2 input) + ;; (doctypedecl Misc*)? + (cond + ((eq (peek-token input) :<!DOCTYPE) + (p/doctype-decl input dtd) + (p/misc*-2 input)) + (dtd + (let ((dummy (string->xstream "<!DOCTYPE dummy>"))) + (setf (xstream-name dummy) + (make-stream-name + :entity-name "dummy doctype" + :entity-kind :main + :uri (zstream-base-sysid input))) + (p/doctype-decl (make-zstream :input-stack (list dummy)) dtd))) + ((and validate (not dtd)) + (validity-error "invalid document: no doctype"))) + (ensure-dtd) + ;; Override expected root element if asked to + (when root + (setf (model-stack *ctx*) (list (make-root-model root)))) + ;; element + (let ((*data-behaviour* :DOC)) + (p/element input)) + ;; optional Misc* + (p/misc*-2 input) + (unless (eq (peek-token input) :eof) + (wf-error input "Garbage at end of document.")) + (when *validate* + (maphash (lambda (k v) + (unless v + (validity-error "(11) IDREF: ~S not defined" (rod-string k)))) + (id-table *ctx*)) + + (dolist (name (referenced-notations *ctx*)) + (unless (find-notation name (dtd *ctx*)) + (validity-error "(23) Notation Declared: ~S" (rod-string name))))) + (sax:end-document handler)))) + +(defun p/element (input) + (multiple-value-bind (cat sem) (read-token input) + (case cat + ((:stag :ztag)) + (:eof (eox input)) + (t (wf-error input "element expected"))) + (destructuring-bind (&optional name &rest raw-attrs) sem + (validate-start-element *ctx* name) + (let* ((attrs + (process-attributes *ctx* name (build-attribute-list raw-attrs))) + (*namespace-bindings* *namespace-bindings*) + new-namespaces) + (when sax:*namespace-processing* + (setf new-namespaces (declare-namespaces attrs)) + (mapc #'set-attribute-namespace attrs)) + (multiple-value-bind (uri prefix local-name) + (if sax:*namespace-processing* + (decode-qname name) + (values nil nil nil)) + (declare (ignore prefix)) + (check-attribute-uniqueness attrs) + (unless (or sax:*include-xmlns-attributes* + (null sax:*namespace-processing*)) + (setf attrs + (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname) + attrs))) + (cond + ((eq cat :ztag) + (sax:start-element (handler *ctx*) uri local-name name attrs) + (sax:end-element (handler *ctx*) uri local-name name)) + + ((eq cat :stag) + (sax:start-element (handler *ctx*) uri local-name name attrs) + (p/content input) + (multiple-value-bind (cat2 sem2) (read-token input) + (unless (and (eq cat2 :etag) + (eq (car sem2) name)) + (wf-error input "Bad nesting. ~S / ~S" + (mu name) + (mu (cons cat2 sem2)))) + (when (cdr sem2) + (wf-error input "no attributes allowed in end tag"))) + (sax:end-element (handler *ctx*) uri local-name name)) + + (t + (wf-error input "Expecting element, got ~S." cat)))) + (undeclare-namespaces new-namespaces)) + (validate-end-element *ctx* name)))) + +(defun p/content (input) + ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* + (multiple-value-bind (cat sem) (peek-token input) + (case cat + ((:stag :ztag) + (p/element input) + (p/content input)) + ((:CDATA) + (consume-token input) + (when (search #"]]>" sem) + (wf-error input "']]>' not allowed in CharData")) + (validate-characters *ctx* sem) + (sax:characters (handler *ctx*) sem) + (p/content input)) + ((:ENTITY-REF) + (let ((name sem)) + (consume-token input) + (append + (recurse-on-entity input name :general + (lambda (input) + (prog1 + (etypecase (checked-get-entdef name :general) + (internal-entdef (p/content input)) + (external-entdef (p/ext-parsed-ent input))) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage. - ~S" + (peek-token input)))))) + (p/content input)))) + ((:<!\[) + (consume-token input) + (cons + (let ((input (car (zstream-input-stack input)))) + (unless (and (rune= #/C (read-rune input)) + (rune= #/D (read-rune input)) + (rune= #/A (read-rune input)) + (rune= #/T (read-rune input)) + (rune= #/A (read-rune input)) + (rune= #/\[ (read-rune input))) + (wf-error input "After '<![', 'CDATA[' is expected.")) + (validate-characters *ctx* #"hack") ;anything other than whitespace + (sax:start-cdata (handler *ctx*)) + (sax:characters (handler *ctx*) (read-cdata-sect input)) + (sax:end-cdata (handler *ctx*))) + (p/content input))) + ((:PI) + (consume-token input) + (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)) + (p/content input)) + ((:COMMENT) + (consume-token input) + (sax:comment (handler *ctx*) sem) + (p/content input)) + (otherwise + nil)))) + +;; [78] extParsedEnt ::= TextDecl? contentw +;; [79] extPE ::= TextDecl? extSubsetDecl + +(defstruct xml-header + version + encoding + (standalone-p nil)) + +(defun p/ext-parsed-ent (input) + ;; [78] extParsedEnt ::= '<?xml' VersionInfo? EncodingDecl S? '?>' content + (when (eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) + (setup-encoding input hd)) + (consume-token input)) + (set-full-speed input) + (p/content input)) + +(defun parse-xml-decl (content) + (let* ((res (make-xml-header)) + (i (make-rod-xstream content)) + (z (make-zstream :input-stack (list i))) + (atts (read-attribute-list z i t))) + (unless (eq (peek-rune i) :eof) + (wf-error i "Garbage at end of XMLDecl.")) + ;; versioninfo muss da sein + ;; dann ? encodingdecl + ;; dann ? sddecl + ;; dann ende + (unless (eq (caar atts) (intern-name '#.(string-rod "version"))) + (wf-error i "XMLDecl needs version.")) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/:) + (rune= x #/-))) + (cdar atts))) + (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts)))) + (setf (xml-header-version res) (rod-string (cdar atts))) + (pop atts) + (when (eq (caar atts) (intern-name '#.(string-rod "encoding"))) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/-))) + (cdar atts)) + ((lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z))) + (aref (cdar atts) 0))) + (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts)))) + (setf (xml-header-encoding res) (rod-string (cdar atts))) + (pop atts)) + (when (eq (caar atts) (intern-name '#.(string-rod "standalone"))) + (unless (or (rod= (cdar atts) '#.(string-rod "yes")) + (rod= (cdar atts) '#.(string-rod "no"))) + (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S." + (rod-string (cdar atts)))) + (setf (xml-header-standalone-p res) + (if (rod-equal '#.(string-rod "yes") (cdar atts)) + :yes + :no)) + (pop atts)) + (when atts + (wf-error i "Garbage in XMLDecl: ~A" (rod-string content))) + res)) + +(defun parse-text-decl (content) + (let* ((res (make-xml-header)) + (i (make-rod-xstream content)) + (z (make-zstream :input-stack (list i))) + (atts (read-attribute-list z i t))) + (unless (eq (peek-rune i) :eof) + (wf-error i "Garbage at end of TextDecl")) + ;; versioninfo optional + ;; encodingdecl muss da sein + ;; dann ende + (when (eq (caar atts) (intern-name '#.(string-rod "version"))) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/:) + (rune= x #/-))) + (cdar atts))) + (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts)))) + (setf (xml-header-version res) (rod-string (cdar atts))) + (pop atts)) + (unless (eq (caar atts) (intern-name '#.(string-rod "encoding"))) + (wf-error i "TextDecl needs encoding.")) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/-))) + (cdar atts)) + ((lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9))) + (aref (cdar atts) 0))) + (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts)))) + (setf (xml-header-encoding res) (rod-string (cdar atts))) + (pop atts) + (when atts + (wf-error i "Garbage in TextDecl: ~A" (rod-string content))) + res)) + +;;;; --------------------------------------------------------------------------- +;;;; mu +;;;; + +(defun mu (x) + (cond ((stringp x) x) + ((vectorp x) (rod-string x)) + ((consp x) + (cons (mu (car x)) (mu (cdr x)))) + (x))) + +;;;; --------------------------------------------------------------------------- +;;;; User interface ;;;; + +(defun specific-or (component &optional (alternative nil)) + (if (eq component :unspecific) + alternative + component)) + +(defun string-or (str &optional (alternative nil)) + (if (zerop (length str)) + alternative + str)) + +(defun make-uri (&rest initargs &key path query &allow-other-keys) + (apply #'make-instance + 'puri:uri + :path (and path (escape-path path)) + :query (and query (escape-query query)) + initargs)) + +(defun escape-path (list) + (puri::render-parsed-path list t)) + +(defun escape-query (pairs) + (flet ((escape (str) + (puri::encode-escaped-encoding str puri::*reserved-characters* t))) + (let ((first t)) + (with-output-to-string (s) + (dolist (pair pairs) + (if first + (setf first nil) + (write-char #\& s)) + (write-string (escape (car pair)) s) + (write-char #\= s) + (write-string (escape (cdr pair)) s)))))) + +(defun uri-parsed-query (uri) + (flet ((unescape (str) + (puri::decode-escaped-encoding str t puri::*reserved-characters*))) + (let ((str (puri:uri-query uri))) + (cond + (str + (let ((pairs '())) + (dolist (s (split-sequence-if (lambda (x) (eql x #\&)) str)) + (destructuring-bind (name value) + (split-sequence-if (lambda (x) (eql x #\=)) s) + (push (cons (unescape name) (unescape value)) pairs))) + (reverse pairs))) + (t + nil))))) + +(defun query-value (name alist) + (cdr (assoc name alist :test #'equal))) + +(defun pathname-to-uri (pathname) + (let ((path + (append (pathname-directory pathname) + (list + (if (specific-or (pathname-type pathname)) + (concatenate 'string + (pathname-name pathname) + "." + (pathname-type pathname)) + (pathname-name pathname)))))) + (if (eq (car path) :relative) + (make-uri :path path) + (make-uri :scheme :file + :host (concatenate 'string + (string-or (host-namestring pathname)) + "+" + (specific-or (pathname-device pathname))) + :path path)))) + +(defun parse-name.type (str) + (if str + (let ((i (position #\. str :from-end t))) + (if i + (values (subseq str 0 i) (subseq str (1+ i))) + (values str nil))) + (values nil nil))) + +(defun uri-to-pathname (uri) + (let ((scheme (puri:uri-scheme uri)) + (path (puri:uri-parsed-path uri))) + (unless (member scheme '(nil :file)) + (error 'xml-parse-error + :format-control "URI scheme ~S not supported" + :format-arguments (list scheme))) + (if (eq (car path) :relative) + (multiple-value-bind (name type) + (parse-name.type (car (last path))) + (make-pathname :directory (butlast path) + :name name + :type type)) + (multiple-value-bind (name type) + (parse-name.type (car (last (cdr path)))) + (destructuring-bind (host device) + (split-sequence-if (lambda (x) (eql x #\+)) + (or (puri:uri-host uri) "+")) + (make-pathname :host (string-or host) + :device (string-or device) + :directory (cons :absolute (butlast (cdr path))) + :name name + :type type)))))) + +(defun parse-xstream (xstream handler &rest args) + (let ((*ctx* nil)) + (handler-case + (let ((zstream (make-zstream :input-stack (list xstream)))) + (peek-rune xstream) + (with-scratch-pads () + (apply #'p/document zstream handler args))) + (runes-encoding:encoding-error (c) + (wf-error xstream "~A" c))))) + +(defun parse-file (filename handler &rest args) + (with-open-xfile (input filename) + (setf (xstream-name input) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (pathname-to-uri filename))) + (apply #'parse-xstream input handler args))) + +(defun resolve-synonym-stream (stream) + (while (typep stream 'synonym-stream) + (setf stream (symbol-value (synonym-stream-symbol stream)))) + stream) + +(defun safe-stream-sysid (stream) + (if (and (typep (resolve-synonym-stream stream) 'file-stream) + ;; ignore-errors, because sb-bsd-sockets creates instances of + ;; FILE-STREAMs that aren't + (ignore-errors (pathname stream))) + (pathname-to-uri (pathname stream)) + nil)) + +(defun parse-stream (stream handler &rest args) + (let ((xstream + (make-xstream + stream + :name (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (safe-stream-sysid stream)) + :initial-speed 1))) + (apply #'parse-xstream xstream handler args))) + +(defun parse-dtd-file (filename &optional handler) + (with-open-file (s filename :element-type '(unsigned-byte 8)) + (parse-dtd-stream s handler))) + +(defun parse-dtd-stream (stream &optional handler) + (let ((input (make-xstream stream))) + (setf (xstream-name input) + (make-stream-name + :entity-name "dtd" + :entity-kind :main + :uri (safe-stream-sysid stream))) + (let ((zstream (make-zstream :input-stack (list input))) + (*ctx* (make-context :handler handler)) + (*validate* t) + (*data-behaviour* :DTD)) + (with-scratch-pads () + (ensure-dtd) + (peek-rune input) + (p/ext-subset zstream) + (dtd *ctx*))))) + +(defun parse-rod (string handler &rest args) + (apply #'parse-xstream (string->xstream string) handler args)) + +(defun string->xstream (string) + (make-rod-xstream (string-rod string))) + +(defclass octet-input-stream + (trivial-gray-stream-mixin fundamental-binary-input-stream) + ((octets :initarg :octets) + (pos :initform 0))) + +(defmethod close ((stream octet-input-stream) &key abort) + (declare (ignore abort)) + (open-stream-p stream)) + +(defmethod stream-read-byte ((stream octet-input-stream)) + (with-slots (octets pos) stream + (if (>= pos (length octets)) + :eof + (prog1 + (elt octets pos) + (incf pos))))) + +(defmethod stream-read-sequence + ((stream octet-input-stream) sequence start end &key &allow-other-keys) + (with-slots (octets pos) stream + (let* ((length (min (- end start) (- (length octets) pos))) + (end1 (+ start length)) + (end2 (+ pos length))) + (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2) + (setf pos end2) + end1))) + +(defun make-octet-input-stream (octets) + (make-instance 'octet-input-stream :octets octets)) + +(defun parse-octets (octets handler &rest args) + (apply #'parse-stream (make-octet-input-stream octets) handler args)) + +;;;; + +(defun zstream-push (new-xstream zstream) + (cond ((find-if (lambda (x) + (and (xstream-p x) + (eql (stream-name-entity-name (xstream-name x)) + (stream-name-entity-name (xstream-name new-xstream))) + (eql (stream-name-entity-kind (xstream-name x)) + (stream-name-entity-kind (xstream-name new-xstream))))) + (zstream-input-stack zstream)) + (wf-error zstream "Infinite recursion."))) + (push new-xstream (zstream-input-stack zstream)) + zstream) + +(defun recurse-on-entity (zstream name kind continuation &optional internalp) + (assert (not (zstream-token-category zstream))) + (call-with-entity-expansion-as-stream + zstream + (lambda (new-xstream) + (push :stop (zstream-input-stack zstream)) + (zstream-push new-xstream zstream) + (prog1 + (funcall continuation zstream) + (assert (eq (peek-token zstream) :eof)) + (assert (eq (pop (zstream-input-stack zstream)) new-xstream)) + (close-xstream new-xstream) + (assert (eq (pop (zstream-input-stack zstream)) :stop)) + (setf (zstream-token-category zstream) nil) + '(consume-token zstream)) ) + name + kind + internalp)) + +#|| +(defmacro read-data-until* ((predicate input res res-start res-end) &body body) + ;; fast variant -- for now disabled for no apparent reason + ;; -> res, res-start, res-end + `(let* ((rptr (xstream-read-ptr ,input)) + (p0 rptr) + (fptr (xstream-fill-ptr ,input)) + (buf (xstream-buffer ,input)) + ,res ,res-start ,res-end) + (declare (type fixnum rptr fptr p0) + (type (simple-array read-element (*)) buf)) + (loop + (cond ((%= rptr fptr) + ;; underflow -- hmm inject the scratch-pad with what we + ;; read and continue, while using read-rune and collecting + ;; d.h. besser wäre hier auch while-reading zu benutzen. + (setf (xstream-read-ptr ,input) rptr) + (multiple-value-setq (,res ,res-start ,res-end) + (with-rune-collector/raw (collect) + (do ((i p0 (%+ i 1))) + ((%= i rptr)) + (collect (%rune buf i))) + (let (c) + (loop + (cond ((%= rptr fptr) + (setf (xstream-read-ptr ,input) rptr) + (setf c (peek-rune input)) + (cond ((eq c :eof) + (return))) + (setf rptr (xstream-read-ptr ,input) + fptr (xstream-fill-ptr ,input) + buf (xstream-buffer ,input))) + (t + (setf c (%rune buf rptr)))) + (cond ((,predicate c) + ;; we stop + (setf (xstream-read-ptr ,input) rptr) + (return)) + (t + ;; we continue + (collect c) + (setf rptr (%+ rptr 1))) ))))) + (return)) + ((,predicate (%rune buf rptr)) + ;; we stop + (setf (xstream-read-ptr ,input) rptr) + (setf ,res buf ,res-start p0 ,res-end rptr) + (return) ) + (t + we continue + (sf rptr (%+ rptr 1))) )) + ,@body )) +||# + +(defmacro read-data-until* ((predicate input res res-start res-end) &body body) + "Read data from `input' until `predicate' applied to the read char + turns true. Then execute `body' with `res', `res-start', `res-end' + bound to denote a subsequence (of RUNEs) containing the read portion. + The rune upon which `predicate' turned true is neither consumed from + the stream, nor included in `res'. + + Keep the predicate short, this it may be included more than once into + the macro's expansion." + ;; + (let ((input-var (gensym)) + (collect (gensym)) + (c (gensym))) + `(LET ((,input-var ,input)) + (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) + (WITH-RUNE-COLLECTOR/RAW (,collect) + (LOOP + (LET ((,c (PEEK-RUNE ,input-var))) + (COND ((EQ ,c :EOF) + ;; xxx error message + (RETURN)) + ((FUNCALL ,predicate ,c) + (RETURN)) + (t + (,collect ,c) + (CONSUME-RUNE ,input-var)))))) + (LOCALLY + ,@body))))) + +(defun read-name-token (input) + (read-data-until* ((lambda (rune) + (declare (type rune rune)) + (not (name-rune-p rune))) + input + r rs re) + (intern-name r rs re))) + +(defun read-cdata (input) + (read-data-until* ((lambda (rune) + (declare (type rune rune)) + (when (and (%rune< rune #/U+0020) + (not (or (%rune= rune #/U+0009) + (%rune= rune #/U+000a) + (%rune= rune #/U+000d)))) + (wf-error input "code point invalid: ~A" rune)) + (or (%rune= rune #/<) (%rune= rune #/&))) + input + source start end) + (locally + (declare (type (simple-array rune (*)) source) + (type ufixnum start) + (type ufixnum end) + (optimize (speed 3) (safety 0))) + (let ((res (make-array (%- end start) :element-type 'rune))) + (declare (type (simple-array rune (*)) res)) + (let ((i (%- end start))) + (declare (type ufixnum i)) + (loop + (setf i (- i 1)) + (setf (%rune res i) (%rune source (the ufixnum (+ i start)))) + (when (= i 0) + (return)))) + res)))) + +(defun internal-entity-expansion (name) + (let ((def (get-entity-definition name :general (dtd *ctx*)))) + (unless def + (wf-error nil "Entity '~A' is not defined." (rod-string name))) + (unless (typep def 'internal-entdef) + (wf-error nil "Entity '~A' is not an internal entity." name)) + (or (entdef-expansion def) + (setf (entdef-expansion def) (find-internal-entity-expansion name))))) + +(defun find-internal-entity-expansion (name) + (let ((zinput (make-zstream))) + (with-rune-collector-3 (collect) + (labels ((muffle (input) + (let (c) + (loop + (setf c (read-rune input)) + (cond ((eq c :eof) + (return)) + ((rune= c #/&) + (setf c (peek-rune input)) + (cond ((eql c :eof) + (eox input)) + ((rune= c #/#) + (let ((c (read-character-reference input))) + (%put-unicode-char c collect))) + (t + (unless (name-start-rune-p c) + (wf-error zinput "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput))))))))) + ((rune= c #/<) + (wf-error zinput "unexpected #\/<")) + ((space-rune-p c) + (collect #/space)) + ((not (data-rune-p c)) + (wf-error zinput "illegal char: ~S." c)) + (t + (collect c))))))) + (declare (dynamic-extent #'muffle)) + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput))))) )))) + +(defun resolve-entity (name handler dtd) + (let ((*validate* nil)) + (if (get-entity-definition name :general dtd) + (let* ((*ctx* (make-context :handler handler :dtd dtd)) + (input (make-zstream)) + (*data-behaviour* :DOC)) + (with-scratch-pads () + (recurse-on-entity + input name :general + (lambda (input) + (prog1 + (etypecase (checked-get-entdef name :general) + (internal-entdef (p/content input)) + (external-entdef (p/ext-parsed-ent input))) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage. - ~S" + (peek-token input)))))))) + nil))) + +(defun read-att-value-2 (input) + (let ((delim (read-rune input))) + (when (eql delim :eof) + (eox input)) + (unless (member delim '(#/\" #/\') :test #'eql) + (wf-error input + "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'." + (rune-char delim))) + (with-rune-collector-4 (collect) + (loop + (let ((c (read-rune input))) + (cond ((eq c :eof) + (eox input "EOF")) + ((rune= c delim) + (return)) + ((rune= c #/<) + (wf-error input "'<' not allowed in attribute values")) + ((rune= #/& c) + (multiple-value-bind (kind sem) (read-entity-like input) + (ecase kind + (:CHARACTER-REFERENCE + (%put-unicode-char sem collect)) + (:ENTITY-REFERENCE + (let* ((exp (internal-entity-expansion sem)) + (n (length exp))) + (declare (type (simple-array rune (*)) exp)) + (do ((i 0 (%+ i 1))) + ((%= i n)) + (collect (%rune exp i)))))))) + ((space-rune-p c) + (collect #/u+0020)) + (t + (collect c)))))))) + +;;;;;;;;;;;;;;;;; + +;;; Namespace stuff + +;; We already know that name is part of a valid XML name, so all we +;; have to check is that the first rune is a name-start-rune and that +;; there is not colon in it. +(defun nc-name-p (name) + (and (plusp (length name)) + (name-start-rune-p (rune name 0)) + (notany #'(lambda (rune) (rune= #/: rune)) name))) + +(defun split-qname (qname) + (declare (type runes:simple-rod qname)) + (let ((pos (position #/: qname))) + (if pos + (let ((prefix (subseq qname 0 pos)) + (local-name (subseq qname (1+ pos)))) + (when (zerop pos) + (wf-error nil "empty namespace prefix")) + (if (nc-name-p local-name) + (values prefix local-name) + (wf-error nil "~S is not a valid NcName." + (rod-string local-name)))) + (values () qname)))) + +(defun decode-qname (qname) + "decode-qname name => namespace-uri, prefix, local-name" + (declare (type runes:simple-rod qname)) + (multiple-value-bind (prefix local-name) (split-qname qname) + (let ((uri (find-namespace-binding prefix))) + (if uri + (values uri prefix local-name) + (values nil nil qname))))) + + +(defun find-namespace-binding (prefix) + (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=) + (wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix))))) + +;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal +(defun rod-starts-with (prefix rod) + (and (<= (length prefix) (length rod)) + (dotimes (i (length prefix) t) + (unless (rune= (rune prefix i) (rune rod i)) + (return nil))))) + +(defun xmlns-attr-p (attr-name) + (rod-starts-with #.(string-rod "xmlns") attr-name)) + +(defun attrname->prefix (attrname) + (if (< 5 (length attrname)) + (subseq attrname 6) + nil)) + +(defun find-namespace-declarations (attributes) + (loop + for attribute in attributes + for qname = (sax:attribute-qname attribute) + when (xmlns-attr-p qname) + collect (cons (attrname->prefix qname) (sax:attribute-value attribute)))) + +(defun declare-namespaces (attributes) + (let ((ns-decls (find-namespace-declarations attributes))) + (dolist (ns-decl ns-decls) + ;; check some namespace validity constraints + (let ((prefix (car ns-decl)) + (uri (cdr ns-decl))) + (cond + ((and (rod= prefix #"xml") + (not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) + (wf-error nil + "Attempt to rebind the prefix \"xml\" to ~S." (mu uri))) + ((and (rod= uri #"http://www.w3.org/XML/1998/namespace") + (not (rod= prefix #"xml"))) + (wf-error nil + "The namespace ~ + URI \"http://www.w3.org/XML/1998/namespace\" may not ~ + be bound to the prefix ~S, only \"xml\" is legal." + (mu prefix))) + ((and (rod= prefix #"xmlns") + (rod= uri #"http://www.w3.org/2000/xmlns/")) + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to its predefined ~ + URI \"http://www.w3.org/2000/xmlns/\", which is ~ + forbidden for no good reason.")) + ((rod= prefix #"xmlns") + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~ + but it may not be declared." (mu uri))) + ((rod= uri #"http://www.w3.org/2000/xmlns/") + (wf-error nil + "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~ + not be bound to prefix ~S (or any other)." (mu prefix))) + ((and (rod= uri #"") prefix) + (wf-error nil + "Only the default namespace (the one without a prefix) ~ + may be bound to an empty namespace URI, thus ~ + undeclaring it.")) + (t + (push (cons prefix (if (rod= #"" uri) nil uri)) + *namespace-bindings*) + (sax:start-prefix-mapping (handler *ctx*) + (car ns-decl) + (cdr ns-decl)))))) + ns-decls)) + +(defun undeclare-namespaces (ns-decls) + (dolist (ns-decl ns-decls) + (sax:end-prefix-mapping (handler *ctx*) (car ns-decl)))) + +(defun build-attribute-list (attr-alist) + ;; fixme: if there is a reason this function reverses attribute order, + ;; it should be documented. + (let (attributes) + (dolist (pair attr-alist) + (push (sax:make-attribute :qname (car pair) + :value (cdr pair) + :specified-p t) + attributes)) + attributes)) + +(defun check-attribute-uniqueness (attributes) + ;; 5.3 Uniqueness of Attributes + ;; In XML documents conforming to [the xmlns] specification, no + ;; tag may contain two attributes which: + ;; 1. have identical names, or + ;; 2. have qualified names with the same local part and with + ;; prefixes which have been bound to namespace names that are + ;; identical. + ;; + ;; 1. is checked by read-tag-2, so we only deal with 2 here + (loop for (attr-1 . rest) on attributes do + (when (and (sax:attribute-namespace-uri attr-1) + (find-if (lambda (attr-2) + (and (rod= (sax:attribute-namespace-uri attr-1) + (sax:attribute-namespace-uri attr-2)) + (rod= (sax:attribute-local-name attr-1) + (sax:attribute-local-name attr-2)))) + rest)) + (wf-error nil + "Multiple definitions of attribute ~S in namespace ~S." + (mu (sax:attribute-local-name attr-1)) + (mu (sax:attribute-namespace-uri attr-1)))))) + +(defun set-attribute-namespace (attribute) + (let ((qname (sax:attribute-qname attribute))) + (if (and sax:*use-xmlns-namespace* (rod= qname #"xmlns")) + (setf (sax:attribute-namespace-uri attribute) + #"http://www.w3.org/2000/xmlns/") + (multiple-value-bind (prefix local-name) (split-qname qname) + (declare (ignorable local-name)) + (when (and prefix ;; default namespace doesn't apply to attributes + (or (not (rod= #"xmlns" prefix)) + sax:*use-xmlns-namespace*)) + (multiple-value-bind (uri prefix local-name) + (decode-qname qname) + (declare (ignore prefix)) + (setf (sax:attribute-namespace-uri attribute) uri) + (setf (sax:attribute-local-name attribute) local-name))))))) + +;;;;;;;;;;;;;;;;; + +;; System Identifier Protocol + +;; A system identifier is an object obeying to the system identifier +;; protocol. Often something like an URL or a pathname. + +;; OPEN-SYS-ID sys-id [generic function] +;; +;; Opens the resource associated with the system identifier `sys-id' +;; for reading and returns a stream. For now it is expected, that the +;; stream is an octet stream (one of element type (unsigned-byte 8)). +;; +;; More precisely: The returned object only has to obey to the xstream +;; controller protocol. (That is it has to provide implementations for +;; READ-OCTETS and XSTREAM-CONTROLLER-CLOSE). + +;; MERGE-SYS-ID sys-id base [generic function] +;; +;; Merges two system identifiers. That is resolve `sys-id' relative to +;; `base' yielding an absolute system identifier suitable for +;; OPEN-SYS-ID. + + +;;;;;;;;;;;;;;;;; +;;; SAX validation handler + +(defclass validator () + ((context :initarg :context :accessor context) + (cdatap :initform nil :accessor cdatap))) + +(defun make-validator (dtd root) + (make-instance 'validator + :context (make-context + :handler nil + :dtd dtd + :model-stack (list (make-root-model root))))) + +(macrolet ((with-context ((validator) &body body) + `(let ((*ctx* (context ,validator)) + (*validate* t)) + (with-scratch-pads () ;nicht schoen + ,@body)))) + (defmethod sax:start-element ((handler validator) uri lname qname attributes) + uri lname + (with-context (handler) + (validate-start-element *ctx* qname) + (process-attributes *ctx* qname attributes))) + + (defmethod sax:start-cdata ((handler validator)) + (setf (cdatap handler) t)) + + (defmethod sax:characters ((handler validator) data) + (with-context (handler) + (validate-characters *ctx* (if (cdatap handler) #"hack" data)))) + + (defmethod sax:end-cdata ((handler validator)) + (setf (cdatap handler) nil)) + + (defmethod sax:end-element ((handler validator) uri lname qname) + uri lname + (with-context (handler) + (validate-end-element *ctx* qname)))) Added: vendor/cxml/xmlns-normalizer.lisp =================================================================== --- vendor/cxml/xmlns-normalizer.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/xmlns-normalizer.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,131 @@ +;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur +;;;; Namespace-Normalisierung aus DOM 3 Core.[1] +;;;; +;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM +;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace +;;;; aber nur die URI sein soll. Und eine Anpassung der zugehoerigen +;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt, +;;;; bzw. wird dem Nutzer ueberlassen. +;;;; +;;;; Daher muss letztlich spaetestens beim Serialisieren eine +;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das +;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas +;;;; Namespace-konformes heraus kommt. +;;;; +;;;; Und das nennen sie dann Namespace-Support. +;;;; +;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorith… + +(in-package :cxml) + +(defclass namespace-normalizer (sax-proxy) + ((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack))) + +(defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/") + +(defun make-namespace-normalizer (chained-handler) + (make-instance 'namespace-normalizer + :xmlns-stack (list (mapcar (lambda (cons) + (make-xmlns-attribute (car cons) (cdr cons))) + *namespace-bindings*)) + :chained-handler chained-handler)) + +(defun normalizer-find-prefix (handler prefix) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (rod= (sax:attribute-local-name attribute) prefix) + (return-from t attribute)))))) + +(defun normalizer-find-uri (handler uri) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (and (rod= (sax:attribute-value attribute) uri) + ;; default-namespace interessiert uns nicht + (not (rod= (sax:attribute-qname attribute) #"xmlns"))) + (return-from t attribute)))))) + +(defun make-xmlns-attribute (prefix uri) + (if prefix + (sax:make-attribute + :qname (concatenate 'rod #"xmlns:" prefix) + :namespace-uri *xmlns-namespace* + :local-name prefix + :value uri) + (sax:make-attribute + :qname #"xmlns" + :namespace-uri *xmlns-namespace* + :local-name #"xmlns" + :value uri))) + +(defun rename-attribute (a new-prefix) + (setf (sax:attribute-qname a) + (concatenate 'rod new-prefix #":" (sax:attribute-local-name a)))) + +(defmethod sax:start-element + ((handler namespace-normalizer) uri lname qname attrs) + (declare (ignore qname)) + (when (null uri) + (setf uri #"")) + (let ((normal-attrs '())) + (push nil (xmlns-stack handler)) + (dolist (a attrs) + (if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a)) + (push a (car (xmlns-stack handler))) + (push a normal-attrs))) + (flet ((push-namespace (prefix uri) + (let ((new (make-xmlns-attribute prefix uri))) + (push new (car (xmlns-stack handler))) + (push new attrs)))) + (multiple-value-bind (prefix local-name) (split-qname qname) + (setf lname local-name) + (let ((binding (normalizer-find-prefix handler prefix))) + (cond + ((null binding) + (unless (and (null prefix) (zerop (length uri))) + (push-namespace prefix uri))) + ((rod= (sax:attribute-value binding) uri)) + ((member binding (car (xmlns-stack handler))) + (setf (sax:attribute-value binding) uri)) + (t + (push-namespace prefix uri))))) + (dolist (a normal-attrs) + (let ((u (sax:attribute-namespace-uri a))) + (when u + (let* ((prefix (split-qname (sax:attribute-qname a))) + (prefix-binding + (when prefix + (normalizer-find-prefix handler prefix)))) + (when (or (null prefix-binding) + (not (rod= (sax:attribute-value prefix-binding) u))) + (let ((uri-binding (normalizer-find-uri handler u))) + (cond + (uri-binding + (rename-attribute + a + (sax:attribute-local-name uri-binding))) + ((null prefix-binding) + (push-namespace prefix u)) + (t + (loop + for i from 1 + for prefix = (rod (format nil "NS~D" i)) + unless (normalizer-find-prefix handler prefix) + do + (push-namespace prefix u) + (rename-attribute a prefix) + (return)))))))))))) + (sax:start-element (proxy-chained-handler handler) uri lname qname attrs)) + +(defmethod sax:end-element ((handler namespace-normalizer) uri lname qname) + (declare (ignore qname)) + (pop (xmlns-stack handler)) + (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname)) Added: vendor/cxml/xmls-compat.lisp =================================================================== --- vendor/cxml/xmls-compat.lisp 2006-02-18 09:24:24 UTC (rev 1844) +++ vendor/cxml/xmls-compat.lisp 2006-02-18 09:34:15 UTC (rev 1845) @@ -0,0 +1,159 @@ +;;;; xml-compat.lisp -- XMLS-compatible data structures +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +;;;; XXX Der namespace-Support in xmls kommt mir zweifelhaft vor. +;;;; Wir immitieren das soweit es gebraucht wurde bisher. + +(defpackage cxml-xmls + (:use :cl :runes) + (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children + #:make-xmls-builder #:map-node)) + +(in-package :cxml-xmls) + + +;;;; Knoten + +(defun make-node (&key name ns attrs children) + `(,(if ns (cons name ns) name) + ,attrs + ,@children)) + +(defun node-name (node) + (let ((car (car node))) + (if (consp car) + (car car) + car))) + +(defun (setf node-name) (newval node) + (let ((car (car node))) + (if (consp car) + (setf (car car) newval) + (setf (car node) newval)))) + +(defun node-ns (node) + (let ((car (car node))) + (if (consp car) + (cdr car) + nil))) + +(defun (setf node-ns) (newval node) + (let ((car (car node))) + (if (consp car) + (setf (cdr car) newval) + (setf (car node) (cons car newval))) + newval)) + +(defun node-attrs (node) + (cadr node)) + +(defun (setf node-attrs) (newval node) + (setf (cadr node) newval)) + +(defun node-children (node) + (cddr node)) + +(defun (setf node-children) (newval node) + (setf (cddr node) newval)) + + +;;;; SAX-Handler (Parser) + +(defclass xmls-builder () + ((element-stack :initform nil :accessor element-stack) + (root :initform nil :accessor root) + (include-default-values :initform t + :initarg :include-default-values + :accessor include-default-values))) + +(defun make-xmls-builder (&key (include-default-values t)) + (make-instance 'xmls-builder :include-default-values include-default-values)) + +(defmethod sax:end-document ((handler xmls-builder)) + (root handler)) + +(defmethod sax:start-element + ((handler xmls-builder) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri)) + (setf local-name (or local-name qname)) + (let* ((attributes + (loop + for attr in attributes + when (or (sax:attribute-specified-p attr) + (include-default-values handler)) + collect + (list (sax:attribute-qname attr) + (sax:attribute-value attr)))) + (node (make-node :name local-name + :ns (let ((lq (length qname)) + (ll (length local-name))) + (if (eql lq ll) + nil + (subseq qname 0 (- lq ll 1)))) + :attrs attributes)) + (parent (car (element-stack handler)))) + (if parent + (push node (node-children parent)) + (setf (root handler) node)) + (push node (element-stack handler)))) + +(defmethod sax:end-element + ((handler xmls-builder) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name qname)) + (let ((node (pop (element-stack handler)))) + (setf (node-children node) (reverse (node-children node))))) + +(defmethod sax:characters ((handler xmls-builder) data) + (let* ((parent (car (element-stack handler))) + (prev (car (node-children parent)))) + ;; Be careful to accept both rods and strings here, so that xmls can be + ;; used with strings even if cxml is configured to use octet string rods. + (if (typep prev '(or rod string)) + ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer + ;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten + ;; erweitern, sonst ist das Dokument nicht normalisiert. + ;; (XXX Oder sollte man besser den Parser entsprechend aendern?) + (setf (car (node-children parent)) + (concatenate `(vector ,(array-element-type prev)) + prev + data)) + (push data (node-children parent))))) + + +;;;; SAX-Treiber (fuer Serialisierung) + +(defun map-node + (handler node + &key (include-xmlns-attributes sax:*include-xmlns-attributes*)) + (sax:start-document handler) + (labels ((walk (node) + (let* ((attlist + (compute-attributes node include-xmlns-attributes)) + (lname (rod (node-name node))) + (ns (rod (node-ns node))) + (qname (concatenate 'rod ns (rod ":") lname))) + ;; fixme: namespaces + (sax:start-element handler nil lname qname attlist) + (dolist (child (node-children node)) + (typecase child + (list (walk child)) + ((or string rod) (sax:characters handler (rod child))))) + (sax:end-element handler nil lname qname)))) + (walk node)) + (sax:end-document handler)) + +(defun compute-attributes (node xmlnsp) + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a + (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) + (sax:make-attribute :qname (rod name) + :value (rod value) + :specified-p t) + nil))) + (node-attrs node))))

1 0

[bknr-cvs] r1844 - branches/xml-class-rework
by bknr＠bknr.net 18 Feb '06

18 Feb '06

Author: hhubner Date: 2006-02-18 03:24:24 -0600 (Sat, 18 Feb 2006) New Revision: 1844 Added: branches/xml-class-rework/thirdparty/ Log: Removing the thirdparty tree completely would be nice, but it breaks too many things at the moment. Revert. Copied: branches/xml-class-rework/thirdparty (from rev 1843, trunk/thirdparty)

1 0

[bknr-cvs] r1843 - in trunk/bknr/src: rss sysclasses utils web xhtmlgen
by bknr＠bknr.net 18 Feb '06

18 Feb '06

Author: hhubner Date: 2006-02-18 02:42:44 -0600 (Sat, 18 Feb 2006) New Revision: 1843 Modified: trunk/bknr/src/rss/rss.lisp trunk/bknr/src/sysclasses/cron.lisp trunk/bknr/src/utils/package.lisp trunk/bknr/src/web/site.lisp trunk/bknr/src/xhtmlgen/xhtmlgen.lisp Log: Tchadvar Roussanov: Here are several more SBCL fixes. Now SBCL compiles the whole bknr/src tree (with a lot of warnings). Modified: trunk/bknr/src/rss/rss.lisp =================================================================== --- trunk/bknr/src/rss/rss.lisp 2006-02-17 21:15:22 UTC (rev 1842) +++ trunk/bknr/src/rss/rss.lisp 2006-02-18 08:42:44 UTC (rev 1843) @@ -1,9 +1,9 @@ (in-package :bknr.rss) -(defconstant +rdf-ns+ "http://www.w3.org/1999/02/22-rdf-syntax-ns#") -(defconstant +rss-ns+ "http://purl.org/rss/1.0/") -(defconstant +dc-ns+ "http://purl.org/dc/elements/1.1/") -(defconstant +content-ns+ "http://purl.org/rss/1.0/modules/content/") +(define-constant +rdf-ns+ "http://www.w3.org/1999/02/22-rdf-syntax-ns#") +(define-constant +rss-ns+ "http://purl.org/rss/1.0/") +(define-constant +dc-ns+ "http://purl.org/dc/elements/1.1/") +(define-constant +content-ns+ "http://purl.org/rss/1.0/modules/content/") (defgeneric rss-to-xml (rss-element)) Modified: trunk/bknr/src/sysclasses/cron.lisp =================================================================== --- trunk/bknr/src/sysclasses/cron.lisp 2006-02-17 21:15:22 UTC (rev 1842) +++ trunk/bknr/src/sysclasses/cron.lisp 2006-02-18 08:42:44 UTC (rev 1843) @@ -10,7 +10,7 @@ (>= hour 0) (< hour 24))) -(defconstant +day-list+ '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) +(define-constant +day-list+ '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) (defun day-p (day) (or (and (numberp day) @@ -27,7 +27,7 @@ (1+ num) (error "Could not find day in day-list"))))) -(defconstant +month-list+ '(:january :february :march :april :may :june :july +(define-constant +month-list+ '(:january :february :march :april :may :june :july :august :september :october :november :december)) (defun month-p (month) @@ -161,4 +161,4 @@ (setq *cron* (make-instance 'cron-actor))) (when (actor-running-p *cron*) (actor-stop *cron*)) - (actor-start *cron*)) \ No newline at end of file + (actor-start *cron*)) Modified: trunk/bknr/src/utils/package.lisp =================================================================== --- trunk/bknr/src/utils/package.lisp 2006-02-17 21:15:22 UTC (rev 1842) +++ trunk/bknr/src/utils/package.lisp 2006-02-18 08:42:44 UTC (rev 1843) @@ -141,6 +141,7 @@ ;; Package cleaning for the build process #:within-temporary-package + #:define-constant ;; mp compatibility #:mp-make-lock Modified: trunk/bknr/src/web/site.lisp =================================================================== --- trunk/bknr/src/web/site.lisp 2006-02-17 21:15:22 UTC (rev 1842) +++ trunk/bknr/src/web/site.lisp 2006-02-18 08:42:44 UTC (rev 1843) @@ -6,5 +6,5 @@ (defparameter *thumbnail-max-height* 54) ;; default billboard to show on home page -(defconstant *default-billboard* "main") +(define-constant *default-billboard* "main") Modified: trunk/bknr/src/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/bknr/src/xhtmlgen/xhtmlgen.lisp 2006-02-17 21:15:22 UTC (rev 1842) +++ trunk/bknr/src/xhtmlgen/xhtmlgen.lisp 2006-02-18 08:42:44 UTC (rev 1843) @@ -159,7 +159,13 @@ ;; das ist fuer WPDISPLAY (let ((s (cxml::chained-handler *html-sink*))) (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str))) + (map nil + (lambda (c) + #-sbcl + (cxml::write-rune (char-code c) s) + #+sbcl + (cxml::write-rune c s)) + str))) (defun princ-http (val) #+(or)

1 0

[bknr-cvs] r1842 - branches/xml-class-rework/bknr/src
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 15:15:22 -0600 (Fri, 17 Feb 2006) New Revision: 1842 Removed: branches/xml-class-rework/bknr/src/bknr-id3.asd branches/xml-class-rework/bknr/src/id3/ Modified: branches/xml-class-rework/bknr/src/bknr.asd Log: Get rid of the id3 module. This has not been used very often, but it was very annoying because it depends on the external libid3tag library be present. There is native ID3 tag reading code available from Peter Seibels' PCL book, if someone needs the capability, please import this. Deleted: branches/xml-class-rework/bknr/src/bknr-id3.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr-id3.asd 2006-02-17 21:12:10 UTC (rev 1841) +++ branches/xml-class-rework/bknr/src/bknr-id3.asd 2006-02-17 21:15:22 UTC (rev 1842) @@ -1,22 +0,0 @@ -(in-package :cl-user) - -(defpackage :bknr-id3.system - (:use :cl :asdf) - (:export :*bknr-id3-directory*)) - -(in-package :bknr-id3.system) - -(defvar *bknr-id3-directory* - (make-pathname :name nil :type nil :version nil - :defaults (parse-namestring *load-truename*))) - -(defsystem :bknr-id3 - :name "bknr-id3 - lisp bindings for libid3tag" - :author "Manuel Odendahl <manuel(a)bl0rg.net>" - :version "0" - :licence "BSD" - :description "LISP UFFI bindings for libid3tag" - :depends-on (:bknr-utils :uffi) - - :components ((:module "id3" :components ((:file "package") - (:file "id3" :depends-on ("package")))))) Modified: branches/xml-class-rework/bknr/src/bknr.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr.asd 2006-02-17 21:12:10 UTC (rev 1841) +++ branches/xml-class-rework/bknr/src/bknr.asd 2006-02-17 21:15:22 UTC (rev 1842) @@ -36,7 +36,6 @@ :bknr-data-impex #+(not allegro) :acl-compat) - ;:bknr-id3) :components ((:file "packages") @@ -128,4 +127,4 @@ (:file "import-images-handler" :depends-on ("image-tags" "image")) (:file "session-image")) - :depends-on ("web")))) \ No newline at end of file + :depends-on ("web"))))

1 0

[bknr-cvs] r1841 - in branches/xml-class-rework: . projects/bos projects/bos/m2 projects/bos/payment-website/infosystem projects/bos/payment-website/infosystem/de projects/bos/payment-website/infosystem/en projects/eboy/eboy-static projects/eboy/eboy-templates projects/eboy/src projects/lisp-ecoop/website/templates projects/quickhoney/src projects/raw-data/mcp tools
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 15:12:10 -0600 (Fri, 17 Feb 2006) New Revision: 1841 Removed: branches/xml-class-rework/thirdparty/ Modified: branches/xml-class-rework/projects/bos/build.lisp branches/xml-class-rework/projects/bos/m2/allocation.lisp branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js branches/xml-class-rework/projects/eboy/eboy-static/catalog.css branches/xml-class-rework/projects/eboy/eboy-static/catalog.html branches/xml-class-rework/projects/eboy/eboy-static/catalog.js branches/xml-class-rework/projects/eboy/eboy-templates/toplevel.bknr branches/xml-class-rework/projects/eboy/src/breadcrumb.lisp branches/xml-class-rework/projects/eboy/src/dynasite-tags.lisp branches/xml-class-rework/projects/eboy/src/eboy-web.lisp branches/xml-class-rework/projects/eboy/src/item-handlers.lisp branches/xml-class-rework/projects/eboy/src/item.lisp branches/xml-class-rework/projects/eboy/src/jerks.lisp branches/xml-class-rework/projects/eboy/src/layout.lisp branches/xml-class-rework/projects/eboy/src/load.lisp branches/xml-class-rework/projects/eboy/src/navi.lisp branches/xml-class-rework/projects/eboy/src/packages.lisp branches/xml-class-rework/projects/lisp-ecoop/website/templates/contact.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/home.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl branches/xml-class-rework/projects/lisp-ecoop/website/templates/profile.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/submissions.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml branches/xml-class-rework/projects/quickhoney/src/handlers.lisp branches/xml-class-rework/projects/raw-data/mcp/hameg-server.pl branches/xml-class-rework/tools/make-core.lisp Log: Get rid of the thirdparty tree. We'll try to use whatever packages the user installed. make-core.lisp now assumes home:central-repository/ as additional search path for asdf packages. Modified: branches/xml-class-rework/projects/bos/build.lisp =================================================================== --- branches/xml-class-rework/projects/bos/build.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/build.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -1,6 +1,7 @@ (in-package :bos.build) (handler-bind ((style-warning #'muffle-warning)) + (asdf:operate 'asdf:load-op :aserve) (asdf:operate 'asdf:load-op :bos.web)) ;;; Modified: branches/xml-class-rework/projects/bos/m2/allocation.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/allocation.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/m2/allocation.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -473,6 +473,7 @@ (right (+ left width)) (bottom (+ top height)) (vertices (allocation-area-vertices (stripe-area stripe)))) + (format t "right ~A bottom ~A~%" right bottom) (when (stripe-full-p stripe) ;; Gleich NIL liefern, und den Stripe beseitigen, damit wir ihn nicht ;; wieder antreffen in Zukunft. Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -279,8 +279,19 @@ (unless (and (integerp m2-count) (plusp m2-count)) (error "number of square meters must be a positive integer")) - (do-make-contract sponsor m2-count :date date :paidp paidp :expires expires)) + (let ((contract (do-make-contract sponsor m2-count :date date :paidp paidp :expires expires))) + (unless contract + (send-system-mail :subject "Contact creation failed - Allocation areas exhaused" + :text (format nil "A contract for ~A square meters could not be created, presumably because no +suitable allocation area was found. Please check the free allocation +areas and add more space. +Sponsor-ID: ~A +" + m2-count (store-object-id sponsor))) + (error "could not create contract, allocation areas exhausted?")) + contract)) + (defun number-of-sold-sqm () (let ((retval 0)) (dolist (contract (remove-if-not #'contract-paidp (class-instances 'contract))) Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm 2006-02-17 21:12:10 UTC (rev 1841) @@ -30,6 +30,7 @@ } --> </style> + <meta http-equiv="imagetoolbar" content="no"/> </head> <body> <table width="740" height="500" border="0" cellpadding="0" cellspacing="0"> @@ -309,7 +310,7 @@ </div> <div id="qmDetail" style="position:absolute; width:1px; height:1; z-index:4; left: 0px; top: 0px; visibility: hidden;"> <div id="qmDetailKarte" style="position:absolute; width:360px; height:390px; z-index:1; left: 169px; top: 100px; visibility: inherit;" class="KarteRahmen"> - <div id="qmLupe" style="position:absolute; width:36px; height:24px; z-index:11; visibility: inherit;"><img src="../bilder/lupe.gif" width="36" height="24"/></div> + <div id="qmLupe" style="position:absolute; width:36px; height:24px; z-index:11; visibility: inherit; cursor: pointer;"><img src="../bilder/lupe.gif" width="36" height="24"/></div> <div id="LayersMenu" class="KarteRahmen" style="position: absolute; bottom: 31px; right: 1px; z-index: 15; visibility: inherit;"> <table width="90" border="0" cellspacing="0" cellpadding="0"> <tr> Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm 2006-02-17 21:12:10 UTC (rev 1841) @@ -30,6 +30,7 @@ } --> </style> + <meta http-equiv="imagetoolbar" content="no"/> </head> <body> <table width="740" height="500" border="0" cellpadding="0" cellspacing="0"> Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-02-17 21:12:10 UTC (rev 1841) @@ -336,6 +336,7 @@ // der Datensatz wird vorher auf Nullwerte gesetzt damit fals keine Daten in der URL enthalten sind der Quadratmeter als unverkauft angezeigt wird m2complete = false; + document.body.style.cursor = 'wait'; timer=0; n_profil = []; n_profil['name'] = msg("noch nicht verkauft"); @@ -397,13 +398,14 @@ } document.getElementById("qmInfoText").innerHTML = text; n_qm_erzeugen(); + document.body.style.cursor = 'auto'; } else { // wenn der Datensatz noch nicht komplett geladen ist wird der timer eroeht und die Funktion nochmal gestartet timer++; if (timer < 100) { setTimeout("n_qm_warten()", 100); } else { - document.getElementById("qmLaden").style.visibility = "hidden"; schreibe_debugger(" -> Nachbar-Quadratmeter konnten nicht geladen werden"); + document.getElementById("qmLaden").style."hidden"; schreibe_debugger(" -> Nachbar-Quadratmeter konnten nicht geladen werden"); } } return true; Modified: branches/xml-class-rework/projects/eboy/eboy-static/catalog.css =================================================================== --- branches/xml-class-rework/projects/eboy/eboy-static/catalog.css 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/eboy-static/catalog.css 2006-02-17 21:12:10 UTC (rev 1841) @@ -138,3 +138,9 @@ .selected-keyword { background-color: #88f; } + +iframe#execute-frame { + width: 0px; + height: 0px; + visibilty: hidden; +} \ No newline at end of file Modified: branches/xml-class-rework/projects/eboy/eboy-static/catalog.html =================================================================== --- branches/xml-class-rework/projects/eboy/eboy-static/catalog.html 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/eboy-static/catalog.html 2006-02-17 21:12:10 UTC (rev 1841) @@ -68,6 +68,6 @@ </div> <div id="debugger"> </div> - <iframe src="about:blank" name="execute" id="execute"></iframe> + <iframe src="about:blank" name="execute-frame" id="execute-frame"></iframe> </body> </html> \ No newline at end of file Modified: branches/xml-class-rework/projects/eboy/eboy-static/catalog.js =================================================================== --- branches/xml-class-rework/projects/eboy/eboy-static/catalog.js 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/eboy-static/catalog.js 2006-02-17 21:12:10 UTC (rev 1841) @@ -19,7 +19,7 @@ function init() { - document.debug = true; + document.debug = false; var url = document.location.href; @@ -230,7 +230,7 @@ debug(operation + ' keyword "' + keyword + '" for image ' + image_description.id); - document.frames['execute'].window.location.replace('/edit-image/' + image_description.id + '?image-id=' + image_description.id + '&action=edit&' + operation + '=' + keyword); + document.getElementById('execute-frame').window.location.replace('/edit-image/' + image_description.id + '?batch=1&image-id=' + image_description.id + '&action=edit&' + operation + '=' + keyword); refresh_image_info(); Modified: branches/xml-class-rework/projects/eboy/eboy-templates/toplevel.bknr =================================================================== --- branches/xml-class-rework/projects/eboy/eboy-templates/toplevel.bknr 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/eboy-templates/toplevel.bknr 2006-02-17 21:12:10 UTC (rev 1841) @@ -1,7 +1,10 @@ <?xml version="1.0" encoding="iso-8859-1"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> -<html lang="en" xml:lang="en"> +<html + lang="en" xml:lang="en" + xmlns:bknr="http://bknr.net/" + xmlns:eboy="http://eboy.com/"> <head> <link rel="SHORTCUT ICON" href="/image/favicon" /> <link rel="stylesheet" href="/adm/$(mycolor).css" /> Modified: branches/xml-class-rework/projects/eboy/src/breadcrumb.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/breadcrumb.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/breadcrumb.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -43,6 +43,6 @@ (in-package :eboy-commands) -(define-bknr-tag breadcrumb (&key (depth 2)) +(define-bknr-tag breadcrumb () (html ((:div :class "breadcrumb") (:princ (caar (form-urlencoded-to-query (uri-path (request-uri *req*)))))))) \ No newline at end of file Modified: branches/xml-class-rework/projects/eboy/src/dynasite-tags.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/dynasite-tags.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/dynasite-tags.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -37,7 +37,7 @@ (let ((host (http-session-host *session*))) (make-object 'mail :subject (format nil "feedback from ~A (~A)" - (user-login *user*) + (bknr.user:user-login *user*) (when host (host-name host))) :body feedback))) Modified: branches/xml-class-rework/projects/eboy/src/eboy-web.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/eboy-web.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/eboy-web.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -29,7 +29,7 @@ (:template-/ template-handler :prefix "/" :command-packages - ((:bknr . :bknr.web.commands) + ((:bknr . :bknr.web) (:eboy . :eboy-commands)) :destination ,+templates-directory+)) :modules '(user mailinglist mailinglist-registration images stats))) Modified: branches/xml-class-rework/projects/eboy/src/item-handlers.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/item-handlers.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/item-handlers.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -4,10 +4,10 @@ ;;; links (defmethod edit-object-url ((item item)) - (format nil "~a/~a" (handler-url :edit-item) (store-object-id item))) + (format nil "/edit-item/~a" (store-object-id item))) (defmethod object-url ((item item)) - (format nil "~a/~a" (handler-url :item) (store-object-id item))) + (format nil "/item/~a" (store-object-id item))) (defmethod html-link ((item item)) (html @@ -27,7 +27,7 @@ (if item (html (:h1 "editing item " (:princ-safe (article-subject item)))) (html (:h1 "edit existing item:") - (:ul (dolist (item (store-objects (current-store) 'item)) + (:ul (dolist (item (class-instances 'item)) (html (:li ((:a :href (edit-object-url item)) (:princ-safe (string-downcase (item-name item))) ": " @@ -74,7 +74,7 @@ (image-collection (item-images item :include-poster nil) :url "/edit-image/")))) (:p (submit-button "save" "save") (when item (submit-button "delete" "delete" - :onClick "javascript:return confirm('Really delete item?');"))))))) + :confirm "Really delete item?"))))))) (defmethod authorized-p ((handler edit-item-handler) req) (admin-p (bknr-request-user req))) @@ -106,6 +106,6 @@ (defmethod handle-object-form ((handler edit-item-handler) (action (eql :delete)) item req) - (delete-store-object item) + (delete-object item) (with-bknr-page (req :title "item has been deleted") (html "item has been deleted"))) \ No newline at end of file Modified: branches/xml-class-rework/projects/eboy/src/item.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/item.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/item.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -25,11 +25,11 @@ (random-elt (item-images item))))) (defun item-with-name (keyword) - (find keyword (store-objects (current-store) 'item) :key #'item-name)) + (find keyword (class-instances 'item) :key #'item-name)) (defun all-items () "return all items which have matching images" - (remove nil (store-objects (current-store) 'item) :key #'item-images)) + (remove nil (class-instances 'item) :key #'item-images)) (defun find-item-keywords () (reduce #'union (all-items) :key #'item-keywords)) Modified: branches/xml-class-rework/projects/eboy/src/jerks.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/jerks.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/jerks.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -54,8 +54,7 @@ (pop bottom)) res)))) (defun autojerk-img-url (autojerk &key (proc "")) - (format nil "~a/~a,~a,~a~a" - (handler-url :autojerk-image) + (format nil "/autojerk-image/~a,~a,~a~a" (store-object-id (first autojerk)) (store-object-id (second autojerk)) (store-object-id (third autojerk)) Modified: branches/xml-class-rework/projects/eboy/src/layout.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/layout.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/layout.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -76,23 +76,22 @@ (store-image-name (cell-image cell))) (defmethod cell-as-html ((cell image-cell) &key background type detail-url) - (let ((image (cell-image cell))) - (html ((:div :class "item_box" :style (format nil "height: ~apx; width: ~apx" (cell-height cell) (cell-width cell))) - ((:a :href (format nil "~a/~a" detail-url (cell-name cell))) - ((:img :src (format nil "/image/~a/cell,~a,~a,~a,~a" - (store-image-name (cell-image cell)) - background - (cell-width cell) - (cell-image-height cell) - type) - :width (format nil "~a" (cell-width cell)) - :height (format nil "~a" (cell-image-height cell)) - :alt (or (cell-caption cell) (cell-name cell))))) - (when (and (image-layout-captions (cell-layout cell)) - (cell-caption cell)) - (html ((:div :class "item_text") - ((:a :href (format nil "~a/~a" detail-url (cell-name cell))) - (:princ (cell-caption cell)))))))))) + (html ((:div :class "item_box" :style (format nil "height: ~apx; width: ~apx" (cell-height cell) (cell-width cell))) + ((:a :href (format nil "~a/~a" detail-url (cell-name cell))) + ((:img :src (format nil "/image/~a/cell,~a,~a,~a,~a" + (store-image-name (cell-image cell)) + background + (cell-width cell) + (cell-image-height cell) + type) + :width (format nil "~a" (cell-width cell)) + :height (format nil "~a" (cell-image-height cell)) + :alt (or (cell-caption cell) (cell-name cell))))) + (when (and (image-layout-captions (cell-layout cell)) + (cell-caption cell)) + (html ((:div :class "item_text") + ((:a :href (format nil "~a/~a" detail-url (cell-name cell))) + (:princ (cell-caption cell))))))))) (defmethod cell-object ((cell image-cell)) (cell-image cell)) Modified: branches/xml-class-rework/projects/eboy/src/load.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/load.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/load.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -2,6 +2,6 @@ (asdf:oos 'asdf:load-op :swank) -(swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t) +(swank::create-swank-server 4008 :spawn #'swank::simple-announce-function t) (mp::startup-idle-and-top-level-loops) Modified: branches/xml-class-rework/projects/eboy/src/navi.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/navi.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/navi.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -41,7 +41,7 @@ (define-bknr-tag secondlevelmenu () "Erzeugt das Second-Level-Men�" (destructuring-bind - (empty first-level &optional second-level &rest rest) + (empty first-level &rest rest) (split "/" (uri-path (request-uri *req*))) (declare (ignore empty rest)) (dolist (choice (website-menu *current-website*)) Modified: branches/xml-class-rework/projects/eboy/src/packages.lisp =================================================================== --- branches/xml-class-rework/projects/eboy/src/packages.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/eboy/src/packages.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -17,7 +17,13 @@ :bknr.images :bknr.user :puri) - (:shadowing-import-from :cl-interpol quote-meta-chars)) + (:shadowing-import-from :cl-interpol quote-meta-chars) + (:export #:find-item + #:item-images + #:item-poster-image + #:all-items + #:item-image-keywords + #:item-keywords)) (defpackage :eboy.tests (:use :cl :eboy :unit-test)) @@ -33,7 +39,11 @@ :bknr.web :bknr.datastore :bknr.utils - :bknr.rss) + :bknr.rss + :bknr.images + :bknr.mail + :bknr.sysparams + :bknr.text) (:shadowing-import-from :cl-interpol quote-meta-chars) (:export ;; tags Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/contact.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/contact.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/contact.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -4,6 +4,6 @@ <h1>Contact</h1> Workshop related: <a href="mailto:pc@p-cos.net">Pascal Costanza</a> - Website related: <a href="mailto:hans@bknr.net">Hans Hüber</a> + Website related: <a href="mailto:hans@bknr.net">Hans Hübner</a> </page> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -6,7 +6,7 @@ title="Edit Profile" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" > <h1>Participant Profile Editor</h1> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -6,7 +6,7 @@ title="Edit Submission" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" > <h1>Submission Editor</h1> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/home.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/home.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/home.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -16,16 +16,21 @@ <h1>Information for Attendees</h1> -Registration of workshop participants has to be done in three mandatory steps: -<ol> -<li>Contact the organizers of the workshop (in order to ensure that the participant limit has not been exceeded).</li> -<li>Advance registration to the workshop is handled through the primary -contact person of the workshop, Pascal Costanza (<a +Registration of workshop participants has to be done in three +mandatory steps: + +<ol> <li>Contact the organizers of the workshop (in order to +ensure that the participant limit has not been exceeded).</li> +<li>Advance registration to the workshop is handled through the +primary contact person of the workshop, Pascal Costanza (<a href="mailto:pc@p-cos.net">pc(a)p-cos.net</a>). Please contact him by regular email with your submission or input to the workshop in order to receive your login to the workshop website. Include your preferred login name for the workshop website with your application.</li> -<li>Register on the <a href="http://2006.ecoop.rg">ECOOP 2006 web site</a> either as a worskhop-only attendee or as a regular attendee. The latter includes access to workshops and to the main conference.</li> +<li>Register on the <a href="http://2006.ecoop.org">ECOOP 2006 web +site</a> either as a +worskhop-only attendee or as a regular attendee. The +latter includes access to workshops and to the main conference.</li> </ol> <!-- Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl 2006-02-17 21:12:10 UTC (rev 1841) @@ -1,5 +1,6 @@ <?xml version="1.0" encoding="iso-8859-1" ?> -<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net"> <xsl:param name="mode">xml</xsl:param> @@ -8,7 +9,7 @@ omit-xml-declaration="yes" doctype-public="-//W3C//DTD HTML 4.0 Strict//EN" /> - <xsl:template match="/page"> + <xsl:template match="/lisp-ecoop:page"> <html xmlns="http://www.w3.org/1999/xhtml"> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/profile.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/profile.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/profile.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -6,7 +6,7 @@ title="Edit Profile" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" > <lisp-ecoop:profile> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -6,7 +6,7 @@ title="Edit Submission" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" > <lisp-ecoop:load-argument-object> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/submissions.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/submissions.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/submissions.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -1,6 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> -<page name="submissions"> +<lisp-ecoop:page name="submissions" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net"> <h1>Submissions</h1> @@ -12,4 +13,4 @@ <h2>Breakout group proposals</h2> <lisp-ecoop:submission-list type="breakout-group-proposal"/> -</page> +</lisp-ecoop:page> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -3,7 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" xmlns:bknr="http://bknr.net" xmlns:menu="http://bknr.net/menu" > Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml 2006-02-17 21:12:10 UTC (rev 1841) @@ -4,7 +4,7 @@ <html xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop06="http://lisp-ecoop06.bknr.net" + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" xmlns:menu="http://bknr.net/menu" > Your request could not be processed because an error occured: Modified: branches/xml-class-rework/projects/quickhoney/src/handlers.lisp =================================================================== --- branches/xml-class-rework/projects/quickhoney/src/handlers.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/quickhoney/src/handlers.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -44,7 +44,7 @@ (format nil " new parent.ServerImage(~S, ~D, ~S, ~D, ~D, ~S)" (store-image-name image) (store-object-id image) - (image-content-type (blob-type image)) + (image-content-type (blob-mime-type image)) (store-image-width image) (store-image-height image) (or (quickhoney-image-client image) ""))) Modified: branches/xml-class-rework/projects/raw-data/mcp/hameg-server.pl =================================================================== --- branches/xml-class-rework/projects/raw-data/mcp/hameg-server.pl 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/projects/raw-data/mcp/hameg-server.pl 2006-02-17 21:12:10 UTC (rev 1841) @@ -13,6 +13,8 @@ die "can't open hameg port $comPort: $!\n" unless ($hameg); $hameg->autoflush(1); +system("stty 38400 icanon cread cs8 -parenb < $comPort"); + while (1) { my $mcp = IO::Socket::INET->new($mcpAddress); Modified: branches/xml-class-rework/tools/make-core.lisp =================================================================== --- branches/xml-class-rework/tools/make-core.lisp 2006-02-17 21:05:51 UTC (rev 1840) +++ branches/xml-class-rework/tools/make-core.lisp 2006-02-17 21:12:10 UTC (rev 1841) @@ -6,6 +6,7 @@ (defparameter *src-directory* (make-pathname :directory (pathname-directory *load-truename*))) (defparameter *bknr-directory* (merge-pathnames #p"bknr-svn/" (user-homedir-pathname))) +(defparameter *central-repository* (merge-pathnames #p"central-repository/" (user-homedir-pathname))) #+cmu #-cmu19b (load (merge-pathnames "bknr/patches/patch-around-mop-cmucl19a.lisp" *bknr-directory*))

1 0

[bknr-cvs] r1840 - in trunk: bknr/src/data bknr/src/web bknr/src/xml-impex projects projects/bknr-website/templates projects/lisp-ecoop05/src
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 15:05:51 -0600 (Fri, 17 Feb 2006) New Revision: 1840 Added: trunk/projects/lisp-ecoop05/ Removed: trunk/bknr/src/xml-impex/xml-update.lisp trunk/projects/lisp-ecoop/ Modified: trunk/bknr/src/data/object.lisp trunk/bknr/src/web/handlers.lisp trunk/bknr/src/xml-impex/xml-class.lisp trunk/bknr/src/xml-impex/xml-import.lisp trunk/projects/bknr-website/templates/generate-html.xsl trunk/projects/lisp-ecoop05/src/alu-logo.jpg trunk/projects/lisp-ecoop05/src/bknr-logo.png Log: Back out changes in trunk back to 1827 in the hopes to have trunk in a useable state. I'm moving my current project work to the branch xml-class-rework as some of the changes will introduce incompatibilties to the existing and documented xml-class API (among others). Modified: trunk/bknr/src/data/object.lisp =================================================================== --- trunk/bknr/src/data/object.lisp 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/bknr/src/data/object.lisp 2006-02-17 21:05:51 UTC (rev 1840) @@ -204,26 +204,20 @@ (relaxed-object-reference-slot-p slot)))) (defmacro define-persistent-class (class (&rest superclasses) slots &rest class-options) - (let ((superclasses (or superclasses '(store-object))) - (metaclass (cadr (assoc :metaclass class-options)))) - (when (and metaclass - (not (validate-superclass (find-class metaclass) - (find-class 'persistent-class)))) - (error "Can not define a persistent class with metaclass ~A." metaclass)) + (let ((superclasses (or superclasses '(store-object)))) + (when (member :metaclass class-options :key #'car) + (error "Can not define a persistent class with a metaclass.")) `(define-bknr-class ,class ,superclasses ,slots - ,@(unless metaclass '(:metaclass persistent-class)) + (:metaclass persistent-class) ,@class-options))) (defmacro defpersistent-class (class (&rest superclasses) slots &rest class-options) - (let ((superclasses (or superclasses '(store-object))) - (metaclass (cadr (assoc :metaclass class-options)))) - (when (and metaclass - (not (validate-superclass (find-class metaclass) - (find-class 'persistent-class)))) - (error "Can not define a persistent class with metaclass ~A." metaclass)) + (let ((superclasses (or superclasses '(store-object)))) + (when (member :metaclass class-options :key #'car) + (error "Can not define a persistent class with a metaclass.")) `(eval-when (:compile-toplevel :load-toplevel :execute) (defclass ,class ,superclasses ,slots - ,@(unless metaclass '(:metaclass persistent-class)) + (:metaclass persistent-class) ,@class-options)))) #+nil Modified: trunk/bknr/src/web/handlers.lisp =================================================================== --- trunk/bknr/src/web/handlers.lisp 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/bknr/src/web/handlers.lisp 2006-02-17 21:05:51 UTC (rev 1840) @@ -446,10 +446,9 @@ :string-rod-fn #'cxml::utf8-string-to-rod)) (defmethod handle-object ((handler xml-object-list-handler) object req) - (let ((element-name (xml-object-list-handler-toplevel-element-name handler))) - (cxml:with-element element-name - (dolist (object (object-list-handler-get-objects handler object req)) - (object-list-handler-show-object-xml handler object req))))) + (cxml:with-element (xml-object-list-handler-toplevel-element-name handler) + (dolist (object (object-list-handler-get-objects handler object req)) + (object-list-handler-show-object-xml handler object req)))) (defclass blob-handler (object-handler) ()) Modified: trunk/bknr/src/xml-impex/xml-class.lisp =================================================================== --- trunk/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/bknr/src/xml-impex/xml-class.lisp 2006-02-17 21:05:51 UTC (rev 1840) @@ -2,22 +2,8 @@ (defclass xml-class (indexed-class) ((dtd :initarg :dtd :initform nil :accessor xml-class-dtd) - (element :initarg :element :initform nil :accessor xml-class-element) - (unique-id-slot :initarg :unique-id-slot :initform nil - :documentation "if set to a slot name, this -signals that the slot can be used as a unique id to refer to an -instance of the object in a n XML update operation") - (unique-id-reader :initarg :unique-id-reader :initform nil - :documentation "if set to a function, this -signals that the function can be used as a unique index-reader when -used in XML update operations."))) + (element :initarg :element :initform nil :accessor xml-class-element))) -(defmethod xml-class-unique-id-slot ((class xml-class)) - (first (slot-value class 'unique-id-slot))) - -(defmethod xml-class-unique-id-reader ((class xml-class)) - (eval (first (slot-value class 'unique-id-reader)))) - (defmethod validate-superclass ((sub xml-class) (super indexed-class)) t) @@ -45,7 +31,7 @@ (object-to-id :initarg :object-to-id :initform nil :documentation "Function used to get the ID of the object stored in the slot.") - + (parent :initarg :parent :initform nil :documentation "Slot is a pointer to the parent object."))) @@ -115,14 +101,11 @@ (error "Attribute ~A is not a CXML attdef." attribute)) attribute)))) -(defmethod initialize-elmdef ((class xml-class) dtd elm) +(defmethod initialize-elmdef ((class xml-class) dtd elmdef) (let* ((dtd (get-dtd dtd)) - elmdef) - (when elm - (setf elmdef (get-dtd-elmdef dtd elm)) - (unless elmdef - (error "Could not find an element definition for class ~A, elmdef ~A." - (class-name class) elm))) + (elmdef (when elmdef (get-dtd-elmdef dtd elmdef)))) + (unless elmdef + (error "Could not find an element definition for ~A." class)) (setf (xml-class-dtd class) dtd (xml-class-element class) elmdef))) Modified: trunk/bknr/src/xml-impex/xml-import.lisp =================================================================== --- trunk/bknr/src/xml-impex/xml-import.lisp 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/bknr/src/xml-impex/xml-import.lisp 2006-02-17 21:05:51 UTC (rev 1840) @@ -6,6 +6,12 @@ (root-elt :initform nil :accessor importer-root-elt) (parent-elts :initform nil :accessor importer-parent-elts))) +(defclass xml-class-instance () + ((initforms :initform nil :initarg :initforms :reader instance-initforms) + (children :initarg :children :accessor instance-children) + (elmdef :initarg :elmdef :accessor instance-elmdef) + (class :initarg :class :initform nil :accessor instance-class))) + (defmethod slot-parse-value ((slot xml-effective-slot-definition) value) (with-slots (parser id-to-object) slot (when parser @@ -14,149 +20,49 @@ (setf value (funcall id-to-object value))) value)) -;;; description for an object instance to be created from the xml. The -;;; data is gathered while parsing the XML, and at the end of an -;;; element, the corresponding object is instanciated. +(defmethod xml-class-attribute-initforms ((class xml-class) attributes) + (let (results) + (dolist (attr attributes) + (let ((slot (xml-class-find-attribute-slot class (sax:attribute-qname attr)))) + (when slot + (push (first (slot-definition-initargs slot)) results) + (push (slot-parse-value slot (sax:attribute-value attr)) results)))) + (nreverse results))) -(defclass xml-node () - ((element :initarg :element :accessor node-element) - (children :initarg :children :initform (make-hash-table) :accessor node-children) - (elmdef :initarg :elmdef :accessor instance-elmdef) - (attributes :initarg :attributes :accessor node-attributes) - (data :initarg :data :initform nil :accessor node-data))) - -(defmethod print-object ((node xml-node) stream) - (print-unreadable-object (node stream :type t) - (format stream "~a" (node-element node)))) - -(defclass xml-class-instance (xml-node) - ((slots :initform (make-hash-table :test #'equal) :accessor instance-slots) - (class :initarg :class :initform nil :accessor instance-class))) - -(defmethod print-object ((instance xml-class-instance) stream) - (print-unreadable-object (instance stream :type t) - (format stream "~a" (instance-class instance)))) - -(defgeneric importer-add-attribute (handler node attr)) -(defgeneric importer-add-characters (handler node data)) -(defgeneric importer-add-element (handler node element value)) -(defgeneric importer-finalize (handler node)) - -(defmethod importer-add-attribute ((handler xml-class-importer) - (class-instance xml-class-instance) attr) - (with-slots (class slots) class-instance - (let ((slot (xml-class-find-attribute-slot class (sax:attribute-qname attr)))) - (when slot - (setf (gethash slot slots) (slot-parse-value slot (sax:attribute-value attr))))))) - -(defmethod importer-add-attribute ((handler xml-class-importer) - (node xml-node) attr) - nil) - -(defmethod importer-add-characters ((handler xml-class-importer) - (node xml-node) characters) - (unless (whitespace-p characters) - (setf characters (string-trim bknr.utils::+whitespace-chars+ characters)) - (with-slots (data) node - (setf data (if data - (concatenate 'string data characters) - characters))))) - -(defmethod importer-add-characters ((handler xml-class-importer) - (instance xml-class-instance) characters) - (with-slots (class elmdef slots children) instance - (let ((slot (xml-class-body-slot class))) - (when slot - (setf (gethash slot slots) (slot-parse-value slot characters)))))) - -(defmethod importer-add-element ((handler xml-class-importer) - (node xml-node) element value) - (with-slots (children) node - (push value (gethash (make-keyword-from-string element) children)))) - -(defmethod importer-add-element ((handler xml-class-importer) - (instance xml-class-instance) element value) - (with-slots (slots elmdef class children) instance - (let ((slot (xml-class-find-element-slot class element))) - (when slot - ;; parse the value if necessary - (setf value (slot-parse-value slot value)) - (let ((containment (xml-effective-slot-definition-containment slot))) - (if (member containment '(:* :+)) - ;; if it has a plural containment, push the - ;; created instance into the initargs hash - (push value (gethash slot slots)) - ;; else set the initarg hash to the new instance - (setf (gethash slot slots) value))))))) - -(defmethod importer-finalize ((handler xml-class-importer) - (node xml-node)) - (with-slots (data children) node - (cond - ((and data - (= (hash-table-count children) 0)) data) - ((> (hash-table-count children) 0) - (children-to-initforms (node-children node))) - (t nil)))) - -(defun add-parent (handler parent child) - (let* ((class (class-of child)) - (parent-slot (when (typep class 'xml-class) - (xml-class-parent-slot class)))) - (when parent-slot - (set-slot-value handler child (slot-definition-name parent-slot) parent)))) - -(defun slots-to-initforms (slots) - (let (initforms) - (loop for slot being the hash-keys of slots using (hash-value value) - when (listp value) - do (push (reverse value) initforms) - else do (push value initforms) - do (push (first (slot-definition-initargs slot)) initforms)) - initforms)) - -(defmethod importer-finalize ((handler xml-class-importer) - (instance xml-class-instance)) - (with-slots (class elmdef children slots) instance - (let* ((initforms (slots-to-initforms slots)) - (object (apply #'create-instance handler (class-name class) initforms))) - - (loop for objs being the hash-values of slots - when (listp objs) - do (dolist (child objs) - (add-parent handler object child)) - else do (add-parent handler object objs)) - - object))) - (defmethod sax:start-document ((handler xml-class-importer)) (setf (importer-root-elt handler) nil)) (defmethod sax:start-element ((handler xml-class-importer) namespace-uri local-name qname attrs) (declare (ignore namespace-uri local-name)) - (let ((class (gethash qname (importer-class-hash handler))) - (element (cxml::string-rod qname)) - instance) + (let ((class (gethash qname (importer-class-hash handler)))) (if class - (setf instance - (make-instance 'xml-class-instance - :element element - :elmdef (xml-class-element class) - :class class)) - (setf instance - (make-instance 'xml-node - :element element - :elmdef (cxml::find-element element (importer-dtd handler))))) + (let ((instance (make-instance 'xml-class-instance + :children (make-hash-table) + :initforms (xml-class-attribute-initforms class attrs) + :elmdef (xml-class-element class) + :class class))) + (push instance (importer-parent-elts handler))) + (let ((instance (make-instance 'xml-class-instance + :children (make-hash-table) + :initforms nil + :elmdef (cxml::find-element (cxml::string-rod qname) + (importer-dtd handler)) + :class nil))) + (push instance (importer-parent-elts handler)))))) - (dolist (attr attrs) - (importer-add-attribute handler instance attr)) - - (push instance (importer-parent-elts handler)))) - (defmethod sax:characters ((handler xml-class-importer) data) (unless (importer-parent-elts handler) (error "Can not parse SAX:CHARACTERS without a parent element.")) - (importer-add-characters handler (first (importer-parent-elts handler)) data)) + (let ((instance (first (importer-parent-elts handler)))) + (with-slots (class elmdef initforms children) instance + (if class + (let ((slot (xml-class-body-slot class))) + (when slot + (push (funcall (xml-effective-slot-definition-parser slot) data) initforms) + (push (first (slot-definition-initargs slot)) initforms))) + (unless (whitespace-p data) + (setf data (string-trim bknr.utils::+whitespace-chars+ data)) + (setf initforms (if initforms (concatenate 'string initforms data) data))))))) (defmethod create-instance ((handler xml-class-importer) class-name &rest initargs) (apply #'make-instance class-name initargs)) @@ -166,15 +72,43 @@ (defmethod sax:end-element ((handler xml-class-importer) namespace-uri local-name qname) (declare (ignore namespace-uri local-name)) + (let ((instance (pop (importer-parent-elts handler)))) + (with-slots (class initforms elmdef children) instance + (loop for key being the hash-keys of children using (hash-value value) + when (listp value) + do (push (reverse value) initforms) + else do (push value initforms) + do (push key initforms)) + + (let ((instance (if class + (apply #'create-instance handler (class-name class) initforms) + initforms))) - (let* ((instance (pop (importer-parent-elts handler))) - (final (importer-finalize handler instance)) - (parent (first (importer-parent-elts handler)))) + (when class + (loop for objs being the hash-values of children + when (listp objs) + do (loop for child in objs + for child-class = (class-of child) + for parent-slot = (when (typep child-class 'xml-class) + (xml-class-parent-slot (class-of child))) + when parent-slot + do (set-slot-value handler child (slot-definition-name parent-slot) instance)))) - (when parent - (importer-add-element handler parent qname final)) - - (setf (importer-root-elt handler) final))) + (let ((parent (first (importer-parent-elts handler)))) + (when parent + (if (instance-class parent) + (let ((slot (xml-class-find-element-slot (instance-class parent) qname))) + (when slot + (setf instance (slot-parse-value slot instance)) + (let ((containment (xml-effective-slot-definition-containment slot))) + (if (member containment '(:* :+)) + (push instance (gethash (first (slot-definition-initargs slot)) + (instance-children parent))) + (setf (gethash (first (slot-definition-initargs slot)) + (instance-children parent)) instance))))) + (push instance (gethash (make-keyword-from-string qname) + (instance-children parent)))))) + (setf (importer-root-elt handler) instance))))) (defun parse-xml-file (xml-file classes &key (recoder #'cxml::rod-string) (importer-class 'xml-class-importer)) Deleted: trunk/bknr/src/xml-impex/xml-update.lisp =================================================================== --- trunk/bknr/src/xml-impex/xml-update.lisp 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/bknr/src/xml-impex/xml-update.lisp 2006-02-17 21:05:51 UTC (rev 1840) @@ -1,39 +0,0 @@ -(in-package :bknr.impex) - -;;; sax parser for xml impex updater, reads updates to objects from an xml file - -(defclass xml-class-updater (xml-class-importer) - ()) - -(defun class-find-slot (class slot-name) - (find-if #'(lambda (slot) - (equal (slot-definition-name slot) slot-name)) - (mop:class-slots class))) - -(defmethod importer-finalize ((handler xml-class-updater) - (instance xml-class-instance)) - (with-slots (class slots) instance - (if (and (xml-class-unique-id-slot class) - (xml-class-unique-id-reader class)) - (let* ((id-slot (class-find-slot class (xml-class-unique-id-slot class))) - (id-value (gethash id-slot slots)) - (obj (when id-value (funcall (xml-class-unique-id-reader class) id-value)))) - (if (and obj id-value) - (progn - (loop for slot being the hash-keys of slots using (hash-value value) - when (not (equal (slot-definition-name slot) (xml-class-unique-id-slot class))) - do - (format t "updating slot ~A with ~S~%" (slot-definition-name slot) - value) - (setf (slot-value obj (slot-definition-name slot)) - value)) - obj) - (progn - (warn "no id-value or object found, creating new~%") - (call-next-method)))) - - (call-next-method)))) - -(defun parse-xml-update-file (xml-file classes &key (recoder #'cxml::rod-string) - (importer-class 'xml-class-updater)) - (parse-xml-file xml-file classes :recoder recoder :importer-class importer-class)) Modified: trunk/projects/bknr-website/templates/generate-html.xsl =================================================================== --- trunk/projects/bknr-website/templates/generate-html.xsl 2006-02-17 20:55:40 UTC (rev 1839) +++ trunk/projects/bknr-website/templates/generate-html.xsl 2006-02-17 21:05:51 UTC (rev 1840) @@ -1,4 +1,4 @@ <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> <xsl:output mode="text" omit-xml-declaration="yes" /> <xsl:template match="item">xsltproc --stringparam mode html -o ../html/<xsl:value-of select="@url"/>.html <xsl:value-of select="@url"/>.xml</xsl:template> -</xsl:stylesheet> +</xsl:stylesheet> \ No newline at end of file Copied: trunk/projects/lisp-ecoop05 (from rev 1827, trunk/projects/lisp-ecoop05)

1 0

[bknr-cvs] r1839 - branches/xml-class-rework/bknr/src/web
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 14:55:40 -0600 (Fri, 17 Feb 2006) New Revision: 1839 Modified: branches/xml-class-rework/bknr/src/web/templates.lisp Log: Change file type of template files to "xml". This makes it easier to work with the files using default file types of the operating system. Modified: branches/xml-class-rework/bknr/src/web/templates.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/templates.lisp 2006-02-17 20:52:07 UTC (rev 1838) +++ branches/xml-class-rework/bknr/src/web/templates.lisp 2006-02-17 20:55:40 UTC (rev 1839) @@ -216,7 +216,7 @@ (let ((result (multiple-value-list (find-template next-dir (cdr components))))) (when (car result) (return-from find-template (values-list result))))) - (let ((file (merge-pathnames (make-pathname :type "bknr" + (let ((file (merge-pathnames (make-pathname :type "xml" :name (first components)) dir))) (when (probe-file file) @@ -248,14 +248,6 @@ (setf (gethash namestring table) cache-entry)) (cdr cache-entry))) -#+nil -(defmethod make-template-pathname ((page-handler template-handler) template-name) - (merge-pathnames - (make-pathname :type "bknr") - (pathname (concatenate 'string - (namestring (template-handler-destination page-handler)) - template-name)))) - (defun send-error-response (handler req message &key (response-code *response-internal-server-error*)) (let* ((pathname (find-template-pathname handler "user-error" :request req)) (template (get-cached-template pathname handler)))

1 0

[bknr-cvs] r1838 - in branches/xml-class-rework/bknr/src: . data web xml-impex
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 14:52:07 -0600 (Fri, 17 Feb 2006) New Revision: 1838 Modified: branches/xml-class-rework/bknr/src/bknr-data-impex.asd branches/xml-class-rework/bknr/src/data/package.lisp branches/xml-class-rework/bknr/src/data/xml-object.lisp branches/xml-class-rework/bknr/src/web/menu.lisp branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp Log: Commit some more pending changes towards the dtd-less xml-class. Modified: branches/xml-class-rework/bknr/src/bknr-data-impex.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr-data-impex.asd 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/bknr-data-impex.asd 2006-02-17 20:52:07 UTC (rev 1838) @@ -1,3 +1,4 @@ + (in-package :cl-user) (defpackage :bknr-data-impex.system Modified: branches/xml-class-rework/bknr/src/data/package.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/package.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/data/package.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -42,6 +42,7 @@ #:persistent-xml-class #:persistent-xml-class-importer #:define-persistent-class + #:define-persistent-xml-class #:defpersistent-class #:store-object Modified: branches/xml-class-rework/bknr/src/data/xml-object.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/xml-object.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/data/xml-object.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -39,4 +39,3 @@ (export '(persistent-xml-class)) - Modified: branches/xml-class-rework/bknr/src/web/menu.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/menu.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/web/menu.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -1,13 +1,13 @@ (in-package :bknr.site-menu) -(defparameter *menu-dtd* (cxml:parse-dtd-file (merge-pathnames #p"menu.dtd" *load-truename*))) +(defparameter *menu-dtd* (ext:unix-namestring (merge-pathnames #p"menu.dtd" *load-truename*))) (defclass menu-defs () ((menus :initarg :menus :element "menu" :reader menu-defs-menus)) (:metaclass xml-class) - (:dtd *menu-dtd*) + (:dtd-name *menu-dtd*) (:element "menus")) (defclass menu () @@ -18,7 +18,7 @@ :element "item" :reader menu-items)) (:metaclass xml-class) - (:dtd *menu-dtd*) + (:dtd-name *menu-dtd*) (:element "menu")) (defclass item () @@ -39,7 +39,7 @@ :reader item-hover-image)) (:default-initargs :inactive-image nil :active-image nil :hover-image nil) (:metaclass xml-class) - (:dtd *menu-dtd*) + (:dtd-name *menu-dtd*) (:element "item")) (defparameter *menu-def-classes* (mapcar #'find-class '(menu-defs menu item))) Modified: branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp =================================================================== --- branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -31,9 +31,9 @@ ;;;# Obtaining and loading BKNR XML import/export ;;; ;;; You can obtain the current CVS sources of BKNR by following the -;;; instructions at `http://bknr.net/blog/bknr-devel'. Add the `src' -;;; directory of BKNR to your `asdf:*central-registry*', and load the -;;; indices module by evaluating the following form: +;;; instructions at `http://bknr.net/'. Add the `src' directory of +;;; BKNR to your `asdf:*central-registry*', and load the indices +;;; module by evaluating the following form: (asdf:oos 'asdf:load-op :bknr-impex) @@ -90,8 +90,7 @@ ;;; class, and by specifying the XML element corresponding to the ;;; class. We also annotate the slot definitions. -(defvar *tutorial-dtd* - (cxml:parse-dtd-file "xml-impex/tutorial.dtd")) +(defvar *tutorial-dtd* "xml-impex/tutorial.dtd") (defclass book () ((author :initarg :author :reader book-author @@ -103,7 +102,7 @@ (title :initarg :title :reader book-title :element "title")) (:metaclass xml-class) - (:dtd *tutorial-dtd*) + (:dtd-name *tutorial-dtd*) (:element "book")) ;;; We can now read the XML file containing the book definitions. As @@ -161,7 +160,7 @@ (title :initarg :title :reader book-title :element "title")) (:metaclass xml-class) - (:dtd *tutorial-dtd*) + (:dtd-name *tutorial-dtd*) (:element "book")) ;;; We can now import our XML file and the indices will automatically @@ -243,8 +242,7 @@ ;;; We can then write the following class definitions: -(defvar *test-dtd* - (cxml:parse-dtd-file #p"xml-impex/tutorial2.dtd")) +(defvar *test-dtd* "xml-impex/tutorial2.dtd") (defclass test-object () ((id :initarg :id :attribute "id" @@ -252,7 +250,7 @@ :index-type unique-index :index-reader object-with-id :index-values all-objects)) (:metaclass xml-class) - (:dtd *test-dtd*) + (:dtd-name *test-dtd*) (:element nil)) (defmethod print-object ((object test-object) stream) @@ -264,7 +262,7 @@ :index-reader test-with-id :index-values all-tests)) (:metaclass xml-class) - (:dtd *test-dtd*) + (:dtd-name *test-dtd*) (:element "test")) (defclass test2 (test-object) @@ -272,7 +270,7 @@ :index-reader test2-with-id :index-values all-test2s)) (:metaclass xml-class) - (:dtd *test-dtd*) + (:dtd-name *test-dtd*) (:element "test2")) (defclass test3 (test-object) @@ -280,7 +278,7 @@ :index-reader test3-with-id :index-values all-test3s)) (:metaclass xml-class) - (:dtd *test-dtd*) + (:dtd-name *test-dtd*) (:element "test3")) ;;; When we parse a sample file, we get the following results: @@ -331,8 +329,7 @@ ;;; we can write the following class definition: -(defvar *adult-dtd* - (cxml:parse-dtd-file "xml-impex/tutorial3.dtd")) +(defvar *adult-dtd* "xml-impex/tutorial3.dtd") (defclass adult () ((name :initarg :name :attribute "name" @@ -340,7 +337,7 @@ (children :initarg :children :element "child" :reader adult-children)) (:metaclass xml-class) - (:dtd *adult-dtd*) + (:dtd-name *adult-dtd*) (:element "adult")) (defmethod print-object ((adult adult) stream) @@ -351,7 +348,7 @@ ((name :initarg :name :attribute "name" :reader child-name)) (:metaclass xml-class) - (:dtd *adult-dtd*) + (:dtd-name *adult-dtd*) (:element "child")) (defmethod print-object ((child child) stream) @@ -403,7 +400,7 @@ (parent :initarg :parent :parent t :reader child-parent)) (:metaclass xml-class) - (:dtd *adult-dtd*) + (:dtd-name *adult-dtd*) (:element "child")) (setf *adults* @@ -429,8 +426,7 @@ book-id CDATA #REQUIRED reviewer CDATA #REQUIRED> -(defvar *resume-dtd* - (cxml:parse-dtd-file "xml-impex/tutorial4.dtd")) +(defvar *resume-dtd* "xml-impex/tutorial4.dtd") (defclass book-resume () ((id :initarg :id :attribute "id" @@ -444,7 +440,7 @@ (review :initarg :review :body t :reader book-resume-review)) (:metaclass xml-class) - (:dtd *resume-dtd*) + (:dtd-name *resume-dtd*) (:element "book-resume")) ;;; Parsing the following file gives the results: @@ -498,8 +494,7 @@ ;;; We can write the following class definitions: -(defparameter *book2-dtd* - (cxml:parse-dtd-file "xml-impex/tutorial5.dtd")) +(defparameter *book2-dtd* "xml-impex/tutorial5.dtd") (defclass author () ((id :initarg :id :reader author-id @@ -509,7 +504,7 @@ (name :initarg :name :reader author-name :element "name")) (:metaclass xml-class) - (:dtd *book2-dtd*) + (:dtd-name *book2-dtd*) (:element "author")) (defmethod print-object ((author author) stream) @@ -528,7 +523,7 @@ (title :initarg :title :reader book-title :element "title")) (:metaclass xml-class) - (:dtd *book2-dtd*) + (:dtd-name *book2-dtd*) (:element "book")) ;;; We can then read the following XML file: Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp =================================================================== --- branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -1,8 +1,7 @@ (in-package :bknr.impex) (defclass xml-class (indexed-class) - ((dtd :initarg :dtd :initform nil :accessor xml-class-dtd) - (element :initarg :element :initform nil :accessor xml-class-element) + ((element :initarg :element :initform nil :accessor xml-class-element) (unique-id-slot :initarg :unique-id-slot :initform nil :documentation "if set to a slot name, this signals that the slot can be used as a unique id to refer to an @@ -67,65 +66,15 @@ (defmethod print-object ((slot xml-effective-slot-definition) stream) (print-unreadable-object (slot stream :type t :identity t) - (format stream "~A (~A ~S)" (slot-definition-name slot) - (with-slots (attribute element body parent) slot + (with-slots (attribute element body parent) slot + (format stream "~A (~A~@[~S~])" (slot-definition-name slot) (cond (attribute "ATTRIBUTE") (element "ELEMENT") (body "BODY") (parent "PARENT") - (t "UNKNOWN"))) - (with-slots (attribute element body) slot - (cond ((and attribute (typep attribute 'cxml::attdef)) - (cxml::rod-string (cxml::attdef-name attribute))) - (attribute attribute) - ((and element (typep element 'cxml::elmdef)) - (cxml::rod-string (cxml::elmdef-name element))) - (element element) - (t "")))))) + (t "UNKNOWN")) + (or attribute element))))) -(defun get-dtd-elmdef (dtd elmdef) - (typecase elmdef - (string (unless dtd - (error "Can not find elmdef ~a in dtd ~A." elmdef dtd)) - (cxml::find-element (cxml::string-rod elmdef) dtd)) - (cxml::elmdef elmdef) - (t (let ((elmdef (eval elmdef))) - (unless (typep elmdef 'cxml::elmdef) - (error "Elmdef ~A is not a CXML elmdef." elmdef)) - elmdef)))) - -(defun get-dtd (dtd) - (cond ((or (stringp dtd) - (pathnamep dtd)) - (cxml:parse-dtd-file dtd)) - ((typep dtd 'cxml::dtd) dtd) - (t (let ((dtd (eval dtd))) - (unless (typep dtd 'cxml::dtd) - (error "DTD ~A is not a CXML dtd." dtd)) - dtd)))) - -(defun get-elmdef-attribute (elmdef attribute) - (typecase attribute - (string (unless elmdef - (error "Can not find attribute ~a in elmdef ~a." attribute elmdef)) - (cxml::find-attribute elmdef (cxml::string-rod attribute))) - (cxml::attdef attribute) - (t (let ((attribute (eval attribute))) - (unless (typep attribute 'cxml::attdef) - (error "Attribute ~A is not a CXML attdef." attribute)) - attribute)))) - -(defmethod initialize-elmdef ((class xml-class) dtd elm) - (let* ((dtd (get-dtd dtd)) - elmdef) - (when elm - (setf elmdef (get-dtd-elmdef dtd elm)) - (unless elmdef - (error "Could not find an element definition for class ~A, elmdef ~A." - (class-name class) elm))) - (setf (xml-class-dtd class) dtd - (xml-class-element class) elmdef))) - (defmethod xml-class-attribute-slots ((class xml-class)) (remove-if #'(lambda (slot) (or (not (typep slot 'xml-effective-slot-definition)) @@ -148,12 +97,12 @@ (defmethod xml-class-find-attribute-slot ((class xml-class) attribute) (find attribute (xml-class-attribute-slots class) :test #'string-equal - :key #'(lambda (slot) (cxml::rod-string (cxml::attdef-name (slot-value slot 'attribute)))))) + :key #'(lambda (slot) (slot-value slot 'attribute)))) (defmethod xml-class-find-element-slot ((class xml-class) element) (find element (xml-class-element-slots class) :test #'string-equal - :key #'(lambda (slot) (cxml::rod-string (cxml::elmdef-name (slot-value slot 'element)))))) + :key #'(lambda (slot) (slot-value slot 'element)))) (defmethod xml-class-parent-slot ((class xml-class)) (let ((parent-slots @@ -165,84 +114,12 @@ (error "Class ~A has more than one parent slot: ~A." class parent-slots)) (first parent-slots))) -(defmethod elmdef-children ((elmdef cxml::elmdef)) - (let (result) - (labels ((elmdef-children-rec (content containment) - (cond ((and (listp content) - (member (first content) '(cxml::and cxml::or))) - (dolist (child (cdr content)) - (elmdef-children-rec child containment))) - ((and (listp content) - (eql (first content) 'cxml::+)) - (dolist (child (cdr content)) - (elmdef-children-rec child :+))) - ((and (listp content) - (eql (first content) 'cxml::*)) - (dolist (child (cdr content)) - (elmdef-children-rec child :*))) - ((and (listp content) - (eql (first content) 'cxml::?)) - (dolist (child (cdr content)) - (elmdef-children-rec child :optional))) - ((listp content) - (error "Unknown content form ~S (missing element declaration for ~S in DTD?)." content (cxml::elmdef-name elmdef))) - ((eql content :pcdata)) - ((eql content :empty)) - (t (push (list content containment) result))))) - (elmdef-children-rec (cxml::elmdef-content elmdef) :single) - (nreverse result)))) - -;;; called multiple times -(defmethod compute-slots :around ((class xml-class)) - #+nil - (format t "around dtd ~A~%" (xml-class-dtd class)) - (when (and (not (typep (xml-class-dtd class) 'cxml::dtd)) - (xml-class-dtd class)) - (initialize-elmdef class (first (xml-class-dtd class)) - (first (xml-class-element class)))) - (call-next-method)) - -(defmethod xml-class-finalize ((class xml-class)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - - (let ((slots (class-slots class)) - (elmdef (xml-class-element class))) - (unless elmdef - (return-from xml-class-finalize)) - - #+nil - (format t "~S slots attributes ~S~%" slots (xml-class-attribute-slots class)) - ;;; check attributes - (dolist (attr (cxml::elmdef-attributes elmdef)) - (let ((attr-name (cxml::rod-string (cxml::attdef-name attr)))) - (when (eql (cxml::attdef-default attr) :required) - (let ((slot (xml-class-find-attribute-slot class attr-name))) - (when (not slot) - (warn "Could not find slot for required attribute ~A." attr-name)))))) - ;;; check elements - (dolist (child (elmdef-children elmdef)) - (let* ((child-name (cxml::rod-string (first child))) - (child-containment (second child)) - (slot (xml-class-find-element-slot class child-name))) - (if slot - (with-slots (containment required-p) slot - (if containment - (when (not (eql containment child-containment)) - (error "Slot containment ~A is not the same as the child containment ~A." - containment child-containment)) - (setf containment child-containment)) - (when (member child-containment '(:single :+)) - (setf required-p t))) - (when (member child-containment '(:single :+)) - (warn "Could not find a slot for the child element ~A with containment ~A." - child-name child-containment))))) - slots)) - -(defmethod initialize-instance :after ((class xml-class) &key &allow-other-keys) +(defmethod initialize-instance :after ((class xml-class) &key element &allow-other-keys) + (setf (xml-class-element class) (or (first element) (string-downcase (class-name class)))) (xml-class-finalize class)) -(defmethod reinitialize-instance :after ((class xml-class) &key &allow-other-keys) +(defmethod reinitialize-instance :after ((class xml-class) &key element &allow-other-keys) + (setf (xml-class-element class) (or (first element) (string-downcase (class-name class)))) (xml-class-finalize class)) (defmethod direct-slot-definition-class ((class xml-class) &key parent attribute element body &allow-other-keys) @@ -264,22 +141,20 @@ (let ((normal-slot (call-next-method))) (when (and xml-direct - (typep normal-slot 'xml-effective-slot-definition) - (xml-class-element class)) + (typep normal-slot 'xml-effective-slot-definition)) (with-slots (attribute element body parent) xml-direct - (let ((dtd (xml-class-dtd class))) - (unless (or element attribute body parent) - (error "Could not find element or attribute for slot ~A." name)) - (when (> (length (remove nil (list parent element attribute body))) 1) - (error "Only one of ELEMENT, ATTRIBUTE, PARENT or BODY is possible for a slot definition.")) + (when (> (length (remove nil (list parent element attribute body))) 1) + (error "Only one of ELEMENT, ATTRIBUTE, PARENT or BODY is possible for a slot definition.")) + (unless (or body parent) + (unless (or element attribute) + (setf element (string-downcase name))) (when element - (setf element (get-dtd-elmdef dtd element))) + (setf element (if (eq t element) (string-downcase name) element))) (when attribute - (setf attribute (get-elmdef-attribute (xml-class-element class) - attribute))) - (unless (or element attribute body parent) + (setf attribute (if (eq t attribute) (string-downcase name) attribute))) + (unless (or element attribute) (error "Could not find element or attribute for slot ~A." name)))) - + (dolist (slot '(parser serializer body id-to-object object-to-id parent attribute element)) (setf (slot-value normal-slot slot) @@ -290,22 +165,9 @@ (when value (setf (slot-value normal-slot slot) (eval value))))) - - ;;; XXX check emptyness of element - (with-slots (attribute element containment required-p) normal-slot - (when attribute - (when (eql (cxml::attdef-default attribute) :required) - (setf required-p t)))) - + normal-slot))) -(defmethod xml-class-reload-dtd ((class xml-class) dtd &optional element) - (let ((element (if element - element - (cxml::rod-string (cxml::elmdef-name (xml-class-element class)))))) - (initialize-elmdef class dtd element) - class)) - (defmethod xml-object-check-validity (object) (let ((class (class-of object))) (unless (typep class 'xml-class) Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp =================================================================== --- branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-17 20:46:26 UTC (rev 1837) +++ branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-17 20:52:07 UTC (rev 1838) @@ -33,15 +33,15 @@ (let* ((attr-slots (xml-class-attribute-slots class)) (elt-slots (xml-class-element-slots class)) (body-slot (xml-class-body-slot class)) - (qname (cxml::elmdef-name (xml-class-element class))) + (qname (cxml::string-rod (xml-class-element class))) ;; attributes (attributes (loop for slot in attr-slots for name = (slot-definition-name slot) - for attdef = (xml-effective-slot-definition-attribute slot) + for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) when (and (slot-boundp object name) (slot-value object name)) collect (sax:make-attribute - :qname (cxml::attdef-name attdef) + :qname attdef :value (funcall string-rod-fn (slot-serialize-value slot (slot-value object name)))))))

1 0

[bknr-cvs] r1837 - branches
by bknr＠bknr.net 17 Feb '06

17 Feb '06

Author: hhubner Date: 2006-02-17 14:46:26 -0600 (Fri, 17 Feb 2006) New Revision: 1837 Added: branches/xml-class-rework/ Log: I finally need to learn how to work on a branch, too. Sorry about this, I'll fix the trunk to a semi-stable state afterwards. Copied: branches/xml-class-rework (from rev 1836, trunk)

1 0