bknr-cvs

Download

bknr-cvs@common-lisp.net

1964 discussions

[bknr-cvs] r2239 - branches/trunk-reorg/projects/scrabble/src
by bknr＠bknr.net 14 Oct '07

14 Oct '07

Author: hhubner Date: 2007-10-14 15:27:25 -0400 (Sun, 14 Oct 2007) New Revision: 2239 Modified: branches/trunk-reorg/projects/scrabble/src/load.lisp Log: Modified: branches/trunk-reorg/projects/scrabble/src/load.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/load.lisp 2007-10-14 19:26:19 UTC (rev 2238) +++ branches/trunk-reorg/projects/scrabble/src/load.lisp 2007-10-14 19:27:25 UTC (rev 2239) @@ -1,5 +1,4 @@ (in-package :cl-user) -(load (merge-pathnames #p"../thirdparty/asdf.lisp" *load-truename*)) -(load (merge-pathnames #p"setup-registry.lisp" *load-truename*)) \ No newline at end of file +(load (merge-pathnames #p"setup-registry.lisp" *load-truename*))

1 0

[bknr-cvs] r2238 - branches/trunk-reorg/bknr/web/src
by bknr＠bknr.net 14 Oct '07

14 Oct '07

Author: hhubner Date: 2007-10-14 15:26:19 -0400 (Sun, 14 Oct 2007) New Revision: 2238 Modified: branches/trunk-reorg/bknr/web/src/packages.lisp Log: remove bogus symbols OpenMCL refused to compile Modified: branches/trunk-reorg/bknr/web/src/packages.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-14 19:25:01 UTC (rev 2237) +++ branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-14 19:26:19 UTC (rev 2238) @@ -210,7 +210,7 @@ #:web-server-error-event-error #:all-web-server-error-events - #:;; web-utils + ;; web-utils #:*upload-file-size-limit* #:all-request-params #:request-uploaded-files @@ -300,7 +300,7 @@ #:bknr-authorizer #:find-user-from-request-parameters - #: + #:handle #:object-handler #:edit-object-handler

1 0

[bknr-cvs] r2237 - branches/trunk-reorg/bknr/datastore/src/utils
by bknr＠bknr.net 14 Oct '07

14 Oct '07

Author: hhubner Date: 2007-10-14 15:25:01 -0400 (Sun, 14 Oct 2007) New Revision: 2237 Modified: branches/trunk-reorg/bknr/datastore/src/utils/acl-mp-compat.lisp Log: OpenMCL locking primitives Modified: branches/trunk-reorg/bknr/datastore/src/utils/acl-mp-compat.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/acl-mp-compat.lisp 2007-10-14 19:13:17 UTC (rev 2236) +++ branches/trunk-reorg/bknr/datastore/src/utils/acl-mp-compat.lisp 2007-10-14 19:25:01 UTC (rev 2237) @@ -1,12 +1,17 @@ (in-package :bknr.utils) +#+(not (or allegro sbcl cmu openmcl)) +(error "missing port for this compiler, please provide for locking primitives for this compiler in ~A" *load-pathname*) + (defun mp-make-lock (&optional (name "Anonymous")) #+allegro (mp:make-process-lock :name name) #+sbcl (sb-thread:make-mutex :name name) #+cmu - (mp:make-lock name)) + (mp:make-lock name) + #+openmcl + (ccl:make-lock name)) (defmacro mp-with-lock-held ((lock) &rest body) #+allegro @@ -17,6 +22,9 @@ ,@body) #+cmu `(mp:with-lock-held (,lock) + ,@body) + #+openmcl + `(ccl:with-lock-grabbed (,lock) ,@body)) (defmacro mp-with-recursive-lock-held ((lock) &rest body) @@ -28,4 +36,7 @@ ,@body) #+cmu `(mp:with-lock-held (,lock) + ,@body) + #+openmcl + `(ccl:with-lock-grabbed (,lock) ,@body))

1 0

[bknr-cvs] r2236 - in branches/trunk-reorg/thirdparty: . asdf asdf/CVS asdf/debian asdf/debian/CVS asdf/test asdf/test/CVS
by bknr＠bknr.net 14 Oct '07

14 Oct '07

Author: hhubner Date: 2007-10-14 15:13:17 -0400 (Sun, 14 Oct 2007) New Revision: 2236 Added: branches/trunk-reorg/thirdparty/asdf/ branches/trunk-reorg/thirdparty/asdf/CVS/ branches/trunk-reorg/thirdparty/asdf/CVS/Entries branches/trunk-reorg/thirdparty/asdf/CVS/Repository branches/trunk-reorg/thirdparty/asdf/CVS/Root branches/trunk-reorg/thirdparty/asdf/LICENSE branches/trunk-reorg/thirdparty/asdf/README branches/trunk-reorg/thirdparty/asdf/asdf-install.lisp branches/trunk-reorg/thirdparty/asdf/asdf.lisp branches/trunk-reorg/thirdparty/asdf/asdf.texinfo branches/trunk-reorg/thirdparty/asdf/cclan-package.lisp branches/trunk-reorg/thirdparty/asdf/cclan.asd branches/trunk-reorg/thirdparty/asdf/cclan.lisp branches/trunk-reorg/thirdparty/asdf/debian/ branches/trunk-reorg/thirdparty/asdf/debian/CVS/ branches/trunk-reorg/thirdparty/asdf/debian/CVS/Entries branches/trunk-reorg/thirdparty/asdf/debian/CVS/Repository branches/trunk-reorg/thirdparty/asdf/debian/CVS/Root branches/trunk-reorg/thirdparty/asdf/debian/README.Debian branches/trunk-reorg/thirdparty/asdf/debian/changelog branches/trunk-reorg/thirdparty/asdf/debian/cl-asdf.postinst branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.postinst branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.prerm branches/trunk-reorg/thirdparty/asdf/debian/compat branches/trunk-reorg/thirdparty/asdf/debian/control branches/trunk-reorg/thirdparty/asdf/debian/copyright branches/trunk-reorg/thirdparty/asdf/debian/docs branches/trunk-reorg/thirdparty/asdf/debian/postinst branches/trunk-reorg/thirdparty/asdf/debian/rules branches/trunk-reorg/thirdparty/asdf/test/ branches/trunk-reorg/thirdparty/asdf/test/CVS/ branches/trunk-reorg/thirdparty/asdf/test/CVS/Entries branches/trunk-reorg/thirdparty/asdf/test/CVS/Repository branches/trunk-reorg/thirdparty/asdf/test/CVS/Root branches/trunk-reorg/thirdparty/asdf/test/compile-asdf.lisp branches/trunk-reorg/thirdparty/asdf/test/file1.lisp branches/trunk-reorg/thirdparty/asdf/test/file2.lisp branches/trunk-reorg/thirdparty/asdf/test/file3.lisp branches/trunk-reorg/thirdparty/asdf/test/file4.lisp branches/trunk-reorg/thirdparty/asdf/test/run-tests.sh branches/trunk-reorg/thirdparty/asdf/test/script-support.lisp branches/trunk-reorg/thirdparty/asdf/test/static-and-serial.asd branches/trunk-reorg/thirdparty/asdf/test/test-force.asd branches/trunk-reorg/thirdparty/asdf/test/test-force.script branches/trunk-reorg/thirdparty/asdf/test/test-package.asd branches/trunk-reorg/thirdparty/asdf/test/test-package.script branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.lisp branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.script branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-1.asd branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-load.lisp branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-test.lisp branches/trunk-reorg/thirdparty/asdf/test/test-static-and-serial.script branches/trunk-reorg/thirdparty/asdf/test/test-version.script branches/trunk-reorg/thirdparty/asdf/test/test1.asd branches/trunk-reorg/thirdparty/asdf/test/test1.script branches/trunk-reorg/thirdparty/asdf/test/test2.asd branches/trunk-reorg/thirdparty/asdf/test/test2.script branches/trunk-reorg/thirdparty/asdf/test/test2a.asd branches/trunk-reorg/thirdparty/asdf/test/test2b1.asd branches/trunk-reorg/thirdparty/asdf/test/test2b2.asd branches/trunk-reorg/thirdparty/asdf/test/test2b3.asd branches/trunk-reorg/thirdparty/asdf/test/test3.asd branches/trunk-reorg/thirdparty/asdf/test/test3.script branches/trunk-reorg/thirdparty/asdf/test/test4.script branches/trunk-reorg/thirdparty/asdf/test/wild-module.asd branches/trunk-reorg/thirdparty/asdf/test/wild-module.script branches/trunk-reorg/thirdparty/asdf/wild-modules.lisp Log: update asdf from cvs Added: branches/trunk-reorg/thirdparty/asdf/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/asdf/CVS/Entries 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/CVS/Entries 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,11 @@ +/LICENSE/1.1/Wed Mar 6 23:59:29 2002// +/README/1.39/Mon Aug 21 10:52:32 2006// +/asdf-install.lisp/1.7/Mon Dec 1 03:14:35 2003// +/asdf.lisp/1.110/Thu Sep 27 13:15:06 2007// +/asdf.texinfo/1.8/Sat Jun 2 02:44:59 2007// +/cclan-package.lisp/1.4/Thu Jun 5 01:13:49 2003// +/cclan.asd/1.6/Thu Jun 5 01:13:49 2003// +/cclan.lisp/1.9/Fri Jul 18 05:32:53 2003// +/wild-modules.lisp/1.3/Tue Aug 12 03:56:43 2003// +D/debian//// +D/test//// Added: branches/trunk-reorg/thirdparty/asdf/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/asdf/CVS/Repository 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/CVS/Repository 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +asdf Added: branches/trunk-reorg/thirdparty/asdf/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/asdf/CVS/Root 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/CVS/Root 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +:pserver:anonymous@cclan.cvs.sourceforge.net:/cvsroot/cclan Added: branches/trunk-reorg/thirdparty/asdf/LICENSE =================================================================== --- branches/trunk-reorg/thirdparty/asdf/LICENSE 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/LICENSE 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,24 @@ + +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2001, 2002 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. Added: branches/trunk-reorg/thirdparty/asdf/README =================================================================== --- branches/trunk-reorg/thirdparty/asdf/README 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/README 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,762 @@ +$Id: README,v 1.39 2006/08/21 10:52:32 crhodes Exp $ -*- Text -*- + +The canonical documentation for asdf is in the file asdf.texinfo. +The significant overlap between this file and that will one day be +resolved by deleting text from this file; in the meantime, please look +there before here. + + + +asdf: another system definition facility +======================================== + +* Getting the latest version + +0) Decide which version you want. HEAD is the newest version and +usually OK, whereas RELEASE is for cautious people (e.g. who already +have systems using asdf that they don't want broken), a slightly older +version about which none of the HEAD users have complained. + +1) Check it out from sourceforge cCLan CVS: + +1a) cvs -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan login + (no password: just press Enter) + +1a.1) cvs -z3 -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan + co -r RELEASE asdf + +or for the bleeding edge, instead + +1a.2) cvs -z3 -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan + co -A asdf + +If you are tracking the bleeding edge, you may want to subscribe to +the cclan-commits mailing list (see +<URL:http://sourceforge.net/mail/?group_id=28536>) to receive commit +messages and diffs whenever changes are made. + +For more CVS information, look at http://sourceforge.net/cvs/?group_id=28536 + + +* Getting started + +- The single file asdf.lisp is all you need to use asdf normally. For +maximum convenience you want to have it loaded whenever you start your +Lisp implementation, by loading it from the startup script, or dumping +a custom core, or something. + +- The variable asdf:*central-registry* is a list of system directory + designators. A system directory designator is a form which will be + evaluated whenever a system is to be found, and must evaluate to a + directory to look in. For example, you might have + + (*default-pathname-defaults* "/home/me/cl/systems/" + "/usr/share/common-lisp/systems/") + + (When we say "directory" here, we mean "designator for a pathname + with a supplied DIRECTORY component") + + It is possible to customize the system definition file search. + That's considered advanced use, and covered later: search forward + for *system-definition-search-functions* + +- To compile and load a system 'foo', you need to (1) ensure that + foo.asd is in one of the directories in *central-registry* (a + symlink to the real location of foo.asd is preferred), (2) execute + ``(asdf:operate 'asdf:load-op 'foo)'' + + $ cd /home/me/cl/systems/ + $ ln -s ~/src/foo/foo.asd . + $ lisp + * (asdf:operate 'asdf:load-op 'foo) + +- To write your own system definitions, look at the test systems in + test/ , and read the rest of this. Ignore systems/ which is old + and may go away when next I clean up + +- Syntax is similar to mk-defsystem 3 for straightforward systems, you + may only need to remove the :source-pathname option (and replace it + with :pathname if the asd file is not in the same place as the + system sources) + +- Join cclan-list(a)lists.sf.net for discussion, bug reports, questions, etc + +- cclan.asd and the source files listed therein contain useful extensions + for maintainers of systems in the cCLan. If this isn't you, you + don't need them - although you may want to look at them anyway + +- For systems that do complicated things (e.g. compiling C files to + load as foreign code), the packages in vn-cclan may provide some + guidance. db-sockets, for example, is known to do outlandish things + with preprocessors + + http://ww.telent.net/cliki/vn-cclan + + + +* Concepts + +This system definition utility talks in terms of 'components' and +'operations'. + +Components form systems: a component represents a source file, or a +collection of components. A system is therefore a component, +recursively formed of a tree of subcomponents. + +Operations are instantiated then performed on the nodes of a tree to +do things like + + - compile all its files + - load the files into a running lisp environment + - copy its source files somewhere else + +Operations can be invoked directly, or examined to see what their +effects would be without performing them. There are a bunch of +methods specialised on operation and component type which actually do +the grunt work. + +asdf is extensible to new operations and to new component types. This +allows the addition of behaviours: for example, a new component could +be added for Java JAR archives, and methods specialised on compile-op +added for it that would accomplish the relevant actions. Users +defining their own operations and component types should inherit from +the asdf base classes asdf:operation and asdf:component respectively. + +* Inspiration + +** mk-defsystem (defsystem-3.x) + +We aim to solve basically the same problems as mk-defsystem does. +However, our architecture for extensibility better exploits CL +language features (and is documented), and we intend to be portable +rather than just widely-ported. No slight on the mk-defsystem authors +and maintainers is intended here; that implementation has the +unenviable task of supporting non-ANSI implementations, which I +propose to ignore. + +The surface defsystem syntax of asdf is more-or-less compatible with +mk-defsystem + +The mk-defsystem code for topologically sorting a module's dependency +list was very useful. + +** defsystem-4 proposal + +Marco and Peter's proposal for defsystem 4 served as the driver for +many of the features in here. Notable differences are + +- we don't specify output files or output file extensions as part of + the system + + If you want to find out what files an operation would create, ask + the operation + +- we don't deal with CL packages + + If you want to compile in a particular package, use an in-package + form in that file (ilisp will like you more if you do this anyway) + +- there is no proposal here that defsystem does version control. + + A system has a given version which can be used to check + dependencies, but that's all. + +The defsystem 4 proposal tends to look more at the external features, +whereas this one centres on a protocol for system introspection. + +** kmp's "The Description of Large Systems", MIT AI Memu 801 + +Available in updated-for-CL form on the web at +http://world.std.com/~pitman/Papers/Large-Systems.html + +In our implementation we borrow kmp's overall PROCESS-OPTIONS and +concept to deal with creating component trees from defsystem surface +syntax. [ this is not true right now, though it used to be and +probably will be again soon ] + + +* The Objects + +** component + +*** Component Attributes + +**** A name (required) + +This is a string or a symbol. If a symbol, its name is taken and +lowercased. The name must be a suitable value for the :name initarg +to make-pathname in whatever filesystem the system is to be found. + +The lower-casing-symbols behaviour is unconventional, but was selected +after some consideration. Observations suggest that the type of +systems we want to support either have lowercase as customary case +(Unix, Mac, windows) or silently convert lowercase to uppercase +(lpns), so this makes more sense than attempting to use :case :common, +which is reported not to work on some implementations + +**** a version identifier (optional) + +This is used by the test-system-version operation (see later). + +**** *features* required + +Traditionally defsystem users have used reader conditionals to include +or exclude specific per-implementation files. This means that any +single implementation cannot read the entire system, which becomes a +problem if it doesn't wish to compile it, but instead for example to +create an archive file containing all the sources, as it will omit to +process the system-dependent sources for other systems. + +Each component in an asdf system may therefore specify features using +the same syntax as #+ does, and it will (somehow) be ignored for +certain operations unless the feature conditional matches + +**** dependencies on its siblings (optional but often necessary) + +There is an excitingly complicated relationship between the initarg +and the method that you use to ask about dependencies + +Dependencies are between (operation component) pairs. In your +initargs, you can say + +:in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) + (load-op (load-op "foo"))) + +- before performing compile-op on this component, we must perform +load-op on "a" and "b", and compile-op on c, - before performing +load-op, we have to load "foo" + +The syntax is approximately + +(this-op {(other-op required-components)}+) + +required-components := component-name + | (required-components required-components) + +component-name := string + | (:version string minimum-version-object) + +[ This is on a par with what ACL defsystem does. mk-defsystem is less +general: it has an implied dependency + + for all x, (load x) depends on (compile x) + +and using a :depends-on argument to say that b depends on a _actually_ +means that + + (compile b) depends on (load a) + +This is insufficient for e.g. the McCLIM system, which requires that +all the files are loaded before any of them can be compiled ] + +In asdf, the dependency information for a given component and +operation can be queried using (component-depends-on operation +component), which returns a list + +((load-op "a") (load-op "b") (compile-op "c") ...) + +component-depends-on can be subclassed for more specific +component/operation types: these need to (call-next-method) and append +the answer to their dependency, unless they have a good reason for +completely overriding the default dependencies + +(If it weren't for CLISP, we'd be using a LIST method combination to +do this transparently. But, we need to support CLISP. If you have +the time for some CLISP hacking, I'm sure they'd welcome your fixes) + +**** a pathname + +This is optional and if absent will be inferred from name, type (the +subclass of source-file), and the location of parent. + +The rules for this inference are: + +(for source-files) +- the host is taken from the parent +- pathname type is (source-file-type component system) +- the pathname case option is :local +- the pathname is merged against the parent + +(for modules) +- the host is taken from the parent +- the name and type are NIL +- the directory is (:relative component-name) +- the pathname case option is :local +- the pathname is merged against the parent + +Note that the DEFSYSTEM operator (used to create a "top-level" system) +does additional processing to set the filesystem location of the +top component in that system. This is detailed elsewhere + +The answer to the frequently asked question "how do I create a system +definition where all the source files have a .cl extension" is thus + +(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys)))) + "cl") + +**** properties (optional) + +Packaging systems often require information about files or systems +additional to that specified here. Programs that create vendor +packages out of asdf systems therefore have to create "placeholder" +information to satisfy these systems. Sometimes the creator of an +asdf system may know the additional information and wish to provide it +directly. + +(component-property component property-name) and associated setf method +will allow the programmatic update of this information. Property +names are compared as if by EQL, so use symbols or keywords or something + +** Subclasses of component + +*** 'source-file' + +A source file is any file that the system does not know how to +generate from other components of the system. + +(Note that this is not necessarily the same thing as "a file +containing data that is typically fed to a compiler". If a file is +generated by some pre-processor stage (e.g. a ".h" file from ".h.in" +by autoconf) then it is not, by this definition, a source file. +Conversely, we might have a graphic file that cannot be automatically +regenerated, or a proprietary shared library that we received as a +binary: these do count as source files for our purposes. All +suggestions for better terminology gratefully received) + +Subclasses of source-file exist for various languages. + +*** 'module', a collection of sub-components + +This has extra slots for + + :components - the components contained in this module + + :default-component-class - for child components which don't specify + their class explicitly + + :if-component-dep-fails takes one of the values :fail, :try-next, :ignore + (default value is :fail). The other values can be used for implementing + conditional compilation based on implementation *features*, where + it is not necessary for all files in a module to be compiled + +The default operation knows how to traverse a module, so most +operations will not need to provide methods specialised on modules. + +The module may be subclassed to represent components such as +foreign-language linked libraries or archive files. + +*** system, subclasses module + +A system is a module with a few extra attributes for documentation +purposes. In behaviour, it's usually identical. + +Users can create new classes for their systems: the default defsystem +macro takes a :classs keyword argument. + + +** operation + +An operation is instantiated whenever the user asks that an operation +be performed, inspected, or etc. The operation object contains +whatever state is relevant to this purpose (perhaps a list of visited +nodes, for example) but primarily is a nice thing to specialise +operation methods on and easier than having them all be EQL methods. + +There are no differences between standard operations and user-defined +operations, except that the user is respectfully requested to keep his +(or more importantly, our) package namespace clean + +*** invoking operations + +(operate operation system &rest keywords-args) + +keyword-args are passed to the make-instance call when creating the +operation: valid keywords depend on the initargs that the operation is +defined to accept. Note that dependencies may cause the operation to +invoke other operations on the system or its components: the new +operation will be created with the same initargs as the original one. + +oos is accepted as a synonym for operate + +*** standard operations + +**** feature-dependent-op + +This is not intended to be instantiated directly, but other operations +may inherit from it. An instance of feature-dependent-op will ignore +any components which have a `features' attribute, unless the feature +combination it designates is satisfied by *features* + +See the earlier explanation about the component features attribute for +more information + +**** compile-op &key proclamations + +If proclamations are supplied, they will be proclaimed. This is a +good place to specify optimization settings + +When creating a new component, you should provide methods for this. + +If you invoke compile-op as a user, component dependencies often mean +you may get some parts of the system loaded. This may not necessarily +be the whole thing, though; for your own sanity it is recommended that +you use load-op if you want to load a system. + +**** load-op &key proclamations + +The default methods for load-op compile files before loading them. +For parity, your own methods on new component types should probably do +so too + +**** load-source-op + +This method will load the source for the files in a module even if the +source files have been compiled. Systems sometimes have knotty +dependencies which require that sources are loaded before they can be +compiled. This is how you do that. + +If you are creating a component type, you need to implement this +operation - at least, where meaningful. + +**** test-system-version &key minimum + +Asks the system whether it satisfies a version requirement. + +The default method accepts a string, which is expected to contain of a +number of integers separated by #\. characters. The method is not +recursive. The component satisfies the version dependency if it has +the same major number as required and each of its sub-versions is +greater than or equal to the sub-version number required. + +(defun version-satisfies (x y) + (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)))))) + +If that doesn't work for your system, you can override it. I hope +yoyu have as much fun writing the new method as #lisp did +reimplementing this one. + +*** Creating new operations + +subclass operation, provide methods for source-file for + +- output-files +- perform + The perform method must call output-files to find out where to + put its files, because the user is allowed to override output-files + for local policy +- explain +- operation-done-p, if you don't like the default one + +* Writing system definitions + +** System designators + +System designators are strings or symbols and behave just like +any other component names (including case conversion) + +** find-system + +Given a system designator, find-system finds an actual system - either +in memory, or in a file on the disk. It funcalls each element in the +*system-definition-search-functions* list, expecting a pathname to be +returned. + +If a suitable file exists, it is loaded if + +- there is no system of that name in memory, +- the file's last-modified time exceeds the last-modified time of the + system in memory + +When system definitions are loaded from .asd files, a new scratch +package is created for them to load into, so that different systems do +not overwrite each others operations. The user may also wish to (and +is recommended to) include defpackage and in-package forms in his +system definition files, however, so that they can be loaded manually +if need be. It is not recommended to use the CL-USER package for this +purpose, as definitions made in this package will affect the parsing +of asdf systems. + +For convenience in the normal case, and for backward compatibility +with the spirit of mk-defsystem, the default contents of +*system-definition-search-functions* is a function called +sysdef-central-registry-search. This looks in each of the directories +given by evaluating members of *central-registry*, for a file whose +name is the name of the system and whose type is "asd". The first +such file is returned, whether or not it turns out to actually define +the appropriate system + + + +** Syntax + +Systems can always be constructed programmatically by instantiating +components using make-instance. For most purposes, however, it is +likely that people will want a static defystem form. + +asdf is based around the principle that components should not have to +know defsystem syntax. That is, the initargs that a component accepts +are not necessarily related to the defsystem form which creates it. + +A defsystem parser must implement a `defsystem' macro, which can +be named for compatibility with whatever other system definition +utility is being emulated. It should instantiate components in +accordance with whatever language it accepts, and register the topmost +component using REGISTER-SYSTEM + +*** Native syntax + +The native syntax is inspired by mk-defsystem, to the extent that it +should be possible to take most straightforward mk- system definitions +and run them with only light editing. For my convenience, this turns +out to be basically the same as the initargs to the various +components, with a few extensions for convenience + +system-definition := ( defsystem system-designator {option}* ) + +option := :components component-list + | :pathname pathname + | :default-component-class + | :perform method-form + | :explain method-form + | :output-files method-form + | :operation-done-p method-form + | :depends-on ( {simple-component-name}* ) + | :serial [ t | nil ] + | :in-order-to ( {dependency}+ ) + +component-list := ( {component-def}* ) + +component-def := simple-component-name + | ( component-type name {option}* ) + +component-type := :module | :file | :system | other-component-type + +dependency := (dependent-op {requirement}+) +requirement := (required-op {required-component}+) + | (feature feature-name) +dependent-op := operation-name +required-op := operation-name | feature + +For example + +(defsystem "foo" + :version "1.0" + :components ((:module "foo" :components ((:file "bar") (:file"baz") + (:file "quux")) + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c))) + (:file "blah"))) + + +The method-form tokens need explaining: esentially, + + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c))) +has the effect of + +(defmethod perform :after ((op compile-op) (c (eql ...))) + (do-something c)) +(defmethod explain :after ((op compile-op) (c (eql ...))) + (explain-something c)) + +where ... is the component in question; note that although this also +supports :before methods, they may not do what you want them to - a +:before method on perform ((op compile-op) (c (eql ...))) will run +after all the dependencies and sub-components have been processed, but +before the component in question has been compiled. + +**** Serial dependencies + +If the `:serial t' option is specified for a module, asdf will add +dependencies for each each child component, on all the children +textually preceding it. This is done as if by :depends-on + +:components ((:file "a") (:file "b") (:file "c")) +:serial t + +is equivalent to +:components ((:file "a") + (:file "b" :depends-on ("a")) + (:file "c" :depends-on ("a" "b"))) + + + +have all the + +**** Source location + +The :pathname option is optional in all cases for native-syntax +systems, and in the usual case the user is recommended not to supply +it. If it is not supplied for the top-level form, defsystem will set +it from + +- The host/device/directory parts of *load-truename*, if it is bound +- *default-pathname-defaults*, otherwise + +If a system is being redefined, the top-level pathname will be + +- changed, if explicitly supplied or obtained from *load-truename* +- changed if it had previously been set from *default-pathname-defaults* +- left as before, if it had previously been set from *load-truename* + and *load-truename* is not now bound + +These rules are designed so that (i) find-system will load a system +from disk and have its pathname default to the right place, (ii) +this pathname information will not be overwritten with +*default-pathname-defaults* (which could be somewhere else altogether) +if the user loads up the .asd file into his editor and +interactively re-evaluates that form + + * Error handling + +It is an error to define a system incorrectly: an implementation may +detect this and signal a generalised instance of +SYSTEM-DEFINITION-ERROR. + +Operations may go wrong (for example when source files contain +errors). These are signalled using generalised instances of +OPERATION-ERROR, with condition readers ERROR-COMPONENT and +ERROR-OPERATION for the component and operation which erred. + +* Compilation error and warning handling + +ASDF checks for warnings and errors when a file is compiled. The +variables *compile-file-warnings-behaviour* and +*compile-file-errors-behavior* controls the handling of any such +events. The valid values for these variables are :error, :warn, and +:ignore. + +---------------------------------------------------------- + TODO List +---------------------------------------------------------- + +* Outstanding spec questions, things to add + +** packaging systems + +*** manual page component? + +** style guide for .asd files + +You should either use keywords or be careful with the package that you +evaluate defsystem forms in. Otherwise (defsystem partition ...) +being read in the cl-user package will intern a cl-user:partition +symbol, which will then collide with the partition:partition symbol. + +Actually there's a hairier packages problem to think about too. +in-order-to is not a keyword: if you read defsystem forms in a package +that doesn't use ASDF, odd things might happen + +** extending defsystem with new options + +You might not want to write a whole parser, but just to add options to +the existing syntax. Reinstate parse-option or something akin + +** document all the error classes + +** what to do with compile-file failure + +Should check the primary return value from compile-file and see if +that gets us any closer to a sensible error handling strategy + +** foreign files + +lift unix-dso stuff from db-sockets + +** Diagnostics + +A "dry run" of an operation can be made with the following form: + +(traverse (make-instance '<operation-name>) + (find-system <system-name>) + 'explain) + +This uses unexported symbols. What would be a nice interface for this +functionality? + +** patches + +Sometimes one wants to + + +* missing bits in implementation + +** all of the above +** reuse the same scratch package whenever a system is reloaded from disk +** rules for system pathname defaulting are not yet implemented properly +** proclamations probably aren't +** when a system is reloaded with fewer components than it previously + had, odd things happen + +we should do something inventive when processing a defsystem form, +like take the list of kids and setf the slot to nil, then transfer +children from old to new list as they're found + +** traverse may become a normal function + +If you're defining methods on traverse, speak up. + + +** a lot of load-op methods can be rewritten to use input-files + +so should be. + + +** (stuff that might happen later) + +*** david lichteblau's patch for symlink resolution? + +*** Propagation of the :force option. ``I notice that + + (oos 'compile-op :araneida :force t) + +also forces compilation of every other system the :araneida system +depends on. This is rarely useful to me; usually, when I want to force +recompilation of something more than a single source file, I want to +recompile only one system. So it would be more useful to have +make-sub-operation refuse to propagate ":force t" to other systems, and +propagate only something like ":force :recursively". '' + +Ideally what we actually want is some kind of criterion that says +to which systems (and which operations) a :force switch will propagate. + +The problem is perhaps that 'force' is a pretty meaningless concept. +How obvious is it that "load :force t" should force _compilation_? +But we don't really have the right dependency setup for the user to +compile :force t and expect it to work (files will not be loaded after +compilation, so the compile environment for subsequent files will be +emptier than it needs to be) + +What does the user actually want to do when he forces? Usually, for +me, update for use with a new version of the lisp compiler. Perhaps +for recovery when he suspects that something has gone wrong. Or else +when he's changed compilation options or configuration in some way +that's not reflected in the dependency graph. + +Other possible interface: have a 'revert' function akin to 'make clean' + + (asdf:revert 'asdf:compile-op 'araneida) + +would delete any files produced by 'compile-op 'araneida. Of course, it +wouldn't be able to do much about stuff in the image itself. + +How would this work? + +traverse + +There's a difference between a module's dependencies (peers) and its +components (children). Perhaps there's a similar difference in +operations? For example, (load "use") depends-on (load "macros") is a +peer, whereas (load "use") depends-on (compile "use") is more of a +`subservient' relationship. Added: branches/trunk-reorg/thirdparty/asdf/asdf-install.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/asdf-install.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/asdf-install.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,299 @@ +#|| sh asdf-install.lisp will compile this file to an exe called asdf-install +sbcl <<EOF +(require 'sb-executable) +(compile-file "asdf-install.lisp") +(sb-executable:make-executable "asdf-install" *) +EOF +exit 0 +||# + +;;; Install an ASDF system or anything else that looks convincingly +;;; like one, including updating symlink for all the toplevel .asd files it +;;; contains + +;;; If the file $HOME/.asdf-install exists, it is loaded. This can be +;;; used to override the default values of exported special variables +;;; (see the defpackage form for details) - however, most of them are +;;; sensible and/or taken from the environment anyway + +#|| +TODO: +a) gpg signature checking would be better if it actually checked against +a list of "trusted to write Lisp" keys, instead of just "trusted to be +who they say they are" + +d) in sbcl 0.8.1 we'll have a run-program that knows about $PATH and so +won't need to hardcode gpgpgpgp and tar locations. + +e) nice to have: resume half-done downloads instead of starting from scratch +every time. but right now we're dealing in fairly small packages, this is not +an immediate concern + +||# +(in-package :cl-user) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'asdf) + (require 'sb-posix) + (require 'sb-executable) + (require 'sb-bsd-sockets)) + +(defpackage :asdf-install + (:use "CL" "SB-EXT" "SB-BSD-SOCKETS") + (:export #:*proxy* #:*cclan-mirror* #:*sbcl-home* + #:*verify-gpg-signatures* #:*locations*)) + +(defpackage :asdf-install-customize + (:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL")) + +(in-package :asdf-install) + +(defvar *proxy* (posix-getenv "http_proxy")) +(defvar *cclan-mirror* + (or (posix-getenv "CCLAN_MIRROR") + "http://ftp.linux.org.uk/pub/lisp/cclan/")) + +(defun directorify (name) + ;; input name may or may not have a training #\/, but we know we + ;; want a directory + (let ((path (pathname name))) + (if (pathname-name path) + (merge-pathnames + (make-pathname :directory `(:relative ,(pathname-name path)) + :name "") + path) + path))) + +(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) +(defvar *dot-sbcl* + (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) + (user-homedir-pathname))) + +(defvar *verify-gpg-signatures* t) + +(defvar *locations* + `((,(merge-pathnames "site/" *sbcl-home*) + ,(merge-pathnames "site-systems/" *sbcl-home*) + "System-wide install") + (,(merge-pathnames "site/" *dot-sbcl*) + ,(merge-pathnames "systems/" *dot-sbcl*) + "Personal installation"))) + +(let* ((*package* (find-package :asdf-install-customize)) + (file (probe-file (merge-pathnames + (make-pathname :name ".asdf-install") + (user-homedir-pathname))))) + (when file (load file))) + +(define-condition download-error (error) + ((url :initarg :url :reader download-url) + (response :initarg :response :reader download-response)) + (:report (lambda (c s) + (format s "Server responded ~A for GET ~A" + (download-response c) (download-url c))))) + +(define-condition signature-error (error) + ((cause :initarg :cause :reader signature-error-cause)) + (:report (lambda (c s) + (format s "Cannot verify package signature: ~A" + (signature-error-cause c))))) + +(defun url-host (url) + (assert (string-equal url "http://" :end1 7)) + (let* ((port-start (position #\: url :start 7)) + (host-end (min (or (position #\/ url :start 7) (length url)) + (or port-start (length url))))) + (subseq url 7 host-end))) + +(defun url-port (url) + (assert (string-equal url "http://" :end1 7)) + (let ((port-start (position #\: url :start 7))) + (if port-start (parse-integer url :start port-start :junk-allowed t) 80))) + +(defun url-connection (url) + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) + (host (url-host url)) + (port (url-port url))) + (socket-connect + s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) + (url-port (or *proxy* url))) + (let ((stream (socket-make-stream s :input t :output t :buffering :full))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%" + url host *cclan-mirror*) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream)))) + +(defun download (package-name-or-url file-name) + (let ((url + (if (= (mismatch package-name-or-url "http://") 7) + package-name-or-url + (format nil "http://www.cliki.net/~A?download" + package-name-or-url)))) + (destructuring-bind (response headers stream) + (block got + (loop + (destructuring-bind (response headers stream) (url-connection url) + (unless (member response '(301 302)) + (return-from got (list response headers stream))) + (close stream) + (setf url (cdr (assoc :location headers)))))) + (if (>= response 400) + (error 'download-error :url url :response response)) + (let ((length (parse-integer + (or (cdr (assoc :content-length headers)) "") + :junk-allowed t))) + (format t "Downloading ~A bytes from ~A ..." + (if length length "some unknown number of") url) + (force-output) + (with-open-file (o file-name :direction :output) + (if length + (let ((buf (make-array length + :element-type + (stream-element-type stream) ))) + (read-sequence buf stream) + (write-sequence buf o)) + (sb-executable:copy-stream stream o)))) + (close stream) + (terpri) + ;; seems to have worked. let's try for a detached gpg signature too + (when *verify-gpg-signatures* + (verify-gpg-signature url file-name))))) + +(defun verify-gpg-signature (url file-name) + (destructuring-bind (response headers stream) + (url-connection (concatenate 'string url ".asc")) + (declare (ignore headers)) + (unwind-protect + (if (= response 200) + ;; sadly, we can't pass the stream directly to run-program, + ;; because (at least in sbcl 0.8) that ignores existing buffered + ;; data and only reads new fresh data direct from the file + ;; descriptor + (let ((data (make-string (parse-integer + (cdr (assoc :content-length headers)) + :junk-allowed t)))) + (read-sequence data stream) + (let ((ret + (process-exit-code + (sb-ext:run-program "/usr/bin/gpg" + (list "--verify" "-" + (namestring file-name)) + :output t + :input (make-string-input-stream data) + :wait t)))) + (unless (zerop ret) + (error 'signature-error + :cause (make-condition + 'simple-error + :format-control "GPG returned exit status ~A" + :format-arguments (list ret)))))) + (error 'signature-error + :cause + (make-condition + 'download-error :url (concatenate 'string url ".asc") + :response response))) + (close stream)))) + + + + +(defun where () + (format t "Install where?~%") + (loop for (source system name) in *locations* + for i from 1 + do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" + i name system source)) + (format t " --> ") (force-output) + (let ((response (read))) + (when (> response 0) + (elt *locations* (1- response))))) + +(defun install (source system packagename) + "Returns a list of asdf system names for installed asdf systems" + (ensure-directories-exist source ) + (ensure-directories-exist system ) + (let* ((tar + (with-output-to-string (o) + (or + (sb-ext:run-program "/bin/tar" + (list "-C" (namestring source) + "-xzvf" (namestring packagename)) + :output o + :wait t) + (error "can't untar")))) + (dummy (princ tar)) + (pos-slash (position #\/ tar)) + (*default-pathname-defaults* + (merge-pathnames + (make-pathname :directory + `(:relative ,(subseq tar 0 pos-slash))) + source))) + (loop for asd in (directory + (make-pathname :name :wild :type "asd")) + do (let ((target (merge-pathnames + (make-pathname :name (pathname-name asd) + :type (pathname-type asd)) + system))) + (when (probe-file target) + (sb-posix:unlink target)) + (sb-posix:symlink asd target)) + collect (pathname-name asd)))) + +(defvar *temporary-files*) +(defun temp-file-name (p) + (let* ((pos-slash (position #\/ p :from-end t)) + (pos-dot (position #\. p :start (or pos-slash 0)))) + (merge-pathnames + (make-pathname + :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot) + :type "asdf-install-tmp")))) + + + +(defun run (&optional (packages (cdr *posix-argv*))) + (destructuring-bind (source system name) (where) + (labels ((one-iter (packages) + (dolist (asd + (loop for p in packages + unless (probe-file p) + do (let ((tmp (temp-file-name p))) + (pushnew tmp *temporary-files*) + (download p tmp) + (setf p tmp)) + end + do (format t "Installing ~A in ~A,~A~%" p source system) + append (install source system p))) + (handler-case + (asdf:operate 'asdf:load-op asd) + (asdf:missing-dependency (c) + (format t "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name (asdf::missing-required-by c))) + (one-iter (list + (symbol-name (asdf::missing-requires c))))))))) + (one-iter packages)))) + +(handler-case + (let ((*temporary-files* nil)) + (unwind-protect + (run) + (dolist (l *temporary-files*) + (when (probe-file l) (delete-file l))))) + (error (c) + (princ "Install failed due to error:") (terpri) + (princ c) (terpri) + (quit :unix-status 1))) + +;(quit) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,1308 @@ +;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ +;;; +;;; 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-2007 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 + #:system-licence + #:system-source-file + #:system-relative-pathname + + #: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 + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + #:duplicate-names + + #:retry + #:accept ; restarts + + #:preference-file-for-system/operation + #:load-preferences + ) + (: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.110 $") + (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) + +(defparameter +asdf-methods+ + '(perform explain output-files operation-done-p)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + +(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 "~@<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 "~@<~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 "~@<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 + :accessor system-license :initarg :license))) + +;;; 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 "~@<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 make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(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-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;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)) + (delete-package package)))) + (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* "~&~@<; ~@;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 ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + 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) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defmethod component-depends-on ((op-spec symbol) (c component)) + (component-depends-on (make-instance op-spec) c)) + +(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)) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ + operation ~S on component ~S as done.~@:>" + file o c) + (return-from operation-done-p t)))))) + (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 + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t 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 + "~@<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)) + (load-preferences c operation)) + +;;; 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)) + #-:broken-fasl-loader + (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 + "~@<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 + "~@<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)) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) + +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + +(defmethod input-files ((op compile-op) (c static-file)) + nil) + + +;;; load-op + +(defclass basic-load-op (operation) ()) + +(defclass load-op (basic-load-op) ()) + +(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 (basic-load-op) ()) + +(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) + +(defgeneric load-preferences (system operation) + (:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded.")) + +(defgeneric preference-file-for-system/operation (system operation) + (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load.")) + +(defmethod load-preferences ((s t) (operation t)) + ;; do nothing + (values)) + +(defmethod load-preferences ((s system) (operation basic-load-op)) + (let* ((*package* (find-package :common-lisp)) + (file (probe-file (preference-file-for-system/operation s operation)))) + (when file + (when *verbose-out* + (format *verbose-out* + "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" + (component-name s) + (type-of operation) file)) + (load file)))) + +(defmethod preference-file-for-system/operation ((system t) (operation t)) + ;; cope with anything other than systems + (preference-file-for-system/operation (find-system system t) operation)) + +(defmethod preference-file-for-system/operation ((s system) (operation t)) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil + :defaults *default-pathname-defaults*))) + (merge-pathnames + (make-pathname :name (component-name s) + :type "lisp" + :directory '(:relative ".asdf")) + (truename (user-homedir-pathname))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; invoking operations + +(defvar *operate-docstring* + "Operate does three things: + +1. It creates an instance of `operation-class` using any keyword parameters +as initargs. +2. It finds the asdf-system specified by `system` (possibly loading +it from disk). +3. It then calls `traverse` with the operation and system as arguments + +The traverse operation is wrapped in `with-compilation-unit` and error +handling code. If a `version` argument is supplied, then operate also +ensures that the system found satisfies it using the `version-satisfies` +method.") + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) + (let* ((op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((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 "~@<Retry performing ~S on ~S.~@:>" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@<Continue, treating ~S on ~S as ~ + having been successful.~@:>" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) + +(setf (documentation 'operate 'function) + *operate-docstring*) + +(defun oos (operation-class system &rest args &key force (verbose t) version) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" + *operate-docstring*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 + (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks *load-truename*))) + *default-pathname-defaults*) + ',component-options)))))) + + +(defun class-for-type (parent type) + (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) + (load-time-value + (package-name :asdf))))) + (class (dolist (symbol (if (keywordp type) + extra-symbols + (cons type extra-symbols))) + (when (and symbol + (find-class symbol nil) + (subtypep symbol 'component)) + (return (find-class symbol)))))) + (or class + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@<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 + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) + (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*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) + + (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)))) + + (%remove-component-inline-methods ret rest) + + ret))) + +(defun %remove-component-inline-methods (ret rest) + (loop for name in +asdf-methods+ + 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 name) m)) + (component-inline-methods ret))) + ;; clear methods, then add the new ones + (setf (component-inline-methods ret) nil) + (loop for name in +asdf-methods+ + for v = (getf rest (intern (symbol-name name) :keyword)) + when v do + (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) + "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-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-ext:process-exit-code + (sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + #+win32 #+win32 :search t + :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))) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) + (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)) + +(defun system-source-file (system-name) + (let ((system (asdf:find-system system-name))) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system)))) + +(defun system-source-directory (system-name) + (make-pathname :name nil + :type nil + :defaults (system-source-file system-name))) + +(defun system-relative-pathname (system pathname &key name type) + (let ((directory (pathname-directory pathname))) + (when (eq (car directory) :absolute) + (setf (car directory) :relative)) + (merge-pathnames + (make-pathname :name (or name (pathname-name pathname)) + :type (or type (pathname-type pathname)) + :directory directory) + (system-source-directory system)))) + + +(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)))) + + (defun contrib-sysdef-search (system) + (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (let* ((name (coerce-name system)) + (home (truename home)) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))))) + + (pushnew + '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (merge-pathnames "site-systems/" (truename home)))) + *central-registry*) + + (pushnew + '(merge-pathnames ".sbcl/systems/" + (user-homedir-pathname)) + *central-registry*) + + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) + +(provide 'asdf) + Added: branches/trunk-reorg/thirdparty/asdf/asdf.texinfo =================================================================== --- branches/trunk-reorg/thirdparty/asdf/asdf.texinfo 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/asdf.texinfo 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,1286 @@ +\input texinfo @c -*- texinfo -*- +@c %**start of header +@setfilename asdf.info +@settitle asdf Manual +@c %**end of header + +@c for install-info +@dircategory Software development +@direntry +* asdf: (asdf). another system definition facility +@end direntry + +@copying +This manual describes asdf, a system definition facility for Common +Lisp programs and libraries. + +asdf Copyright @copyright{} 2001-2007 Daniel Barlow and contributors + +This manual Copyright @copyright{} 2001-2007 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. + +@end copying + + + +@titlepage +@title asdf: another system definition facility + +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@c Output the table of contents at the beginning. +@contents + +@c ------------------- + +@ifnottex + +@node Top, Using asdf to load systems, (dir), (dir) +@top asdf: another system definition facility + +@insertcopying + +@menu +* Using asdf to load systems:: +* Defining systems with defsystem:: +* The object model of asdf:: +* Error handling:: +* Compilation error and warning handling:: +* Miscellaneous additional functionality:: +* Getting the latest version:: +* TODO list:: +* missing bits in implementation:: +* Inspiration:: +* Concept Index:: +* Function and Class Index:: +* Variable Index:: + +@detailmenu + --- The Detailed Node Listing --- + +Defining systems with defsystem + +* The defsystem form:: +* A more involved example:: +* The defsystem grammar:: + +The object model of asdf + +* Operations:: +* Components:: + +Operations + +* Predefined operations of asdf:: +* Creating new operations:: + +Components + +* Common attributes of components:: +* Pre-defined subclasses of component:: +* Creating new component types:: + +properties + +* Pre-defined subclasses of component:: +* Creating new component types:: + +@end detailmenu +@end menu + +@end ifnottex + +@c ------------------- + + +@node Using asdf to load systems, Defining systems with defsystem, Top, Top +@comment node-name, next, previous, up +@chapter Using asdf to load systems +@cindex system directory designator +@vindex *central-registry* + +This chapter describes how to use asdf to compile and load ready-made +Lisp programs and libraries. + +@section Downloading asdf + +Some Lisp implementations (such as SBCL and OpenMCL) come with asdf +included already, so you don't need to download it separately. +Consult your Lisp system's documentation. If you need to download +asdf and install it by hand, the canonical source is the cCLan CVS +repository at +@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/}. + +@section Setting up asdf + +The single file @file{asdf.lisp} is all you need to use asdf normally. +Once you load it in a running Lisp, you're ready to use asdf. For +maximum convenience you might want to have asdf loaded whenever you +start your Lisp implementation, for example by loading it from the +startup script or dumping a custom core -- check your Lisp +implementation's manual for details. + +The variable @code{asdf:*central-registry*} is a list of ``system +directory designators''@footnote{When we say ``directory'' here, we +mean ``designator for a pathname with a supplied DIRECTORY +component''.}. A @dfn{system directory designator} is a form which +will be evaluated whenever a system is to be found, and must evaluate +to a directory to look in. You might want to set or augment +@code{*central-registry*} in your Lisp init file, for example: + +@lisp +(setf asdf:*central-registry* + (list* '*default-pathname-defaults* + #p"/home/me/cl/systems/" + #p"/usr/share/common-lisp/systems/" + asdf:*central-registry*)) +@end lisp + +@section Setting up a system to be loaded + +To compile and load a system, you need to ensure that a symbolic link to its +system definition is in one of the directories in +@code{*central-registry*}@footnote{It is possible to customize the +system definition file search. That's considered advanced use, and +covered later: search forward for +@code{*system-definition-search-functions*}. @xref{Defining systems +with defsystem}.}. + +For example, if @code{#p"/home/me/cl/systems/"} (note the trailing +slash) is a member of @code{*central-registry*}, you would set up a +system @var{foo} that is stored in a directory +@file{/home/me/src/foo/} for loading with asdf with the following +commands at the shell (this has to be done only once): + +@example +$ cd /home/me/cl/systems/ +$ ln -s ~/src/foo/foo.asd . +@end example + +@section Loading a system + +The system @var{foo} is loaded (and compiled, if necessary) by +evaluating the following form in your Lisp implementation: + +@example +(asdf:operate 'asdf:load-op '@var{foo}) +@end example + +Output from asdf and asdf extensions are supposed to be sent to the CL +stream @code{*standard-output*}, and so rebinding that stream around +calls to @code{asdf:operate} should redirect all output from asdf +operations. + +That's all you need to know to use asdf to load systems written by +others. The rest of this manual deals with writing system +definitions for Lisp software you write yourself. + +@node Defining systems with defsystem, The object model of asdf, Using asdf to load systems, Top +@comment node-name, next, previous, up +@chapter Defining systems with defsystem + +This chapter describes how to use asdf to define systems and develop +software. + + +@menu +* The defsystem form:: +* A more involved example:: +* The defsystem grammar:: +* Other code in .asd files:: +@end menu + +@node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem +@comment node-name, next, previous, up +@section The defsystem form + +Systems can be constructed programmatically by instantiating +components using make-instance. Most of the time, however, it is much +more practical to use a static @code{defsystem} form. This section +begins with an example of a system definition, then gives the full +grammar of @code{defsystem}. + +Let's look at a simple system. This is a complete file that would +usually be saved as @file{hello-lisp.asd}: + +@lisp +(defpackage hello-lisp-system + (:use :common-lisp :asdf)) + +(in-package :hello-lisp-system) + +(defsystem "hello-lisp" + :description "hello-lisp: a sample Lisp system." + :version "0.2" + :author "Joe User <joe@@example.com>" + :licence "Public Domain" + :components ((:file "packages") + (:file "macros" :depends-on ("packages")) + (:file "hello" :depends-on ("macros")))) +@end lisp + +Some notes about this example: + +@itemize + +@item +The file starts with @code{defpackage} and @code{in-package} forms to +make and use a package expressly for defining this system in. This +package is named by taking the system name and suffixing +@code{-system} - note that it is @emph{not} the same package as you +will use for the application code. + +This is not absolutely required by asdf, but helps avoid namespace +pollution and so is considered good form. + +@item +The defsystem form defines a system named "hello-lisp" that contains +three source files: @file{packages}, @file{macros} and @file{hello}. + +@item +The file @file{macros} depends on @file{packages} (presumably because +the package it's in is defined in @file{packages}), and the file +@file{hello} depends on @file{macros} (and hence, transitively on +@file{packages}). This means that asdf will compile and load +@file{packages} and @file{macros} before starting the compilation of +file @file{hello}. + + +@item +The files are located in the same directory as the file with the +system definition. asdf resolves symbolic links before loading the system +definition file and stores its location in the resulting +system@footnote{It is possible, though almost never necessary, to +override this behaviour.}. This is a good thing because the user can +move the system sources without having to edit the system definition. + +@end itemize + +@node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem +@comment node-name, next, previous, up +@section A more involved example + +Let's illustrate some more involved uses of @code{defsystem} via a +slightly convoluted example: + +@lisp +(defsystem "foo" + :version "1.0" + :components ((:module "foo" :components ((:file "bar") (:file"baz") + (:file "quux")) + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c))) + (:file "blah"))) +@end lisp + +The method-form tokens need explaining: essentially, this part: + +@lisp + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c)) +@end lisp + +has the effect of + +@lisp +(defmethod perform :after ((op compile-op) (c (eql ...))) + (do-something c)) +(defmethod explain :after ((op compile-op) (c (eql ...))) + (explain-something c)) +@end lisp + +where @code{...} is the component in question; note that although this +also supports @code{:before} methods, they may not do what you want +them to -- a @code{:before} method on perform @code{((op compile-op) (c +(eql ...)))} will run after all the dependencies and sub-components +have been processed, but before the component in question has been +compiled. + +@node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem +@comment node-name, next, previous, up +@section The defsystem grammar + +@verbatim +system-definition := ( defsystem system-designator {option}* ) + +option := :components component-list + | :pathname pathname + | :default-component-class + | :perform method-form + | :explain method-form + | :output-files method-form + | :operation-done-p method-form + | :depends-on ( {simple-component-name}* ) + | :serial [ t | nil ] + | :in-order-to ( {dependency}+ ) + +component-list := ( {component-def}* ) + +component-def := simple-component-name + | ( component-type name {option}* ) + +component-type := :module | :file | :system | other-component-type + +dependency := (dependent-op {requirement}+) +requirement := (required-op {required-component}+) + | (feature feature-name) +dependent-op := operation-name +required-op := operation-name | feature +@end verbatim + +@subsection Serial dependencies + +If the @code{:serial t} option is specified for a module, asdf will add +dependencies for each each child component, on all the children +textually preceding it. This is done as if by @code{:depends-on}. + +@lisp +:components ((:file "a") (:file "b") (:file "c")) +:serial t +@end lisp + +is equivalent to + +@lisp +:components ((:file "a") + (:file "b" :depends-on ("a")) + (:file "c" :depends-on ("a" "b"))) +@end lisp + + +@subsection Source location + +The @code{:pathname} option is optional in all cases for systems +defined via @code{defsystem}, and in the usual case the user is +recommended not to supply it. + +Instead, asdf follows a hairy set of rules that are designed so that +@enumerate +@item @code{find-system} will load a system from disk and have its pathname +default to the right place +@item this pathname information will not be +overwritten with @code{*default-pathname-defaults*} (which could be +somewhere else altogether) if the user loads up the @file{.asd} file +into his editor and interactively re-evaluates that form. +@end enumerate + +If a system is being loaded for the first time, its top-level pathname +will be set to: + +@itemize +@item The host/device/directory parts of @code{*load-truename*}, if it is bound +@item @code{*default-pathname-defaults*}, otherwise +@end itemize + +If a system is being redefined, the top-level pathname will be + +@itemize +@item +changed, if explicitly supplied or obtained from +@code{*load-truename*} (so that an updated source location is +reflected in the system definition) +@item +changed if it had previously been set from +@code{*default-pathname-defaults*} +@item +left as before, if it had previously been set from +@code{*load-truename*} and @code{*load-truename*} is currently +unbound (so that a developer can evaluate a @code{defsystem} form from +within an editor without clobbering its source location) +@end itemize + +@node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem +@section Other code in .asd files + +Files containing defsystem forms are regular Lisp files that are +executed by @code{load}. Consequently, you can put whatever Lisp code +you like into these files (e.g., code that examines the compile-time +environment and adds appropriate features to @code{*features*}). +However, some conventions should be followed, so that users can +control certain details of execution of the Lisp in .asd files: + +@itemize +@item +Any informative output (other than warnings and errors, which are the +condition system's to dispose of) should be sent to the standard CL +stream @code{*standard-output*}, so that users can easily control the +disposition of output from asdf operations. +@end itemize + + +@node The object model of asdf, Error handling, Defining systems with defsystem, Top +@comment node-name, next, previous, up +@chapter The object model of asdf + +asdf is designed in an object-oriented way from the ground up. Both a +system's structure and the operations that can be performed on systems +follow a protocol. asdf is extensible to new operations and to new +component types. This allows the addition of behaviours: for example, +a new component could be added for Java JAR archives, and methods +specialised on @code{compile-op} added for it that would accomplish the +relevant actions. + +This chapter deals with @emph{components}, the building blocks of a +system, and @emph{operations}, the actions that can be performed on a +system. + + + +@menu +* Operations:: +* Components:: +@end menu + +@node Operations, Components, The object model of asdf, The object model of asdf +@comment node-name, next, previous, up +@section Operations +@cindex operation + +An @dfn{operation} object of the appropriate type is instantiated +whenever the user wants to do something with a system like + +@itemize +@item compile all its files +@item load the files into a running lisp environment +@item copy its source files somewhere else +@end itemize + +Operations can be invoked directly, or examined to see what their +effects would be without performing them. @emph{FIXME: document how!} There +are a bunch of methods specialised on operation and component type +that actually do the grunt work. + +The operation object contains whatever state is relevant for this +purpose (perhaps a list of visited nodes, for example) but primarily +is a nice thing to specialise operation methods on and easier than +having them all be EQL methods. + +Operations are invoked on systems via @code{operate}. + +@deffn {Generic function} operate operation system &rest initargs +@deffnx {Generic function} oos operation system &rest initargs +@code{operate} invokes @var{operation} on @var{system}. @code{oos} +is a synonym for @code{operate}. + +@var{operation} is a symbol that is passed, along with the supplied +@var{initargs}, to @code{make-instance} to create the operation object. +@var{system} is a system designator. + +The initargs are passed to the @code{make-instance} call when creating +the operation object. Note that dependencies may cause the operation +to invoke other operations on the system or its components: the new +operations will be created with the same initargs as the original one. + +@end deffn + +@menu +* Predefined operations of asdf:: +* Creating new operations:: +@end menu + +@node Predefined operations of asdf, Creating new operations, Operations, Operations +@comment node-name, next, previous, up +@subsection Predefined operations of asdf + +All the operations described in this section are in the @code{asdf} +package. They are invoked via the @code{operate} generic function. + +@lisp +(asdf:operate 'asdf:@var{operation-name} '@var{system-name} @{@var{operation-options ...}@}) +@end lisp + +@deffn Operation compile-op &key proclamations + +This operation compiles the specified component. If proclamations are +supplied, they will be proclaimed. This is a good place to specify +optimization settings. + +When creating a new component type, you should provide methods for +@code{compile-op}. + +When @code{compile-op} is invoked, component dependencies often cause +some parts of the system to be loaded as well as compiled. Invoking +@code{compile-op} does not necessarily load all the parts of the +system, though; use @code{load-op} to load a system. +@end deffn + +@deffn Operation load-op &key proclamations + +This operation loads a system. + +The default methods for @code{load-op} compile files before loading them. +For parity, your own methods on new component types should probably do +so too. +@end deffn + +@deffn Operation load-source-op + +This operation will load the source for the files in a module even if +the source files have been compiled. Systems sometimes have knotty +dependencies which require that sources are loaded before they can be +compiled. This is how you do that. + +If you are creating a component type, you need to implement this +operation - at least, where meaningful. +@end deffn + +@deffn Operation test-system-version &key minimum + +Asks the system whether it satisfies a version requirement. + +The default method accepts a string, which is expected to contain of a +number of integers separated by #\. characters. The method is not +recursive. The component satisfies the version dependency if it has +the same major number as required and each of its sub-versions is +greater than or equal to the sub-version number required. + +@lisp +(defun version-satisfies (x y) + (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)))))) +@end lisp + +If that doesn't work for your system, you can override it. I hope +you have as much fun writing the new method as @verb{|#lisp|} did +reimplementing this one. +@end deffn + +@deffn Operation feature-dependent-op + +An instance of @code{feature-dependent-op} will ignore any components +which have a @code{features} attribute, unless the feature combination +it designates is satisfied by @code{*features*}. This operation is +not intended to be instantiated directly, but other operations may +inherit from it. + +@end deffn + +@node Creating new operations, , Predefined operations of asdf, Operations +@comment node-name, next, previous, up +@subsection Creating new operations + +asdf was designed to be extensible in an object-oriented fashion. To +teach asdf new tricks, a programmer can implement the behaviour he +wants by creating a subclass of @code{operation}. + + +asdf's pre-defined operations are in no way ``privileged'', but it is +requested that developers never use the @code{asdf} package for +operations they develop themselves. The rationale for this rule is +that we don't want to establish a ``global asdf operation name +registry'', but also want to avoid name clashes. + +An operation must provide methods for the following generic functions +when invoked with an object of type @code{source-file}: @emph{FIXME describe +this better} + +@itemize + +@item @code{output-files} +@item @code{perform} +The @code{perform} method must call @code{output-files} to find out +where to put its files, because the user is allowed to override +@item @code{output-files} for local policy @code{explain} +@item @code{operation-done-p}, if you don't like the default one + +@end itemize + +Operations that print output should send that output to the standard +CL stream @code{*standard-output*}, as the Lisp compiler and loader do. + +@node Components, , Operations, The object model of asdf +@comment node-name, next, previous, up +@section Components +@cindex component +@cindex system +@cindex system designator +@vindex *system-definition-search-functions* + +A @dfn{component} represents a source file or (recursively) a +collection of components. A @dfn{system} is (roughly speaking) a +top-level component that can be found via @code{find-system}. + +A @dfn{system designator} is a string or symbol and behaves just like +any other component name (including with regard to the case conversion +rules for component names). + + +@defun find-system system-designator &optional (error-p t) + +Given a system designator, @code{find-system} finds and returns a +system. If no system is found, an error of type +@code{missing-component} is thrown, or @code{nil} is returned if +@code{error-p} is false. + +To find and update systems, @code{find-system} funcalls each element +in the @code{*system-definition-search-functions*} list, expecting a +pathname to be returned. The resulting pathname is loaded if either +of the following conditions is true: + +@itemize +@item there is no system of that name in memory +@item the file's last-modified time exceeds the last-modified time of the + system in memory +@end itemize + +When system definitions are loaded from @file{.asd} files, a new +scratch package is created for them to load into, so that different +systems do not overwrite each others operations. The user may also +wish to (and is recommended to) include @code{defpackage} and +@code{in-package} forms in his system definition files, however, so +that they can be loaded manually if need be. + +The default value of @code{*system-definition-search-functions*} is a +function that looks in each of the directories given by evaluating +members of @code{*central-registry*} for a file whose name is the +name of the system and whose type is @file{asd}. The first such file +is returned, whether or not it turns out to actually define the +appropriate system. Hence, it is strongly advised to define a system +@var{foo} in the corresponding file @var{foo.asd}. +@end defun + + +@menu +* Common attributes of components:: +* Pre-defined subclasses of component:: +* Creating new component types:: +@end menu + +@node Common attributes of components, Pre-defined subclasses of component, Components, Components +@comment node-name, next, previous, up +@subsection Common attributes of components + +All components, regardless of type, have the following attributes. +All attributes except @code{name} are optional. + +@subsubsection Name + +A component name is a string or a symbol. If a symbol, its name is +taken and lowercased. The name must be a suitable value for the +@code{:name} initarg to @code{make-pathname} in whatever filesystem +the system is to be found. + +The lower-casing-symbols behaviour is unconventional, but was selected +after some consideration. Observations suggest that the type of +systems we want to support either have lowercase as customary case +(Unix, Mac, windows) or silently convert lowercase to uppercase +(lpns), so this makes more sense than attempting to use @code{:case +:common} as argument to @code{make-pathname}, which is reported not to +work on some implementations + +@subsubsection Version identifier + +This optional attribute is used by the test-system-version +operation. @xref{Predefined operations of asdf}. For the default method of +test-system-version, the version should be a string of intergers +separated by dots, for example @samp{1.0.11}. + +@subsubsection Required features + +Traditionally defsystem users have used reader conditionals to include +or exclude specific per-implementation files. This means that any +single implementation cannot read the entire system, which becomes a +problem if it doesn't wish to compile it, but instead for example to +create an archive file containing all the sources, as it will omit to +process the system-dependent sources for other systems. + +Each component in an asdf system may therefore specify features using +the same syntax as #+ does, and it will (somehow) be ignored for +certain operations unless the feature conditional is a member of +@code{*features*}. + + +@subsubsection Dependencies + +This attribute specifies dependencies of the component on its +siblings. It is optional but often necessary. + +There is an excitingly complicated relationship between the initarg +and the method that you use to ask about dependencies + +Dependencies are between (operation component) pairs. In your +initargs for the component, you can say + +@lisp +:in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) + (load-op (load-op "foo"))) +@end lisp + +This means the following things: +@itemize +@item +before performing compile-op on this component, we must perform +load-op on @var{a} and @var{b}, and compile-op on @var{c}, +@item +before performing @code{load-op}, we have to load @var{foo} +@end itemize + +The syntax is approximately + +@verbatim +(this-op {(other-op required-components)}+) + +required-components := component-name + | (required-components required-components) + +component-name := string + | (:version string minimum-version-object) +@end verbatim + +Side note: + +This is on a par with what ACL defsystem does. mk-defsystem is less +general: it has an implied dependency + +@verbatim + for all x, (load x) depends on (compile x) +@end verbatim + +and using a @code{:depends-on} argument to say that @var{b} depends on +@var{a} @emph{actually} means that + +@verbatim + (compile b) depends on (load a) +@end verbatim + +This is insufficient for e.g. the McCLIM system, which requires that +all the files are loaded before any of them can be compiled ] + +End side note + +In asdf, the dependency information for a given component and +operation can be queried using @code{(component-depends-on operation +component)}, which returns a list + +@lisp +((load-op "a") (load-op "b") (compile-op "c") ...) +@end lisp + +@code{component-depends-on} can be subclassed for more specific +component/operation types: these need to @code{(call-next-method)} and +append the answer to their dependency, unless they have a good reason +for completely overriding the default dependencies + +(If it weren't for CLISP, we'd be using a @code{LIST} method +combination to do this transparently. But, we need to support CLISP. +If you have the time for some CLISP hacking, I'm sure they'd welcome +your fixes) + +@subsubsection pathname + +This attribute is optional and if absent will be inferred from the +component's name, type (the subclass of source-file), and the location +of its parent. + +The rules for this inference are: + +(for source-files) +@itemize +@item the host is taken from the parent +@item pathname type is @code{(source-file-type component system)} +@item the pathname case option is @code{:local} +@item the pathname is merged against the parent +@end itemize + +(for modules) +@itemize +@item the host is taken from the parent +@item the name and type are @code{NIL} +@item the directory is @code{(:relative component-name)} +@item the pathname case option is @code{:local} +@item the pathname is merged against the parent +@end itemize + +Note that the DEFSYSTEM operator (used to create a ``top-level'' +system) does additional processing to set the filesystem location of +the top component in that system. This is detailed +elsewhere, @xref{Defining systems with defsystem}. + +The answer to the frequently asked question "how do I create a system +definition where all the source files have a .cl extension" is thus + +@lisp +(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys)))) + "cl") +@end lisp + +@subsubsection properties + +This attribute is optional. + +Packaging systems often require information about files or systems in +addition to that specified by asdf's pre-defined component attributes. +Programs that create vendor packages out of asdf systems therefore +have to create ``placeholder'' information to satisfy these systems. +Sometimes the creator of an asdf system may know the additional +information and wish to provide it directly. + +(component-property component property-name) and associated setf +method will allow the programmatic update of this information. +Property names are compared as if by @code{EQL}, so use symbols or +keywords or something. + +@menu +* Pre-defined subclasses of component:: +* Creating new component types:: +@end menu + +@node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components +@comment node-name, next, previous, up +@subsection Pre-defined subclasses of component + +@deffn Component source-file + +A source file is any file that the system does not know how to +generate from other components of the system. + +Note that this is not necessarily the same thing as ``a file +containing data that is typically fed to a compiler''. If a file is +generated by some pre-processor stage (e.g. a @file{.h} file from +(a)file{.h.in} by autoconf) then it is not, by this definition, a source +file. Conversely, we might have a graphic file that cannot be +automatically regenerated, or a proprietary shared library that we +received as a binary: these do count as source files for our purposes. + +Subclasses of source-file exist for various languages. @emph{FIXME: +describe these.} +@end deffn + +@deffn Component module + +A module is a collection of sub-components. + +A module component has the following extra initargs: + +@itemize +@item +@code{:components} the components contained in this module + +@item +@code{:default-component-class} All child components which don't +specify their class explicitly are inferred to be of this type. + +@item +@code{:if-component-dep-fails} This attribute takes one of the values +@code{:fail}, @code{:try-next}, @code{:ignore}, its default value is +@code{:fail}. The other values can be used for implementing +conditional compilation based on implementation @code{*features*}, for +the case where it is not necessary for all files in a module to be +compiled. + +@item +@code{:serial} When this attribute is set, each subcomponent of this +component is assumed to depend on all subcomponents before it in the +list given to @code{:components}, i.e. all of them are loaded before +a compile or load operation is performed on it. + +@end itemize + +The default operation knows how to traverse a module, so most +operations will not need to provide methods specialised on modules. + +@code{module} may be subclassed to represent components such as +foreign-language linked libraries or archive files. +@end deffn + +@deffn Component system + +@code{system} is a subclass of @code{module}. + +A system is a module with a few extra attributes for documentation +purposes; these are given elsewhere. @xref{The defsystem grammar}. + +Users can create new classes for their systems: the default +@code{defsystem} macro takes a @code{:classs} keyword +argument. +@end deffn + +@node Creating new component types, , Pre-defined subclasses of component, Components +@comment node-name, next, previous, up +@subsection Creating new component types + +New component types are defined by subclassing one of the existing +component classes and specializing methods on the new component class. + +@emph{FIXME: this should perhaps be explained more throughly, not only by +example ...} + +As an example, suppose we have some implementation-dependent +functionality that we want to isolate in one subdirectory per Lisp +implementation our system supports. We create a subclass of +@code{cl-source-file}: + +@lisp +(defclass unportable-cl-source-file (cl-source-file) + ()) +@end lisp + +A hypothetical function @code{system-dependent-dirname} gives us the +name of the subdirectory. All that's left is to define how to +calculate the pathname of an @code{unportable-cl-source-file}. + +@lisp +(defmethod component-pathname ((component unportable-cl-source-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (system-dependent-dirname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) +@end lisp + +The new component type is used in a @code{defsystem} form in this way: + +@lisp +(defsystem :foo + :components + ((:file "packages") + ... + (:unportable-cl-source-file "threads" + :depends-on ("packages" ...)) + ... + ) +@end lisp + +@node Error handling, Compilation error and warning handling, The object model of asdf, Top +@comment node-name, next, previous, up +@chapter Error handling +@findex SYSTEM-DEFINITION-ERROR +@findex OPERATION-ERROR + +It is an error to define a system incorrectly: an implementation may +detect this and signal a generalised instance of +@code{SYSTEM-DEFINITION-ERROR}. + +Operations may go wrong (for example when source files contain +errors). These are signalled using generalised instances of +@code{OPERATION-ERROR}. + +@node Compilation error and warning handling, Miscellaneous additional functionality, Error handling, Top +@comment node-name, next, previous, up +@chapter Compilation error and warning handling +@vindex *compile-file-warnings-behaviour* +@vindex *compile-file-errors-behavior* + +ASDF checks for warnings and errors when a file is compiled. The +variables @code{*compile-file-warnings-behaviour*} and +@code{*compile-file-errors-behavior*} controls the handling of any +such events. The valid values for these variables are @code{:error}, +@code{:warn}, and @code{:ignore}. + +@node Miscellaneous additional functionality, Getting the latest version, Compilation error and warning handling, Top +@comment node-name, next, previous, up +@chapter Additional Functionality + +ASDF includes several additional features that are generally +useful for system definition and development. These include: + +@enumerate +@item +system-relative-pathname + +It's often handy to locate a file relative to some system. The system-relative-pathname function meets this need. It takes two arguments: the name of a system and a relative pathname. It returns a pathname built from the +location of the system's source file and the relative pathname. For example + +@lisp +> (asdf:system-relative-pathname 'cl-ppcre "regex.data") +#P"/repository/other/cl-ppcre/regex.data" +@end lisp + +@item +hyperdocumentation + +to be documented + +@item +hyperdoc + +to be documented + +@end enumerate + + +@node Getting the latest version, TODO list, Miscellaneous additional functionality, Top +@comment node-name, next, previous, up +@chapter Getting the latest version + +@enumerate +@item +Decide which version you want. HEAD is the newest version and +usually OK, whereas RELEASE is for cautious people (e.g. who already +have systems using asdf that they don't want broken), a slightly older +version about which none of the HEAD users have complained. + +@item +Check it out from sourceforge cCLan CVS: + +@kbd{cvs -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan login} + +(no password: just press @key{Enter}) + +@kbd{cvs -z3 -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan co -r RELEASE asdf} + +or for the bleeding edge, instead + +@kbd{cvs -z3 -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan co -A asdf} + +@end enumerate + +If you are tracking the bleeding edge, you may want to subscribe to +the cclan-commits mailing list (see +@url{http://sourceforge.net/mail/?group_id=28536}) to receive commit +messages and diffs whenever changes are made. + +For more CVS information, look at +@url{http://sourceforge.net/cvs/?group_id=28536}. + + + + +@node TODO list, missing bits in implementation, Getting the latest version, Top +@comment node-name, next, previous, up +@chapter TODO list + +* Outstanding spec questions, things to add + +** packaging systems + +*** manual page component? + +** style guide for .asd files + +You should either use keywords or be careful with the package that you +evaluate defsystem forms in. Otherwise (defsystem partition ...) +being read in the cl-user package will intern a cl-user:partition +symbol, which will then collide with the partition:partition symbol. + +Actually there's a hairier packages problem to think about too. +in-order-to is not a keyword: if you read defsystem forms in a package +that doesn't use ASDF, odd things might happen + +** extending defsystem with new options + +You might not want to write a whole parser, but just to add options to +the existing syntax. Reinstate parse-option or something akin + +** document all the error classes + +** what to do with compile-file failure + +Should check the primary return value from compile-file and see if +that gets us any closer to a sensible error handling strategy + +** foreign files + +lift unix-dso stuff from db-sockets + +** Diagnostics + +A ``dry run'' of an operation can be made with the following form: + +@lisp +(traverse (make-instance '<operation-name>) + (find-system <system-name>) + 'explain) +@end lisp + +This uses unexported symbols. What would be a nice interface for this +functionality? + +@node missing bits in implementation, Inspiration, TODO list, Top +@comment node-name, next, previous, up +@chapter missing bits in implementation + +** all of the above + +** reuse the same scratch package whenever a system is reloaded from disk + +** rules for system pathname defaulting are not yet implemented properly + +** proclamations probably aren't + +** when a system is reloaded with fewer components than it previously + had, odd things happen + +we should do something inventive when processing a defsystem form, +like take the list of kids and setf the slot to nil, then transfer +children from old to new list as they're found + +** traverse may become a normal function + +If you're defining methods on traverse, speak up. + + +** a lot of load-op methods can be rewritten to use input-files + +so should be. + + +** (stuff that might happen later) + +*** david lichteblau's patch for symlink resolution? + +*** Propagation of the :force option. ``I notice that + + (oos 'compile-op :araneida :force t) + +also forces compilation of every other system the :araneida system +depends on. This is rarely useful to me; usually, when I want to force +recompilation of something more than a single source file, I want to +recompile only one system. So it would be more useful to have +make-sub-operation refuse to propagate @code{:force t} to other systems, and +propagate only something like @code{:force :recursively}. + +Ideally what we actually want is some kind of criterion that says to +which systems (and which operations) a @code{:force} switch will +propagate. + +The problem is perhaps that `force' is a pretty meaningless concept. +How obvious is it that @code{load :force t} should force +@emph{compilation}? But we don't really have the right dependency +setup for the user to compile @code{:force t} and expect it to work +(files will not be loaded after compilation, so the compile +environment for subsequent files will be emptier than it needs to be) + +What does the user actually want to do when he forces? Usually, for +me, update for use with a new version of the lisp compiler. Perhaps +for recovery when he suspects that something has gone wrong. Or else +when he's changed compilation options or configuration in some way +that's not reflected in the dependency graph. + +Other possible interface: have a 'revert' function akin to 'make clean' + +@lisp +(asdf:revert 'asdf:compile-op 'araneida) +@end lisp + +would delete any files produced by 'compile-op 'araneida. Of course, it +wouldn't be able to do much about stuff in the image itself. + +How would this work? + +traverse + +There's a difference between a module's dependencies (peers) and its +components (children). Perhaps there's a similar difference in +operations? For example, @code{(load "use") depends-on (load "macros")} is a +peer, whereas @code{(load "use") depends-on (compile "use")} is more of a +`subservient' relationship. + +@node Inspiration, Concept Index, missing bits in implementation, Top +@comment node-name, next, previous, up +@chapter Inspiration + +@section mk-defsystem (defsystem-3.x) + +We aim to solve basically the same problems as mk-defsystem does. +However, our architecture for extensibility better exploits CL +language features (and is documented), and we intend to be portable +rather than just widely-ported. No slight on the mk-defsystem authors +and maintainers is intended here; that implementation has the +unenviable task of supporting pre-ANSI implementations, which is +no longer necessary. + +The surface defsystem syntax of asdf is more-or-less compatible with +mk-defsystem, except that we do not support the @code{source-foo} and +@code{binary-foo} prefixes for separating source and binary files, and +we advise the removal of all options to specify pathnames. + +The mk-defsystem code for topologically sorting a module's dependency +list was very useful. + +@section defsystem-4 proposal + +Marco and Peter's proposal for defsystem 4 served as the driver for +many of the features in here. Notable differences are: + +@itemize +@item +We don't specify output files or output file extensions as part of the +system. + +If you want to find out what files an operation would create, ask the +operation. + +@item +We don't deal with CL packages + +If you want to compile in a particular package, use an in-package form +in that file (ilisp / SLIME will like you more if you do this anyway) + +@item +There is no proposal here that defsystem does version control. + +A system has a given version which can be used to check dependencies, +but that's all. +@end itemize + +The defsystem 4 proposal tends to look more at the external features, +whereas this one centres on a protocol for system introspection. + +@section kmp's ``The Description of Large Systems'', MIT AI Memu 801 + +Available in updated-for-CL form on the web at +@url{http://world.std.com/~pitman/Papers/Large-Systems.html} + +In our implementation we borrow kmp's overall PROCESS-OPTIONS and +concept to deal with creating component trees from defsystem surface +syntax. [ this is not true right now, though it used to be and +probably will be again soon ] + + +@c ------------------- + + +@node Concept Index, Function and Class Index, Inspiration, Top +@unnumbered Concept Index + +@printindex cp + +@node Function and Class Index, Variable Index, Concept Index, Top +@unnumbered Function and Class Index + +@printindex fn + +@node Variable Index, , Function and Class Index, Top +@unnumbered Variable Index + +@printindex vr + + + + +@bye + Added: branches/trunk-reorg/thirdparty/asdf/cclan-package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/cclan-package.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/cclan-package.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,5 @@ +(in-package :cl-user) + +(defpackage :cclan (:use #:cl #:asdf) + (:export #:all-components #:write-package)) + Added: branches/trunk-reorg/thirdparty/asdf/cclan.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/cclan.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/cclan.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- +(defpackage :cclan-system (:use #:cl #:asdf)) +(in-package :cclan-system) + +(defsystem cclan + :version "0.1" + :components ((:file "cclan-package") + (:file "cclan" :depends-on ("cclan-package")))) Added: branches/trunk-reorg/thirdparty/asdf/cclan.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/cclan.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/cclan.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,99 @@ +(in-package :cclan) + +;;;; This file contains functions, classes etc that are not part of +;;;; asdf itself, but extend it in various ways useful for maintainers +;;;; of new-style cCLan packages + +;;;; The public interface consists of the functions whose symbols are +;;;; exported from the package + +;;;; This file does not contain references to asdf internals - or +;;;; shouldn't, anyway. Send bug reports + + +(defun mapappend (function list) + (let ((f (coerce function 'function))) + (loop for i in list append (funcall f i)))) + +(defgeneric all-components (component)) +(defmethod all-components ((source-file source-file)) + (list source-file)) + +(defmethod all-components ((module module)) + (cons module (mapappend #'all-components (module-components module)))) + +(defmethod all-components ((module symbol)) + (all-components (find-system module))) + +(defun cvs-tag-name (system) + (let* ((system (find-system system)) + (version (component-version system))) + (format nil "release_~A" (substitute #\_ #\. version)))) + +(defun cvs-tag (system) + (let* ((system (find-system system)) + (directory (component-pathname system))) + (run-shell-command "cd ~A && cvs tag -F ~A" + (namestring directory) (cvs-tag-name system)))) + + +(defun write-readme-file (stream suggested-registry system-name) + "Write a README.install file detailing a possible sequence of commands to use the newly-untarred system." + (format stream "~ +1. Make a symlink in ~W[*] pointing to the .asd file +2. Start your asdf-enabled lisp +2a. Ensure that ~W[*] is in asdf:*central-registry* +3. At the lisp prompt, type '(asdf:operate 'asdf:load-op ~W)'. This + will compile and load the system into your running lisp. + +[*] This path (~W) is only a suggestion; the important +thing is that asdf know where to find the .asd file. asdf uses the +contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system +definitions. + +These instructions were automatically generated by cCLan software. Use +at your own peril.~%" suggested-registry suggested-registry system-name suggested-registry)) + +(defun write-package (system) + (let* ((parent-dir + (parse-namestring + (format nil "/tmp/~A.~A/" + #+sbcl (sb-unix:unix-getpid) + #-sbcl (random 1000000) + (get-internal-run-time)))) + (system (find-system system)) + (sub-dir-name + (format nil "~A_~A" + (component-name system) (component-version system))) + (cvsroot-file + (merge-pathnames "CVS/Root" (component-pathname system))) + (old-pwd *default-pathname-defaults*) + (*default-pathname-defaults* parent-dir)) + (ensure-directories-exist parent-dir) + (cvs-tag system) + (and + (zerop (asdf:run-shell-command + "cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A" + (namestring parent-dir) + (namestring cvsroot-file) + sub-dir-name + (cvs-tag-name system) + (component-name system))) + (with-open-file (o (format nil "~A/INSTALL.asdf" sub-dir-name) + :direction :output) + (write-readme-file o "$HOME/lisp/systems/" (component-name system)) + t) + (zerop (asdf:run-shell-command "cd ~A && tar cf ~A~A.tar ~A" + (namestring parent-dir) + (namestring old-pwd) sub-dir-name + sub-dir-name)) + (zerop (asdf:run-shell-command + "gzip -f9 ~A~A.tar" + (namestring old-pwd) sub-dir-name)) + (format t "Now run~% gpg -b -a ~A~A.tar.gz~%in a shell with a tty" + (namestring old-pwd) sub-dir-name)))) + +(defun class-name-of (x) + (class-name (class-of x))) + + Added: branches/trunk-reorg/thirdparty/asdf/debian/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/CVS/Entries 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/CVS/Entries 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,12 @@ +/README.Debian/1.2/Sat Jul 2 19:58:38 2005// +/changelog/1.61/Fri Sep 30 06:18:46 2005// +/cl-asdf.postinst/1.6/Sun Feb 9 19:34:40 2003// +/cl-cclan.postinst/1.5/Mon Dec 9 17:27:21 2002// +/cl-cclan.prerm/1.5/Mon Dec 9 17:27:21 2002// +/compat/1.2/Sat Jun 7 22:34:20 2003// +/control/1.17/Fri Jul 1 12:03:47 2005// +/copyright/1.2/Mon Dec 2 16:29:15 2002// +/docs/1.1/Sun Aug 18 07:41:36 2002// +/postinst/1.6/Wed May 25 06:23:00 2005// +/rules/1.9/Fri Sep 30 06:18:46 2005// +D Added: branches/trunk-reorg/thirdparty/asdf/debian/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/CVS/Repository 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/CVS/Repository 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +asdf/debian Added: branches/trunk-reorg/thirdparty/asdf/debian/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/CVS/Root 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/CVS/Root 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +:pserver:anonymous@cclan.cvs.sourceforge.net:/cvsroot/cclan Added: branches/trunk-reorg/thirdparty/asdf/debian/README.Debian =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/README.Debian 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/README.Debian 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,18 @@ +Debian Package cl-asdf +---------------------- + +This package was created for Debian by Kevin M. Rosenberg +<kmr(a)debian.org> in Aug 2002. The URL for asdf is +http://www.telent.net/cliki/asdf. The README file has details +about the use of asdf. + +To load asdf into your Lisp system, give the command +(load "/usr/share/common-lisp/source/asdf/asdf.lisp") + +Additionally, there is an optional module that you can load +with the command +(load "/usr/share/common-lisp/source/asdf/wild-modules.lisp") + +This package is build using darcs-buildpackage and the darcs archives can be +downloaded from http://people.debian.org/~pvaneynd/repository/ + Added: branches/trunk-reorg/thirdparty/asdf/debian/changelog =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/changelog 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/changelog 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,358 @@ +cl-asdf (1.88-1) unstable; urgency=low + + * Noticed that I actually increased the version with the CVS commit + * Updated the standards version + * Remove the prepare build stuff, build through darcs + * Improve duplicate names test: use equal instead of equalp. + From a comment from Faré. + + -- Peter Van Eynde <pvaneynd(a)debian.org> Thu, 22 Sep 2005 12:52:31 +0200 + +cl-asdf (1.86-5) unstable; urgency=low + + * Fixed duplicate components patch to better handle reloading + defsystem files. Now works again with McClim. Closes: #310640 + * Corrected dependencies. + * Added postinst rebuild of all clc-enabled lisps so the new version + actually gets loaded. + + -- Peter Van Eynde <pvaneynd(a)debian.org> Wed, 25 May 2005 08:22:17 +0200 + +cl-asdf (1.86-4) unstable; urgency=low + + * My release script stripped the patch. So this should really contain the + patch. Damn. + + -- Peter Van Eynde <pvaneynd(a)debian.org> Tue, 10 May 2005 14:17:51 +0200 + +cl-asdf (1.86-3) unstable; urgency=low + + * Now checks if components names are unique Closes: #304972, #304970 + * Fix dependency on common-lisp-controller Closes: #308385 + + -- Peter Van Eynde <pvaneynd(a)debian.org> Tue, 10 May 2005 07:50:25 +0200 + +cl-asdf (1.86-2) unstable; urgency=low + + * New maintainer. (Closes: #297349: O: cl-asdf -- Another System + Definition Facility) + * Adopted by Peter Van Eynde + + -- Peter Van Eynde <pvaneynd(a)debian.org> Tue, 1 Mar 2005 10:11:55 +0100 + +cl-asdf (1.86-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 4 Aug 2004 21:19:16 -0600 + +cl-asdf (1.84-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 12 May 2004 12:43:58 -0600 + +cl-asdf (1.81-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 30 Dec 2003 12:12:38 -0700 + +cl-asdf (1.80-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 5 Dec 2003 14:55:43 -0700 + +cl-asdf (1.79-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 16:12:07 -0700 + +cl-asdf (1.78-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 9 Oct 2003 16:46:38 -0600 + +cl-asdf (1.77.2-1) unstable; urgency=low + + * Don't export asdf:wild-module as can cause a full warning when + reloading asdf + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 11 Aug 2003 21:55:16 -0600 + +cl-asdf (1.77.1-1) unstable; urgency=low + + * cclan.lisp: conditionalize for sbcl (closes: 201822) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 17 Jul 2003 23:30:57 -0600 + +cl-asdf (1.77-1) unstable; urgency=low + + * New upstream + * Add automated [cvs2cl] ChangeLog + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 17 Jul 2003 10:27:27 -0600 + +cl-asdf (1.76) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 10 Jul 2003 16:42:48 -0600 + +cl-asdf (1.75) unstable; urgency=low + + * New upstream + * Use compat rather than DH_COMPAT + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 5 Jun 2003 00:15:11 -0600 + +cl-asdf (1.73b) unstable; urgency=low + + * Update README + * export two variables + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 28 May 2003 11:19:40 -0600 + +cl-asdf (1.73) unstable; urgency=low + + * Update README to mention asdf::*compile-file-warnings-behaviour* + (closes:194957) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 27 May 2003 16:00:36 -0600 + +cl-asdf (1.72) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 20 May 2003 14:07:10 -0600 + +cl-asdf (1.71) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 13 May 2003 09:33:51 -0600 + +cl-asdf (1.70) unstable; urgency=low + + * Add another check in check-component-values. + * Signal a generalized instance of SYSTEM-DEFINITION-ERROR + from check-component-values + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 6 May 2003 09:32:16 -0600 + +cl-asdf (1.69) unstable; urgency=low + + * Add check-component-values function with partial checking of components + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 6 May 2003 08:26:11 -0600 + +cl-asdf (1.68) unstable; urgency=low + + * New upstream with 'asdf:test-op + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 19 Mar 2003 10:16:01 -0700 + +cl-asdf (1.66) unstable; urgency=low + + * New upstream version, added changes to dependent system + compilations with :force option. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 17 Mar 2003 12:50:00 -0700 + +cl-asdf (1.62) unstable; urgency=low + + * New upstream, fixes a sbcl-specific directory name + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 7 Mar 2003 09:23:11 -0700 + +cl-asdf (1.61-1) unstable; urgency=low + + * New upstream, fixes 'load-source-op + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 4 Mar 2003 09:48:40 -0700 + +cl-asdf (1.60-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 3 Mar 2003 12:40:27 -0700 + +cl-asdf (1.59-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 14 Feb 2003 09:24:59 -0700 + +cl-asdf (1.58-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 9 Feb 2003 11:55:03 -0700 + +cl-asdf (1.57-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 4 Feb 2003 10:23:03 -0700 + +cl-asdf (1.55-1) unstable; urgency=low + + * New upstream.version (closes: 172074) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 9 Dec 2002 10:23:21 -0700 + +cl-asdf (1.54-1) unstable; urgency=low + + * New upstream. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 8 Nov 2002 07:30:41 -0700 + +cl-asdf (1.49-1) unstable; urgency=low + + * Remove clc-reregister-all-impl from postinst + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 5 Oct 2002 09:38:18 -0600 + +cl-asdf (1.49) unstable; urgency=low + + * New upstream release, fixes run-shell-command for allegro. Code + refactoring for run-shell-code. + * Support new CLC reregister command + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 25 Sep 2002 23:57:23 -0600 + +cl-asdf (1.47) unstable; urgency=low + + * Return numeric exit status for openmcl's run-shell-command + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 20 Sep 2002 10:22:36 -0600 + +cl-asdf (1.46) unstable; urgency=low + + * New upstream version, adds run-shell-command for openmcl + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 20 Sep 2002 10:11:48 -0600 + +cl-asdf (1.45) unstable; urgency=low + + * Changes to improve clisp support + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 20 Sep 2002 07:12:21 -0600 + +cl-asdf (1.44.1-1) unstable; urgency=low + + * Make cclan.asd a symlink, remove :pathname keyword + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 18 Sep 2002 00:19:26 -0600 + +cl-asdf (1.44-1) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 17 Sep 2002 12:24:27 -0600 + +cl-asdf (1.43-1) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 17 Sep 2002 10:34:57 -0600 + +cl-asdf (1.42-2) unstable; urgency=low + + * Add reregister-common-lisp-implementations call when installing cl-asdf. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 16 Sep 2002 08:31:13 -0600 + +cl-asdf (1.42-1) unstable; urgency=low + + * Remove Depends on lisp-compiler for cl-asdf (fixes problem with + circular dependencies) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 14 Sep 2002 11:59:58 -0600 + +cl-asdf (1.42) unstable; urgency=low + + * New upstream. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Sep 2002 08:40:58 -0600 + +cl-asdf (1.41) unstable; urgency=low + + * Same release as 1.40, but with proper version number. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Sep 2002 08:38:30 -0600 + +cl-asdf (1.40) unstable; urgency=low + + * New upstream version. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Sep 2002 07:31:27 -0600 + +cl-asdf (1.39) unstable; urgency=low + + * New upstream version. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 11 Sep 2002 19:21:32 -0600 + +cl-asdf (1.38) unstable; urgency=low + + * New upstream version + * Re-add register and unregister clc-source for cclan + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 11 Sep 2002 13:39:51 -0600 + +cl-asdf (1.35-1) unstable; urgency=low + + * Comment call to register and unregister clc-source until new + version of clc is released. (closes: 158697) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 28 Aug 2002 18:58:59 -0600 + +cl-asdf (1.35) unstable; urgency=high + + * New upstream version, fixes important bugs. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 28 Aug 2002 09:36:58 -0600 + +cl-asdf (1.34) unstable; urgency=low + + * New upstream version. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 28 Aug 2002 07:18:57 -0600 + +cl-asdf (0.0+cvs.2002.08.26-1) unstable; urgency=low + + * Add Common Lisp Controller registration functions for cl-cclan + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 26 Aug 2002 04:21:32 -0600 + +cl-asdf (0.0+cvs.2002.08.26) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 26 Aug 2002 01:23:48 -0600 + +cl-asdf (0.0+cvs.2002.08.22) unstable; urgency=low + + * Add new binary package: cl-cclan + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 22 Aug 2002 12:43:21 -0600 + +cl-asdf (0.0+cvs.2002.08.18) unstable; urgency=low + + * New upstream version + * Expand description in control file. + * Change version numbering scheme since upstream has native debian + directory + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 17 Aug 2002 14:25:33 -0600 + +cl-asdf (0.0+cvs.2002.08.15-1) unstable; urgency=low + + * Initial Release (closes: 157009) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 16 Aug 2002 23:14:49 -0600 + Added: branches/trunk-reorg/thirdparty/asdf/debian/cl-asdf.postinst =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/cl-asdf.postinst 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/cl-asdf.postinst 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,45 @@ +#! /bin/sh +# postinst script for asdf + +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 http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# 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'. + +case "$1" in + configure) + if [ -x /usr/sbin/clc-reregister-all-impl ]; then + /usr/sbin/clc-reregister-all-impl + fi + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.postinst =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.postinst 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.postinst 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,41 @@ +#!/bin/sh + +set -e + +pkg=cclan + +# 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 http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# 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'. + +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 1 + ;; +esac + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.prerm =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.prerm 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/cl-cclan.prerm 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,36 @@ +#!/bin/sh + +set -e + +pkg=cclan + +# 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 http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source $pkg + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/asdf/debian/compat =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/compat 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/compat 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,2 @@ +4 +4 Added: branches/trunk-reorg/thirdparty/asdf/debian/control =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/control 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/control 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,25 @@ +Source: cl-asdf +Section: devel +Priority: optional +Maintainer: Peter Van Eynde <pvaneynd(a)debian.org> +Build-Depends-Indep: debhelper (>> 4.0.0), cvs2cl +Standards-Version: 3.6.2.1 + +Package: cl-asdf +Architecture: all +Recommends: common-lisp-controller, sbcl | lisp-compiler +Description: Another System Definition Facility + asdf provides a "make" type functions for Common Lisp packages. It + provides compilation and loading features for complex Lisp systems + with multiple modules and files. It is similar in concept to, but + with features different from, "defsystem" which is included in the + common-lisp-controller package. Unlike defsystem3 in CLC, asdf is + object-oriented and extensible. + +Package: cl-cclan +Architecture: all +Depends: common-lisp-controller +Description: Comprehensive Common Lisp Archive Network + cclan is a tool for creating a repository of Common Lisp packages. + cclan utilizes asdf to automatically create installable packages for various + operating systems. Added: branches/trunk-reorg/thirdparty/asdf/debian/copyright =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/copyright 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/copyright 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,37 @@ +This package was debianized by Kevin M. Rosenberg <kmr(a)debian.org> on +Fri, 16 Aug 2002 23:14:49 -0600. + +It was downloaded from SourceForge CVS server with the below commands: + cvs -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan login + (no password: just press Enter) + cvs -z3 -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan \ + co asdf + +Upstream Authors: Dan Barlow <dan(a)telent.net> & Contributors + +Copyright: + +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2001, 2002 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. + Added: branches/trunk-reorg/thirdparty/asdf/debian/docs =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/docs 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/docs 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +README Added: branches/trunk-reorg/thirdparty/asdf/debian/postinst =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/postinst 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/postinst 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,62 @@ +#!/bin/bash +# postinst script for common-lisp-controller +# +# 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'. + + +. /usr/share/debconf/confmodule + +case "$1" in + configure) + # We need to rebuild the images + for compiler in /usr/lib/common-lisp/bin/*.sh ; do + if [ -f "$compiler" -a -r "$compiler" ] ; then + i=${compiler##*/} + i=${i%.sh} + if [ -x "$compiler" ] ; then + echo Reinstalling for $i + echo Recompiling Common Lisp Controller for $i + bash "$compiler" install-clc || true + echo + echo Done rebuilding + fi + fi + done + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/asdf/debian/rules =================================================================== --- branches/trunk-reorg/thirdparty/asdf/debian/rules 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/debian/rules 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,86 @@ +#!/usr/bin/make -f +# GNU copyright 1997 to 1999 by Joey Hess. + +pkg=cl-asdf +pkg-cclan=cl-cclan +clc-base=usr/share/common-lisp +clc-src=$(clc-base)/source +clc-systems=$(clc-base)/systems +asdf-files=$(clc-src)/asdf +cclan-files=$(clc-src)/cclan +doc-dir=usr/share/doc/$(pkg) + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + + # Add here commands to install the package into debian/asdf. + dh_installdirs -p $(pkg) $(asdf-files) $(doc-dir)/examples + dh_install -p $(pkg) asdf.lisp wild-modules.lisp asdf-install.lisp $(asdf-files) + chmod +x test/run-tests.sh + dh_install -p $(pkg) test/* $(doc-dir)/examples + dh_installdirs -p $(pkg-cclan) $(clc-systems) $(cclan-files) + dh_install -p $(pkg-cclan) cclan-package.lisp cclan.lisp cclan.asd $(cclan-files) + dh_link -p $(pkg-cclan) $(cclan-files)/cclan.asd $(clc-systems)/cclan.asd + +# Build architecture-independent files here. +binary-indep: build install +# We have nothing to do by default. + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs +# dh_installexamples + dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit + dh_installcron + dh_installman + dh_installinfo +# dh_undocumented + dh_installchangelogs ChangeLog + find debian/cl-asdf -name CVS -print0 | xargs -0t rm -rf || true + find debian/cl-asdf -name .cvsignore -print0 | xargs -0t rm -f || true + dh_link + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure Property changes on: branches/trunk-reorg/thirdparty/asdf/debian/rules ___________________________________________________________________ Name: svn:executable + * Added: branches/trunk-reorg/thirdparty/asdf/test/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/CVS/Entries 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/CVS/Entries 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,33 @@ +/compile-asdf.lisp/1.1/Fri Jul 27 02:58:19 2007// +/file1.lisp/1.2/Mon Sep 9 14:28:56 2002// +/file2.lisp/1.1/Wed Feb 20 11:12:35 2002// +/file3.lisp/1.2/Mon Sep 9 14:28:56 2002// +/file4.lisp/1.1/Wed Feb 20 11:12:35 2002// +/run-tests.sh/1.12/Thu Sep 27 13:15:06 2007// +/script-support.lisp/1.1/Fri Jul 27 02:58:19 2007// +/static-and-serial.asd/1.1/Fri Jul 27 02:58:19 2007// +/test-force.asd/1.1/Tue May 30 18:14:40 2006// +/test-force.script/1.2/Wed Jun 13 01:30:55 2007// +/test-package.asd/1.1/Mon Aug 21 10:52:34 2006// +/test-package.script/1.2/Wed Jun 13 01:30:55 2007// +/test-preferences-1.lisp/1.1/Thu Jul 6 02:26:00 2006// +/test-preferences-1.script/1.2/Wed Jun 13 01:30:55 2007// +/test-preferences-system-1.asd/1.1/Thu Jul 6 02:26:00 2006// +/test-preferences-system-load.lisp/1.1/Thu Jul 6 02:26:00 2006// +/test-preferences-system-test.lisp/1.1/Thu Jul 6 02:26:00 2006// +/test-static-and-serial.script/1.1/Fri Jul 27 02:58:19 2007// +/test-version.script/1.2/Wed Jun 13 01:30:55 2007// +/test1.asd/1.1/Wed Feb 20 11:12:35 2002// +/test1.script/1.4/Wed Jun 13 01:30:55 2007// +/test2.asd/1.1/Wed Feb 20 11:12:35 2002// +/test2.script/1.4/Wed Jun 13 01:30:55 2007// +/test2a.asd/1.1/Wed Feb 20 11:12:35 2002// +/test2b1.asd/1.1/Wed Feb 20 11:12:35 2002// +/test2b2.asd/1.1/Wed Feb 20 11:12:35 2002// +/test2b3.asd/1.1/Wed Feb 20 11:12:35 2002// +/test3.asd/1.2/Mon May 20 14:16:27 2002// +/test3.script/1.4/Wed Jun 13 01:30:55 2007// +/test4.script/1.2/Wed Jun 13 01:30:55 2007// +/wild-module.asd/1.2/Sun May 14 16:03:16 2006// +/wild-module.script/1.3/Wed Jun 13 01:30:55 2007// +D Added: branches/trunk-reorg/thirdparty/asdf/test/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/CVS/Repository 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/CVS/Repository 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +asdf/test Added: branches/trunk-reorg/thirdparty/asdf/test/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/CVS/Root 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/CVS/Root 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1 @@ +:pserver:anonymous@cclan.cvs.sourceforge.net:/cvsroot/cclan Added: branches/trunk-reorg/thirdparty/asdf/test/compile-asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/compile-asdf.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/compile-asdf.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,18 @@ +(in-package #:common-lisp-user) + +(load "test/script-support.lisp") + +(cond ((probe-file "asdf.lisp") + (multiple-value-bind (result warnings-p errors-p) + (compile-file "asdf.lisp") + (declare (ignore result)) + (cond (warnings-p + (leave-lisp "Testuite failed: ASDF compiled with warnings" 1)) + (errors-p + (leave-lisp "Testuite failed: ASDF compiled with ERRORS" 2)) + (t + (leave-lisp "ASDF compiled cleanly" 0))))) + (t + (leave-lisp "Testsuite failed: unable to find ASDF source" 3))) + + \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/file1.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/file1.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/file1.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,4 @@ +(defpackage :test-package (:use :cl)) +(in-package :test-package) +(defvar *file1* t) + Added: branches/trunk-reorg/thirdparty/asdf/test/file2.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/file2.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/file2.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,2 @@ +(in-package :test-package) +(assert *file1*) Added: branches/trunk-reorg/thirdparty/asdf/test/file3.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/file3.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/file3.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,4 @@ +(defpackage :test-package (:use :cl)) +(in-package :test-package) +(defvar *file3* t) + Added: branches/trunk-reorg/thirdparty/asdf/test/file4.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/file4.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/file4.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,2 @@ +(in-package :test-package) +(assert *file3*) Added: branches/trunk-reorg/thirdparty/asdf/test/run-tests.sh =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/run-tests.sh 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/run-tests.sh 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,97 @@ +#!/bin/sh + +# do_tests {lisp invocation} {fasl extension} +# - read lisp forms one at a time from standard input +# - quit with exit status 0 on getting eof +# - quit with exit status >0 if an unhandled error occurs + + +if [ -z "$2" ]; then + scripts="*.script" +else + scripts="$2" +fi + +sok=1 + +do_tests() { +rm *.$2 || true +( cd .. && echo '(load "test/compile-asdf.lisp")' | $1 ) +if [ $? -eq 0 ] ; then + test_count=0 + test_pass=0 + test_fail=0 + failed_list="" + for i in $scripts ; + do + echo "Testing: $i" >&2 + test_count=`expr "$test_count" + 1` + rm *.$2 || true + if $1 < $i ;then + echo "Using $1, $i passed" >&2 + test_pass=`expr "$test_pass" + 1` + else + echo "Using $1, $i failed" >&2 + test_fail=`expr "$test_fail" + 1` + failed_list="$failed_list $i" + sok=0 + fi + done + echo >&2 + echo "Using $1" >&2 + echo "Ran $test_count tests: " >&2 + echo " $test_pass passing and $test_fail failing" >&2 + if [ $test_fail -eq 0 ] ; then + echo "all tests apparently successful" >&2 + else + echo "failing test(s): $failed_list" >&2 + fi + echo >&2 +fi +} + +# terminate on error +set -e + +lisp=$1 +if [ -z $1 ] ; then + lisp="sbcl" +fi + +if [ "$lisp" = "sbcl" ] ; then + if type sbcl ; then + fasl_ext="fasl" + command="sbcl --userinit /dev/null --sysinit /dev/null --noprogrammer" + fi +elif [ "$lisp" = "clisp" ] ; then + if type clisp ; then + fasl_ext="fas" + command=`where clisp` + command="$command -norc -ansi -I - " + fi +elif [ "$lisp" = "allegro" ] ; then + if type alisp ; then + fasl_ext="fasl" + command="alisp -q --batch " + fi +elif [ "$lisp" = "allegromodern" ] ; then + if type mlisp ; then + fasl_ext="fasl" + command="mlisp -q --batch " + fi +fi + + +#if [ -x /usr/bin/lisp ] +#then +# do_tests "/usr/bin/lisp -batch -noinit" x86f +#fi + + +if [ -z "$command" ] ; then + echo "Error: don't know how to run Lisp named $lisp" +else + echo $command + do_tests "$command" $fasl_ext +fi + Added: branches/trunk-reorg/thirdparty/asdf/test/script-support.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/script-support.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/script-support.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,36 @@ +(in-package #:common-lisp-user) + +#+allegro +(setf excl:*warn-on-nested-reader-conditionals* nil) + +;;; code adapted from cl-launch (any errors in transcription are mine!) +;; http://www.cliki.net/cl-launch +(defun leave-lisp (message return) + (when message + (format *error-output* message)) + #+allegro + (excl:exit return) + #+clisp + (ext:quit return) + #+(or cmu scl) + (unix:unix-exit code) + #+ecl + (si:quit return) + #+gcl + (lisp:quit code) + #+lispworks + (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) + #+(or openmcl mcl) + (ccl::quit return) + #+sbcl + (sb-ext:quit :unix-status return) + + (error "Don't know how to quit Lisp; wanting to use exit code ~a" return)) + +(defmacro exit-on-error (&body body) + `(handler-case + (progn ,@body + (leave-lisp "Script succeeded" 0)) + (error (c) + (format *error-output* "~a" c) + (leave-lisp "Script failed" 1)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/static-and-serial.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/static-and-serial.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/static-and-serial.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,12 @@ +#| +make sure that serial t and static-files don't cause full rebuilds all +the time... +|# + +(defsystem static-and-serial + :version "0.1" + :serial t + :components + ((:static-file "file2.lisp") + (:static-file "run-tests.sh") + (:file "file1"))) Added: branches/trunk-reorg/thirdparty/asdf/test/test-force.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-force.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-force.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,5 @@ +;;; -*- Lisp -*- +(asdf:defsystem test-force + :components + ((:file "file1"))) + Added: branches/trunk-reorg/thirdparty/asdf/test/test-force.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-force.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-force.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,19 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + + (asdf:operate 'asdf:load-op 'test-force) + (defvar file1-date (file-write-date (compile-file-pathname "file1"))) + + ;; unforced, date should stay same + (sleep 1) + (asdf:operate 'asdf:load-op 'test-force) + (assert (= (file-write-date (compile-file-pathname "file1")) file1-date)) + + ;; forced, it should be later + (sleep 1) + (asdf:operate 'asdf:load-op 'test-force :force t) + (assert (> (file-write-date (compile-file-pathname "file1")) file1-date)) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test-package.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-package.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-package.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,10 @@ +;;; NB: This way of managing packages is explicitly NOT recommended. +;;; However, it is found in the wild, and debugging it is a pain, so +;;; we should probably not break. The thing that this is testing is +;;; that unrelated definitions of symbols naming ASDF keywords should +;;; not affect the parsing of a system. + +(in-package :cl-user) ; BAD BAD BAD + +(asdf:defsystem test-package + :components ((:module "foo" :components ((:file "bar") (:file "baz"))))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test-package.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-package.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-package.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,14 @@ +(in-package :cl-user) +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + + (defun module () 1) + + (load "test-package.asd") + + (defclass module () ()) + + (load "test-package.asd") +) Added: branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(defvar *test-preferences-variable-1* :default) Added: branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-preferences-1.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,11 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (in-package :asdf) + (asdf:oos 'asdf:load-op 'test-preferences-system-1) + (assert (eq common-lisp-user::*test-preferences-variable-1* :load)) + (asdf:oos 'asdf:test-op 'test-preferences-system-1) + (assert (eq common-lisp-user::*test-preferences-variable-1* :test)) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-1.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-1.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-1.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,35 @@ +;;; -*- Lisp -*- +(in-package #:common-lisp) + +(defpackage #:test-preferences-1-asdf-system + (:use #:common-lisp #:asdf)) +(in-package #:asdf) + +(defsystem test-preferences-system-1 + :components + ((:file "test-preferences-1")) + :in-order-to ((test-op (load-op test-preferences-system-1)))) + +(defmethod operation-done-p + ((o test-op) + (c (eql (find-system 'test-preferences-system-1)))) + (values nil)) + +(defmethod load-preferences + ((system (eql (find-system 'test-preferences-system-1))) + (operation test-op)) + ;; the default load-preferences does nothing for anything other than a + ;; basic-load-op. So, ... we hack it + (load (make-pathname + :name "test-preferences-system-test" + :type "lisp" + :defaults *default-pathname-defaults*))) + +(defmethod preference-file-for-system/operation + ((system (eql (find-system 'test-preferences-system-1))) + (operation load-op)) + (make-pathname + :name "test-preferences-system-load" + :type "lisp" + :defaults *default-pathname-defaults*)) + Added: branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-load.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-load.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-load.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(setf *test-preferences-variable-1* :load) Added: branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-test.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-test.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-preferences-system-test.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(setf *test-preferences-variable-1* :test) Added: branches/trunk-reorg/thirdparty/asdf/test/test-static-and-serial.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-static-and-serial.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-static-and-serial.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,17 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + + (asdf:operate 'asdf:load-op 'static-and-serial) + (defvar file1-date (file-write-date (compile-file-pathname "file1"))) + + ;; cheat + (setf asdf::*defined-systems* (make-hash-table :test 'equal)) + + ;; date should stay same + (sleep 1) + (asdf:operate 'asdf:load-op 'static-and-serial) + (assert (= (file-write-date (compile-file-pathname "file1")) file1-date)) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test-version.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test-version.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test-version.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,31 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(setf asdf:*central-registry* '(*default-pathname-defaults*)) + +(defpackage :test-version-system + (:use :cl :asdf)) + +(in-package :test-version-system) + +(cl-user::exit-on-error + (defsystem :versioned-system-1 + :pathname #.*default-pathname-defaults* + :version "1.0") + + (defsystem :versioned-system-2 + :pathname #.*default-pathname-defaults* + :version "1.1") + + (defsystem :versioned-system-3 + :pathname #.*default-pathname-defaults* + :version "1.2") + + (flet ((test (name v &optional (true t)) + (or (eq true (asdf::version-satisfies (find-system name) v)) + (error "no satisfaction: ~S version ~A not ~A" name v true)))) + (test :versioned-system-1 "1.0") + (test :versioned-system-2 "1.0") + (test :versioned-system-3 "2.0" nil)) + + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test1.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test1.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test1.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,12 @@ +;;; -*- Lisp -*- +(asdf:defsystem test1 + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + (:file "file1"))) + +#| +1) from clean, check that all fasl files build and that some function + defined in the second file is present + +2) delete the second fasl file, and build again. do test 1 again and + also check the date on file1.fasl +|# Added: branches/trunk-reorg/thirdparty/asdf/test/test1.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test1.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test1.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,36 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (asdf:operate 'asdf:load-op 'test1) + + ;; test that it compiled + (defvar file1-date (file-write-date (compile-file-pathname "file1"))) + (assert (and file1-date (file-write-date (compile-file-pathname "file2"))))) + +;; and loaded +(assert test-package::*file1*) + +(exit-on-error + ;; now remove one output file and check that the other is _not_ + ;; recompiled + (sleep 1) ; mtime has 1-second granularity, so pause here for fast machines + + (asdf::run-shell-command "rm ~A" + (namestring (compile-file-pathname "file2"))) + (asdf:operate 'asdf:load-op 'test1) + (assert (= file1-date (file-write-date (compile-file-pathname "file1")))) + (assert (file-write-date (compile-file-pathname "file2"))) + + ;; now touch file1 and check that file2 _is_ also recompiled + + ;; XXX run-shell-command loses if *default-pathname-defaults* is not the + ;; unix cwd. this is not a problem for run-tests.sh, but can be in general + + (let ((before (file-write-date (compile-file-pathname "file2")))) + (asdf::run-shell-command "touch file1.lisp") + (sleep 1) + (asdf:operate 'asdf:load-op 'test1) + (assert (> (file-write-date (compile-file-pathname "file2")) before))) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test2.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- +(asdf:defsystem test2b + :version "1.0" + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + (:file "file1")) + :depends-on (version 'test2a "1.1")) + + Added: branches/trunk-reorg/thirdparty/asdf/test/test2.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,22 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + ;(trace asdf::perform) + ;(trace asdf::find-component) + ;(trace asdf::traverse) + (asdf:oos 'asdf:load-op 'test2b1) + (assert (and (probe-file (compile-file-pathname "file3")) + (probe-file (compile-file-pathname "file4")))) + (handler-case + (asdf:oos 'asdf:load-op 'test2b2) + (asdf:missing-dependency (c) + (format t "load failed as expected: - ~%~A~%" c)) + (:no-error (c) (error "should have failed, oops"))) + (handler-case + (asdf:oos 'asdf:load-op 'test2b3) + (asdf:missing-dependency (c) + (format t "load failed as expected: - ~%~A~%" c)) + (:no-error (c) (error "should have failed, oops"))) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/test2a.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2a.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2a.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,12 @@ +;;; -*- Lisp -*- +(asdf:defsystem test2a + :version "1.1" + :components ((:file "file4" :in-order-to ((compile-op (load-op "file3")))) + (:file "file3"))) +#| +this system is referenced by test2b[12] +|# + + + + Added: branches/trunk-reorg/thirdparty/asdf/test/test2b1.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2b1.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2b1.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- +(asdf:defsystem test2b1 + :version "1.0" + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + (:file "file1")) + :in-order-to ((load-op (load-op (version test2a "1.1"))))) + + Added: branches/trunk-reorg/thirdparty/asdf/test/test2b2.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2b2.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2b2.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- +(asdf:defsystem test2b2 + :version "1.0" + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + (:file "file1")) + :in-order-to ((load-op (load-op (version test2a "1.2"))))) + + Added: branches/trunk-reorg/thirdparty/asdf/test/test2b3.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test2b3.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test2b3.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- +(asdf:defsystem test2b3 + :version "1.0" + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + (:file "file1")) + :depends-on (bet-you-cant-find-this)) + + Added: branches/trunk-reorg/thirdparty/asdf/test/test3.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test3.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test3.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,11 @@ +;;; -*- Lisp -*- +(asdf:defsystem test3 + :properties ((:prop1 . "value")) + :components + ((:module "deps" + :if-component-dep-fails :try-next + :pathname "." + :components + ((:file "file1" :in-order-to ((compile-op (feature :f1)))) + (:file "file2" :in-order-to ((compile-op (feature :f2)))))))) + Added: branches/trunk-reorg/thirdparty/asdf/test/test3.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test3.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test3.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,26 @@ +;;; -*- Lisp -*- +#+(or f1 f2) + (error "This test cannot run if :f1 or :f2 are on *features*") +(load "script-support") +(load "../asdf") +(in-package :asdf) +(cl-user::exit-on-error + (asdf:run-shell-command "rm ~A ~A" + (namestring (compile-file-pathname "file1")) + (namestring (compile-file-pathname "file2"))) + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (handler-case + (asdf:oos 'asdf:load-op 'test3) + (asdf:missing-dependency (c) + (format t "first test failed as expected: - ~%~A~%" c)) + (:no-error (c) (error "should have failed, oops"))) + (pushnew :f1 *features*) + (asdf:oos 'asdf:load-op 'test3) + (assert (probe-file (compile-file-pathname "file1"))) + (assert (not (probe-file (compile-file-pathname "file2")))) + (run-shell-command "rm ~A" (namestring (compile-file-pathname "file1"))) + (setf *features* (cons :f2 (cdr *features*))) + (asdf:oos 'asdf:load-op 'test3) + (assert (probe-file (compile-file-pathname "file2"))) + (assert (not (probe-file (compile-file-pathname "file1")))) + ) Added: branches/trunk-reorg/thirdparty/asdf/test/test4.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/test4.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/test4.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,12 @@ +;;; -*- Lisp -*- +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(in-package :asdf) +(cl-user::exit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (assert (not (component-property (find-system 'test3) :foo))) + (assert (equal (component-property (find-system 'test3) :prop1) "value")) + (setf (component-property (find-system 'test3) :foo) "bar") + (assert (equal (component-property (find-system 'test3) :foo) "bar")) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/test/wild-module.asd =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/wild-module.asd 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/wild-module.asd 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,5 @@ +;;; -*- Lisp -*- + +(asdf:defsystem :wild-module + :version "0.0" + :components ((:wild-module "systems" :pathname "*.asd"))) Added: branches/trunk-reorg/thirdparty/asdf/test/wild-module.script =================================================================== --- branches/trunk-reorg/thirdparty/asdf/test/wild-module.script 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/test/wild-module.script 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,11 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(exit-on-error + + (load "../asdf") + (load "../wild-modules") + + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (asdf:operate 'asdf:load-op 'wild-module) + ) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/asdf/wild-modules.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/wild-modules.lisp 2007-10-14 19:12:46 UTC (rev 2235) +++ branches/trunk-reorg/thirdparty/asdf/wild-modules.lisp 2007-10-14 19:13:17 UTC (rev 2236) @@ -0,0 +1,38 @@ +(in-package :asdf) + +(defclass wild-module (module) + ((component-class :accessor wild-module-component-class + :initform 'static-file :initarg :component-class) + (component-options :accessor wild-module-component-options + :initform nil :initarg :component-options))) + +(defmethod (setf module-components) (new-value (module wild-module)) + (when new-value + (sysdef-error "Cannot explicitly set wild-module ~A's components. Please ~ +use a wild pathname instead." module))) + +(defmethod reinitialize-instance :after ((self wild-module) &key) + (let ((pathname (slot-value self 'relative-pathname))) + (and pathname + (not (wild-pathname-p pathname)) + (sysdef-error "Wild-module ~A specified with non-wild pathname ~A." + self pathname)) + (setf (slot-value self 'components) + (let* ((*default-pathname-defaults* (component-parent-pathname self)) + (files (directory (merge-pathnames (component-relative-pathname self)))) + (class (wild-module-component-class self)) + (options (wild-module-component-options self))) + (mapcar (lambda (file) + (apply #'make-instance class + :name (file-namestring file) + ;; XXX fails when wildcards are in + ;; the directory or higher parts. + :pathname file + :parent self + options)) + files))))) + +;; Don't export wild-module or else will get a full warning +;; when (require 'asdf) if asdf is already loaded + +;;(export '(wild-module))

1 0

[bknr-cvs] r2235 - branches/trunk-reorg/thirdparty
by bknr＠bknr.net 14 Oct '07

14 Oct '07

Author: hhubner Date: 2007-10-14 15:12:46 -0400 (Sun, 14 Oct 2007) New Revision: 2235 Removed: branches/trunk-reorg/thirdparty/asdf/ Log: update asdf

1 0

[bknr-cvs] r2234 - in branches/trunk-reorg/projects/scrabble: src website website/images website/images/de website/images/en
by bknr＠bknr.net 09 Oct '07

09 Oct '07

Author: hhubner Date: 2007-10-09 03:11:50 -0400 (Tue, 09 Oct 2007) New Revision: 2234 Added: branches/trunk-reorg/projects/scrabble/website/images/ branches/trunk-reorg/projects/scrabble/website/images/de/ branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png branches/trunk-reorg/projects/scrabble/website/images/en/ Removed: branches/trunk-reorg/projects/scrabble/website/de/ branches/trunk-reorg/projects/scrabble/website/en/ branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.css branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.html branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.js branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.css branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.html branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.js Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.asd branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/scrabble.css branches/trunk-reorg/projects/scrabble/website/scrabble.html branches/trunk-reorg/projects/scrabble/website/scrabble.js Log: checkpoint Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-09 07:11:50 UTC (rev 2234) @@ -48,6 +48,11 @@ :hunchentoot :bknr.datastore :bknr.user + :cl-who + :cl-interpol + :cl-ppcre :json - :scrabble)) + :scrabble) + (:shadowing-import-from :cl-interpol "QUOTE-META-CHARS") + (:export "START-WEBSERVER")) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-09 07:11:50 UTC (rev 2234) @@ -13,7 +13,10 @@ :depends-on (:bknr-datastore :bknr-web :hunchentoot + :cl-who :cl-json + :cl-ppcre + :cl-interpol :vecto :alexandria :anaphora) @@ -23,5 +26,6 @@ (:file "rules") (:file "game") (:file "web") + (:file "start-webserver") (:file "make-html") (:file "make-letters"))) Modified: branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-10-09 07:11:50 UTC (rev 2234) @@ -9,11 +9,15 @@ (make-pathname :name nil :type nil :version nil :defaults (merge-pathnames #p"../../../thirdparty/MochiKit/MochiKit/"))) -(when (and (boundp '*server*) *server*) - (stop-server *server*)) +(defun start-webserver (&key (port 4242)) + (when (and (boundp '*server*) *server*) + (stop-server *server*)) -(setq *dispatch-table* - (list (create-folder-dispatcher-and-handler "/MochiKit/" *mochikit-directory*) - (create-folder-dispatcher-and-handler "/scrabble/" *website-directory*))) + (setq *dispatch-table* + (list 'dispatch-easy-handlers + (create-prefix-dispatcher "/game/" 'game-handler) + (create-folder-dispatcher-and-handler "/MochiKit/" *mochikit-directory*) + (create-folder-dispatcher-and-handler "/images/" (merge-pathnames "images/de/" *website-directory*)) + (create-folder-dispatcher-and-handler "/" *website-directory*))) -(setq *server* (start-server :port 4242)) \ No newline at end of file + (setq *server* (start-server :port port))) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-09 07:11:50 UTC (rev 2234) @@ -1,5 +1,7 @@ (in-package :scrabble.web) +(enable-interpol-syntax) + (defparameter *ignore-slots* '(bknr.datastore::id bknr.indices::destroyed-p)) (defun encode-json-alist (alist stream) @@ -23,7 +25,7 @@ (princ #\} stream)) (defmethod encode-json ((tile-bag tile-bag) stream) - (encode-json-alist (list "remainingTiles" (remaining-tile-count tile-bag)) stream)) + (encode-json-alist (list :remaining-tiles (remaining-tile-count tile-bag)) stream)) (defmethod encode-json ((board board) stream) (princ #\[ stream) @@ -35,7 +37,55 @@ (princ #\] stream)) (defmethod encode-json ((participant participant) stream) - (encode-json-alist (list :name (user-login (player-of participant)) + (encode-json-alist (list :name (user-full-name (player-of participant)) :remaining-tiles (length (tray-of participant))) stream)) +(define-easy-handler (login :uri "/login" :default-request-type :post) + (login password) + (when (and login + (find-user login)) + (start-session) + (setf (session-value :user) login) + (redirect "/games")) + (with-html-output-to-string (*standard-output* nil) + + (:html + (:head + (:title "scrabble login")) + (:body + (:form :method "POST" + (:table + (:tr (:td "Username") (:td (:input :type "TEXT" :name "login"))) + (:tr (:td "Password") (:td (:input :type "PASSWORD" :name "password"))) + (:tr (:td) (:td (:input :type "SUBMIT"))))))))) + +(define-easy-handler (games :uri "/games") () + (start-session) + (with-html-output-to-string (*standard-output* nil) + (:html + (:head + (:title "scrabble game list")) + (:body + (:ul + (dolist (game (remove-if-not (lambda (game) + (member (find-user (session-value :user)) (participants-of game) + :key #'player-of)) + (class-instances 'game))) + (htm + (:li (:a :href (str (format nil "/game/~A" (store-object-id game))) "game"))))))))) + +(defun game-handler () + (start-session) + (register-groups-bind (object-id-string) (#?r".*/(\d+)$" (request-uri)) + (let ((object (find-store-object (parse-integer object-id-string)))) + (when (typep object 'game) + (return-from game-handler + (with-output-to-string (s) + (encode-json object s)))))) + (with-html-output-to-string (*standard-output* nil) + (:html + (:head + (:title "Invalid game ID")) + (:body + (:div "Invalid game ID"))))) \ No newline at end of file Copied: branches/trunk-reorg/projects/scrabble/website/images/de (from rev 2213, branches/trunk-reorg/projects/scrabble/website/de) Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png =================================================================== (Binary files differ) Copied: branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png (from rev 2233, branches/trunk-reorg/projects/scrabble/website/de/double-letter.png) Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png =================================================================== (Binary files differ) Copied: branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png (from rev 2233, branches/trunk-reorg/projects/scrabble/website/de/double-word.png) Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-04 22:25:38 UTC (rev 2213) +++ branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.css 2007-10-09 07:11:50 UTC (rev 2234) @@ -1,229 +0,0 @@ -body { background-color: #004B36 } -#playfield { position: absolute } -#playfield div { position: absolute; width: 40px; height: 40px } -#playfield img { position: absolute; top: 3px; left: 3px } -#playfield #field-0-0 { background-image: url(triple-word.png); left: 0; top: 0 } -#playfield #field-0-1 { background-image: url(standard.png); left: 0; top: 44 } -#playfield #field-0-2 { background-image: url(standard.png); left: 0; top: 88 } -#playfield #field-0-3 { background-image: url(double-letter.png); left: 0; top: 132 } -#playfield #field-0-4 { background-image: url(standard.png); left: 0; top: 176 } -#playfield #field-0-5 { background-image: url(standard.png); left: 0; top: 220 } -#playfield #field-0-6 { background-image: url(standard.png); left: 0; top: 264 } -#playfield #field-0-7 { background-image: url(triple-word.png); left: 0; top: 308 } -#playfield #field-0-8 { background-image: url(standard.png); left: 0; top: 352 } -#playfield #field-0-9 { background-image: url(standard.png); left: 0; top: 396 } -#playfield #field-0-10 { background-image: url(standard.png); left: 0; top: 440 } -#playfield #field-0-11 { background-image: url(double-letter.png); left: 0; top: 484 } -#playfield #field-0-12 { background-image: url(standard.png); left: 0; top: 528 } -#playfield #field-0-13 { background-image: url(standard.png); left: 0; top: 572 } -#playfield #field-0-14 { background-image: url(triple-word.png); left: 0; top: 616 } -#playfield #field-1-0 { background-image: url(standard.png); left: 44; top: 0 } -#playfield #field-1-1 { background-image: url(double-word.png); left: 44; top: 44 } -#playfield #field-1-2 { background-image: url(standard.png); left: 44; top: 88 } -#playfield #field-1-3 { background-image: url(standard.png); left: 44; top: 132 } -#playfield #field-1-4 { background-image: url(standard.png); left: 44; top: 176 } -#playfield #field-1-5 { background-image: url(triple-letter.png); left: 44; top: 220 } -#playfield #field-1-6 { background-image: url(standard.png); left: 44; top: 264 } -#playfield #field-1-7 { background-image: url(standard.png); left: 44; top: 308 } -#playfield #field-1-8 { background-image: url(standard.png); left: 44; top: 352 } -#playfield #field-1-9 { background-image: url(triple-letter.png); left: 44; top: 396 } -#playfield #field-1-10 { background-image: url(standard.png); left: 44; top: 440 } -#playfield #field-1-11 { background-image: url(standard.png); left: 44; top: 484 } -#playfield #field-1-12 { background-image: url(standard.png); left: 44; top: 528 } -#playfield #field-1-13 { background-image: url(double-word.png); left: 44; top: 572 } -#playfield #field-1-14 { background-image: url(standard.png); left: 44; top: 616 } -#playfield #field-2-0 { background-image: url(standard.png); left: 88; top: 0 } -#playfield #field-2-1 { background-image: url(standard.png); left: 88; top: 44 } -#playfield #field-2-2 { background-image: url(double-word.png); left: 88; top: 88 } -#playfield #field-2-3 { background-image: url(standard.png); left: 88; top: 132 } -#playfield #field-2-4 { background-image: url(standard.png); left: 88; top: 176 } -#playfield #field-2-5 { background-image: url(standard.png); left: 88; top: 220 } -#playfield #field-2-6 { background-image: url(double-letter.png); left: 88; top: 264 } -#playfield #field-2-7 { background-image: url(standard.png); left: 88; top: 308 } -#playfield #field-2-8 { background-image: url(double-letter.png); left: 88; top: 352 } -#playfield #field-2-9 { background-image: url(standard.png); left: 88; top: 396 } -#playfield #field-2-10 { background-image: url(standard.png); left: 88; top: 440 } -#playfield #field-2-11 { background-image: url(standard.png); left: 88; top: 484 } -#playfield #field-2-12 { background-image: url(double-word.png); left: 88; top: 528 } -#playfield #field-2-13 { background-image: url(standard.png); left: 88; top: 572 } -#playfield #field-2-14 { background-image: url(standard.png); left: 88; top: 616 } -#playfield #field-3-0 { background-image: url(double-letter.png); left: 132; top: 0 } -#playfield #field-3-1 { background-image: url(standard.png); left: 132; top: 44 } -#playfield #field-3-2 { background-image: url(standard.png); left: 132; top: 88 } -#playfield #field-3-3 { background-image: url(double-word.png); left: 132; top: 132 } -#playfield #field-3-4 { background-image: url(standard.png); left: 132; top: 176 } -#playfield #field-3-5 { background-image: url(standard.png); left: 132; top: 220 } -#playfield #field-3-6 { background-image: url(standard.png); left: 132; top: 264 } -#playfield #field-3-7 { background-image: url(double-letter.png); left: 132; top: 308 } -#playfield #field-3-8 { background-image: url(standard.png); left: 132; top: 352 } -#playfield #field-3-9 { background-image: url(standard.png); left: 132; top: 396 } -#playfield #field-3-10 { background-image: url(standard.png); left: 132; top: 440 } -#playfield #field-3-11 { background-image: url(double-word.png); left: 132; top: 484 } -#playfield #field-3-12 { background-image: url(standard.png); left: 132; top: 528 } -#playfield #field-3-13 { background-image: url(standard.png); left: 132; top: 572 } -#playfield #field-3-14 { background-image: url(double-letter.png); left: 132; top: 616 } -#playfield #field-4-0 { background-image: url(standard.png); left: 176; top: 0 } -#playfield #field-4-1 { background-image: url(standard.png); left: 176; top: 44 } -#playfield #field-4-2 { background-image: url(standard.png); left: 176; top: 88 } -#playfield #field-4-3 { background-image: url(standard.png); left: 176; top: 132 } -#playfield #field-4-4 { background-image: url(double-word.png); left: 176; top: 176 } -#playfield #field-4-5 { background-image: url(standard.png); left: 176; top: 220 } -#playfield #field-4-6 { background-image: url(standard.png); left: 176; top: 264 } -#playfield #field-4-7 { background-image: url(standard.png); left: 176; top: 308 } -#playfield #field-4-8 { background-image: url(standard.png); left: 176; top: 352 } -#playfield #field-4-9 { background-image: url(standard.png); left: 176; top: 396 } -#playfield #field-4-10 { background-image: url(double-word.png); left: 176; top: 440 } -#playfield #field-4-11 { background-image: url(standard.png); left: 176; top: 484 } -#playfield #field-4-12 { background-image: url(standard.png); left: 176; top: 528 } -#playfield #field-4-13 { background-image: url(standard.png); left: 176; top: 572 } -#playfield #field-4-14 { background-image: url(standard.png); left: 176; top: 616 } -#playfield #field-5-0 { background-image: url(standard.png); left: 220; top: 0 } -#playfield #field-5-1 { background-image: url(triple-letter.png); left: 220; top: 44 } -#playfield #field-5-2 { background-image: url(standard.png); left: 220; top: 88 } -#playfield #field-5-3 { background-image: url(standard.png); left: 220; top: 132 } -#playfield #field-5-4 { background-image: url(standard.png); left: 220; top: 176 } -#playfield #field-5-5 { background-image: url(triple-letter.png); left: 220; top: 220 } -#playfield #field-5-6 { background-image: url(standard.png); left: 220; top: 264 } -#playfield #field-5-7 { background-image: url(standard.png); left: 220; top: 308 } -#playfield #field-5-8 { background-image: url(standard.png); left: 220; top: 352 } -#playfield #field-5-9 { background-image: url(triple-letter.png); left: 220; top: 396 } -#playfield #field-5-10 { background-image: url(standard.png); left: 220; top: 440 } -#playfield #field-5-11 { background-image: url(standard.png); left: 220; top: 484 } -#playfield #field-5-12 { background-image: url(standard.png); left: 220; top: 528 } -#playfield #field-5-13 { background-image: url(triple-letter.png); left: 220; top: 572 } -#playfield #field-5-14 { background-image: url(standard.png); left: 220; top: 616 } -#playfield #field-6-0 { background-image: url(standard.png); left: 264; top: 0 } -#playfield #field-6-1 { background-image: url(standard.png); left: 264; top: 44 } -#playfield #field-6-2 { background-image: url(double-letter.png); left: 264; top: 88 } -#playfield #field-6-3 { background-image: url(standard.png); left: 264; top: 132 } -#playfield #field-6-4 { background-image: url(standard.png); left: 264; top: 176 } -#playfield #field-6-5 { background-image: url(standard.png); left: 264; top: 220 } -#playfield #field-6-6 { background-image: url(double-letter.png); left: 264; top: 264 } -#playfield #field-6-7 { background-image: url(standard.png); left: 264; top: 308 } -#playfield #field-6-8 { background-image: url(double-letter.png); left: 264; top: 352 } -#playfield #field-6-9 { background-image: url(standard.png); left: 264; top: 396 } -#playfield #field-6-10 { background-image: url(standard.png); left: 264; top: 440 } -#playfield #field-6-11 { background-image: url(standard.png); left: 264; top: 484 } -#playfield #field-6-12 { background-image: url(double-letter.png); left: 264; top: 528 } -#playfield #field-6-13 { background-image: url(standard.png); left: 264; top: 572 } -#playfield #field-6-14 { background-image: url(standard.png); left: 264; top: 616 } -#playfield #field-7-0 { background-image: url(triple-word.png); left: 308; top: 0 } -#playfield #field-7-1 { background-image: url(standard.png); left: 308; top: 44 } -#playfield #field-7-2 { background-image: url(standard.png); left: 308; top: 88 } -#playfield #field-7-3 { background-image: url(double-letter.png); left: 308; top: 132 } -#playfield #field-7-4 { background-image: url(standard.png); left: 308; top: 176 } -#playfield #field-7-5 { background-image: url(standard.png); left: 308; top: 220 } -#playfield #field-7-6 { background-image: url(standard.png); left: 308; top: 264 } -#playfield #field-7-7 { background-image: url(triple-word.png); left: 308; top: 308 } -#playfield #field-7-8 { background-image: url(standard.png); left: 308; top: 352 } -#playfield #field-7-9 { background-image: url(standard.png); left: 308; top: 396 } -#playfield #field-7-10 { background-image: url(standard.png); left: 308; top: 440 } -#playfield #field-7-11 { background-image: url(double-letter.png); left: 308; top: 484 } -#playfield #field-7-12 { background-image: url(standard.png); left: 308; top: 528 } -#playfield #field-7-13 { background-image: url(standard.png); left: 308; top: 572 } -#playfield #field-7-14 { background-image: url(triple-word.png); left: 308; top: 616 } -#playfield #field-8-0 { background-image: url(standard.png); left: 352; top: 0 } -#playfield #field-8-1 { background-image: url(standard.png); left: 352; top: 44 } -#playfield #field-8-2 { background-image: url(double-letter.png); left: 352; top: 88 } -#playfield #field-8-3 { background-image: url(standard.png); left: 352; top: 132 } -#playfield #field-8-4 { background-image: url(standard.png); left: 352; top: 176 } -#playfield #field-8-5 { background-image: url(standard.png); left: 352; top: 220 } -#playfield #field-8-6 { background-image: url(double-letter.png); left: 352; top: 264 } -#playfield #field-8-7 { background-image: url(standard.png); left: 352; top: 308 } -#playfield #field-8-8 { background-image: url(double-letter.png); left: 352; top: 352 } -#playfield #field-8-9 { background-image: url(standard.png); left: 352; top: 396 } -#playfield #field-8-10 { background-image: url(standard.png); left: 352; top: 440 } -#playfield #field-8-11 { background-image: url(standard.png); left: 352; top: 484 } -#playfield #field-8-12 { background-image: url(double-letter.png); left: 352; top: 528 } -#playfield #field-8-13 { background-image: url(standard.png); left: 352; top: 572 } -#playfield #field-8-14 { background-image: url(standard.png); left: 352; top: 616 } -#playfield #field-9-0 { background-image: url(standard.png); left: 396; top: 0 } -#playfield #field-9-1 { background-image: url(triple-letter.png); left: 396; top: 44 } -#playfield #field-9-2 { background-image: url(standard.png); left: 396; top: 88 } -#playfield #field-9-3 { background-image: url(standard.png); left: 396; top: 132 } -#playfield #field-9-4 { background-image: url(standard.png); left: 396; top: 176 } -#playfield #field-9-5 { background-image: url(triple-letter.png); left: 396; top: 220 } -#playfield #field-9-6 { background-image: url(standard.png); left: 396; top: 264 } -#playfield #field-9-7 { background-image: url(standard.png); left: 396; top: 308 } -#playfield #field-9-8 { background-image: url(standard.png); left: 396; top: 352 } -#playfield #field-9-9 { background-image: url(triple-letter.png); left: 396; top: 396 } -#playfield #field-9-10 { background-image: url(standard.png); left: 396; top: 440 } -#playfield #field-9-11 { background-image: url(standard.png); left: 396; top: 484 } -#playfield #field-9-12 { background-image: url(standard.png); left: 396; top: 528 } -#playfield #field-9-13 { background-image: url(triple-letter.png); left: 396; top: 572 } -#playfield #field-9-14 { background-image: url(standard.png); left: 396; top: 616 } -#playfield #field-10-0 { background-image: url(standard.png); left: 440; top: 0 } -#playfield #field-10-1 { background-image: url(standard.png); left: 440; top: 44 } -#playfield #field-10-2 { background-image: url(standard.png); left: 440; top: 88 } -#playfield #field-10-3 { background-image: url(standard.png); left: 440; top: 132 } -#playfield #field-10-4 { background-image: url(double-word.png); left: 440; top: 176 } -#playfield #field-10-5 { background-image: url(standard.png); left: 440; top: 220 } -#playfield #field-10-6 { background-image: url(standard.png); left: 440; top: 264 } -#playfield #field-10-7 { background-image: url(standard.png); left: 440; top: 308 } -#playfield #field-10-8 { background-image: url(standard.png); left: 440; top: 352 } -#playfield #field-10-9 { background-image: url(standard.png); left: 440; top: 396 } -#playfield #field-10-10 { background-image: url(double-word.png); left: 440; top: 440 } -#playfield #field-10-11 { background-image: url(standard.png); left: 440; top: 484 } -#playfield #field-10-12 { background-image: url(standard.png); left: 440; top: 528 } -#playfield #field-10-13 { background-image: url(standard.png); left: 440; top: 572 } -#playfield #field-10-14 { background-image: url(standard.png); left: 440; top: 616 } -#playfield #field-11-0 { background-image: url(double-letter.png); left: 484; top: 0 } -#playfield #field-11-1 { background-image: url(standard.png); left: 484; top: 44 } -#playfield #field-11-2 { background-image: url(standard.png); left: 484; top: 88 } -#playfield #field-11-3 { background-image: url(double-word.png); left: 484; top: 132 } -#playfield #field-11-4 { background-image: url(standard.png); left: 484; top: 176 } -#playfield #field-11-5 { background-image: url(standard.png); left: 484; top: 220 } -#playfield #field-11-6 { background-image: url(standard.png); left: 484; top: 264 } -#playfield #field-11-7 { background-image: url(double-letter.png); left: 484; top: 308 } -#playfield #field-11-8 { background-image: url(standard.png); left: 484; top: 352 } -#playfield #field-11-9 { background-image: url(standard.png); left: 484; top: 396 } -#playfield #field-11-10 { background-image: url(standard.png); left: 484; top: 440 } -#playfield #field-11-11 { background-image: url(double-word.png); left: 484; top: 484 } -#playfield #field-11-12 { background-image: url(standard.png); left: 484; top: 528 } -#playfield #field-11-13 { background-image: url(standard.png); left: 484; top: 572 } -#playfield #field-11-14 { background-image: url(double-letter.png); left: 484; top: 616 } -#playfield #field-12-0 { background-image: url(standard.png); left: 528; top: 0 } -#playfield #field-12-1 { background-image: url(standard.png); left: 528; top: 44 } -#playfield #field-12-2 { background-image: url(double-word.png); left: 528; top: 88 } -#playfield #field-12-3 { background-image: url(standard.png); left: 528; top: 132 } -#playfield #field-12-4 { background-image: url(standard.png); left: 528; top: 176 } -#playfield #field-12-5 { background-image: url(standard.png); left: 528; top: 220 } -#playfield #field-12-6 { background-image: url(double-letter.png); left: 528; top: 264 } -#playfield #field-12-7 { background-image: url(standard.png); left: 528; top: 308 } -#playfield #field-12-8 { background-image: url(double-letter.png); left: 528; top: 352 } -#playfield #field-12-9 { background-image: url(standard.png); left: 528; top: 396 } -#playfield #field-12-10 { background-image: url(standard.png); left: 528; top: 440 } -#playfield #field-12-11 { background-image: url(standard.png); left: 528; top: 484 } -#playfield #field-12-12 { background-image: url(double-word.png); left: 528; top: 528 } -#playfield #field-12-13 { background-image: url(standard.png); left: 528; top: 572 } -#playfield #field-12-14 { background-image: url(standard.png); left: 528; top: 616 } -#playfield #field-13-0 { background-image: url(standard.png); left: 572; top: 0 } -#playfield #field-13-1 { background-image: url(double-word.png); left: 572; top: 44 } -#playfield #field-13-2 { background-image: url(standard.png); left: 572; top: 88 } -#playfield #field-13-3 { background-image: url(standard.png); left: 572; top: 132 } -#playfield #field-13-4 { background-image: url(standard.png); left: 572; top: 176 } -#playfield #field-13-5 { background-image: url(triple-letter.png); left: 572; top: 220 } -#playfield #field-13-6 { background-image: url(standard.png); left: 572; top: 264 } -#playfield #field-13-7 { background-image: url(standard.png); left: 572; top: 308 } -#playfield #field-13-8 { background-image: url(standard.png); left: 572; top: 352 } -#playfield #field-13-9 { background-image: url(triple-letter.png); left: 572; top: 396 } -#playfield #field-13-10 { background-image: url(standard.png); left: 572; top: 440 } -#playfield #field-13-11 { background-image: url(standard.png); left: 572; top: 484 } -#playfield #field-13-12 { background-image: url(standard.png); left: 572; top: 528 } -#playfield #field-13-13 { background-image: url(double-word.png); left: 572; top: 572 } -#playfield #field-13-14 { background-image: url(standard.png); left: 572; top: 616 } -#playfield #field-14-0 { background-image: url(triple-word.png); left: 616; top: 0 } -#playfield #field-14-1 { background-image: url(standard.png); left: 616; top: 44 } -#playfield #field-14-2 { background-image: url(standard.png); left: 616; top: 88 } -#playfield #field-14-3 { background-image: url(double-letter.png); left: 616; top: 132 } -#playfield #field-14-4 { background-image: url(standard.png); left: 616; top: 176 } -#playfield #field-14-5 { background-image: url(standard.png); left: 616; top: 220 } -#playfield #field-14-6 { background-image: url(standard.png); left: 616; top: 264 } -#playfield #field-14-7 { background-image: url(triple-word.png); left: 616; top: 308 } -#playfield #field-14-8 { background-image: url(standard.png); left: 616; top: 352 } -#playfield #field-14-9 { background-image: url(standard.png); left: 616; top: 396 } -#playfield #field-14-10 { background-image: url(standard.png); left: 616; top: 440 } -#playfield #field-14-11 { background-image: url(double-letter.png); left: 616; top: 484 } -#playfield #field-14-12 { background-image: url(standard.png); left: 616; top: 528 } -#playfield #field-14-13 { background-image: url(standard.png); left: 616; top: 572 } -#playfield #field-14-14 { background-image: url(triple-word.png); left: 616; top: 616 } Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.html 2007-10-04 22:25:38 UTC (rev 2213) +++ branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.html 2007-10-09 07:11:50 UTC (rev 2234) @@ -1,236 +0,0 @@ -<html> - <head> - <link rel="stylesheet" type="text/css" href="scrabble.css" /> - <script type="text/javascript" src="/MochiKit/MochiKit.js"> </script> - <script type="text/javascript" src="scrabble.js"> </script> - </head> - <body onload="init()"> - <div id='playfield'> - <div id='field-0-0'/></div> - <div id='field-0-1'/></div> - <div id='field-0-2'/></div> - <div id='field-0-3'/></div> - <div id='field-0-4'/></div> - <div id='field-0-5'/></div> - <div id='field-0-6'/></div> - <div id='field-0-7'/></div> - <div id='field-0-8'/></div> - <div id='field-0-9'/></div> - <div id='field-0-10'/></div> - <div id='field-0-11'/></div> - <div id='field-0-12'/></div> - <div id='field-0-13'/></div> - <div id='field-0-14'/></div> - <div id='field-1-0'/></div> - <div id='field-1-1'/></div> - <div id='field-1-2'/></div> - <div id='field-1-3'/></div> - <div id='field-1-4'/></div> - <div id='field-1-5'/></div> - <div id='field-1-6'/></div> - <div id='field-1-7'/></div> - <div id='field-1-8'/></div> - <div id='field-1-9'/></div> - <div id='field-1-10'/></div> - <div id='field-1-11'/></div> - <div id='field-1-12'/></div> - <div id='field-1-13'/></div> - <div id='field-1-14'/></div> - <div id='field-2-0'/></div> - <div id='field-2-1'/></div> - <div id='field-2-2'/></div> - <div id='field-2-3'/></div> - <div id='field-2-4'/></div> - <div id='field-2-5'/></div> - <div id='field-2-6'/></div> - <div id='field-2-7'/></div> - <div id='field-2-8'/></div> - <div id='field-2-9'/></div> - <div id='field-2-10'/></div> - <div id='field-2-11'/></div> - <div id='field-2-12'/></div> - <div id='field-2-13'/></div> - <div id='field-2-14'/></div> - <div id='field-3-0'/></div> - <div id='field-3-1'/></div> - <div id='field-3-2'/></div> - <div id='field-3-3'/></div> - <div id='field-3-4'/></div> - <div id='field-3-5'/></div> - <div id='field-3-6'/></div> - <div id='field-3-7'/></div> - <div id='field-3-8'/></div> - <div id='field-3-9'/></div> - <div id='field-3-10'/></div> - <div id='field-3-11'/></div> - <div id='field-3-12'/></div> - <div id='field-3-13'/></div> - <div id='field-3-14'/></div> - <div id='field-4-0'/></div> - <div id='field-4-1'/></div> - <div id='field-4-2'/></div> - <div id='field-4-3'/></div> - <div id='field-4-4'/></div> - <div id='field-4-5'/></div> - <div id='field-4-6'/></div> - <div id='field-4-7'/></div> - <div id='field-4-8'/></div> - <div id='field-4-9'/></div> - <div id='field-4-10'/></div> - <div id='field-4-11'/></div> - <div id='field-4-12'/></div> - <div id='field-4-13'/></div> - <div id='field-4-14'/></div> - <div id='field-5-0'/></div> - <div id='field-5-1'/></div> - <div id='field-5-2'/></div> - <div id='field-5-3'/></div> - <div id='field-5-4'/></div> - <div id='field-5-5'/></div> - <div id='field-5-6'/></div> - <div id='field-5-7'/></div> - <div id='field-5-8'/></div> - <div id='field-5-9'/></div> - <div id='field-5-10'/></div> - <div id='field-5-11'/></div> - <div id='field-5-12'/></div> - <div id='field-5-13'/></div> - <div id='field-5-14'/></div> - <div id='field-6-0'/></div> - <div id='field-6-1'/></div> - <div id='field-6-2'/></div> - <div id='field-6-3'/></div> - <div id='field-6-4'/></div> - <div id='field-6-5'/></div> - <div id='field-6-6'/></div> - <div id='field-6-7'/></div> - <div id='field-6-8'/></div> - <div id='field-6-9'/></div> - <div id='field-6-10'/></div> - <div id='field-6-11'/></div> - <div id='field-6-12'/></div> - <div id='field-6-13'/></div> - <div id='field-6-14'/></div> - <div id='field-7-0'/></div> - <div id='field-7-1'/></div> - <div id='field-7-2'/></div> - <div id='field-7-3'/></div> - <div id='field-7-4'/></div> - <div id='field-7-5'/></div> - <div id='field-7-6'/></div> - <div id='field-7-7'/></div> - <div id='field-7-8'/></div> - <div id='field-7-9'/></div> - <div id='field-7-10'/></div> - <div id='field-7-11'/></div> - <div id='field-7-12'/></div> - <div id='field-7-13'/></div> - <div id='field-7-14'/></div> - <div id='field-8-0'/></div> - <div id='field-8-1'/></div> - <div id='field-8-2'/></div> - <div id='field-8-3'/></div> - <div id='field-8-4'/></div> - <div id='field-8-5'/></div> - <div id='field-8-6'/></div> - <div id='field-8-7'/></div> - <div id='field-8-8'/></div> - <div id='field-8-9'/></div> - <div id='field-8-10'/></div> - <div id='field-8-11'/></div> - <div id='field-8-12'/></div> - <div id='field-8-13'/></div> - <div id='field-8-14'/></div> - <div id='field-9-0'/></div> - <div id='field-9-1'/></div> - <div id='field-9-2'/></div> - <div id='field-9-3'/></div> - <div id='field-9-4'/></div> - <div id='field-9-5'/></div> - <div id='field-9-6'/></div> - <div id='field-9-7'/></div> - <div id='field-9-8'/></div> - <div id='field-9-9'/></div> - <div id='field-9-10'/></div> - <div id='field-9-11'/></div> - <div id='field-9-12'/></div> - <div id='field-9-13'/></div> - <div id='field-9-14'/></div> - <div id='field-10-0'/></div> - <div id='field-10-1'/></div> - <div id='field-10-2'/></div> - <div id='field-10-3'/></div> - <div id='field-10-4'/></div> - <div id='field-10-5'/></div> - <div id='field-10-6'/></div> - <div id='field-10-7'/></div> - <div id='field-10-8'/></div> - <div id='field-10-9'/></div> - <div id='field-10-10'/></div> - <div id='field-10-11'/></div> - <div id='field-10-12'/></div> - <div id='field-10-13'/></div> - <div id='field-10-14'/></div> - <div id='field-11-0'/></div> - <div id='field-11-1'/></div> - <div id='field-11-2'/></div> - <div id='field-11-3'/></div> - <div id='field-11-4'/></div> - <div id='field-11-5'/></div> - <div id='field-11-6'/></div> - <div id='field-11-7'/></div> - <div id='field-11-8'/></div> - <div id='field-11-9'/></div> - <div id='field-11-10'/></div> - <div id='field-11-11'/></div> - <div id='field-11-12'/></div> - <div id='field-11-13'/></div> - <div id='field-11-14'/></div> - <div id='field-12-0'/></div> - <div id='field-12-1'/></div> - <div id='field-12-2'/></div> - <div id='field-12-3'/></div> - <div id='field-12-4'/></div> - <div id='field-12-5'/></div> - <div id='field-12-6'/></div> - <div id='field-12-7'/></div> - <div id='field-12-8'/></div> - <div id='field-12-9'/></div> - <div id='field-12-10'/></div> - <div id='field-12-11'/></div> - <div id='field-12-12'/></div> - <div id='field-12-13'/></div> - <div id='field-12-14'/></div> - <div id='field-13-0'/></div> - <div id='field-13-1'/></div> - <div id='field-13-2'/></div> - <div id='field-13-3'/></div> - <div id='field-13-4'/></div> - <div id='field-13-5'/></div> - <div id='field-13-6'/></div> - <div id='field-13-7'/></div> - <div id='field-13-8'/></div> - <div id='field-13-9'/></div> - <div id='field-13-10'/></div> - <div id='field-13-11'/></div> - <div id='field-13-12'/></div> - <div id='field-13-13'/></div> - <div id='field-13-14'/></div> - <div id='field-14-0'/></div> - <div id='field-14-1'/></div> - <div id='field-14-2'/></div> - <div id='field-14-3'/></div> - <div id='field-14-4'/></div> - <div id='field-14-5'/></div> - <div id='field-14-6'/></div> - <div id='field-14-7'/></div> - <div id='field-14-8'/></div> - <div id='field-14-9'/></div> - <div id='field-14-10'/></div> - <div id='field-14-11'/></div> - <div id='field-14-12'/></div> - <div id='field-14-13'/></div> - <div id='field-14-14'/></div> - </div> - </body> -</html> \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-04 22:25:38 UTC (rev 2213) +++ branches/trunk-reorg/projects/scrabble/website/images/de/scrabble.js 2007-10-09 07:11:50 UTC (rev 2234) @@ -1,22 +0,0 @@ -// -*- Java -*- (really Javascript) - -function setLetter(x, y, letter) { - $('field-' + x + '-' + y).innerHTML = '<img src="' + letter + '.png"/>'; -} - -function setWord(x, y, word, down) { - for (i = 0; i < word.length; i++) { - setLetter(x, y, word.charAt(i)); - if (down) { - y++; - } else { - x++; - } - }; -} - -function init() { - setWord(6, 6, "ICH"); - setWord(7, 7, "LIEBE"); - setWord(8, 8, "DICH"); -} Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png =================================================================== (Binary files differ) Copied: branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png (from rev 2233, branches/trunk-reorg/projects/scrabble/website/de/triple-letter.png) Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png =================================================================== (Binary files differ) Copied: branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png (from rev 2233, branches/trunk-reorg/projects/scrabble/website/de/triple-word.png) Copied: branches/trunk-reorg/projects/scrabble/website/images/en (from rev 2228, branches/trunk-reorg/projects/scrabble/website/en) Deleted: branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.css 2007-10-09 07:11:50 UTC (rev 2234) @@ -1 +0,0 @@ -link ../de/scrabble.css \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.html 2007-10-09 07:11:50 UTC (rev 2234) @@ -1 +0,0 @@ -link ../de/scrabble.html \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/website/images/en/scrabble.js 2007-10-09 07:11:50 UTC (rev 2234) @@ -1 +0,0 @@ -link ../de/scrabble.js \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.css 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.css 2007-10-09 07:11:50 UTC (rev 2234) @@ -2,228 +2,235 @@ #playfield { position: absolute } #playfield div { position: absolute; width: 40px; height: 40px } #playfield img { position: absolute; top: 3px; left: 3px } -#playfield #field-0-0 { background-image: url(triple-word.png); left: 0; top: 0 } -#playfield #field-0-1 { background-image: url(standard.png); left: 0; top: 44 } -#playfield #field-0-2 { background-image: url(standard.png); left: 0; top: 88 } -#playfield #field-0-3 { background-image: url(double-letter.png); left: 0; top: 132 } -#playfield #field-0-4 { background-image: url(standard.png); left: 0; top: 176 } -#playfield #field-0-5 { background-image: url(standard.png); left: 0; top: 220 } -#playfield #field-0-6 { background-image: url(standard.png); left: 0; top: 264 } -#playfield #field-0-7 { background-image: url(triple-word.png); left: 0; top: 308 } -#playfield #field-0-8 { background-image: url(standard.png); left: 0; top: 352 } -#playfield #field-0-9 { background-image: url(standard.png); left: 0; top: 396 } -#playfield #field-0-10 { background-image: url(standard.png); left: 0; top: 440 } -#playfield #field-0-11 { background-image: url(double-letter.png); left: 0; top: 484 } -#playfield #field-0-12 { background-image: url(standard.png); left: 0; top: 528 } -#playfield #field-0-13 { background-image: url(standard.png); left: 0; top: 572 } -#playfield #field-0-14 { background-image: url(triple-word.png); left: 0; top: 616 } -#playfield #field-1-0 { background-image: url(standard.png); left: 44; top: 0 } -#playfield #field-1-1 { background-image: url(double-word.png); left: 44; top: 44 } -#playfield #field-1-2 { background-image: url(standard.png); left: 44; top: 88 } -#playfield #field-1-3 { background-image: url(standard.png); left: 44; top: 132 } -#playfield #field-1-4 { background-image: url(standard.png); left: 44; top: 176 } -#playfield #field-1-5 { background-image: url(triple-letter.png); left: 44; top: 220 } -#playfield #field-1-6 { background-image: url(standard.png); left: 44; top: 264 } -#playfield #field-1-7 { background-image: url(standard.png); left: 44; top: 308 } -#playfield #field-1-8 { background-image: url(standard.png); left: 44; top: 352 } -#playfield #field-1-9 { background-image: url(triple-letter.png); left: 44; top: 396 } -#playfield #field-1-10 { background-image: url(standard.png); left: 44; top: 440 } -#playfield #field-1-11 { background-image: url(standard.png); left: 44; top: 484 } -#playfield #field-1-12 { background-image: url(standard.png); left: 44; top: 528 } -#playfield #field-1-13 { background-image: url(double-word.png); left: 44; top: 572 } -#playfield #field-1-14 { background-image: url(standard.png); left: 44; top: 616 } -#playfield #field-2-0 { background-image: url(standard.png); left: 88; top: 0 } -#playfield #field-2-1 { background-image: url(standard.png); left: 88; top: 44 } -#playfield #field-2-2 { background-image: url(double-word.png); left: 88; top: 88 } -#playfield #field-2-3 { background-image: url(standard.png); left: 88; top: 132 } -#playfield #field-2-4 { background-image: url(standard.png); left: 88; top: 176 } -#playfield #field-2-5 { background-image: url(standard.png); left: 88; top: 220 } -#playfield #field-2-6 { background-image: url(double-letter.png); left: 88; top: 264 } -#playfield #field-2-7 { background-image: url(standard.png); left: 88; top: 308 } -#playfield #field-2-8 { background-image: url(double-letter.png); left: 88; top: 352 } -#playfield #field-2-9 { background-image: url(standard.png); left: 88; top: 396 } -#playfield #field-2-10 { background-image: url(standard.png); left: 88; top: 440 } -#playfield #field-2-11 { background-image: url(standard.png); left: 88; top: 484 } -#playfield #field-2-12 { background-image: url(double-word.png); left: 88; top: 528 } -#playfield #field-2-13 { background-image: url(standard.png); left: 88; top: 572 } -#playfield #field-2-14 { background-image: url(standard.png); left: 88; top: 616 } -#playfield #field-3-0 { background-image: url(double-letter.png); left: 132; top: 0 } -#playfield #field-3-1 { background-image: url(standard.png); left: 132; top: 44 } -#playfield #field-3-2 { background-image: url(standard.png); left: 132; top: 88 } -#playfield #field-3-3 { background-image: url(double-word.png); left: 132; top: 132 } -#playfield #field-3-4 { background-image: url(standard.png); left: 132; top: 176 } -#playfield #field-3-5 { background-image: url(standard.png); left: 132; top: 220 } -#playfield #field-3-6 { background-image: url(standard.png); left: 132; top: 264 } -#playfield #field-3-7 { background-image: url(double-letter.png); left: 132; top: 308 } -#playfield #field-3-8 { background-image: url(standard.png); left: 132; top: 352 } -#playfield #field-3-9 { background-image: url(standard.png); left: 132; top: 396 } -#playfield #field-3-10 { background-image: url(standard.png); left: 132; top: 440 } -#playfield #field-3-11 { background-image: url(double-word.png); left: 132; top: 484 } -#playfield #field-3-12 { background-image: url(standard.png); left: 132; top: 528 } -#playfield #field-3-13 { background-image: url(standard.png); left: 132; top: 572 } -#playfield #field-3-14 { background-image: url(double-letter.png); left: 132; top: 616 } -#playfield #field-4-0 { background-image: url(standard.png); left: 176; top: 0 } -#playfield #field-4-1 { background-image: url(standard.png); left: 176; top: 44 } -#playfield #field-4-2 { background-image: url(standard.png); left: 176; top: 88 } -#playfield #field-4-3 { background-image: url(standard.png); left: 176; top: 132 } -#playfield #field-4-4 { background-image: url(double-word.png); left: 176; top: 176 } -#playfield #field-4-5 { background-image: url(standard.png); left: 176; top: 220 } -#playfield #field-4-6 { background-image: url(standard.png); left: 176; top: 264 } -#playfield #field-4-7 { background-image: url(standard.png); left: 176; top: 308 } -#playfield #field-4-8 { background-image: url(standard.png); left: 176; top: 352 } -#playfield #field-4-9 { background-image: url(standard.png); left: 176; top: 396 } -#playfield #field-4-10 { background-image: url(double-word.png); left: 176; top: 440 } -#playfield #field-4-11 { background-image: url(standard.png); left: 176; top: 484 } -#playfield #field-4-12 { background-image: url(standard.png); left: 176; top: 528 } -#playfield #field-4-13 { background-image: url(standard.png); left: 176; top: 572 } -#playfield #field-4-14 { background-image: url(standard.png); left: 176; top: 616 } -#playfield #field-5-0 { background-image: url(standard.png); left: 220; top: 0 } -#playfield #field-5-1 { background-image: url(triple-letter.png); left: 220; top: 44 } -#playfield #field-5-2 { background-image: url(standard.png); left: 220; top: 88 } -#playfield #field-5-3 { background-image: url(standard.png); left: 220; top: 132 } -#playfield #field-5-4 { background-image: url(standard.png); left: 220; top: 176 } -#playfield #field-5-5 { background-image: url(triple-letter.png); left: 220; top: 220 } -#playfield #field-5-6 { background-image: url(standard.png); left: 220; top: 264 } -#playfield #field-5-7 { background-image: url(standard.png); left: 220; top: 308 } -#playfield #field-5-8 { background-image: url(standard.png); left: 220; top: 352 } -#playfield #field-5-9 { background-image: url(triple-letter.png); left: 220; top: 396 } -#playfield #field-5-10 { background-image: url(standard.png); left: 220; top: 440 } -#playfield #field-5-11 { background-image: url(standard.png); left: 220; top: 484 } -#playfield #field-5-12 { background-image: url(standard.png); left: 220; top: 528 } -#playfield #field-5-13 { background-image: url(triple-letter.png); left: 220; top: 572 } -#playfield #field-5-14 { background-image: url(standard.png); left: 220; top: 616 } -#playfield #field-6-0 { background-image: url(standard.png); left: 264; top: 0 } -#playfield #field-6-1 { background-image: url(standard.png); left: 264; top: 44 } -#playfield #field-6-2 { background-image: url(double-letter.png); left: 264; top: 88 } -#playfield #field-6-3 { background-image: url(standard.png); left: 264; top: 132 } -#playfield #field-6-4 { background-image: url(standard.png); left: 264; top: 176 } -#playfield #field-6-5 { background-image: url(standard.png); left: 264; top: 220 } -#playfield #field-6-6 { background-image: url(double-letter.png); left: 264; top: 264 } -#playfield #field-6-7 { background-image: url(standard.png); left: 264; top: 308 } -#playfield #field-6-8 { background-image: url(double-letter.png); left: 264; top: 352 } -#playfield #field-6-9 { background-image: url(standard.png); left: 264; top: 396 } -#playfield #field-6-10 { background-image: url(standard.png); left: 264; top: 440 } -#playfield #field-6-11 { background-image: url(standard.png); left: 264; top: 484 } -#playfield #field-6-12 { background-image: url(double-letter.png); left: 264; top: 528 } -#playfield #field-6-13 { background-image: url(standard.png); left: 264; top: 572 } -#playfield #field-6-14 { background-image: url(standard.png); left: 264; top: 616 } -#playfield #field-7-0 { background-image: url(triple-word.png); left: 308; top: 0 } -#playfield #field-7-1 { background-image: url(standard.png); left: 308; top: 44 } -#playfield #field-7-2 { background-image: url(standard.png); left: 308; top: 88 } -#playfield #field-7-3 { background-image: url(double-letter.png); left: 308; top: 132 } -#playfield #field-7-4 { background-image: url(standard.png); left: 308; top: 176 } -#playfield #field-7-5 { background-image: url(standard.png); left: 308; top: 220 } -#playfield #field-7-6 { background-image: url(standard.png); left: 308; top: 264 } -#playfield #field-7-7 { background-image: url(double-word.png); left: 308; top: 308 } -#playfield #field-7-8 { background-image: url(standard.png); left: 308; top: 352 } -#playfield #field-7-9 { background-image: url(standard.png); left: 308; top: 396 } -#playfield #field-7-10 { background-image: url(standard.png); left: 308; top: 440 } -#playfield #field-7-11 { background-image: url(double-letter.png); left: 308; top: 484 } -#playfield #field-7-12 { background-image: url(standard.png); left: 308; top: 528 } -#playfield #field-7-13 { background-image: url(standard.png); left: 308; top: 572 } -#playfield #field-7-14 { background-image: url(triple-word.png); left: 308; top: 616 } -#playfield #field-8-0 { background-image: url(standard.png); left: 352; top: 0 } -#playfield #field-8-1 { background-image: url(standard.png); left: 352; top: 44 } -#playfield #field-8-2 { background-image: url(double-letter.png); left: 352; top: 88 } -#playfield #field-8-3 { background-image: url(standard.png); left: 352; top: 132 } -#playfield #field-8-4 { background-image: url(standard.png); left: 352; top: 176 } -#playfield #field-8-5 { background-image: url(standard.png); left: 352; top: 220 } -#playfield #field-8-6 { background-image: url(double-letter.png); left: 352; top: 264 } -#playfield #field-8-7 { background-image: url(standard.png); left: 352; top: 308 } -#playfield #field-8-8 { background-image: url(double-letter.png); left: 352; top: 352 } -#playfield #field-8-9 { background-image: url(standard.png); left: 352; top: 396 } -#playfield #field-8-10 { background-image: url(standard.png); left: 352; top: 440 } -#playfield #field-8-11 { background-image: url(standard.png); left: 352; top: 484 } -#playfield #field-8-12 { background-image: url(double-letter.png); left: 352; top: 528 } -#playfield #field-8-13 { background-image: url(standard.png); left: 352; top: 572 } -#playfield #field-8-14 { background-image: url(standard.png); left: 352; top: 616 } -#playfield #field-9-0 { background-image: url(standard.png); left: 396; top: 0 } -#playfield #field-9-1 { background-image: url(triple-letter.png); left: 396; top: 44 } -#playfield #field-9-2 { background-image: url(standard.png); left: 396; top: 88 } -#playfield #field-9-3 { background-image: url(standard.png); left: 396; top: 132 } -#playfield #field-9-4 { background-image: url(standard.png); left: 396; top: 176 } -#playfield #field-9-5 { background-image: url(triple-letter.png); left: 396; top: 220 } -#playfield #field-9-6 { background-image: url(standard.png); left: 396; top: 264 } -#playfield #field-9-7 { background-image: url(standard.png); left: 396; top: 308 } -#playfield #field-9-8 { background-image: url(standard.png); left: 396; top: 352 } -#playfield #field-9-9 { background-image: url(triple-letter.png); left: 396; top: 396 } -#playfield #field-9-10 { background-image: url(standard.png); left: 396; top: 440 } -#playfield #field-9-11 { background-image: url(standard.png); left: 396; top: 484 } -#playfield #field-9-12 { background-image: url(standard.png); left: 396; top: 528 } -#playfield #field-9-13 { background-image: url(triple-letter.png); left: 396; top: 572 } -#playfield #field-9-14 { background-image: url(standard.png); left: 396; top: 616 } -#playfield #field-10-0 { background-image: url(standard.png); left: 440; top: 0 } -#playfield #field-10-1 { background-image: url(standard.png); left: 440; top: 44 } -#playfield #field-10-2 { background-image: url(standard.png); left: 440; top: 88 } -#playfield #field-10-3 { background-image: url(standard.png); left: 440; top: 132 } -#playfield #field-10-4 { background-image: url(double-word.png); left: 440; top: 176 } -#playfield #field-10-5 { background-image: url(standard.png); left: 440; top: 220 } -#playfield #field-10-6 { background-image: url(standard.png); left: 440; top: 264 } -#playfield #field-10-7 { background-image: url(standard.png); left: 440; top: 308 } -#playfield #field-10-8 { background-image: url(standard.png); left: 440; top: 352 } -#playfield #field-10-9 { background-image: url(standard.png); left: 440; top: 396 } -#playfield #field-10-10 { background-image: url(double-word.png); left: 440; top: 440 } -#playfield #field-10-11 { background-image: url(standard.png); left: 440; top: 484 } -#playfield #field-10-12 { background-image: url(standard.png); left: 440; top: 528 } -#playfield #field-10-13 { background-image: url(standard.png); left: 440; top: 572 } -#playfield #field-10-14 { background-image: url(standard.png); left: 440; top: 616 } -#playfield #field-11-0 { background-image: url(double-letter.png); left: 484; top: 0 } -#playfield #field-11-1 { background-image: url(standard.png); left: 484; top: 44 } -#playfield #field-11-2 { background-image: url(standard.png); left: 484; top: 88 } -#playfield #field-11-3 { background-image: url(double-word.png); left: 484; top: 132 } -#playfield #field-11-4 { background-image: url(standard.png); left: 484; top: 176 } -#playfield #field-11-5 { background-image: url(standard.png); left: 484; top: 220 } -#playfield #field-11-6 { background-image: url(standard.png); left: 484; top: 264 } -#playfield #field-11-7 { background-image: url(double-letter.png); left: 484; top: 308 } -#playfield #field-11-8 { background-image: url(standard.png); left: 484; top: 352 } -#playfield #field-11-9 { background-image: url(standard.png); left: 484; top: 396 } -#playfield #field-11-10 { background-image: url(standard.png); left: 484; top: 440 } -#playfield #field-11-11 { background-image: url(double-word.png); left: 484; top: 484 } -#playfield #field-11-12 { background-image: url(standard.png); left: 484; top: 528 } -#playfield #field-11-13 { background-image: url(standard.png); left: 484; top: 572 } -#playfield #field-11-14 { background-image: url(double-letter.png); left: 484; top: 616 } -#playfield #field-12-0 { background-image: url(standard.png); left: 528; top: 0 } -#playfield #field-12-1 { background-image: url(standard.png); left: 528; top: 44 } -#playfield #field-12-2 { background-image: url(double-word.png); left: 528; top: 88 } -#playfield #field-12-3 { background-image: url(standard.png); left: 528; top: 132 } -#playfield #field-12-4 { background-image: url(standard.png); left: 528; top: 176 } -#playfield #field-12-5 { background-image: url(standard.png); left: 528; top: 220 } -#playfield #field-12-6 { background-image: url(double-letter.png); left: 528; top: 264 } -#playfield #field-12-7 { background-image: url(standard.png); left: 528; top: 308 } -#playfield #field-12-8 { background-image: url(double-letter.png); left: 528; top: 352 } -#playfield #field-12-9 { background-image: url(standard.png); left: 528; top: 396 } -#playfield #field-12-10 { background-image: url(standard.png); left: 528; top: 440 } -#playfield #field-12-11 { background-image: url(standard.png); left: 528; top: 484 } -#playfield #field-12-12 { background-image: url(double-word.png); left: 528; top: 528 } -#playfield #field-12-13 { background-image: url(standard.png); left: 528; top: 572 } -#playfield #field-12-14 { background-image: url(standard.png); left: 528; top: 616 } -#playfield #field-13-0 { background-image: url(standard.png); left: 572; top: 0 } -#playfield #field-13-1 { background-image: url(double-word.png); left: 572; top: 44 } -#playfield #field-13-2 { background-image: url(standard.png); left: 572; top: 88 } -#playfield #field-13-3 { background-image: url(standard.png); left: 572; top: 132 } -#playfield #field-13-4 { background-image: url(standard.png); left: 572; top: 176 } -#playfield #field-13-5 { background-image: url(triple-letter.png); left: 572; top: 220 } -#playfield #field-13-6 { background-image: url(standard.png); left: 572; top: 264 } -#playfield #field-13-7 { background-image: url(standard.png); left: 572; top: 308 } -#playfield #field-13-8 { background-image: url(standard.png); left: 572; top: 352 } -#playfield #field-13-9 { background-image: url(triple-letter.png); left: 572; top: 396 } -#playfield #field-13-10 { background-image: url(standard.png); left: 572; top: 440 } -#playfield #field-13-11 { background-image: url(standard.png); left: 572; top: 484 } -#playfield #field-13-12 { background-image: url(standard.png); left: 572; top: 528 } -#playfield #field-13-13 { background-image: url(double-word.png); left: 572; top: 572 } -#playfield #field-13-14 { background-image: url(standard.png); left: 572; top: 616 } -#playfield #field-14-0 { background-image: url(triple-word.png); left: 616; top: 0 } -#playfield #field-14-1 { background-image: url(standard.png); left: 616; top: 44 } -#playfield #field-14-2 { background-image: url(standard.png); left: 616; top: 88 } -#playfield #field-14-3 { background-image: url(double-letter.png); left: 616; top: 132 } -#playfield #field-14-4 { background-image: url(standard.png); left: 616; top: 176 } -#playfield #field-14-5 { background-image: url(standard.png); left: 616; top: 220 } -#playfield #field-14-6 { background-image: url(standard.png); left: 616; top: 264 } -#playfield #field-14-7 { background-image: url(triple-word.png); left: 616; top: 308 } -#playfield #field-14-8 { background-image: url(standard.png); left: 616; top: 352 } -#playfield #field-14-9 { background-image: url(standard.png); left: 616; top: 396 } -#playfield #field-14-10 { background-image: url(standard.png); left: 616; top: 440 } -#playfield #field-14-11 { background-image: url(double-letter.png); left: 616; top: 484 } -#playfield #field-14-12 { background-image: url(standard.png); left: 616; top: 528 } -#playfield #field-14-13 { background-image: url(standard.png); left: 616; top: 572 } -#playfield #field-14-14 { background-image: url(triple-word.png); left: 616; top: 616 } +#playfield #field-0-0 { background-image: url(images/triple-word.png); left: 0; top: 0 } +#playfield #field-0-1 { background-image: url(images/standard.png); left: 0; top: 44 } +#playfield #field-0-2 { background-image: url(images/standard.png); left: 0; top: 88 } +#playfield #field-0-3 { background-image: url(images/double-letter.png); left: 0; top: 132 } +#playfield #field-0-4 { background-image: url(images/standard.png); left: 0; top: 176 } +#playfield #field-0-5 { background-image: url(images/standard.png); left: 0; top: 220 } +#playfield #field-0-6 { background-image: url(images/standard.png); left: 0; top: 264 } +#playfield #field-0-7 { background-image: url(images/triple-word.png); left: 0; top: 308 } +#playfield #field-0-8 { background-image: url(images/standard.png); left: 0; top: 352 } +#playfield #field-0-9 { background-image: url(images/standard.png); left: 0; top: 396 } +#playfield #field-0-10 { background-image: url(images/standard.png); left: 0; top: 440 } +#playfield #field-0-11 { background-image: url(images/double-letter.png); left: 0; top: 484 } +#playfield #field-0-12 { background-image: url(images/standard.png); left: 0; top: 528 } +#playfield #field-0-13 { background-image: url(images/standard.png); left: 0; top: 572 } +#playfield #field-0-14 { background-image: url(images/triple-word.png); left: 0; top: 616 } +#playfield #field-1-0 { background-image: url(images/standard.png); left: 44; top: 0 } +#playfield #field-1-1 { background-image: url(images/double-word.png); left: 44; top: 44 } +#playfield #field-1-2 { background-image: url(images/standard.png); left: 44; top: 88 } +#playfield #field-1-3 { background-image: url(images/standard.png); left: 44; top: 132 } +#playfield #field-1-4 { background-image: url(images/standard.png); left: 44; top: 176 } +#playfield #field-1-5 { background-image: url(images/triple-letter.png); left: 44; top: 220 } +#playfield #field-1-6 { background-image: url(images/standard.png); left: 44; top: 264 } +#playfield #field-1-7 { background-image: url(images/standard.png); left: 44; top: 308 } +#playfield #field-1-8 { background-image: url(images/standard.png); left: 44; top: 352 } +#playfield #field-1-9 { background-image: url(images/triple-letter.png); left: 44; top: 396 } +#playfield #field-1-10 { background-image: url(images/standard.png); left: 44; top: 440 } +#playfield #field-1-11 { background-image: url(images/standard.png); left: 44; top: 484 } +#playfield #field-1-12 { background-image: url(images/standard.png); left: 44; top: 528 } +#playfield #field-1-13 { background-image: url(images/double-word.png); left: 44; top: 572 } +#playfield #field-1-14 { background-image: url(images/standard.png); left: 44; top: 616 } +#playfield #field-2-0 { background-image: url(images/standard.png); left: 88; top: 0 } +#playfield #field-2-1 { background-image: url(images/standard.png); left: 88; top: 44 } +#playfield #field-2-2 { background-image: url(images/double-word.png); left: 88; top: 88 } +#playfield #field-2-3 { background-image: url(images/standard.png); left: 88; top: 132 } +#playfield #field-2-4 { background-image: url(images/standard.png); left: 88; top: 176 } +#playfield #field-2-5 { background-image: url(images/standard.png); left: 88; top: 220 } +#playfield #field-2-6 { background-image: url(images/double-letter.png); left: 88; top: 264 } +#playfield #field-2-7 { background-image: url(images/standard.png); left: 88; top: 308 } +#playfield #field-2-8 { background-image: url(images/double-letter.png); left: 88; top: 352 } +#playfield #field-2-9 { background-image: url(images/standard.png); left: 88; top: 396 } +#playfield #field-2-10 { background-image: url(images/standard.png); left: 88; top: 440 } +#playfield #field-2-11 { background-image: url(images/standard.png); left: 88; top: 484 } +#playfield #field-2-12 { background-image: url(images/double-word.png); left: 88; top: 528 } +#playfield #field-2-13 { background-image: url(images/standard.png); left: 88; top: 572 } +#playfield #field-2-14 { background-image: url(images/standard.png); left: 88; top: 616 } +#playfield #field-3-0 { background-image: url(images/double-letter.png); left: 132; top: 0 } +#playfield #field-3-1 { background-image: url(images/standard.png); left: 132; top: 44 } +#playfield #field-3-2 { background-image: url(images/standard.png); left: 132; top: 88 } +#playfield #field-3-3 { background-image: url(images/double-word.png); left: 132; top: 132 } +#playfield #field-3-4 { background-image: url(images/standard.png); left: 132; top: 176 } +#playfield #field-3-5 { background-image: url(images/standard.png); left: 132; top: 220 } +#playfield #field-3-6 { background-image: url(images/standard.png); left: 132; top: 264 } +#playfield #field-3-7 { background-image: url(images/double-letter.png); left: 132; top: 308 } +#playfield #field-3-8 { background-image: url(images/standard.png); left: 132; top: 352 } +#playfield #field-3-9 { background-image: url(images/standard.png); left: 132; top: 396 } +#playfield #field-3-10 { background-image: url(images/standard.png); left: 132; top: 440 } +#playfield #field-3-11 { background-image: url(images/double-word.png); left: 132; top: 484 } +#playfield #field-3-12 { background-image: url(images/standard.png); left: 132; top: 528 } +#playfield #field-3-13 { background-image: url(images/standard.png); left: 132; top: 572 } +#playfield #field-3-14 { background-image: url(images/double-letter.png); left: 132; top: 616 } +#playfield #field-4-0 { background-image: url(images/standard.png); left: 176; top: 0 } +#playfield #field-4-1 { background-image: url(images/standard.png); left: 176; top: 44 } +#playfield #field-4-2 { background-image: url(images/standard.png); left: 176; top: 88 } +#playfield #field-4-3 { background-image: url(images/standard.png); left: 176; top: 132 } +#playfield #field-4-4 { background-image: url(images/double-word.png); left: 176; top: 176 } +#playfield #field-4-5 { background-image: url(images/standard.png); left: 176; top: 220 } +#playfield #field-4-6 { background-image: url(images/standard.png); left: 176; top: 264 } +#playfield #field-4-7 { background-image: url(images/standard.png); left: 176; top: 308 } +#playfield #field-4-8 { background-image: url(images/standard.png); left: 176; top: 352 } +#playfield #field-4-9 { background-image: url(images/standard.png); left: 176; top: 396 } +#playfield #field-4-10 { background-image: url(images/double-word.png); left: 176; top: 440 } +#playfield #field-4-11 { background-image: url(images/standard.png); left: 176; top: 484 } +#playfield #field-4-12 { background-image: url(images/standard.png); left: 176; top: 528 } +#playfield #field-4-13 { background-image: url(images/standard.png); left: 176; top: 572 } +#playfield #field-4-14 { background-image: url(images/standard.png); left: 176; top: 616 } +#playfield #field-5-0 { background-image: url(images/standard.png); left: 220; top: 0 } +#playfield #field-5-1 { background-image: url(images/triple-letter.png); left: 220; top: 44 } +#playfield #field-5-2 { background-image: url(images/standard.png); left: 220; top: 88 } +#playfield #field-5-3 { background-image: url(images/standard.png); left: 220; top: 132 } +#playfield #field-5-4 { background-image: url(images/standard.png); left: 220; top: 176 } +#playfield #field-5-5 { background-image: url(images/triple-letter.png); left: 220; top: 220 } +#playfield #field-5-6 { background-image: url(images/standard.png); left: 220; top: 264 } +#playfield #field-5-7 { background-image: url(images/standard.png); left: 220; top: 308 } +#playfield #field-5-8 { background-image: url(images/standard.png); left: 220; top: 352 } +#playfield #field-5-9 { background-image: url(images/triple-letter.png); left: 220; top: 396 } +#playfield #field-5-10 { background-image: url(images/standard.png); left: 220; top: 440 } +#playfield #field-5-11 { background-image: url(images/standard.png); left: 220; top: 484 } +#playfield #field-5-12 { background-image: url(images/standard.png); left: 220; top: 528 } +#playfield #field-5-13 { background-image: url(images/triple-letter.png); left: 220; top: 572 } +#playfield #field-5-14 { background-image: url(images/standard.png); left: 220; top: 616 } +#playfield #field-6-0 { background-image: url(images/standard.png); left: 264; top: 0 } +#playfield #field-6-1 { background-image: url(images/standard.png); left: 264; top: 44 } +#playfield #field-6-2 { background-image: url(images/double-letter.png); left: 264; top: 88 } +#playfield #field-6-3 { background-image: url(images/standard.png); left: 264; top: 132 } +#playfield #field-6-4 { background-image: url(images/standard.png); left: 264; top: 176 } +#playfield #field-6-5 { background-image: url(images/standard.png); left: 264; top: 220 } +#playfield #field-6-6 { background-image: url(images/double-letter.png); left: 264; top: 264 } +#playfield #field-6-7 { background-image: url(images/standard.png); left: 264; top: 308 } +#playfield #field-6-8 { background-image: url(images/double-letter.png); left: 264; top: 352 } +#playfield #field-6-9 { background-image: url(images/standard.png); left: 264; top: 396 } +#playfield #field-6-10 { background-image: url(images/standard.png); left: 264; top: 440 } +#playfield #field-6-11 { background-image: url(images/standard.png); left: 264; top: 484 } +#playfield #field-6-12 { background-image: url(images/double-letter.png); left: 264; top: 528 } +#playfield #field-6-13 { background-image: url(images/standard.png); left: 264; top: 572 } +#playfield #field-6-14 { background-image: url(images/standard.png); left: 264; top: 616 } +#playfield #field-7-0 { background-image: url(images/triple-word.png); left: 308; top: 0 } +#playfield #field-7-1 { background-image: url(images/standard.png); left: 308; top: 44 } +#playfield #field-7-2 { background-image: url(images/standard.png); left: 308; top: 88 } +#playfield #field-7-3 { background-image: url(images/double-letter.png); left: 308; top: 132 } +#playfield #field-7-4 { background-image: url(images/standard.png); left: 308; top: 176 } +#playfield #field-7-5 { background-image: url(images/standard.png); left: 308; top: 220 } +#playfield #field-7-6 { background-image: url(images/standard.png); left: 308; top: 264 } +#playfield #field-7-7 { background-image: url(images/double-word.png); left: 308; top: 308 } +#playfield #field-7-8 { background-image: url(images/standard.png); left: 308; top: 352 } +#playfield #field-7-9 { background-image: url(images/standard.png); left: 308; top: 396 } +#playfield #field-7-10 { background-image: url(images/standard.png); left: 308; top: 440 } +#playfield #field-7-11 { background-image: url(images/double-letter.png); left: 308; top: 484 } +#playfield #field-7-12 { background-image: url(images/standard.png); left: 308; top: 528 } +#playfield #field-7-13 { background-image: url(images/standard.png); left: 308; top: 572 } +#playfield #field-7-14 { background-image: url(images/triple-word.png); left: 308; top: 616 } +#playfield #field-8-0 { background-image: url(images/standard.png); left: 352; top: 0 } +#playfield #field-8-1 { background-image: url(images/standard.png); left: 352; top: 44 } +#playfield #field-8-2 { background-image: url(images/double-letter.png); left: 352; top: 88 } +#playfield #field-8-3 { background-image: url(images/standard.png); left: 352; top: 132 } +#playfield #field-8-4 { background-image: url(images/standard.png); left: 352; top: 176 } +#playfield #field-8-5 { background-image: url(images/standard.png); left: 352; top: 220 } +#playfield #field-8-6 { background-image: url(images/double-letter.png); left: 352; top: 264 } +#playfield #field-8-7 { background-image: url(images/standard.png); left: 352; top: 308 } +#playfield #field-8-8 { background-image: url(images/double-letter.png); left: 352; top: 352 } +#playfield #field-8-9 { background-image: url(images/standard.png); left: 352; top: 396 } +#playfield #field-8-10 { background-image: url(images/standard.png); left: 352; top: 440 } +#playfield #field-8-11 { background-image: url(images/standard.png); left: 352; top: 484 } +#playfield #field-8-12 { background-image: url(images/double-letter.png); left: 352; top: 528 } +#playfield #field-8-13 { background-image: url(images/standard.png); left: 352; top: 572 } +#playfield #field-8-14 { background-image: url(images/standard.png); left: 352; top: 616 } +#playfield #field-9-0 { background-image: url(images/standard.png); left: 396; top: 0 } +#playfield #field-9-1 { background-image: url(images/triple-letter.png); left: 396; top: 44 } +#playfield #field-9-2 { background-image: url(images/standard.png); left: 396; top: 88 } +#playfield #field-9-3 { background-image: url(images/standard.png); left: 396; top: 132 } +#playfield #field-9-4 { background-image: url(images/standard.png); left: 396; top: 176 } +#playfield #field-9-5 { background-image: url(images/triple-letter.png); left: 396; top: 220 } +#playfield #field-9-6 { background-image: url(images/standard.png); left: 396; top: 264 } +#playfield #field-9-7 { background-image: url(images/standard.png); left: 396; top: 308 } +#playfield #field-9-8 { background-image: url(images/standard.png); left: 396; top: 352 } +#playfield #field-9-9 { background-image: url(images/triple-letter.png); left: 396; top: 396 } +#playfield #field-9-10 { background-image: url(images/standard.png); left: 396; top: 440 } +#playfield #field-9-11 { background-image: url(images/standard.png); left: 396; top: 484 } +#playfield #field-9-12 { background-image: url(images/standard.png); left: 396; top: 528 } +#playfield #field-9-13 { background-image: url(images/triple-letter.png); left: 396; top: 572 } +#playfield #field-9-14 { background-image: url(images/standard.png); left: 396; top: 616 } +#playfield #field-10-0 { background-image: url(images/standard.png); left: 440; top: 0 } +#playfield #field-10-1 { background-image: url(images/standard.png); left: 440; top: 44 } +#playfield #field-10-2 { background-image: url(images/standard.png); left: 440; top: 88 } +#playfield #field-10-3 { background-image: url(images/standard.png); left: 440; top: 132 } +#playfield #field-10-4 { background-image: url(images/double-word.png); left: 440; top: 176 } +#playfield #field-10-5 { background-image: url(images/standard.png); left: 440; top: 220 } +#playfield #field-10-6 { background-image: url(images/standard.png); left: 440; top: 264 } +#playfield #field-10-7 { background-image: url(images/standard.png); left: 440; top: 308 } +#playfield #field-10-8 { background-image: url(images/standard.png); left: 440; top: 352 } +#playfield #field-10-9 { background-image: url(images/standard.png); left: 440; top: 396 } +#playfield #field-10-10 { background-image: url(images/double-word.png); left: 440; top: 440 } +#playfield #field-10-11 { background-image: url(images/standard.png); left: 440; top: 484 } +#playfield #field-10-12 { background-image: url(images/standard.png); left: 440; top: 528 } +#playfield #field-10-13 { background-image: url(images/standard.png); left: 440; top: 572 } +#playfield #field-10-14 { background-image: url(images/standard.png); left: 440; top: 616 } +#playfield #field-11-0 { background-image: url(images/double-letter.png); left: 484; top: 0 } +#playfield #field-11-1 { background-image: url(images/standard.png); left: 484; top: 44 } +#playfield #field-11-2 { background-image: url(images/standard.png); left: 484; top: 88 } +#playfield #field-11-3 { background-image: url(images/double-word.png); left: 484; top: 132 } +#playfield #field-11-4 { background-image: url(images/standard.png); left: 484; top: 176 } +#playfield #field-11-5 { background-image: url(images/standard.png); left: 484; top: 220 } +#playfield #field-11-6 { background-image: url(images/standard.png); left: 484; top: 264 } +#playfield #field-11-7 { background-image: url(images/double-letter.png); left: 484; top: 308 } +#playfield #field-11-8 { background-image: url(images/standard.png); left: 484; top: 352 } +#playfield #field-11-9 { background-image: url(images/standard.png); left: 484; top: 396 } +#playfield #field-11-10 { background-image: url(images/standard.png); left: 484; top: 440 } +#playfield #field-11-11 { background-image: url(images/double-word.png); left: 484; top: 484 } +#playfield #field-11-12 { background-image: url(images/standard.png); left: 484; top: 528 } +#playfield #field-11-13 { background-image: url(images/standard.png); left: 484; top: 572 } +#playfield #field-11-14 { background-image: url(images/double-letter.png); left: 484; top: 616 } +#playfield #field-12-0 { background-image: url(images/standard.png); left: 528; top: 0 } +#playfield #field-12-1 { background-image: url(images/standard.png); left: 528; top: 44 } +#playfield #field-12-2 { background-image: url(images/double-word.png); left: 528; top: 88 } +#playfield #field-12-3 { background-image: url(images/standard.png); left: 528; top: 132 } +#playfield #field-12-4 { background-image: url(images/standard.png); left: 528; top: 176 } +#playfield #field-12-5 { background-image: url(images/standard.png); left: 528; top: 220 } +#playfield #field-12-6 { background-image: url(images/double-letter.png); left: 528; top: 264 } +#playfield #field-12-7 { background-image: url(images/standard.png); left: 528; top: 308 } +#playfield #field-12-8 { background-image: url(images/double-letter.png); left: 528; top: 352 } +#playfield #field-12-9 { background-image: url(images/standard.png); left: 528; top: 396 } +#playfield #field-12-10 { background-image: url(images/standard.png); left: 528; top: 440 } +#playfield #field-12-11 { background-image: url(images/standard.png); left: 528; top: 484 } +#playfield #field-12-12 { background-image: url(images/double-word.png); left: 528; top: 528 } +#playfield #field-12-13 { background-image: url(images/standard.png); left: 528; top: 572 } +#playfield #field-12-14 { background-image: url(images/standard.png); left: 528; top: 616 } +#playfield #field-13-0 { background-image: url(images/standard.png); left: 572; top: 0 } +#playfield #field-13-1 { background-image: url(images/double-word.png); left: 572; top: 44 } +#playfield #field-13-2 { background-image: url(images/standard.png); left: 572; top: 88 } +#playfield #field-13-3 { background-image: url(images/standard.png); left: 572; top: 132 } +#playfield #field-13-4 { background-image: url(images/standard.png); left: 572; top: 176 } +#playfield #field-13-5 { background-image: url(images/triple-letter.png); left: 572; top: 220 } +#playfield #field-13-6 { background-image: url(images/standard.png); left: 572; top: 264 } +#playfield #field-13-7 { background-image: url(images/standard.png); left: 572; top: 308 } +#playfield #field-13-8 { background-image: url(images/standard.png); left: 572; top: 352 } +#playfield #field-13-9 { background-image: url(images/triple-letter.png); left: 572; top: 396 } +#playfield #field-13-10 { background-image: url(images/standard.png); left: 572; top: 440 } +#playfield #field-13-11 { background-image: url(images/standard.png); left: 572; top: 484 } +#playfield #field-13-12 { background-image: url(images/standard.png); left: 572; top: 528 } +#playfield #field-13-13 { background-image: url(images/double-word.png); left: 572; top: 572 } +#playfield #field-13-14 { background-image: url(images/standard.png); left: 572; top: 616 } +#playfield #field-14-0 { background-image: url(images/triple-word.png); left: 616; top: 0 } +#playfield #field-14-1 { background-image: url(images/standard.png); left: 616; top: 44 } +#playfield #field-14-2 { background-image: url(images/standard.png); left: 616; top: 88 } +#playfield #field-14-3 { background-image: url(images/double-letter.png); left: 616; top: 132 } +#playfield #field-14-4 { background-image: url(images/standard.png); left: 616; top: 176 } +#playfield #field-14-5 { background-image: url(images/standard.png); left: 616; top: 220 } +#playfield #field-14-6 { background-image: url(images/standard.png); left: 616; top: 264 } +#playfield #field-14-7 { background-image: url(images/triple-word.png); left: 616; top: 308 } +#playfield #field-14-8 { background-image: url(images/standard.png); left: 616; top: 352 } +#playfield #field-14-9 { background-image: url(images/standard.png); left: 616; top: 396 } +#playfield #field-14-10 { background-image: url(images/standard.png); left: 616; top: 440 } +#playfield #field-14-11 { background-image: url(images/double-letter.png); left: 616; top: 484 } +#playfield #field-14-12 { background-image: url(images/standard.png); left: 616; top: 528 } +#playfield #field-14-13 { background-image: url(images/standard.png); left: 616; top: 572 } +#playfield #field-14-14 { background-image: url(images/triple-word.png); left: 616; top: 616 } +#playfield #my-tray-0 { left: 194; top: 665 } +#playfield #my-tray-1 { left: 232; top: 665 } +#playfield #my-tray-2 { left: 270; top: 665 } +#playfield #my-tray-3 { left: 308; top: 665 } +#playfield #my-tray-4 { left: 346; top: 665 } +#playfield #my-tray-5 { left: 384; top: 665 } +#playfield #my-tray-6 { left: 422; top: 665 } Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-10-09 07:11:50 UTC (rev 2234) @@ -6,231 +6,238 @@ </head> <body onload="init()"> <div id='playfield'> - <div id='field-0-0'/></div> - <div id='field-0-1'/></div> - <div id='field-0-2'/></div> - <div id='field-0-3'/></div> - <div id='field-0-4'/></div> - <div id='field-0-5'/></div> - <div id='field-0-6'/></div> - <div id='field-0-7'/></div> - <div id='field-0-8'/></div> - <div id='field-0-9'/></div> - <div id='field-0-10'/></div> - <div id='field-0-11'/></div> - <div id='field-0-12'/></div> - <div id='field-0-13'/></div> - <div id='field-0-14'/></div> - <div id='field-1-0'/></div> - <div id='field-1-1'/></div> - <div id='field-1-2'/></div> - <div id='field-1-3'/></div> - <div id='field-1-4'/></div> - <div id='field-1-5'/></div> - <div id='field-1-6'/></div> - <div id='field-1-7'/></div> - <div id='field-1-8'/></div> - <div id='field-1-9'/></div> - <div id='field-1-10'/></div> - <div id='field-1-11'/></div> - <div id='field-1-12'/></div> - <div id='field-1-13'/></div> - <div id='field-1-14'/></div> - <div id='field-2-0'/></div> - <div id='field-2-1'/></div> - <div id='field-2-2'/></div> - <div id='field-2-3'/></div> - <div id='field-2-4'/></div> - <div id='field-2-5'/></div> - <div id='field-2-6'/></div> - <div id='field-2-7'/></div> - <div id='field-2-8'/></div> - <div id='field-2-9'/></div> - <div id='field-2-10'/></div> - <div id='field-2-11'/></div> - <div id='field-2-12'/></div> - <div id='field-2-13'/></div> - <div id='field-2-14'/></div> - <div id='field-3-0'/></div> - <div id='field-3-1'/></div> - <div id='field-3-2'/></div> - <div id='field-3-3'/></div> - <div id='field-3-4'/></div> - <div id='field-3-5'/></div> - <div id='field-3-6'/></div> - <div id='field-3-7'/></div> - <div id='field-3-8'/></div> - <div id='field-3-9'/></div> - <div id='field-3-10'/></div> - <div id='field-3-11'/></div> - <div id='field-3-12'/></div> - <div id='field-3-13'/></div> - <div id='field-3-14'/></div> - <div id='field-4-0'/></div> - <div id='field-4-1'/></div> - <div id='field-4-2'/></div> - <div id='field-4-3'/></div> - <div id='field-4-4'/></div> - <div id='field-4-5'/></div> - <div id='field-4-6'/></div> - <div id='field-4-7'/></div> - <div id='field-4-8'/></div> - <div id='field-4-9'/></div> - <div id='field-4-10'/></div> - <div id='field-4-11'/></div> - <div id='field-4-12'/></div> - <div id='field-4-13'/></div> - <div id='field-4-14'/></div> - <div id='field-5-0'/></div> - <div id='field-5-1'/></div> - <div id='field-5-2'/></div> - <div id='field-5-3'/></div> - <div id='field-5-4'/></div> - <div id='field-5-5'/></div> - <div id='field-5-6'/></div> - <div id='field-5-7'/></div> - <div id='field-5-8'/></div> - <div id='field-5-9'/></div> - <div id='field-5-10'/></div> - <div id='field-5-11'/></div> - <div id='field-5-12'/></div> - <div id='field-5-13'/></div> - <div id='field-5-14'/></div> - <div id='field-6-0'/></div> - <div id='field-6-1'/></div> - <div id='field-6-2'/></div> - <div id='field-6-3'/></div> - <div id='field-6-4'/></div> - <div id='field-6-5'/></div> - <div id='field-6-6'/></div> - <div id='field-6-7'/></div> - <div id='field-6-8'/></div> - <div id='field-6-9'/></div> - <div id='field-6-10'/></div> - <div id='field-6-11'/></div> - <div id='field-6-12'/></div> - <div id='field-6-13'/></div> - <div id='field-6-14'/></div> - <div id='field-7-0'/></div> - <div id='field-7-1'/></div> - <div id='field-7-2'/></div> - <div id='field-7-3'/></div> - <div id='field-7-4'/></div> - <div id='field-7-5'/></div> - <div id='field-7-6'/></div> - <div id='field-7-7'/></div> - <div id='field-7-8'/></div> - <div id='field-7-9'/></div> - <div id='field-7-10'/></div> - <div id='field-7-11'/></div> - <div id='field-7-12'/></div> - <div id='field-7-13'/></div> - <div id='field-7-14'/></div> - <div id='field-8-0'/></div> - <div id='field-8-1'/></div> - <div id='field-8-2'/></div> - <div id='field-8-3'/></div> - <div id='field-8-4'/></div> - <div id='field-8-5'/></div> - <div id='field-8-6'/></div> - <div id='field-8-7'/></div> - <div id='field-8-8'/></div> - <div id='field-8-9'/></div> - <div id='field-8-10'/></div> - <div id='field-8-11'/></div> - <div id='field-8-12'/></div> - <div id='field-8-13'/></div> - <div id='field-8-14'/></div> - <div id='field-9-0'/></div> - <div id='field-9-1'/></div> - <div id='field-9-2'/></div> - <div id='field-9-3'/></div> - <div id='field-9-4'/></div> - <div id='field-9-5'/></div> - <div id='field-9-6'/></div> - <div id='field-9-7'/></div> - <div id='field-9-8'/></div> - <div id='field-9-9'/></div> - <div id='field-9-10'/></div> - <div id='field-9-11'/></div> - <div id='field-9-12'/></div> - <div id='field-9-13'/></div> - <div id='field-9-14'/></div> - <div id='field-10-0'/></div> - <div id='field-10-1'/></div> - <div id='field-10-2'/></div> - <div id='field-10-3'/></div> - <div id='field-10-4'/></div> - <div id='field-10-5'/></div> - <div id='field-10-6'/></div> - <div id='field-10-7'/></div> - <div id='field-10-8'/></div> - <div id='field-10-9'/></div> - <div id='field-10-10'/></div> - <div id='field-10-11'/></div> - <div id='field-10-12'/></div> - <div id='field-10-13'/></div> - <div id='field-10-14'/></div> - <div id='field-11-0'/></div> - <div id='field-11-1'/></div> - <div id='field-11-2'/></div> - <div id='field-11-3'/></div> - <div id='field-11-4'/></div> - <div id='field-11-5'/></div> - <div id='field-11-6'/></div> - <div id='field-11-7'/></div> - <div id='field-11-8'/></div> - <div id='field-11-9'/></div> - <div id='field-11-10'/></div> - <div id='field-11-11'/></div> - <div id='field-11-12'/></div> - <div id='field-11-13'/></div> - <div id='field-11-14'/></div> - <div id='field-12-0'/></div> - <div id='field-12-1'/></div> - <div id='field-12-2'/></div> - <div id='field-12-3'/></div> - <div id='field-12-4'/></div> - <div id='field-12-5'/></div> - <div id='field-12-6'/></div> - <div id='field-12-7'/></div> - <div id='field-12-8'/></div> - <div id='field-12-9'/></div> - <div id='field-12-10'/></div> - <div id='field-12-11'/></div> - <div id='field-12-12'/></div> - <div id='field-12-13'/></div> - <div id='field-12-14'/></div> - <div id='field-13-0'/></div> - <div id='field-13-1'/></div> - <div id='field-13-2'/></div> - <div id='field-13-3'/></div> - <div id='field-13-4'/></div> - <div id='field-13-5'/></div> - <div id='field-13-6'/></div> - <div id='field-13-7'/></div> - <div id='field-13-8'/></div> - <div id='field-13-9'/></div> - <div id='field-13-10'/></div> - <div id='field-13-11'/></div> - <div id='field-13-12'/></div> - <div id='field-13-13'/></div> - <div id='field-13-14'/></div> - <div id='field-14-0'/></div> - <div id='field-14-1'/></div> - <div id='field-14-2'/></div> - <div id='field-14-3'/></div> - <div id='field-14-4'/></div> - <div id='field-14-5'/></div> - <div id='field-14-6'/></div> - <div id='field-14-7'/></div> - <div id='field-14-8'/></div> - <div id='field-14-9'/></div> - <div id='field-14-10'/></div> - <div id='field-14-11'/></div> - <div id='field-14-12'/></div> - <div id='field-14-13'/></div> - <div id='field-14-14'/></div> + <div id='field-0-0'></div> + <div id='field-0-1'></div> + <div id='field-0-2'></div> + <div id='field-0-3'></div> + <div id='field-0-4'></div> + <div id='field-0-5'></div> + <div id='field-0-6'></div> + <div id='field-0-7'></div> + <div id='field-0-8'></div> + <div id='field-0-9'></div> + <div id='field-0-10'></div> + <div id='field-0-11'></div> + <div id='field-0-12'></div> + <div id='field-0-13'></div> + <div id='field-0-14'></div> + <div id='field-1-0'></div> + <div id='field-1-1'></div> + <div id='field-1-2'></div> + <div id='field-1-3'></div> + <div id='field-1-4'></div> + <div id='field-1-5'></div> + <div id='field-1-6'></div> + <div id='field-1-7'></div> + <div id='field-1-8'></div> + <div id='field-1-9'></div> + <div id='field-1-10'></div> + <div id='field-1-11'></div> + <div id='field-1-12'></div> + <div id='field-1-13'></div> + <div id='field-1-14'></div> + <div id='field-2-0'></div> + <div id='field-2-1'></div> + <div id='field-2-2'></div> + <div id='field-2-3'></div> + <div id='field-2-4'></div> + <div id='field-2-5'></div> + <div id='field-2-6'></div> + <div id='field-2-7'></div> + <div id='field-2-8'></div> + <div id='field-2-9'></div> + <div id='field-2-10'></div> + <div id='field-2-11'></div> + <div id='field-2-12'></div> + <div id='field-2-13'></div> + <div id='field-2-14'></div> + <div id='field-3-0'></div> + <div id='field-3-1'></div> + <div id='field-3-2'></div> + <div id='field-3-3'></div> + <div id='field-3-4'></div> + <div id='field-3-5'></div> + <div id='field-3-6'></div> + <div id='field-3-7'></div> + <div id='field-3-8'></div> + <div id='field-3-9'></div> + <div id='field-3-10'></div> + <div id='field-3-11'></div> + <div id='field-3-12'></div> + <div id='field-3-13'></div> + <div id='field-3-14'></div> + <div id='field-4-0'></div> + <div id='field-4-1'></div> + <div id='field-4-2'></div> + <div id='field-4-3'></div> + <div id='field-4-4'></div> + <div id='field-4-5'></div> + <div id='field-4-6'></div> + <div id='field-4-7'></div> + <div id='field-4-8'></div> + <div id='field-4-9'></div> + <div id='field-4-10'></div> + <div id='field-4-11'></div> + <div id='field-4-12'></div> + <div id='field-4-13'></div> + <div id='field-4-14'></div> + <div id='field-5-0'></div> + <div id='field-5-1'></div> + <div id='field-5-2'></div> + <div id='field-5-3'></div> + <div id='field-5-4'></div> + <div id='field-5-5'></div> + <div id='field-5-6'></div> + <div id='field-5-7'></div> + <div id='field-5-8'></div> + <div id='field-5-9'></div> + <div id='field-5-10'></div> + <div id='field-5-11'></div> + <div id='field-5-12'></div> + <div id='field-5-13'></div> + <div id='field-5-14'></div> + <div id='field-6-0'></div> + <div id='field-6-1'></div> + <div id='field-6-2'></div> + <div id='field-6-3'></div> + <div id='field-6-4'></div> + <div id='field-6-5'></div> + <div id='field-6-6'></div> + <div id='field-6-7'></div> + <div id='field-6-8'></div> + <div id='field-6-9'></div> + <div id='field-6-10'></div> + <div id='field-6-11'></div> + <div id='field-6-12'></div> + <div id='field-6-13'></div> + <div id='field-6-14'></div> + <div id='field-7-0'></div> + <div id='field-7-1'></div> + <div id='field-7-2'></div> + <div id='field-7-3'></div> + <div id='field-7-4'></div> + <div id='field-7-5'></div> + <div id='field-7-6'></div> + <div id='field-7-7'></div> + <div id='field-7-8'></div> + <div id='field-7-9'></div> + <div id='field-7-10'></div> + <div id='field-7-11'></div> + <div id='field-7-12'></div> + <div id='field-7-13'></div> + <div id='field-7-14'></div> + <div id='field-8-0'></div> + <div id='field-8-1'></div> + <div id='field-8-2'></div> + <div id='field-8-3'></div> + <div id='field-8-4'></div> + <div id='field-8-5'></div> + <div id='field-8-6'></div> + <div id='field-8-7'></div> + <div id='field-8-8'></div> + <div id='field-8-9'></div> + <div id='field-8-10'></div> + <div id='field-8-11'></div> + <div id='field-8-12'></div> + <div id='field-8-13'></div> + <div id='field-8-14'></div> + <div id='field-9-0'></div> + <div id='field-9-1'></div> + <div id='field-9-2'></div> + <div id='field-9-3'></div> + <div id='field-9-4'></div> + <div id='field-9-5'></div> + <div id='field-9-6'></div> + <div id='field-9-7'></div> + <div id='field-9-8'></div> + <div id='field-9-9'></div> + <div id='field-9-10'></div> + <div id='field-9-11'></div> + <div id='field-9-12'></div> + <div id='field-9-13'></div> + <div id='field-9-14'></div> + <div id='field-10-0'></div> + <div id='field-10-1'></div> + <div id='field-10-2'></div> + <div id='field-10-3'></div> + <div id='field-10-4'></div> + <div id='field-10-5'></div> + <div id='field-10-6'></div> + <div id='field-10-7'></div> + <div id='field-10-8'></div> + <div id='field-10-9'></div> + <div id='field-10-10'></div> + <div id='field-10-11'></div> + <div id='field-10-12'></div> + <div id='field-10-13'></div> + <div id='field-10-14'></div> + <div id='field-11-0'></div> + <div id='field-11-1'></div> + <div id='field-11-2'></div> + <div id='field-11-3'></div> + <div id='field-11-4'></div> + <div id='field-11-5'></div> + <div id='field-11-6'></div> + <div id='field-11-7'></div> + <div id='field-11-8'></div> + <div id='field-11-9'></div> + <div id='field-11-10'></div> + <div id='field-11-11'></div> + <div id='field-11-12'></div> + <div id='field-11-13'></div> + <div id='field-11-14'></div> + <div id='field-12-0'></div> + <div id='field-12-1'></div> + <div id='field-12-2'></div> + <div id='field-12-3'></div> + <div id='field-12-4'></div> + <div id='field-12-5'></div> + <div id='field-12-6'></div> + <div id='field-12-7'></div> + <div id='field-12-8'></div> + <div id='field-12-9'></div> + <div id='field-12-10'></div> + <div id='field-12-11'></div> + <div id='field-12-12'></div> + <div id='field-12-13'></div> + <div id='field-12-14'></div> + <div id='field-13-0'></div> + <div id='field-13-1'></div> + <div id='field-13-2'></div> + <div id='field-13-3'></div> + <div id='field-13-4'></div> + <div id='field-13-5'></div> + <div id='field-13-6'></div> + <div id='field-13-7'></div> + <div id='field-13-8'></div> + <div id='field-13-9'></div> + <div id='field-13-10'></div> + <div id='field-13-11'></div> + <div id='field-13-12'></div> + <div id='field-13-13'></div> + <div id='field-13-14'></div> + <div id='field-14-0'></div> + <div id='field-14-1'></div> + <div id='field-14-2'></div> + <div id='field-14-3'></div> + <div id='field-14-4'></div> + <div id='field-14-5'></div> + <div id='field-14-6'></div> + <div id='field-14-7'></div> + <div id='field-14-8'></div> + <div id='field-14-9'></div> + <div id='field-14-10'></div> + <div id='field-14-11'></div> + <div id='field-14-12'></div> + <div id='field-14-13'></div> + <div id='field-14-14'></div> + <div id='my-tray-0'></div> + <div id='my-tray-1'></div> + <div id='my-tray-2'></div> + <div id='my-tray-3'></div> + <div id='my-tray-4'></div> + <div id='my-tray-5'></div> + <div id='my-tray-6'></div> </div> </body> </html> \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-10-09 05:52:40 UTC (rev 2233) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-10-09 07:11:50 UTC (rev 2234) @@ -1,32 +1,38 @@ // -*- Java -*- (really Javascript) function setLetter(x, y, letter) { - $('field-' + x + '-' + y).innerHTML = '<img src="' + letter + '.png"/>'; + $('field-' + x + '-' + y).innerHTML = '<img src="images/' + letter + '.png"/>'; } -function setWord(x, y, word, down) { - for (i = 0; i < word.length; i++) { - setLetter(x, y, word.charAt(i)); - if (down) { - y++; - } else { - x++; - } - }; +function setMyTray(n, letter) { + $('my-tray-' + n).innerHTML = letter ? '<img src="images/' + letter + '.png"/>' : ''; } +function drawGameState (gameState) { + for (var i = 0; i < gameState.board.length; i++) { + var x = gameState.board[i][0]; + var y = gameState.board[i][1]; + var char = gameState.board[i][2]; + setLetter(x, y, char); + } +} + +function trayClick(letter) { + this.clicked = !this.clicked; + setElementPosition(this, { y: (this.clicked ? 680 : 665) }); +} + function init() { + for (var i = 0; i < 7; i++) { + $('my-tray-' + i).onclick = trayClick; + } + setMyTray(0, 'A'); + setMyTray(1, 'B'); + setMyTray(2, 'C'); + setMyTray(3, 'D'); + setMyTray(4, 'E'); + setMyTray(5, 'F'); + setMyTray(6, 'G'); var d = loadJSONDoc("/game/108"); - d.addCallbacks( - function (gameState) { - for (var i = 0; i < gameState.board.length; i++) { - var x = gameState.board[i][0]; - var y = gameState.board[i][1]; - var char = gameState.board[i][2]; - setLetter(x, y, char); - } - }, - function (error) { - alert(error); - }); + d.addCallbacks(drawGameState, alert); }

1 0

[bknr-cvs] r2233 - in branches/trunk-reorg/projects/scrabble/website: . de en
by bknr＠bknr.net 09 Oct '07

09 Oct '07

Author: hhubner Date: 2007-10-09 01:52:40 -0400 (Tue, 09 Oct 2007) New Revision: 2233 Added: branches/trunk-reorg/projects/scrabble/website/scrabble.css branches/trunk-reorg/projects/scrabble/website/scrabble.html branches/trunk-reorg/projects/scrabble/website/scrabble.js Removed: branches/trunk-reorg/projects/scrabble/website/de/scrabble.css branches/trunk-reorg/projects/scrabble/website/de/scrabble.html branches/trunk-reorg/projects/scrabble/website/de/scrabble.js branches/trunk-reorg/projects/scrabble/website/en/scrabble.css branches/trunk-reorg/projects/scrabble/website/en/scrabble.html branches/trunk-reorg/projects/scrabble/website/en/scrabble.js Log: checkpoint Deleted: branches/trunk-reorg/projects/scrabble/website/de/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-09 05:52:40 UTC (rev 2233) @@ -1,229 +0,0 @@ -body { background-color: #004B36 } -#playfield { position: absolute } -#playfield div { position: absolute; width: 40px; height: 40px } -#playfield img { position: absolute; top: 3px; left: 3px } -#playfield #field-0-0 { background-image: url(triple-word.png); left: 0; top: 0 } -#playfield #field-0-1 { background-image: url(standard.png); left: 0; top: 44 } -#playfield #field-0-2 { background-image: url(standard.png); left: 0; top: 88 } -#playfield #field-0-3 { background-image: url(double-letter.png); left: 0; top: 132 } -#playfield #field-0-4 { background-image: url(standard.png); left: 0; top: 176 } -#playfield #field-0-5 { background-image: url(standard.png); left: 0; top: 220 } -#playfield #field-0-6 { background-image: url(standard.png); left: 0; top: 264 } -#playfield #field-0-7 { background-image: url(triple-word.png); left: 0; top: 308 } -#playfield #field-0-8 { background-image: url(standard.png); left: 0; top: 352 } -#playfield #field-0-9 { background-image: url(standard.png); left: 0; top: 396 } -#playfield #field-0-10 { background-image: url(standard.png); left: 0; top: 440 } -#playfield #field-0-11 { background-image: url(double-letter.png); left: 0; top: 484 } -#playfield #field-0-12 { background-image: url(standard.png); left: 0; top: 528 } -#playfield #field-0-13 { background-image: url(standard.png); left: 0; top: 572 } -#playfield #field-0-14 { background-image: url(triple-word.png); left: 0; top: 616 } -#playfield #field-1-0 { background-image: url(standard.png); left: 44; top: 0 } -#playfield #field-1-1 { background-image: url(double-word.png); left: 44; top: 44 } -#playfield #field-1-2 { background-image: url(standard.png); left: 44; top: 88 } -#playfield #field-1-3 { background-image: url(standard.png); left: 44; top: 132 } -#playfield #field-1-4 { background-image: url(standard.png); left: 44; top: 176 } -#playfield #field-1-5 { background-image: url(triple-letter.png); left: 44; top: 220 } -#playfield #field-1-6 { background-image: url(standard.png); left: 44; top: 264 } -#playfield #field-1-7 { background-image: url(standard.png); left: 44; top: 308 } -#playfield #field-1-8 { background-image: url(standard.png); left: 44; top: 352 } -#playfield #field-1-9 { background-image: url(triple-letter.png); left: 44; top: 396 } -#playfield #field-1-10 { background-image: url(standard.png); left: 44; top: 440 } -#playfield #field-1-11 { background-image: url(standard.png); left: 44; top: 484 } -#playfield #field-1-12 { background-image: url(standard.png); left: 44; top: 528 } -#playfield #field-1-13 { background-image: url(double-word.png); left: 44; top: 572 } -#playfield #field-1-14 { background-image: url(standard.png); left: 44; top: 616 } -#playfield #field-2-0 { background-image: url(standard.png); left: 88; top: 0 } -#playfield #field-2-1 { background-image: url(standard.png); left: 88; top: 44 } -#playfield #field-2-2 { background-image: url(double-word.png); left: 88; top: 88 } -#playfield #field-2-3 { background-image: url(standard.png); left: 88; top: 132 } -#playfield #field-2-4 { background-image: url(standard.png); left: 88; top: 176 } -#playfield #field-2-5 { background-image: url(standard.png); left: 88; top: 220 } -#playfield #field-2-6 { background-image: url(double-letter.png); left: 88; top: 264 } -#playfield #field-2-7 { background-image: url(standard.png); left: 88; top: 308 } -#playfield #field-2-8 { background-image: url(double-letter.png); left: 88; top: 352 } -#playfield #field-2-9 { background-image: url(standard.png); left: 88; top: 396 } -#playfield #field-2-10 { background-image: url(standard.png); left: 88; top: 440 } -#playfield #field-2-11 { background-image: url(standard.png); left: 88; top: 484 } -#playfield #field-2-12 { background-image: url(double-word.png); left: 88; top: 528 } -#playfield #field-2-13 { background-image: url(standard.png); left: 88; top: 572 } -#playfield #field-2-14 { background-image: url(standard.png); left: 88; top: 616 } -#playfield #field-3-0 { background-image: url(double-letter.png); left: 132; top: 0 } -#playfield #field-3-1 { background-image: url(standard.png); left: 132; top: 44 } -#playfield #field-3-2 { background-image: url(standard.png); left: 132; top: 88 } -#playfield #field-3-3 { background-image: url(double-word.png); left: 132; top: 132 } -#playfield #field-3-4 { background-image: url(standard.png); left: 132; top: 176 } -#playfield #field-3-5 { background-image: url(standard.png); left: 132; top: 220 } -#playfield #field-3-6 { background-image: url(standard.png); left: 132; top: 264 } -#playfield #field-3-7 { background-image: url(double-letter.png); left: 132; top: 308 } -#playfield #field-3-8 { background-image: url(standard.png); left: 132; top: 352 } -#playfield #field-3-9 { background-image: url(standard.png); left: 132; top: 396 } -#playfield #field-3-10 { background-image: url(standard.png); left: 132; top: 440 } -#playfield #field-3-11 { background-image: url(double-word.png); left: 132; top: 484 } -#playfield #field-3-12 { background-image: url(standard.png); left: 132; top: 528 } -#playfield #field-3-13 { background-image: url(standard.png); left: 132; top: 572 } -#playfield #field-3-14 { background-image: url(double-letter.png); left: 132; top: 616 } -#playfield #field-4-0 { background-image: url(standard.png); left: 176; top: 0 } -#playfield #field-4-1 { background-image: url(standard.png); left: 176; top: 44 } -#playfield #field-4-2 { background-image: url(standard.png); left: 176; top: 88 } -#playfield #field-4-3 { background-image: url(standard.png); left: 176; top: 132 } -#playfield #field-4-4 { background-image: url(double-word.png); left: 176; top: 176 } -#playfield #field-4-5 { background-image: url(standard.png); left: 176; top: 220 } -#playfield #field-4-6 { background-image: url(standard.png); left: 176; top: 264 } -#playfield #field-4-7 { background-image: url(standard.png); left: 176; top: 308 } -#playfield #field-4-8 { background-image: url(standard.png); left: 176; top: 352 } -#playfield #field-4-9 { background-image: url(standard.png); left: 176; top: 396 } -#playfield #field-4-10 { background-image: url(double-word.png); left: 176; top: 440 } -#playfield #field-4-11 { background-image: url(standard.png); left: 176; top: 484 } -#playfield #field-4-12 { background-image: url(standard.png); left: 176; top: 528 } -#playfield #field-4-13 { background-image: url(standard.png); left: 176; top: 572 } -#playfield #field-4-14 { background-image: url(standard.png); left: 176; top: 616 } -#playfield #field-5-0 { background-image: url(standard.png); left: 220; top: 0 } -#playfield #field-5-1 { background-image: url(triple-letter.png); left: 220; top: 44 } -#playfield #field-5-2 { background-image: url(standard.png); left: 220; top: 88 } -#playfield #field-5-3 { background-image: url(standard.png); left: 220; top: 132 } -#playfield #field-5-4 { background-image: url(standard.png); left: 220; top: 176 } -#playfield #field-5-5 { background-image: url(triple-letter.png); left: 220; top: 220 } -#playfield #field-5-6 { background-image: url(standard.png); left: 220; top: 264 } -#playfield #field-5-7 { background-image: url(standard.png); left: 220; top: 308 } -#playfield #field-5-8 { background-image: url(standard.png); left: 220; top: 352 } -#playfield #field-5-9 { background-image: url(triple-letter.png); left: 220; top: 396 } -#playfield #field-5-10 { background-image: url(standard.png); left: 220; top: 440 } -#playfield #field-5-11 { background-image: url(standard.png); left: 220; top: 484 } -#playfield #field-5-12 { background-image: url(standard.png); left: 220; top: 528 } -#playfield #field-5-13 { background-image: url(triple-letter.png); left: 220; top: 572 } -#playfield #field-5-14 { background-image: url(standard.png); left: 220; top: 616 } -#playfield #field-6-0 { background-image: url(standard.png); left: 264; top: 0 } -#playfield #field-6-1 { background-image: url(standard.png); left: 264; top: 44 } -#playfield #field-6-2 { background-image: url(double-letter.png); left: 264; top: 88 } -#playfield #field-6-3 { background-image: url(standard.png); left: 264; top: 132 } -#playfield #field-6-4 { background-image: url(standard.png); left: 264; top: 176 } -#playfield #field-6-5 { background-image: url(standard.png); left: 264; top: 220 } -#playfield #field-6-6 { background-image: url(double-letter.png); left: 264; top: 264 } -#playfield #field-6-7 { background-image: url(standard.png); left: 264; top: 308 } -#playfield #field-6-8 { background-image: url(double-letter.png); left: 264; top: 352 } -#playfield #field-6-9 { background-image: url(standard.png); left: 264; top: 396 } -#playfield #field-6-10 { background-image: url(standard.png); left: 264; top: 440 } -#playfield #field-6-11 { background-image: url(standard.png); left: 264; top: 484 } -#playfield #field-6-12 { background-image: url(double-letter.png); left: 264; top: 528 } -#playfield #field-6-13 { background-image: url(standard.png); left: 264; top: 572 } -#playfield #field-6-14 { background-image: url(standard.png); left: 264; top: 616 } -#playfield #field-7-0 { background-image: url(triple-word.png); left: 308; top: 0 } -#playfield #field-7-1 { background-image: url(standard.png); left: 308; top: 44 } -#playfield #field-7-2 { background-image: url(standard.png); left: 308; top: 88 } -#playfield #field-7-3 { background-image: url(double-letter.png); left: 308; top: 132 } -#playfield #field-7-4 { background-image: url(standard.png); left: 308; top: 176 } -#playfield #field-7-5 { background-image: url(standard.png); left: 308; top: 220 } -#playfield #field-7-6 { background-image: url(standard.png); left: 308; top: 264 } -#playfield #field-7-7 { background-image: url(double-word.png); left: 308; top: 308 } -#playfield #field-7-8 { background-image: url(standard.png); left: 308; top: 352 } -#playfield #field-7-9 { background-image: url(standard.png); left: 308; top: 396 } -#playfield #field-7-10 { background-image: url(standard.png); left: 308; top: 440 } -#playfield #field-7-11 { background-image: url(double-letter.png); left: 308; top: 484 } -#playfield #field-7-12 { background-image: url(standard.png); left: 308; top: 528 } -#playfield #field-7-13 { background-image: url(standard.png); left: 308; top: 572 } -#playfield #field-7-14 { background-image: url(triple-word.png); left: 308; top: 616 } -#playfield #field-8-0 { background-image: url(standard.png); left: 352; top: 0 } -#playfield #field-8-1 { background-image: url(standard.png); left: 352; top: 44 } -#playfield #field-8-2 { background-image: url(double-letter.png); left: 352; top: 88 } -#playfield #field-8-3 { background-image: url(standard.png); left: 352; top: 132 } -#playfield #field-8-4 { background-image: url(standard.png); left: 352; top: 176 } -#playfield #field-8-5 { background-image: url(standard.png); left: 352; top: 220 } -#playfield #field-8-6 { background-image: url(double-letter.png); left: 352; top: 264 } -#playfield #field-8-7 { background-image: url(standard.png); left: 352; top: 308 } -#playfield #field-8-8 { background-image: url(double-letter.png); left: 352; top: 352 } -#playfield #field-8-9 { background-image: url(standard.png); left: 352; top: 396 } -#playfield #field-8-10 { background-image: url(standard.png); left: 352; top: 440 } -#playfield #field-8-11 { background-image: url(standard.png); left: 352; top: 484 } -#playfield #field-8-12 { background-image: url(double-letter.png); left: 352; top: 528 } -#playfield #field-8-13 { background-image: url(standard.png); left: 352; top: 572 } -#playfield #field-8-14 { background-image: url(standard.png); left: 352; top: 616 } -#playfield #field-9-0 { background-image: url(standard.png); left: 396; top: 0 } -#playfield #field-9-1 { background-image: url(triple-letter.png); left: 396; top: 44 } -#playfield #field-9-2 { background-image: url(standard.png); left: 396; top: 88 } -#playfield #field-9-3 { background-image: url(standard.png); left: 396; top: 132 } -#playfield #field-9-4 { background-image: url(standard.png); left: 396; top: 176 } -#playfield #field-9-5 { background-image: url(triple-letter.png); left: 396; top: 220 } -#playfield #field-9-6 { background-image: url(standard.png); left: 396; top: 264 } -#playfield #field-9-7 { background-image: url(standard.png); left: 396; top: 308 } -#playfield #field-9-8 { background-image: url(standard.png); left: 396; top: 352 } -#playfield #field-9-9 { background-image: url(triple-letter.png); left: 396; top: 396 } -#playfield #field-9-10 { background-image: url(standard.png); left: 396; top: 440 } -#playfield #field-9-11 { background-image: url(standard.png); left: 396; top: 484 } -#playfield #field-9-12 { background-image: url(standard.png); left: 396; top: 528 } -#playfield #field-9-13 { background-image: url(triple-letter.png); left: 396; top: 572 } -#playfield #field-9-14 { background-image: url(standard.png); left: 396; top: 616 } -#playfield #field-10-0 { background-image: url(standard.png); left: 440; top: 0 } -#playfield #field-10-1 { background-image: url(standard.png); left: 440; top: 44 } -#playfield #field-10-2 { background-image: url(standard.png); left: 440; top: 88 } -#playfield #field-10-3 { background-image: url(standard.png); left: 440; top: 132 } -#playfield #field-10-4 { background-image: url(double-word.png); left: 440; top: 176 } -#playfield #field-10-5 { background-image: url(standard.png); left: 440; top: 220 } -#playfield #field-10-6 { background-image: url(standard.png); left: 440; top: 264 } -#playfield #field-10-7 { background-image: url(standard.png); left: 440; top: 308 } -#playfield #field-10-8 { background-image: url(standard.png); left: 440; top: 352 } -#playfield #field-10-9 { background-image: url(standard.png); left: 440; top: 396 } -#playfield #field-10-10 { background-image: url(double-word.png); left: 440; top: 440 } -#playfield #field-10-11 { background-image: url(standard.png); left: 440; top: 484 } -#playfield #field-10-12 { background-image: url(standard.png); left: 440; top: 528 } -#playfield #field-10-13 { background-image: url(standard.png); left: 440; top: 572 } -#playfield #field-10-14 { background-image: url(standard.png); left: 440; top: 616 } -#playfield #field-11-0 { background-image: url(double-letter.png); left: 484; top: 0 } -#playfield #field-11-1 { background-image: url(standard.png); left: 484; top: 44 } -#playfield #field-11-2 { background-image: url(standard.png); left: 484; top: 88 } -#playfield #field-11-3 { background-image: url(double-word.png); left: 484; top: 132 } -#playfield #field-11-4 { background-image: url(standard.png); left: 484; top: 176 } -#playfield #field-11-5 { background-image: url(standard.png); left: 484; top: 220 } -#playfield #field-11-6 { background-image: url(standard.png); left: 484; top: 264 } -#playfield #field-11-7 { background-image: url(double-letter.png); left: 484; top: 308 } -#playfield #field-11-8 { background-image: url(standard.png); left: 484; top: 352 } -#playfield #field-11-9 { background-image: url(standard.png); left: 484; top: 396 } -#playfield #field-11-10 { background-image: url(standard.png); left: 484; top: 440 } -#playfield #field-11-11 { background-image: url(double-word.png); left: 484; top: 484 } -#playfield #field-11-12 { background-image: url(standard.png); left: 484; top: 528 } -#playfield #field-11-13 { background-image: url(standard.png); left: 484; top: 572 } -#playfield #field-11-14 { background-image: url(double-letter.png); left: 484; top: 616 } -#playfield #field-12-0 { background-image: url(standard.png); left: 528; top: 0 } -#playfield #field-12-1 { background-image: url(standard.png); left: 528; top: 44 } -#playfield #field-12-2 { background-image: url(double-word.png); left: 528; top: 88 } -#playfield #field-12-3 { background-image: url(standard.png); left: 528; top: 132 } -#playfield #field-12-4 { background-image: url(standard.png); left: 528; top: 176 } -#playfield #field-12-5 { background-image: url(standard.png); left: 528; top: 220 } -#playfield #field-12-6 { background-image: url(double-letter.png); left: 528; top: 264 } -#playfield #field-12-7 { background-image: url(standard.png); left: 528; top: 308 } -#playfield #field-12-8 { background-image: url(double-letter.png); left: 528; top: 352 } -#playfield #field-12-9 { background-image: url(standard.png); left: 528; top: 396 } -#playfield #field-12-10 { background-image: url(standard.png); left: 528; top: 440 } -#playfield #field-12-11 { background-image: url(standard.png); left: 528; top: 484 } -#playfield #field-12-12 { background-image: url(double-word.png); left: 528; top: 528 } -#playfield #field-12-13 { background-image: url(standard.png); left: 528; top: 572 } -#playfield #field-12-14 { background-image: url(standard.png); left: 528; top: 616 } -#playfield #field-13-0 { background-image: url(standard.png); left: 572; top: 0 } -#playfield #field-13-1 { background-image: url(double-word.png); left: 572; top: 44 } -#playfield #field-13-2 { background-image: url(standard.png); left: 572; top: 88 } -#playfield #field-13-3 { background-image: url(standard.png); left: 572; top: 132 } -#playfield #field-13-4 { background-image: url(standard.png); left: 572; top: 176 } -#playfield #field-13-5 { background-image: url(triple-letter.png); left: 572; top: 220 } -#playfield #field-13-6 { background-image: url(standard.png); left: 572; top: 264 } -#playfield #field-13-7 { background-image: url(standard.png); left: 572; top: 308 } -#playfield #field-13-8 { background-image: url(standard.png); left: 572; top: 352 } -#playfield #field-13-9 { background-image: url(triple-letter.png); left: 572; top: 396 } -#playfield #field-13-10 { background-image: url(standard.png); left: 572; top: 440 } -#playfield #field-13-11 { background-image: url(standard.png); left: 572; top: 484 } -#playfield #field-13-12 { background-image: url(standard.png); left: 572; top: 528 } -#playfield #field-13-13 { background-image: url(double-word.png); left: 572; top: 572 } -#playfield #field-13-14 { background-image: url(standard.png); left: 572; top: 616 } -#playfield #field-14-0 { background-image: url(triple-word.png); left: 616; top: 0 } -#playfield #field-14-1 { background-image: url(standard.png); left: 616; top: 44 } -#playfield #field-14-2 { background-image: url(standard.png); left: 616; top: 88 } -#playfield #field-14-3 { background-image: url(double-letter.png); left: 616; top: 132 } -#playfield #field-14-4 { background-image: url(standard.png); left: 616; top: 176 } -#playfield #field-14-5 { background-image: url(standard.png); left: 616; top: 220 } -#playfield #field-14-6 { background-image: url(standard.png); left: 616; top: 264 } -#playfield #field-14-7 { background-image: url(triple-word.png); left: 616; top: 308 } -#playfield #field-14-8 { background-image: url(standard.png); left: 616; top: 352 } -#playfield #field-14-9 { background-image: url(standard.png); left: 616; top: 396 } -#playfield #field-14-10 { background-image: url(standard.png); left: 616; top: 440 } -#playfield #field-14-11 { background-image: url(double-letter.png); left: 616; top: 484 } -#playfield #field-14-12 { background-image: url(standard.png); left: 616; top: 528 } -#playfield #field-14-13 { background-image: url(standard.png); left: 616; top: 572 } -#playfield #field-14-14 { background-image: url(triple-word.png); left: 616; top: 616 } Deleted: branches/trunk-reorg/projects/scrabble/website/de/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.html 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.html 2007-10-09 05:52:40 UTC (rev 2233) @@ -1,236 +0,0 @@ -<html> - <head> - <link rel="stylesheet" type="text/css" href="scrabble.css" /> - <script type="text/javascript" src="/MochiKit/MochiKit.js"> </script> - <script type="text/javascript" src="scrabble.js"> </script> - </head> - <body onload="init()"> - <div id='playfield'> - <div id='field-0-0'/></div> - <div id='field-0-1'/></div> - <div id='field-0-2'/></div> - <div id='field-0-3'/></div> - <div id='field-0-4'/></div> - <div id='field-0-5'/></div> - <div id='field-0-6'/></div> - <div id='field-0-7'/></div> - <div id='field-0-8'/></div> - <div id='field-0-9'/></div> - <div id='field-0-10'/></div> - <div id='field-0-11'/></div> - <div id='field-0-12'/></div> - <div id='field-0-13'/></div> - <div id='field-0-14'/></div> - <div id='field-1-0'/></div> - <div id='field-1-1'/></div> - <div id='field-1-2'/></div> - <div id='field-1-3'/></div> - <div id='field-1-4'/></div> - <div id='field-1-5'/></div> - <div id='field-1-6'/></div> - <div id='field-1-7'/></div> - <div id='field-1-8'/></div> - <div id='field-1-9'/></div> - <div id='field-1-10'/></div> - <div id='field-1-11'/></div> - <div id='field-1-12'/></div> - <div id='field-1-13'/></div> - <div id='field-1-14'/></div> - <div id='field-2-0'/></div> - <div id='field-2-1'/></div> - <div id='field-2-2'/></div> - <div id='field-2-3'/></div> - <div id='field-2-4'/></div> - <div id='field-2-5'/></div> - <div id='field-2-6'/></div> - <div id='field-2-7'/></div> - <div id='field-2-8'/></div> - <div id='field-2-9'/></div> - <div id='field-2-10'/></div> - <div id='field-2-11'/></div> - <div id='field-2-12'/></div> - <div id='field-2-13'/></div> - <div id='field-2-14'/></div> - <div id='field-3-0'/></div> - <div id='field-3-1'/></div> - <div id='field-3-2'/></div> - <div id='field-3-3'/></div> - <div id='field-3-4'/></div> - <div id='field-3-5'/></div> - <div id='field-3-6'/></div> - <div id='field-3-7'/></div> - <div id='field-3-8'/></div> - <div id='field-3-9'/></div> - <div id='field-3-10'/></div> - <div id='field-3-11'/></div> - <div id='field-3-12'/></div> - <div id='field-3-13'/></div> - <div id='field-3-14'/></div> - <div id='field-4-0'/></div> - <div id='field-4-1'/></div> - <div id='field-4-2'/></div> - <div id='field-4-3'/></div> - <div id='field-4-4'/></div> - <div id='field-4-5'/></div> - <div id='field-4-6'/></div> - <div id='field-4-7'/></div> - <div id='field-4-8'/></div> - <div id='field-4-9'/></div> - <div id='field-4-10'/></div> - <div id='field-4-11'/></div> - <div id='field-4-12'/></div> - <div id='field-4-13'/></div> - <div id='field-4-14'/></div> - <div id='field-5-0'/></div> - <div id='field-5-1'/></div> - <div id='field-5-2'/></div> - <div id='field-5-3'/></div> - <div id='field-5-4'/></div> - <div id='field-5-5'/></div> - <div id='field-5-6'/></div> - <div id='field-5-7'/></div> - <div id='field-5-8'/></div> - <div id='field-5-9'/></div> - <div id='field-5-10'/></div> - <div id='field-5-11'/></div> - <div id='field-5-12'/></div> - <div id='field-5-13'/></div> - <div id='field-5-14'/></div> - <div id='field-6-0'/></div> - <div id='field-6-1'/></div> - <div id='field-6-2'/></div> - <div id='field-6-3'/></div> - <div id='field-6-4'/></div> - <div id='field-6-5'/></div> - <div id='field-6-6'/></div> - <div id='field-6-7'/></div> - <div id='field-6-8'/></div> - <div id='field-6-9'/></div> - <div id='field-6-10'/></div> - <div id='field-6-11'/></div> - <div id='field-6-12'/></div> - <div id='field-6-13'/></div> - <div id='field-6-14'/></div> - <div id='field-7-0'/></div> - <div id='field-7-1'/></div> - <div id='field-7-2'/></div> - <div id='field-7-3'/></div> - <div id='field-7-4'/></div> - <div id='field-7-5'/></div> - <div id='field-7-6'/></div> - <div id='field-7-7'/></div> - <div id='field-7-8'/></div> - <div id='field-7-9'/></div> - <div id='field-7-10'/></div> - <div id='field-7-11'/></div> - <div id='field-7-12'/></div> - <div id='field-7-13'/></div> - <div id='field-7-14'/></div> - <div id='field-8-0'/></div> - <div id='field-8-1'/></div> - <div id='field-8-2'/></div> - <div id='field-8-3'/></div> - <div id='field-8-4'/></div> - <div id='field-8-5'/></div> - <div id='field-8-6'/></div> - <div id='field-8-7'/></div> - <div id='field-8-8'/></div> - <div id='field-8-9'/></div> - <div id='field-8-10'/></div> - <div id='field-8-11'/></div> - <div id='field-8-12'/></div> - <div id='field-8-13'/></div> - <div id='field-8-14'/></div> - <div id='field-9-0'/></div> - <div id='field-9-1'/></div> - <div id='field-9-2'/></div> - <div id='field-9-3'/></div> - <div id='field-9-4'/></div> - <div id='field-9-5'/></div> - <div id='field-9-6'/></div> - <div id='field-9-7'/></div> - <div id='field-9-8'/></div> - <div id='field-9-9'/></div> - <div id='field-9-10'/></div> - <div id='field-9-11'/></div> - <div id='field-9-12'/></div> - <div id='field-9-13'/></div> - <div id='field-9-14'/></div> - <div id='field-10-0'/></div> - <div id='field-10-1'/></div> - <div id='field-10-2'/></div> - <div id='field-10-3'/></div> - <div id='field-10-4'/></div> - <div id='field-10-5'/></div> - <div id='field-10-6'/></div> - <div id='field-10-7'/></div> - <div id='field-10-8'/></div> - <div id='field-10-9'/></div> - <div id='field-10-10'/></div> - <div id='field-10-11'/></div> - <div id='field-10-12'/></div> - <div id='field-10-13'/></div> - <div id='field-10-14'/></div> - <div id='field-11-0'/></div> - <div id='field-11-1'/></div> - <div id='field-11-2'/></div> - <div id='field-11-3'/></div> - <div id='field-11-4'/></div> - <div id='field-11-5'/></div> - <div id='field-11-6'/></div> - <div id='field-11-7'/></div> - <div id='field-11-8'/></div> - <div id='field-11-9'/></div> - <div id='field-11-10'/></div> - <div id='field-11-11'/></div> - <div id='field-11-12'/></div> - <div id='field-11-13'/></div> - <div id='field-11-14'/></div> - <div id='field-12-0'/></div> - <div id='field-12-1'/></div> - <div id='field-12-2'/></div> - <div id='field-12-3'/></div> - <div id='field-12-4'/></div> - <div id='field-12-5'/></div> - <div id='field-12-6'/></div> - <div id='field-12-7'/></div> - <div id='field-12-8'/></div> - <div id='field-12-9'/></div> - <div id='field-12-10'/></div> - <div id='field-12-11'/></div> - <div id='field-12-12'/></div> - <div id='field-12-13'/></div> - <div id='field-12-14'/></div> - <div id='field-13-0'/></div> - <div id='field-13-1'/></div> - <div id='field-13-2'/></div> - <div id='field-13-3'/></div> - <div id='field-13-4'/></div> - <div id='field-13-5'/></div> - <div id='field-13-6'/></div> - <div id='field-13-7'/></div> - <div id='field-13-8'/></div> - <div id='field-13-9'/></div> - <div id='field-13-10'/></div> - <div id='field-13-11'/></div> - <div id='field-13-12'/></div> - <div id='field-13-13'/></div> - <div id='field-13-14'/></div> - <div id='field-14-0'/></div> - <div id='field-14-1'/></div> - <div id='field-14-2'/></div> - <div id='field-14-3'/></div> - <div id='field-14-4'/></div> - <div id='field-14-5'/></div> - <div id='field-14-6'/></div> - <div id='field-14-7'/></div> - <div id='field-14-8'/></div> - <div id='field-14-9'/></div> - <div id='field-14-10'/></div> - <div id='field-14-11'/></div> - <div id='field-14-12'/></div> - <div id='field-14-13'/></div> - <div id='field-14-14'/></div> - </div> - </body> -</html> \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/de/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-09 05:52:40 UTC (rev 2233) @@ -1,27 +0,0 @@ -// -*- Java -*- (really Javascript) - -function setLetter(x, y, letter) { - $('field-' + x + '-' + y).innerHTML = '<img src="' + letter + '.png"/>'; -} - -function setWord(x, y, word, down) { - for (i = 0; i < word.length; i++) { - setLetter(x, y, word.charAt(i)); - if (down) { - y++; - } else { - x++; - } - }; -} - -function init() { - var gameState = {"language":"de","board":[[7,7,"E",1],[7,8,"I",1],[7,9,"M",3],],"tileBag":{"remainingTiles":88,},"participants":[{"player":{"login":"user1","flags":null,"email":null,"fullName":"User Eins","lastLogin":0,"password":"$1$GNNXDZNW$hrPGuT8YOoGzJ6IXoUZGo1","preferences":{},"subscriptions":null,"games":null,},"tray":[{"char":"I","value":1,},{"char":"N","value":1,},{"char":"H","value":2,},{"char":"S","value":1,},{"char":"S","value":1,},{"char":"G","value":2,},{"char":"I","value":1,}],},{"player":{"login":"user2","flags":null,"email":null,"fullName":"User Zwei","lastLogin":0,"password":"$1$NSOVKSSC$enFJIydIQa.X77ATDtBNU1","preferences":{},"subscriptions":null,"games":null,},"tray":[{"char":"T","value":1,},{"char":"F","value":4,},{"char":"A","value":1,},{"char":"J","value":6,},{"char":"E","value":1,},{"char":"H","value":2,},{"char":"E","value":1,}],}],}; - - for (var i = 0; i < gameState.board.length; i++) { - var x = gameState.board[i][0]; - var y = gameState.board[i][1]; - var char = gameState.board[i][2]; - setLetter(x, y, char); - } -} Deleted: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-09 05:52:40 UTC (rev 2233) @@ -1 +0,0 @@ -link ../de/scrabble.css \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-09 05:52:40 UTC (rev 2233) @@ -1 +0,0 @@ -link ../de/scrabble.html \ No newline at end of file Deleted: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-08 04:39:27 UTC (rev 2232) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-09 05:52:40 UTC (rev 2233) @@ -1 +0,0 @@ -link ../de/scrabble.js \ No newline at end of file Copied: branches/trunk-reorg/projects/scrabble/website/scrabble.css (from rev 2221, branches/trunk-reorg/projects/scrabble/website/de/scrabble.css) Copied: branches/trunk-reorg/projects/scrabble/website/scrabble.html (from rev 2213, branches/trunk-reorg/projects/scrabble/website/de/scrabble.html) Copied: branches/trunk-reorg/projects/scrabble/website/scrabble.js (from rev 2231, branches/trunk-reorg/projects/scrabble/website/de/scrabble.js) =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-10-09 05:52:40 UTC (rev 2233) @@ -0,0 +1,32 @@ +// -*- Java -*- (really Javascript) + +function setLetter(x, y, letter) { + $('field-' + x + '-' + y).innerHTML = '<img src="' + letter + '.png"/>'; +} + +function setWord(x, y, word, down) { + for (i = 0; i < word.length; i++) { + setLetter(x, y, word.charAt(i)); + if (down) { + y++; + } else { + x++; + } + }; +} + +function init() { + var d = loadJSONDoc("/game/108"); + d.addCallbacks( + function (gameState) { + for (var i = 0; i < gameState.board.length; i++) { + var x = gameState.board[i][0]; + var y = gameState.board[i][1]; + var char = gameState.board[i][2]; + setLetter(x, y, char); + } + }, + function (error) { + alert(error); + }); +}

1 0

[bknr-cvs] r2232 - in branches/trunk-reorg/thirdparty: . cl-who-0.11.0 cl-who-0.11.0/doc
by bknr＠bknr.net 08 Oct '07

08 Oct '07

Author: hhubner Date: 2007-10-08 00:39:27 -0400 (Mon, 08 Oct 2007) New Revision: 2232 Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/ branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/ branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp Removed: branches/trunk-reorg/thirdparty/cl-who-0.10.0/ Log: update cl-who Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,91 @@ +Version 0.11.0 +2007-08-24 +Replaces *DOWNCASE-TAGS-P* with *DOWNCASE-TOKENS-P* (thanks to Osei Poku) + +Version 0.10.0 +2007-07-25 +Added ESCAPE-CHAR-... functions (based on a patch by Volkan Yazici) + +Version 0.9.1 +2007-05-28 +Fixed bug in CONVERT-TAG-TO-STRING-LIST (thanks to Simon Cusack) + +Version 0.9.0 +2007-05-08 +Changed behaviour of STR and ESC when "argument" is NIL (patch by Mac Chan) + +Version 0.8.1 +2007-04-27 +Removed antiquated installation instructions and files (thanks to a hint by Mac Chan) + +Version 0.8.0 +2007-04-27 +Added *HTML-EMPTY-TAG-AWARE-P* (patch by Mac Chan) +A bit of refactoring + +Version 0.7.1 +2007-04-05 +Made *HTML-MODE* a compile-time flag (patch by Mac Chan) + +Version 0.7.0 +2007-03-23 +Added *DOWNCASE-TAGS-P* (patch by Mac Chan) + +Version 0.6.3 +2006-12-22 +Fixed example for CONVERT-TAG-TO-STRING-LIST (thanks to Daniel Gackle) + +Version 0.6.2 +2006-10-10 +Reintroduced ESCAPE-STRING-ISO-8859-1 for backwards compatibility + +Version 0.6.1 +2006-07-27 +EVAL CONSTANTP forms in attribute position (caught by Erik Enge) +Added WHO nickname to CL-WHO package + +Version 0.6.0 +2005-08-02 +Introduced *ATTRIBUTE-QUOTE-CHAR* and HTML-MODE and adapted code accordingly (patch by Stefan Scholl) + +Version 0.5.0 +2005-03-01 +Enable customization via CONVERT-TAG-TO-STRING-LIST + +Version 0.4.4 +2005-01-22 +Explicitely provide elementy type for +SPACES+ to prevent problems with LW (thanks to Bob Hutchinson) + +Version 0.4.3 +2004-09-13 +ESCAPE-STRING-ISO-8859 wasn't exported + +Version 0.4.2 +2004-09-08 +Fixed bug in docs (caught by Peter Seibel) +Added hyperdoc support + +Version 0.4.1 +2004-04-15 +Added :CL-WHO to *FEATURES* (for TBNL) + +Version 0.4.0 +2003-12-03 +Allow for optional LHTML syntax (patch by Kevin Rosenberg) + +Version 0.3.0 +2003-08-02 +Changed behaviour of attributes (incompatible with 0.2.0 syntax!) due to a question by J�rg-Cyril H�hle +Changed ' back to ' because of IE + +Version 0.2.0 +2003-07-27 +Changed default for :PROLOGUE (I was convinced by Rob Warnock and Eduardo Mu�oz) + +Version 0.1.1 +2003-07-20 +Typo in WITH-OUTPUT-TO-STRING + +Version 0.1.0 +2003-07-17 +Initial release Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,35 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/cl-who.asd,v 1.18 2007/08/24 08:01:37 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(asdf:defsystem :cl-who + :version "0.11.0" + :serial t + :components ((:file "packages") + (:file "specials") + (:file "who"))) Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,807 @@ +<!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-WHO - Yet another Lisp markup language</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + a { text-decoration: none; padding: 1px 2px 1px 2px; } + a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } + a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> +</head> + +<body bgcolor=white> + +<h2>CL-WHO - Yet another Lisp markup language</h2> + +<blockquote> +<br> <br><h3><a name=abstract class=none>Abstract</a></h3> + +There are plenty of <a +href="http://www.cliki.net/Lisp%20Markup%20Languages">Lisp Markup +Languages</a> out there - every Lisp programmer seems to write at +least one during his career - and CL-WHO (where <em>WHO</em> means +"with-html-output" for want of a better acronym) is probably +just as good or bad as the next one. They are all more or less similar +in that they provide convenient means to convert S-expressions +intermingled with code into (X)HTML, XML, or whatever but differ with +respect to syntax, implementation, and API. So, if you haven't made a +choice yet, check out the alternatives as well before you begin to use +CL-WHO just because it was the first one you came across. (Was that +repelling enough?) If you're looking for a slightly different approach +you might also want to look at <a +href="http://weitz.de/html-template/">HTML-TEMPLATE</a>. +<p> +I wrote this one in 2002 although at least Tim Bradshaw's <a +href="http://www.cliki.net/htout">htout</a> and <a +href="http://opensource.franz.com/aserve/aserve-dist/doc/htmlgen.html">AllegroServe's +HTML generation facilities</a> by John Foderaro of Franz Inc. where +readily available. Actually, I don't remember why I had to write my +own library - maybe just because it was fun and didn't take very long. The +syntax was obviously inspired by htout although it is slightly +different. +<p> +CL-WHO tries to create efficient code in that it makes constant +strings as long as possible. In other words, the code generated by the +CL-WHO macros will usually be a sequence of <code>WRITE-STRING</code> +forms for constant parts of the output interspersed with arbitrary +code inserted by the user of the macro. CL-WHO will make sure that +there aren't two adjacent <code>WRITE-STRING</code> forms with +constant strings - see +examples <a href="#show-html-expansion">below</a>. CL-WHO's output is +either XHTML (default) or 'plain' (SGML) HTML — depending on +what you've set <a href="#html-mode"><code>HTML-MODE</code></a> to. +<p> +CL-WHO is intended to be portable and should work with all +conforming Common Lisp implementations. <a +href="#mail">Let us know</a> if you encounter any +problems. +<p> +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. +<p> +CL-WHO is used by <a href="http://clutu.com/">clutu</a>, <a href="http://ergoweb.de/">ERGO</a>, and <a href="http://heikestephan.de/">Heike Stephan</a>. + +<p> +<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-who.tar.gz">http://weitz.de/files/cl-who.tar.gz</a>. +</blockquote> + +<br> <br><h3><a class=none name="contents">Contents</a></h3> +<ol> + <li><a href="#example">Example usage</a> + <li><a href="#install">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#syntax">Syntax and Semantics</a> + <li><a href="#dictionary">The CL-WHO dictionary</a> + <ol> + <li><a href="#with-html-output"><code>with-html-output</code></a> + <li><a href="#with-html-output-to-string"><code>with-html-output-to-string</code></a> + <li><a href="#show-html-expansion"><code>show-html-expansion</code></a> + <li><a href="#*attribute-quote-char*"><code>*attribute-quote-char*</code></a> + <li><a href="#*prologue*"><code>*prologue*</code></a> + <li><a href="#*html-empty-tag-aware-p*"><code>*html-empty-tag-aware-p*</code></a> + <li><a href="#*html-empty-tags*"><code>*html-empty-tags*</code></a> + <li><a href="#*downcase-tokens-p*"><code>*downcase-tokens-p*</code></a> + <li><a href="#esc"><code>esc</code></a> + <li><a href="#fmt"><code>fmt</code></a> + <li><a href="#htm"><code>htm</code></a> + <li><a href="#str"><code>str</code></a> + <li><a href="#html-mode"><code>html-mode</code></a> + <li><a href="#escape-string"><code>escape-string</code></a> + <li><a href="#escape-char"><code>escape-char</code></a> + <li><a href="#*escape-char-p*"><code>*escape-char-p*</code></a> + <li><a href="#escape-string-minimal"><code>escape-string-minimal</code></a> + <li><a href="#escape-string-minimal-plus-quotes"><code>escape-string-minimal-plus-quotes</code></a> + <li><a href="#escape-string-iso-8859"><code>escape-string-iso-8859</code></a> + <li><a href="#escape-string-iso-8859-1"><code>escape-string-iso-8859-1</code></a> + <li><a href="#escape-string-all"><code>escape-string-all</code></a> + <li><a href="#escape-char-minimal"><code>escape-char-minimal</code></a> + <li><a href="#escape-char-minimal-plus-quotes"><code>escape-char-minimal-plus-quotes</code></a> + <li><a href="#escape-char-iso-8859-1"><code>escape-char-iso-8859-1</code></a> + <li><a href="#escape-char-all"><code>escape-char-all</code></a> + <li><a href="#conc"><code>conc</code></a> + <li><a href="#convert-tag-to-string-list"><code>convert-tag-to-string-list</code></a> + <li><a href="#convert-attributes"><code>convert-attributes</code></a> + </ol> + <li><a href="#ack">Acknowledgements</a> +</ol> + +<br> <br><h3><a name="example" class=none>Example usage</a></h3> + +Let's assume that <code>*HTTP-STREAM*</code> is the stream your web +application is supposed to write to. Here are some contrived code snippets +together with the Lisp code generated by CL-WHO and the resulting HTML output. + +<table border=0 cellspacing=10 width="100%"> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*http-stream*) + (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa") + ("http://marcusmiller.com/" . "Marcus Miller") + ("http://www.milesdavis.com/" . "Miles Davis")) + do (<a class=noborder href="#htm">htm</a> (:a :href link + (:b (str title))) + :br))) +</pre></td> + +<td valign=top rowspan=2> +<a href='http://zappa.com/'><b>Frank Zappa</b></a><br /><a href='http://marcusmiller.com/'><b>Marcus Miller</b></a><br /><a href='http://www.milesdavis.com/'><b>Miles Davis</b></a><br /> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(let ((*http-stream* *http-stream*)) + (progn + nil + (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa") + ("http://marcusmiller.com/" . "Marcus Miller") + ("http://www.milesdavis.com/" . "Miles Davis")) + do (progn + (write-string "<a href='" *http-stream*) + (princ link *http-stream*) + (write-string "'><b>" *http-stream*) + (princ title *http-stream*) + (write-string "</b></a><br />" *http-stream*))))) +</pre></td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*http-stream*) + (:table :border 0 :cellpadding 4 + (loop for i below 25 by 5 + do (<a class=noborder href="#htm">htm</a> + (:tr :align "right" + (loop for j from i below (+ i 5) + do (<a class=noborder href="#htm">htm</a> + (:td :bgcolor (if (oddp j) + "pink" + "green") + (fmt "~@R" (1+ j)))))))))) +</pre></td> + +<td valign=top rowspan=2> +<table border='0' cellpadding='4'><tr align='right'><td bgcolor='green'>I</td><td bgcolor='pink'>II</td><td bgcolor='green'>III</td><td bgcolor='pink'>IV</td><td bgcolor='green'>V</td></tr><tr align='right'><td bgcolor='pink'>VI</td><td bgcolor='green'>VII</td><td bgcolor='pink'>VIII</td><td bgcolor='green'>IX</td><td bgcolor='pink'>X</td></tr><tr align='right'><td bgcolor='green'>XI</td><td bgcolor='pink'>XII</td><td bgcolor='green'>XIII</td><td bgcolor='pink'>XIV</td><td bgcolor='green'>XV</td></tr><tr align='right'><td bgcolor='pink'>XVI</td><td bgcolor='green'>XVII</td><td bgcolor='pink'>XVIII</td><td bgcolor='green'>XIX</td><td bgcolor='pink'>XX</td></tr><tr align='right'><td bgcolor='green'>XXI</td><td bgcolor='pink'>XXII</td><td bgcolor='green'>XXIII</td><td bgcolor='pink'>XXIV</td><td bgcolor='green'>XXV</td></tr></table> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(let ((*http-stream* *http-stream*)) + (progn + nil + (write-string "<table border='0' cellpadding='4'>" *http-stream*) + (loop for i below 25 by 5 + do (progn + (write-string "<tr align='right'>" *http-stream*) + (loop for j from i below (+ i 5) + do (progn + (write-string "<td bgcolor='" *http-stream*) + (princ (if (oddp j) "pink" "green") *http-stream*) + (write-string "'>" *http-stream*) + (format *http-stream* "~@r" (1+ j)) + (write-string "</td>" *http-stream*))) + (write-string "</tr>" *http-stream*))) + (write-string "</table>" *http-stream*))) +</pre></td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*http-stream*) + (:h4 "Look at the character entities generated by this example") + (loop for i from 0 + for string in '("F�te" "S�rensen" "na�ve" "H�hner" "Stra�e") + do (<a class=noborder href="#htm">htm</a> + (:p :style (<a href="#conc">conc</a> "background-color:" (case (mod i 3) + ((0) "red") + ((1) "orange") + ((2) "blue"))) + (<a class=noborder href="#htm">htm</a> (<a href="#esc">esc</a> string)))))) +</pre></td> +<td valign=top rowspan=2> +<h4>Look at the character entities generated by this example</h4><p style='background-color:red'>Fête</p><p style='background-color:orange'>Sørensen</p><p style='background-color:blue'>naïve</p><p style='background-color:red'>Hühner</p><p style='background-color:orange'>Straße</p> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(let ((*http-stream* *http-stream*)) + (progn + nil + (write-string + "<h4>Look at the character entities generated by this example</h4>" + *http-stream*) + (loop for i from 0 for string in '("F�te" "S�rensen" "na�ve" "H�hner" "Stra�e") + do (progn + (write-string "<p style='" *http-stream*) + (princ (<a class=noborder href="#conc">conc</a> "background-color:" + (case (mod i 3) + ((0) "red") + ((1) "orange") + ((2) "blue"))) + *http-stream*) + (write-string "'>" *http-stream*) + (progn (write-string (<a class=noborder href="#escape-string">escape-string</a> string) *http-stream*)) + (write-string "</p>" *http-stream*))))) +</pre></td> +</tr> + + +</table> + +<br> <br><h3><a name="install" class=none>Download and installation</a></h3> + +CL-WHO together with this documentation can be downloaded from <a +href="http://weitz.de/files/cl-who.tar.gz">http://weitz.de/files/cl-who.tar.gz</a>. The +current version is 0.11.0. +<p> +The preferred method to compile and load Hunchentoot is via <a href="http://www.cliki.net/asdf">ASDF</a>. +<p> +If you're on <a href="http://www.debian.org/">Debian</a> you can +probably use +the <a +href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-who&s…">cl-who +Debian package</a> which is available thanks to Kevin +Rosenberg. There's also a port +for <a +href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo +Linux</a> thanks to Matthew Kennedy. In both cases, check if they have the newest version available. +<p> +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of CL-WHO +at <a +href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. + +<br> <br><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-who-devel">cl-who-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-who-announce">cl-who-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>. +<p> +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + +<br> <br><h3><a name="syntax" class=none>Syntax and Semantics</a></h3> + +CL-WHO is essentially just one <a +href="http://cl-cookbook.sourceforge.net/macros.html">macro</a>, <a +href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a>, which +transforms the body of code it encloses into something else obeying the +following rules (which we'll call <em>transformation rules</em>) for the body's forms: + +<ul> + + <li>A string will be printed verbatim. To be +more precise, it is transformed into a form which'll print this +string to the stream the user provides. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>"foo" <font color="red">=></font> (write-string "foo" s)</pre></td></tr></table> + + (Here and for the rest of this document the <em>red arrow</em> means '... will be converted to code equivalent to ...' where <em>equivalent</em> means that all output is sent to the "right" stream.) + + <li>Each list beginning with a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/t_kwd.htm"><em>keyword</em></a> +is transformed into an (X)HTML <b>tag</b> of the same (usually <href="#*downcase-tokens-p*">downcased</a>) name by the following rules: + + <ul> + + <li>If the list contains nothing but the keyword, the resulting tag + will be empty. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:br) <font color="red">=></font> (write-string "<br />" s)</pre></td></tr></table> + With <a href="#html-mode"><code>HTML-MODE</code></a> set to <code>:SGML</code> an empty element is written this way: + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:br) <font color="red">=></font> (write-string "<br>" s)</pre></td></tr></table> + + <li>The initial keyword can be followed by another keyword which will be interpreted as the name of an <b>attribute</b>. The next form which will be taken as the attribute's <b>value</b>. (If there's no next form it'll be as if the next form had been <code>NIL</code>.) The form denoting the attribute's value will be treated as follows. (Note that the behaviour with respect to attributes is <em>incompatible</em> with versions earlier than 0.3.0!) + <ul> + <li>If it is a string it will be printed literally. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :bgcolor "red") <font color="red">=></font> (write-string "<td bgcolor='red' />" s)</pre></td></tr></table> + + <li>If it is <code>T</code> and <a href="#html-mode"><code>HTML-MODE</code></a> is <code>:XML</code> (default) the attribute's value will be the attribute's name (following XHTML convention to denote attributes which don't have a value in HTML). + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap t) <font color="red">=></font> (write-string "<td nowrap='nowrap' />" s)</pre></td></tr></table> + + With <a href="#html-mode"><code>HTML-MODE</code></a> set to <code>:SGML</code>: + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap t) <font color="red">=></font> (write-string "<td nowrap>" s)</pre></td></tr></table> + + <li>If it is <code>NIL</code> the attribute will be left out completely. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap nil) <font color="red">=></font> (write-string "<td />" s)</pre></td></tr></table> + + <li>If it is a <a + href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#constant_form"><em>constant form</em></a>, the result of evaluating it will be inserted into the resulting string as if printed with the <a + href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#constant_form">format string</a> <code>"~A"</code> at macro expansion time. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:table :border 3) <font color="red">=></font> (write-string "<table border='3' />" s)</pre></td></tr></table> + + <li>If it is any other form it will be left as is and later evaluated at run time and printed with <a + href="http://www.lispworks.com/reference/HyperSpec/Body/f_wr_pr.htm"><code>PRINC</code></a> <em>unless</em> the value is <code>T</code> or <code>NIL</code> which will be treated as above. (It is the application developer's job to provide the correct <a href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_p.htm#printer_cont…">printer control variables</a>.) + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre><font color="orange">;; simplified example, see function CHECKBOX below +;; note that this form is not necessarily CONSTANTP in all Lisps</font> + +(:table :border (+ 1 2)) <font color="red">=></font> (write-string "<table border='" s) + (princ (+ 1 2) s) + (write-string "' />" s)</pre></td></tr></table> + </ul> + + <li>Once an attribute/value pair has been worked up another one can follow, i.e. if the form following an attribute's value is again a keyword it will again be treated as an attribute and so on. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:table :border 0 :cellpadding 5 :cellspacing 5) + <font color="red">=></font> (write-string "<table border='0' cellpadding='5' cellspacing='5' />" s)</pre></td></tr></table> + + <li>The first form following either the tag's name itself or an attribute value which is <em>not</em> a keyword determines the beginning of the tag's <b>content</b>. This and all the following forms are subject to the transformation rules we're just describing. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:p "Paragraph") <font color="red">=></font> (write-string "<p>Paragraph</p>" s) +(:p :class "foo" "Paragraph") <font color="red">=></font> (write-string "<p class='foo'>Paragraph</p>" s) +(:p :class "foo" "One" " " "long" " " "sentence") <font color="red">=></font> (write-string "<p class='foo'>One long sentence</p>" s) +(:p :class "foo" "Visit " (:a :href "http://www.cliki.net/" "CLiki")) + <font color="red">=></font> (write-string "<p class='foo'>Visit <a href='http://www.cliki.net/'>CLiki</a></p>" s)</pre></td></tr></table> + + <li>Beginning with <a href="#install">version 0.4.0</a> you can also use a syntax like that of <a href="http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm">LHTML</a> where the tag and all attribute/value pairs are enclosed in an additional list: + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>((:p) "Paragraph") <font color="red">=></font> (write-string "<p>Paragraph</p>" s) +((:p :class "foo") "Paragraph") <font color="red">=></font> (write-string "<p class='foo'>Paragraph</p>" s) +((:p :class "foo" :name "humpty-dumpty") "One" " " "long" " " "sentence") + <font color="red">=></font> (write-string "<p class='foo' name='humpty-dumpty'>One long sentence</p>" s) +((:p :class "foo") "Visit " ((:a :href "http://www.cliki.net/") "CLiki")) + <font color="red">=></font> (write-string "<p class='foo'>Visit <a href='http://www.cliki.net/'>CLiki</a></p>" s)</pre></td></tr></table> + + </ul> + + Here's a slightly more elaborate example: +<pre> +* (defun checkbox (stream name checked &optional value) + (with-html-output (stream) + (:input :type "checkbox" :name name :checked checked :value value))) + +CHECKBOX +* (with-output-to-string (s) (checkbox s "foo" t)) + +"<input type='checkbox' name='foo' checked='checked' />" +* (with-output-to-string (s) (checkbox s "foo" nil)) + +"<input type='checkbox' name='foo' />" +* (with-output-to-string (s) (checkbox s "foo" nil "bar")) + +"<input type='checkbox' name='foo' value='bar' />" +* (with-output-to-string (s) (checkbox s "foo" t "bar")) + +"<input type='checkbox' name='foo' checked='checked' value='bar' />" +</pre> + + <li>A keyword alone will be treated like a list containing only this keyword. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>:hr <font color="red">=></font> (write-string "<hr />" s)</pre></td></tr></table> + + <li>A form which is neither a string nor a keyword nor a list beginning with a keyword will be left as is except for the following <em>substitutions</em>: + <ul> + <li>Forms that look like <code>(<b>str</b> <i>form1</i> <i>form*</i>)</code> will be substituted with + <span style="white-space: nowrap"><code>(let ((result <i>form1</i>)) (when result (princ result s)))</code></span>. <br> + (Note that all forms behind <code><i>form1</i></code> are ignored.) + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 10 do (str i)) <font color="red">=></font> +(loop for i below 10 do + (let ((#:result i)) + (when #:result (princ #:result *standard-output*))))</pre></td></tr></table> + + <li>Forms that look like <code>(<b>fmt</b> <i>form*</i>)</code> will be substituted with <code>(format s <i>form*</i>)</code>. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 10 do (fmt "~R" i)) <font color="red">=></font> (loop for i below 10 do (format s "~R" i))</pre></td></tr></table> + <li>Forms that look like <code>(<b>esc</b> <i>form1</i> <i>form*</i>)</code> will be substituted with + <span style="white-space: nowrap"><code>(let ((result <i>form1</i>)) (when result (write-string (<a href="#escape-string">escape-string</a> result s))))</code></span>. + + <li>If a form looks like <code>(<b>htm</b> <i>form*</i>)</code> then each of the <code><i>forms</i></code> will be subject to the transformation rules we're just describing. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 100 do (htm (:b "foo") :br)) + <font color="red">=></font> (loop for i below 100 do (progn (write-string "<b>foo</b><br />" s)))</pre></td></tr></table> + + + </ul> + + <li>That's all. Note in particular that CL-WHO knows <em>nothing</em> about HTML or XHTML, i.e. it doesn't check whether you mis-spelled tag names or use attributes which aren't allowed. CL-WHO doesn't care if you use, say, <code>:foobar</code> instead of <code>:hr</code>. +</ul> + +<br> <br><h3><a class=none name="dictionary">The CL-WHO dictionary</a></h3> + +CL-WHO exports the following symbols: + +<p><br>[Macro] +<br><a class=none name="with-html-output"><b>with-html-output</b> <i>(var <tt>&optional</tt> stream <tt>&key</tt> prologue indent) declaration* form*</i> => <i>result*</i></a> + +<blockquote><br> +This is the main macro of CL-WHO. It will transform its body by the transformation rules described in <a href="#syntax"><em>Syntax and Semantics</em></a> such that the output generated is sent to the stream denoted by <code><i>var</i></code> and <code><i>stream</i></code>. <code><i>var</i></code> must be a symbol. If <code><i>stream</i></code> is <code>NIL</code> it is assumed that <code><i>var</i></code> is already bound to a stream, if <code><i>stream</i></code> is not <code>NIL</code> <code><i>var</i></code> will be bound to the form <code><i>stream</i></code> which will be evaluated at run time. <code><i>prologue</i></code> should be a string (or <code>NIL</code> for the empty string which is the default) which is guaranteed to be the first thing sent to the stream from within the body of this macro. If <code><i>prologue</i></code> is <code>T</code> the prologue string is the value of <a href="#*prologue*"><code>*PROLOGUE*</code></a>. CL-WHO will usually try not to insert any unnecessary whitespace in order to save bandwidth. However, if <code><i>indent</i></code> is <em>true</em> line breaks will be inserted and nested tags will be intended properly. The value of <code><i>indent</i></code> - if it is an integer - will be taken as the initial indentation. If it is not an integer it is assumed to mean <code>0</code>. The <code><i>results</i></code> are the values returned by the <code><i>forms</i></code>. +<p> +Note that the keyword arguments <code><i>prologue</i></code> and <code><i>indent</i></code> are used at macro expansion time. + +<pre> +* (with-html-output (*standard-output* nil :prologue t) + (:html (:body "Not much there")) + (values)) +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"><html><body>Not much there</body></html> +* (with-html-output (*standard-output*) + (:html (:body :bgcolor "white" + "Not much there")) + (values)) +<html><body bgcolor='white'>Not much there</body></html> +* (with-html-output (*standard-output* nil :prologue t :indent t) + (:html (:body :bgcolor "white" + "Not much there")) + (values)) +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html> + <body bgcolor='white'> + Not much there + </body> +</html> +</pre> +</blockquote> + +<p><br>[Macro] +<br><a class=none name="with-html-output-to-string"><b>with-html-output-to-string</b> <i>(var <tt>&optional</tt> string-form <tt>&key</tt> element-type prologue indent) declaration* form*</i> => <i>result*</i></a> + +<blockquote><br> +This is just a thin wrapper around <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a>. Indeed, the wrapper is so thin that the best explanation probably is to show its definition: +<pre> +(defmacro with-html-output-to-string ((var &optional string-form + &key (element-type 'character) + prologue + indent) + &body body) + "Transform the enclosed BODY consisting of HTML as s-expressions +into Lisp code which creates the corresponding HTML as a string." + `(with-output-to-string (,var ,string-form :elementy-type ,element-type) + (with-html-output (,var nil :prologue ,prologue :indent ,indent) + ,@body))) +</pre> +Note that the <code><i>results</i></code> of this macro are determined by the behaviour of <a href="http://www.lispworks.com/reference/HyperSpec/Body/m_w_out_.htm"><code>WITH-OUTPUT-TO-STRING</code></a>. +</blockquote> + +<p><br>[Macro] +<br><a class=none name="show-html-expansion"><b>show-html-expansion</b> <i>(var <tt>&optional</tt> stream <tt>&key</tt> prologue indent) declaration* form*</i> => <tt><no values></tt></a> + +<blockquote><br> +This macro is intended for debugging purposes. It'll print to <code>*STANDARD-OUTPUT*</code> the code which would have been generated by <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a> had it been invoked with the same arguments. + +<pre> +* (show-html-expansion (s) + (:html + (:body :bgcolor "white" + (:table + (:tr + (dotimes (i 5) + (htm (:td :align "left" + (str i))))))))) +(LET ((S S)) + (PROGN + (WRITE-STRING + "<html><body bgcolor='white'><table><tr>" S) + (DOTIMES (I 5) + (PROGN + (WRITE-STRING "<td align='left'>" S) + (PRINC I S) + (WRITE-STRING "</td>" S))) + (WRITE-STRING "</tr></table></body></html>" S))) +</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*attribute-quote-char*"><b>*attribute-quote-char*</b></a> + +<blockquote><br> +This character is used as the quote character when building attributes. Defaults to the single quote <code>#\'</code>. Only other reasonable character is the double quote <code>#\"</code>. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*prologue*"><b>*prologue*</b></a> + +<blockquote><br> +This is the prologue string which will be printed if the <code><i>prologue</i></code> keyword argument to <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a> is <code>T</code>. Gets changed when you set <a href="#html-mode"><code>HTML-MODE</code></a>. Its initial value is + +<pre>"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*html-empty-tag-aware-p*"><b>*html-empty-tag-aware-p*</b></a> + +<blockquote><br> +Set this to <code>NIL</code> to if you want to use CL-WHO as a strict XML +generator. Otherwise, CL-WHO will only write empty tags listed in +<a href="#*html-empty-tags*"><code>*HTML-EMPTY-TAGS*</code></a> as <code><tag/></code> (XHTML mode) or <code><tag></code> (SGML mode). For +all other tags, it will always generate <code><tag></tag></code>. The initial value of this variable is <code>T</code>. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*html-empty-tags*"><b>*html-empty-tags*</b></a> + +<blockquote><br> +The list of HTML tags that should be output as empty tags. See +<a href="#*html-empty-tag-aware-p*"><code>*HTML-EMPTY-TAG-AWARE-P*</code></a>. +The initial value is the list +<pre> +(:area :atop :audioscope :base :basefont :br :choose :col :frame + :hr :img :input :isindex :keygen :left :limittext :link :meta + :nextid :of :over :param :range :right :spacer :spot :tab :wbr) +</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*downcase-tokens-p*"><b>*downcase-tokens-p*</b></a> + +<blockquote><br> +If the value of this variable is <code>NIL</code>, keyword symbols representing a tag or attribute name will not be +automatically converted to lowercase. This is useful when one needs to +output case sensitive XML. The default is <code>T</code>. +</blockquote> + +<p><br>[Symbol] +<br><a class=none name="esc"><b>esc</b></a> +<br>[Symbol] +<br><a class=none name="fmt"><b>fmt</b></a> +<br>[Symbol] +<br><a class=none name="htm"><b>htm</b></a> +<br>[Symbol] +<br><a class=none name="str"><b>str</b></a> + +<blockquote><br> +These are just symbols with no bindings associated with them. The only reason they are exported is their special meaning during the transformations described in <a href="#syntax"><em>Syntax and Semantics</em></a>. +</blockquote> + +<p><br>[Accessor] +<br><a class=none name="html-mode"><b>html-mode</b></a> <i>=> mode</i> +<br><tt>(setf (</tt><b>html-mode</b>) <i>mode</i><tt>)</tt> +<blockquote><br> +The function <code>HTML-MODE</code> returns the current mode for generating HTML. The default is <code>:XML</code> for XHTML. You can change this by setting it with <code>(SETF (HTML-MODE) :SGML)</code> to pre-XML HTML mode. +<p> +Setting it to SGML HTML sets the <a href="#*prologue*"><code>*prologue*</code></a> to the doctype string for HTML 4.01 transitional: +<pre><!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"></pre> +Code generation in SGML HTML is slightly different from XHTML - there's no need to end empty elements with <code>/></code> and empty attributes are allowed. +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-string"><b>escape-string</b></a> <i>string <tt>&key</tt> test</i> => <i>escaped-string</i> + +<blockquote><br> +This function will accept a string <code><i>string</i></code> and will replace every character for which <code><i>test</i></code> returns <em>true</em> with its character entity. The numeric character entities use decimal instead of hexadecimal values when <a href="#html-mode"><code>HTML-MODE</code></a> is set to <code>:SGML</code> because of compatibility reasons with old clients. <code><i>test</i></code> must be a function of one argument which accepts a character and returns a <a href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_g.htm#generalized_…">generalized boolean</a>. The default is the value of <a href="#*escape-char-p*"><code>*ESCAPE-CHAR-P*</code></a>. Note the <a href="#esc"><code>ESC</code></a> shortcut described in <a href="#syntax"><em>Syntax and Semantics</em></a>. + +<pre> +* (escape-string "<H�hner> 'na�ve'") +"&lt;H&#xFC;hner&gt; &#x27;na&#xEF;ve&#x27;" +* (with-html-output-to-string (s) + (:b (esc "<H�hner> 'na�ve'"))) +"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"<b>&lt;H&#xFC;hner&gt; &#x27;na&#xEF;ve&#x27;</b>" +</pre> +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-char"><b>escape-char</b></a> <i>character <tt>&key</tt> test</i> => <i>escaped-string</i> + +<blockquote><br> +This function works identical to <a href="#escape-string"><code>ESCAPE-STRING</code></a>, except that it operates on characters instead of strings. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*escape-char-p*"><b>*escape-char-p*</b></a> + +<blockquote><br> +This is the default for the <code><i>test</i></code> keyword argument to <a href="#escape-string"><code>ESCAPE-STRING</code></a> and <a href="#escape-char"><code>ESCAPE-CHAR</code></a>. Its initial value is + +<pre> +#'(lambda (char) + (or (find char "<>&'\"") + (> (char-code char) 127))) +</pre> +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-string-minimal"><b>escape-string-minimal</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-minimal-plus-quotes"><b>escape-string-minimal-plus-quotes</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-iso-8859-1"><b>escape-string-iso-8859-1</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-iso-8859"><b>escape-string-iso-8859</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-all"><b>escape-string-all</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-minimal"><b>escape-char-minimal</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-minimal-plus-quotes"><b>escape-char-minimal-plus-quotes</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-iso-8859-1"><b>escape-char-iso-8859-1</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-all"><b>escape-char-all</b> <i>character</i> => <i>escaped-string</i></a> + +<blockquote><br> These are convenience function based +on <a href="#escape-string"><code>ESCAPE-STRING</code></a> +and <a href="#escape-char"><code>ESCAPE-CHAR</code></a>. The string +functions are defined in a way similar to this one: + +<pre> +(defun escape-string-minimal (string) + "Escape only #\<, #\>, and #\& in STRING." + (escape-string string :test #'(lambda (char) (find char "<>&")))) + +(defun escape-string-minimal-plus-quotes (string) + "Like ESCAPE-STRING-MINIMAL but also escapes quotes." + (escape-string string :test #'(lambda (char) (find char "<>&'\"")))) + +(defun escape-string-iso-8859-1 (string) + "Escapes all characters in STRING which aren't defined in ISO-8859-1." + (escape-string string :test #'(lambda (char) + (or (find char "<>&'\"") + (> (char-code char) 255))))) + +(defun escape-string-iso-8859 (string) + "Identical to ESCAPE-STRING-ISO-8859-1. Kept for backward compatibility." + (escape-string-iso-8859-1 string)) + +(defun escape-string-all (string) + "Escapes all characters in STRING which aren't in the 7-bit ASCII +character set." + (escape-string string :test #'(lambda (char) + (or (find char "<>&'\"") + (> (char-code char) 127))))) +</pre> +The character functions are defined in an analogous manner. +</blockquote> + +<p><br>[Function] +<br><a class=none name="conc"><b>conc</b> <i><tt>&rest</tt> string-list</i> => <i>string</i></a> + +<blockquote><br> +Utility function to concatenate all arguments (which should be strings) into one string. Meant to be used mainly with attribute values. + +<pre> +* (conc "This" " " "is" " " "a" " " "sentence") +"This is a sentence" +* (with-html-output-to-string (s) + (:div :style (conc "padding:" + (format nil "~A" (+ 3 2))) + "Foobar")) +"<div style='padding:5'>Foobar</div>" +</pre> +</blockquote> + +<p><br>[Generic Function] +<br><a class=none name="convert-tag-to-string-list"><b>convert-tag-to-string-list</b></a> <i>tag attr-list body body-fn</i> => <i>strings-or-forms</i> + +<blockquote><br> + +This function exposes some of CL-WHO's internals so users can +customize its behaviour. It is called whenever a tag is processed and +must return a corresponding list of strings or Lisp forms. The idea +is that you can specialize this generic function in order to process +certain tags yourself. +<p> +<code><i>tag</i></code> is a keyword symbol naming the outer tag, +<code><i>attr-list</i></code> is an alist of its attributes (the car +is the attribute's name as a keyword, the cdr is its value), +<code><i>body</i></code> is the tag's body, and +<code><i>body-fn</i></code> is a function which should be applied to +the body to further process it. Of course, if you define your own +methods you can ignore <code><i>body-fn</i></code> if you want. +<p> +Here are some simple examples: +<pre> +* (defmethod convert-tag-to-string-list ((tag (eql :red)) attr-list body body-fn) + (declare (ignore attr-list)) + (nconc (cons "<font color='red'>" (funcall body-fn body)) (list "</font>"))) +; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. TAG ATTR-LIST BODY BODY-FN): +; Compiling Top-Level Form: + +#<STANDARD-METHOD CONVERT-TAG-TO-STRING-LIST ((EQL :RED) T T T) {582B268D}> +* (with-html-output (*standard-output*) + (:red (:b "Bold and red")) + (values)) +<font color='red'><b>Bold and red</b></font> +* (show-html-expansion (s) + (:red :style "spiffy" (if (foo) (htm "Attributes are ignored")))) + +(LET ((S S)) + (PROGN + NIL + (WRITE-STRING "<font color='red'>" S) + (IF (FOO) (PROGN (WRITE-STRING "Attributes are ignored" S))) + (WRITE-STRING "</font>" S))) +* (defmethod convert-tag-to-string-list ((tag (eql :table)) attr-list body body-fn) + (cond ((cdr (assoc :simple attr-list)) + (nconc (cons "<table" + (<a class=noborder href="#convert-attributes">convert-attributes</a> (remove :simple attr-list :key #'car))) + (list ">") + (loop for row in body + collect "<tr>" + nconc (loop for col in row + collect "<td>" + when (constantp col) + collect (format nil "~A" col) + else + collect col + collect "</td>") + collect "</tr>") + (list "</table>"))) + (t + <font color=orange>;; you could as well invoke CALL-NEXT-METHOD here, of course</font> + (nconc (cons "<table " + (<a class=noborder href="#convert-attributes">convert-attributes</a> attr-list)) + (list ">") + (funcall body-fn body) + (list "</table>"))))) +; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. TAG ATTR-LIST BODY BODY-FN): +; Compiling Top-Level Form: + +#<STANDARD-METHOD CONVERT-TAG-TO-STRING-LIST ((EQL :TABLE) T T T) {58AFB7CD}> +* (with-html-output (*standard-output*) + (:table :border 0 (:tr (:td "1") (:td "2")) (:tr (:td "3") (:td "4")))) +<table border='0'><tr><td>1</td><td>2</td></tr><tr><td>3</td><td>4</td></tr></table> +"</td></tr></table>" +* (show-html-expansion (s) + (:table :simple t :border 0 + (1 2) (3 (fmt "Result = ~A" (compute-result))))) + +(LET ((S S)) + (PROGN + NIL + (WRITE-STRING + "<table border='0'><tr><td>1</td><td>2</td></tr><tr><td>3</td><td>" + S) + (FORMAT S "Result = ~A" (COMPUTE-RESULT)) + (WRITE-STRING "</td></tr></table>" S))) +</pre> + +</blockquote> + +<p><br>[Function] +<br><a class=none name="convert-attributes"><b>convert-attributes</b></a> <i>attr-list</i> => <i>strings-or-forms</i> + +<blockquote><br> + +This is a helper function which can be called from +<a href="#convert-tag-to-string-list"><code>CONVERT-TAG-TO-STRING-LIST</code></a> to process the list of attributes. + +</blockquote> + +<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3> + +Thanks to Tim Bradshaw and John Foderaro for the inspiration provided +by their libraries mentioned <a href="#abstract">above</a>. Thanks to +Jörg-Cyril Höhle for his suggestions with respect to +attribute values. Thanks to Kevin Rosenberg for the LHTML patch. +Thanks to Stefan Scholl for the 'old school' patch. Thanks to Mac +Chan for several useful additions. + +<p> +$Header: /usr/local/cvsrep/cl-who/doc/index.html,v 1.58 2007/08/24 08:01:40 edi Exp $ +<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,65 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/packages.lisp,v 1.17 2007/08/24 08:01:37 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-who + (:use :cl) + (:nicknames :who) + #+:sbcl (:shadow :defconstant) + (:export :*attribute-quote-char* + :*escape-char-p* + :*prologue* + :*downcase-tokens-p* + :*html-empty-tags* + :*html-empty-tag-aware-p* + :conc + :convert-attributes + :convert-tag-to-string-list + :esc + :escape-char + :escape-char-all + :escape-char-iso-8859-1 + :escape-char-minimal + :escape-char-minimal-plus-quotes + :escape-string + :escape-string-all + :escape-string-iso-8859 + :escape-string-iso-8859-1 + :escape-string-minimal + :escape-string-minimal-plus-quotes + :fmt + :htm + :html-mode + :show-html-expansion + :str + :with-html-output + :with-html-output-to-string)) + +(pushnew :cl-who *features*) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,113 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/specials.lisp,v 1.2 2007/08/24 08:01:37 edi Exp $ + +;;; Copyright (c) 2003-2007, 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-who) + +#+:sbcl +(defmacro defconstant (name value &optional doc) + "Make sure VALUE is evaluated only once \(to appease SBCL)." + `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + +(defvar *prologue* + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" + "This is the first line that'll be printed if the :PROLOGUE keyword +argument is T") + +(defparameter *escape-char-p* + #'(lambda (char) + (or (find char "<>&'\"") + (> (char-code char) 127))) + "Used by ESCAPE-STRING to test whether a character should be escaped.") + +(defparameter *indent* nil + "Whether to insert line breaks and indent. Also controls amount of +indentation dynamically.") + +(defvar *html-mode* :xml + ":SGML for \(SGML-)HTML, :XML \(default) for XHTML.") + +(defvar *downcase-tokens-p* t + "If NIL, a keyword symbol representing a tag or attribute name will +not be automatically converted to lowercase. This is useful when one +needs to output case sensitive XML.") + +(defparameter *attribute-quote-char* #\' + "Quote character for attributes.") + +(defparameter *empty-tag-end* " />" + "End of an empty tag. Default is XML style.") + +(defparameter *html-empty-tags* + '(:area + :atop + :audioscope + :base + :basefont + :br + :choose + :col + :frame + :hr + :img + :input + :isindex + :keygen + :left + :limittext + :link + :meta + :nextid + :of + :over + :param + :range + :right + :spacer + :spot + :tab + :wbr) + "The list of HTML tags that should be output as empty tags. +See *HTML-EMPTY-TAG-AWARE-P*.") + +(defvar *html-empty-tag-aware-p* T + "Set this to NIL to if you want to use CL-WHO as a strict XML +generator. Otherwise, CL-WHO will only write empty tags listed +in *HTML-EMPTY-TAGS* as <tag/> \(XHTML mode) or <tag> \(SGML +mode). For all other tags, it will always generate +<tag></tag>.") + +(defconstant +newline+ (make-string 1 :initial-element #\Newline) + "Used for indentation.") + +(defconstant +spaces+ (make-string 2000 + :initial-element #\Space + :element-type 'base-char) + "Used for indentation.") + Property changes on: branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp ___________________________________________________________________ Name: svn:executable + * Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,499 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.35 2007/08/24 08:01:37 edi Exp $ + +;;; Copyright (c) 2003-2007, 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-who) + +(defmacro n-spaces (n) + "A string with N spaces - used by indentation." + `(make-array ,n + :element-type 'base-char + :displaced-to +spaces+ + :displaced-index-offset 0)) + +(defun html-mode () + "Returns the current HTML mode. :SGML for (SGML-)HTML and +:XML for XHTML." + *html-mode*) + +(defun (setf html-mode) (mode) + "Sets the output mode to XHTML or \(SGML-)HTML. MODE can be +:SGML for HTML or :XML for XHTML." + (ecase mode + ((:sgml) + (setf *html-mode* :sgml + *empty-tag-end* ">" + *prologue* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">")) + ((:xml) + (setf *html-mode* :xml + *empty-tag-end* " />" + *prologue* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")))) + +(declaim (inline escape-char)) +(defun escape-char (char &key (test *escape-char-p*)) + (declare (optimize speed)) + "Returns an escaped version of the character CHAR if CHAR satisfies +the predicate TEST. Always returns a string." + (if (funcall test char) + (case char + (#\< "<") + (#\> ">") + (#\& "&") + (#\' "'") + (#\" """) + (t (format nil (if (eq *html-mode* :xml) "&#x~x;" "&#~d;") + (char-code char)))) + (make-string 1 :initial-element char))) + +(defun escape-string (string &key (test *escape-char-p*)) + (declare (optimize speed)) + "Escape all characters in STRING which pass TEST. This function is +not guaranteed to return a fresh string. Note that you can pass NIL +for STRING which'll just be returned." + (let ((first-pos (position-if test string)) + (format-string (if (eq *html-mode* :xml) "&#x~x;" "&#~d;"))) + (if (not first-pos) + ;; nothing to do, just return STRING + string + (with-output-to-string (s) + (loop with len = (length string) + for old-pos = 0 then (1+ pos) + for pos = first-pos + then (position-if test string :start old-pos) + ;; now the characters from OLD-POS to (excluding) POS + ;; don't have to be escaped while the next character has to + for char = (and pos (char string pos)) + while pos + do (write-sequence string s :start old-pos :end pos) + (case char + ((#\<) + (write-sequence "<" s)) + ((#\>) + (write-sequence ">" s)) + ((#\&) + (write-sequence "&" s)) + ((#\') + (write-sequence "'" s)) + ((#\") + (write-sequence """ s)) + (otherwise + (format s format-string (char-code char)))) + while (< (1+ pos) len) + finally (unless pos + (write-sequence string s :start old-pos))))))) + +(flet ((minimal-escape-char-p (char) (find char "<>&"))) + (defun escape-char-minimal (char) + "Escapes only #\<, #\>, and #\& characters." + (escape-char char :test #'minimal-escape-char-p)) + (defun escape-string-minimal (string) + "Escapes only #\<, #\>, and #\& in STRING." + (escape-string string :test #'minimal-escape-char-p))) + +(flet ((minimal-plus-quotes-escape-char-p (char) (find char "<>&'\""))) + (defun escape-char-minimal-plus-quotes (char) + "Like ESCAPE-CHAR-MINIMAL but also escapes quotes." + (escape-char char :test #'minimal-plus-quotes-escape-char-p)) + (defun escape-string-minimal-plus-quotes (string) + "Like ESCAPE-STRING-MINIMAL but also escapes quotes." + (escape-string string :test #'minimal-plus-quotes-escape-char-p))) + +(flet ((iso-8859-1-escape-char-p (char) + (or (find char "<>&'\"") + (> (char-code char) 255)))) + (defun escape-char-iso-8859-1 (char) + "Escapes characters that aren't defined in ISO-8859-9." + (escape-char char :test #'iso-8859-1-escape-char-p)) + (defun escape-string-iso-8859-1 (string) + "Escapes all characters in STRING which aren't defined in ISO-8859-1." + (escape-string string :test #'iso-8859-1-escape-char-p))) + +(defun escape-string-iso-8859 (string) + "Identical to ESCAPE-STRING-8859-1. Kept for backward compatibility." + (escape-string-iso-8859-1 string)) + +(flet ((non-7bit-ascii-escape-char-p (char) + (or (find char "<>&'\"") + (> (char-code char) 127)))) + (defun escape-char-all (char) + "Escapes characters which aren't in the 7-bit ASCII character set." + (escape-char char :test #'non-7bit-ascii-escape-char-p)) + (defun escape-string-all (string) + "Escapes all characters in STRING which aren't in the 7-bit ASCII +character set." + (escape-string string :test #'non-7bit-ascii-escape-char-p))) + +(defun process-tag (sexp body-fn) + (declare (optimize speed space)) + "Returns a string list corresponding to the `HTML' \(in CL-WHO +syntax) in SEXP. Uses the generic function CONVERT-TO-STRING-LIST +internally. Utility function used by TREE-TO-TEMPLATE." + (let (tag attr-list body) + (cond + ((keywordp sexp) + (setq tag sexp)) + ((atom (first sexp)) + (setq tag (first sexp)) + ;; collect attribute/value pairs into ATTR-LIST and tag body (if + ;; any) into BODY + (loop for rest on (cdr sexp) by #'cddr + if (keywordp (first rest)) + collect (cons (first rest) (second rest)) into attr + else + do (progn (setq attr-list attr) + (setq body rest) + (return)) + finally (setq attr-list attr))) + ((listp (first sexp)) + (setq tag (first (first sexp))) + (loop for rest on (cdr (first sexp)) by #'cddr + if (keywordp (first rest)) + collect (cons (first rest) (second rest)) into attr + finally (setq attr-list attr)) + (setq body (cdr sexp)))) + (convert-tag-to-string-list tag attr-list body body-fn))) + +(defun convert-attributes (attr-list) + "Helper function for CONVERT-TAG-TO-STRING-LIST which converts the +alist ATTR-LIST of attributes into a list of strings and/or Lisp +forms." + (declare (optimize speed space)) + (loop with =var= = (gensym) + with attribute-quote = (string *attribute-quote-char*) + for (orig-attr . val) in attr-list + for attr = (if *downcase-tokens-p* + (string-downcase orig-attr) + (string orig-attr)) + unless (null val) ;; no attribute at all if VAL is NIL + if (constantp val) + if (and (eq *html-mode* :sgml) (eq val t)) ; special case for SGML + nconc (list " " attr) + else + nconc (list " " + ;; name of attribute + attr + (format nil "=~C" *attribute-quote-char*) + ;; value of attribute + (cond ((stringp val) + ;; a string, just use it - this case is + ;; actually not necessary because of + ;; the last case + val) + ((eq val t) + ;; VAL is T, use attribute's name + attr) + (t + ;; constant form, PRINC it - + ;; EVAL is OK here because of CONSTANTP + (format nil "~A" (eval val)))) + attribute-quote) + end + else + ;; do the same things as above but at runtime + nconc (list `(let ((,=var= ,val)) + (cond ((null ,=var=)) + ((eq ,=var= t) + ,(case *html-mode* + (:sgml + `(htm ,(format nil " ~A" attr))) + ;; otherwise default to :xml mode + (t + `(htm ,(format nil " ~A=~C~A~C" + attr + *attribute-quote-char* + attr + *attribute-quote-char*))))) + (t + (htm ,(format nil " ~A=~C" attr *attribute-quote-char*) + (str ,=var=) + ,attribute-quote))))))) + +(defgeneric convert-tag-to-string-list (tag attr-list body body-fn) + (:documentation "Used by PROCESS-TAG to convert `HTML' into a list +of strings. TAG is a keyword symbol naming the outer tag, ATTR-LIST +is an alist of its attributes \(the car is the attribute's name as a +keyword, the cdr is its value), BODY is the tag's body, and BODY-FN is +a function which should be applied to BODY. The function must return +a list of strings or Lisp forms.")) + +(defmethod convert-tag-to-string-list (tag attr-list body body-fn) + "The standard method which is not specialized. The idea is that you +can use EQL specializers on the first argument." + (declare (optimize speed space)) + (let ((tag (if *downcase-tokens-p* (string-downcase tag) (string tag)))) + (nconc + (if *indent* + ;; indent by *INDENT* spaces + (list +newline+ (n-spaces *indent*))) + ;; tag name + (list "<" tag) + ;; attributes + (convert-attributes attr-list) + ;; body + (if body + (append + (list ">") + ;; now hand over the tag's body to TREE-TO-TEMPLATE, increase + ;; *INDENT* by 2 if necessary + (if *indent* + (let ((*indent* (+ 2 *indent*))) + (funcall body-fn body)) + (funcall body-fn body)) + (if *indent* + ;; indentation + (list +newline+ (n-spaces *indent*))) + ;; closing tag + (list "</" tag ">")) + ;; no body, so no closing tag unless defined in *HTML-EMPTY-TAGS* + (if (or (not *html-empty-tag-aware-p*) + (member tag *html-empty-tags* :test #'string-equal)) + (list *empty-tag-end*) + (list ">" "</" tag ">")))))) + +(defun apply-to-tree (function test tree) + (declare (optimize speed space)) + (declare (type function function test)) + "Apply FUNCTION recursively to all elements of the tree TREE \(not +only leaves) which pass TEST." + (cond + ((funcall test tree) + (funcall function tree)) + ((consp tree) + (cons + (apply-to-tree function test (car tree)) + (apply-to-tree function test (cdr tree)))) + (t tree))) + +(defun replace-htm (tree transformation) + (declare (optimize speed space)) + "Replace all subtrees of TREE starting with the symbol HTM with the +same subtree after TRANSFORMATION has been applied to it. Utility +function used by TREE-TO-TEMPLATE and TREE-TO-COMMANDS-AUX." + (apply-to-tree #'(lambda (element) + (cons 'htm (funcall transformation (cdr element)))) + #'(lambda (element) + (and (consp element) + (eq (car element) 'htm))) + tree)) + +(defun tree-to-template (tree) + "Transforms an HTML tree into an intermediate format - mainly a +flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX." + (loop for element in tree + nconc (cond ((or (keywordp element) + (and (listp element) + (keywordp (first element))) + (and (listp element) + (listp (first element)) + (keywordp (first (first element))))) + ;; normal tag + (process-tag element #'tree-to-template)) + ((listp element) + ;; most likely a normal Lisp form - check if we + ;; have nested HTM subtrees + (list + (replace-htm element #'tree-to-template))) + (t + (if *indent* + (list +newline+ (n-spaces *indent*) element) + (list element)))))) + +(defun string-list-to-string (string-list) + (declare (optimize speed space)) + "Concatenates a list of strings to one string." + ;; note that we can't use APPLY with CONCATENATE here because of + ;; CALL-ARGUMENTS-LIMIT + (let ((total-size 0)) + (dolist (string string-list) + (incf total-size (length string))) + (let ((result-string (make-sequence 'simple-string total-size)) + (curr-pos 0)) + (dolist (string string-list) + (replace result-string string :start1 curr-pos) + (incf curr-pos (length string))) + result-string))) + +(defun conc (&rest string-list) + "Concatenates all arguments which should be string into one string." + (funcall #'string-list-to-string string-list)) + +(defun tree-to-commands-aux (tree stream) + (declare (optimize speed space)) + "Transforms the intermediate representation of an HTML tree into +Lisp code to print the HTML to STREAM. Utility function used by +TREE-TO-COMMANDS." + (let ((in-string t) + collector + string-collector) + (flet ((emit-string-collector () + "Generate a WRITE-STRING statement for what is currently +in STRING-COLLECTOR." + (list 'write-string + (string-list-to-string (nreverse string-collector)) + stream)) + (tree-to-commands-aux-internal (tree) + "Same as TREE-TO-COMMANDS-AUX but with closed-over STREAM +for REPLACE-HTM." + (tree-to-commands-aux tree stream))) + (unless (listp tree) + (return-from tree-to-commands-aux tree)) + (loop for element in tree + do (cond ((and in-string (stringp element)) + ;; this element is a string and the last one + ;; also was (or this is the first element) - + ;; collect into STRING-COLLECTOR + (push element string-collector)) + ((stringp element) + ;; the last one wasn't a string so we start + ;; with an empty STRING-COLLECTOR + (setq string-collector (list element) + in-string t)) + (string-collector + ;; not a string but STRING-COLLECTOR isn't + ;; empty so we have to emit the collected + ;; strings first + (push (emit-string-collector) collector) + (setq in-string nil + string-collector '()) + ;; collect this element but walk down the + ;; subtree first + (push (replace-htm element #'tree-to-commands-aux-internal) + collector)) + (t + ;; not a string and empty STRING-COLLECTOR + (push (replace-htm element #'tree-to-commands-aux-internal) + collector))) + finally (return (if string-collector + ;; finally empty STRING-COLLECTOR if + ;; there's something in it + (nreverse (cons (emit-string-collector) + collector)) + (nreverse collector))))))) + +(defun tree-to-commands (tree stream &optional prologue) + (declare (optimize speed space)) + "Transforms an HTML tree into code to print the HTML to STREAM." + ;; use TREE-TO-TEMPLATE, then TREE-TO-COMMANDS-AUX, and finally + ;; replace the special symbols ESC, STR, FMT, and HTM + (apply-to-tree #'(lambda (x) + (case (first x) + ((esc) + ;; (ESC form ...) + ;; --> (LET ((RESULT form)) + ;; (WHEN RESULT + ;; (WRITE-STRING (ESCAPE-STRING RESULT STREAM)))) + (let ((result (gensym))) + `(let ((,result ,(second x))) + (when ,result (write-string (escape-string ,result) ,stream))))) + ((str) + ;; (STR form ...) + ;; --> (LET ((RESULT form)) + ;; (WHEN RESULT (PRINC RESULT STREAM))) + (let ((result (gensym))) + `(let ((,result ,(second x))) + (when ,result (princ ,result ,stream))))) + ((fmt) + ;; (FMT form*) --> (FORMAT STREAM form*) + (list* 'format stream (rest x))))) + #'(lambda (x) + (and (consp x) + (member (first x) + '(esc str fmt) + :test #'eq))) + ;; wrap PROGN around the HTM forms + (apply-to-tree (constantly 'progn) + #'(lambda (x) + (and (atom x) + (eq x 'htm))) + (tree-to-commands-aux + (if prologue + (list* 'htm prologue +newline+ + (tree-to-template tree)) + (cons 'htm (tree-to-template tree))) + stream)))) + +(defmacro with-html-output ((var &optional stream + &key prologue + ((:indent *indent*) *indent*)) + &body body) + "Transform the enclosed BODY consisting of HTML as s-expressions +into Lisp code to write the corresponding HTML as strings to VAR - +which should either hold a stream or which'll be bound to STREAM if +supplied." + (when (and *indent* + (not (integerp *indent*))) + (setq *indent* 0)) + (when (eq prologue t) + (setq prologue *prologue*)) + `(let ((,var ,(or stream var))) + ,(tree-to-commands body var prologue))) + +(defmacro with-html-output-to-string ((var &optional string-form + &key (element-type ''character) + prologue + indent) + &body body) + "Transform the enclosed BODY consisting of HTML as s-expressions +into Lisp code which creates the corresponding HTML as a string." + `(with-output-to-string (,var ,string-form + #-(or :ecl :cmu :sbcl) :element-type + #-(or :ecl :cmu :sbcl) ,element-type) + (with-html-output (,var nil :prologue ,prologue :indent ,indent) + ,@body))) + +(defmacro show-html-expansion ((var &optional stream + &key prologue + ((:indent *indent*) *indent*)) + &body body) + "Show the macro expansion of WITH-HTML-OUTPUT." + (when (and *indent* + (not (integerp *indent*))) + (setq *indent* 0)) + (when (eq prologue t) + (setq prologue *prologue*)) + `(pprint '(let ((,var ,(or stream var))) + ,(tree-to-commands body var prologue)))) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> +;; also used by LW-ADD-ONS + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-who/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-who + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq))))

1 0

[bknr-cvs] r2231 - in branches/trunk-reorg/projects/scrabble: src website/de
by bknr＠bknr.net 07 Oct '07

07 Oct '07

Author: hhubner Date: 2007-10-07 19:19:21 -0400 (Sun, 07 Oct 2007) New Revision: 2231 Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.asd branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/de/scrabble.js Log: Generate JSON instead of XML from game data. Proof of concept that this works. Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-07 23:18:29 UTC (rev 2230) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-07 23:19:21 UTC (rev 2231) @@ -48,6 +48,6 @@ :hunchentoot :bknr.datastore :bknr.user - :cxml + :json :scrabble)) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-07 23:18:29 UTC (rev 2230) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-07 23:19:21 UTC (rev 2231) @@ -13,7 +13,7 @@ :depends-on (:bknr-datastore :bknr-web :hunchentoot - :cxml + :cl-json :vecto :alexandria :anaphora) Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-07 23:18:29 UTC (rev 2230) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-07 23:19:21 UTC (rev 2231) @@ -1,25 +1,41 @@ (in-package :scrabble.web) -(defmethod as-xml ((board board)) - (with-element "board" - (dotimes (x 15) - (dotimes (y 15) - (awhen (at-xy board x y) - (with-element "tile" - (attribute "x" x) - (attribute "y" y) - (attribute "letter" (princ-to-string (char-of it))) - (attribute "value" (value-of it)))))))) +(defparameter *ignore-slots* '(bknr.datastore::id bknr.indices::destroyed-p)) -(defmethod as-xml ((participant participant)) - (with-element "participant" - (attribute "name" (user-full-name (player-of participant))) - (attribute "tiles" (length (tray-of participant))))) +(defun encode-json-alist (alist stream) + (princ #\{ stream) + (loop for (key value) on alist by #'cddr + do (encode-json key stream) + do (princ #\: stream) + do (encode-json value stream) + do (princ #\, stream)) + (princ #\} stream)) -(defmethod as-xml ((game game)) - (with-element "game" - (attribute "language" (princ-to-string (language-of game))) - (attribute "remaining-tiles" (remaining-tile-count (tile-bag-of game))) - (dolist (participant (participants-of game)) - (as-xml participant)) - (as-xml (board-of game)))) +(defmethod encode-json ((object store-object) stream) + (princ #\{ stream) + (dolist (slotdef (closer-mop:class-slots (class-of object))) + (when (and (slot-boundp object (closer-mop:slot-definition-name slotdef)) + (not (find (closer-mop:slot-definition-name slotdef) *ignore-slots*))) + (encode-json (closer-mop:slot-definition-name slotdef) stream) + (princ #\: stream) + (encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream) + (princ #\, stream))) + (princ #\} stream)) + +(defmethod encode-json ((tile-bag tile-bag) stream) + (encode-json-alist (list "remainingTiles" (remaining-tile-count tile-bag)) stream)) + +(defmethod encode-json ((board board) stream) + (princ #\[ stream) + (dotimes (x 15) + (dotimes (y 15) + (awhen (at-xy board x y) + (encode-json (list x y (char-of it) (value-of it)) stream) + (princ #\, stream)))) + (princ #\] stream)) + +(defmethod encode-json ((participant participant) stream) + (encode-json-alist (list :name (user-login (player-of participant)) + :remaining-tiles (length (tray-of participant))) + stream)) + Modified: branches/trunk-reorg/projects/scrabble/website/de/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-07 23:18:29 UTC (rev 2230) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.js 2007-10-07 23:19:21 UTC (rev 2231) @@ -16,7 +16,12 @@ } function init() { - setWord(6, 6, "ICH"); - setWord(7, 7, "LIEBE"); - setWord(8, 8, "DICH"); + var gameState = {"language":"de","board":[[7,7,"E",1],[7,8,"I",1],[7,9,"M",3],],"tileBag":{"remainingTiles":88,},"participants":[{"player":{"login":"user1","flags":null,"email":null,"fullName":"User Eins","lastLogin":0,"password":"$1$GNNXDZNW$hrPGuT8YOoGzJ6IXoUZGo1","preferences":{},"subscriptions":null,"games":null,},"tray":[{"char":"I","value":1,},{"char":"N","value":1,},{"char":"H","value":2,},{"char":"S","value":1,},{"char":"S","value":1,},{"char":"G","value":2,},{"char":"I","value":1,}],},{"player":{"login":"user2","flags":null,"email":null,"fullName":"User Zwei","lastLogin":0,"password":"$1$NSOVKSSC$enFJIydIQa.X77ATDtBNU1","preferences":{},"subscriptions":null,"games":null,},"tray":[{"char":"T","value":1,},{"char":"F","value":4,},{"char":"A","value":1,},{"char":"J","value":6,},{"char":"E","value":1,},{"char":"H","value":2,},{"char":"E","value":1,}],}],}; + + for (var i = 0; i < gameState.board.length; i++) { + var x = gameState.board[i][0]; + var y = gameState.board[i][1]; + var char = gameState.board[i][2]; + setLetter(x, y, char); + } }

1 0

[bknr-cvs] r2230 - in branches/trunk-reorg/thirdparty: . cl-json cl-json/_darcs cl-json/_darcs/current cl-json/_darcs/current/doc cl-json/_darcs/current/src cl-json/_darcs/current/t cl-json/_darcs/inventories cl-json/_darcs/patches cl-json/_darcs/prefs cl-json/doc cl-json/src cl-json/t
by bknr＠bknr.net 07 Oct '07

07 Oct '07

Author: hhubner Date: 2007-10-07 19:18:29 -0400 (Sun, 07 Oct 2007) New Revision: 2230 Added: branches/trunk-reorg/thirdparty/cl-json/ branches/trunk-reorg/thirdparty/cl-json/_darcs/ branches/trunk-reorg/thirdparty/cl-json/_darcs/checkpoints/ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/cl-json.asd branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/index.html branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/style.css branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/common.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/decoder.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/encoder.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/json-rpc.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/package.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/utils.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail1.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail10.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail11.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail12.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail13.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail14.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail15.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail16.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail17.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail18.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail19.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail2.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail20.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail21.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail22.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail23.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail24.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail3.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail4.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail5.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail6.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail7.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail8.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail9.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/package.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass1.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass2.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass3.json branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testdecoder.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testencoder.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testjson.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testmisc.lisp branches/trunk-reorg/thirdparty/cl-json/_darcs/inventories/ branches/trunk-reorg/thirdparty/cl-json/_darcs/inventories/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/inventory branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/ branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060130172648-1073e-418fe73231a10472a503fd6a02be8cd4fb2fae3c.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060202142849-1073e-1a01685d86ae410a3daf0517a12b5aefa4ad47e5.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203193308-2eda4-3e8a8b08934e415ee98f432847ba99b2a0f2473b.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203211337-2eda4-e84b2961e6d77a27f5ad145a8c86e6e1741bff86.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205110905-2eda4-d75e1b0c3492c980c371f3245f366fca64303c5b.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205170525-2eda4-7a1ca0472deb835294a687b38d17c3c7c6fd99bf.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060218114508-2eda4-19149c99c1e3fa477e9428078c8080f313e15d62.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060222215326-2eda4-45a4ea19782481ca9ac576abd121369f646fbbcd.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060223090421-2eda4-15cccaa2bee2022dd3fd03c7648749fea1afc94d.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060818161526-2eda4-151021eec164a7b52d9a4844bfe6a24c6b8b5a63.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142524-2eda4-3a71033e3fe281e3f9aa88777045388f6242df3d.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142711-2eda4-e150e8c262db6cedf82a2b5caed3d7e5aa2c958f.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923090745-2eda4-2860a46edd40564768cf5a0805a3903063442a08.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923091853-2eda4-f86b21590e38fdb6a4461efe49be66cf33e62cf7.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923103021-2eda4-4c1ababe563eafb2829dde088e91471f83d059a4.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923171022-2eda4-87a564361d8011f62b557e75b851012c9bc45580.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060924093311-2eda4-e9f67bed3e76e28d407dcbf02f47c847fb13a077.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060926135223-f2a76-a2fd736ee3105a64d17620c3f7e8c7b961bdc05d.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061031054156-f2a76-534fb5a215d2339b2244e01ce64ff840ee52a69a.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229094512-f2a76-979034ec4301db8ae7fd3698b4369abbb3aa2cbb.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101705-f2a76-121dfafa63680808271452a8990031095330951b.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101832-f2a76-cb5d7aa34b17526bcf8bffc901f6294eb8b3ef53.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101922-f2a76-1d8519ead2fbb540ebc80b00a703781043bd7932.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324093357-f2a76-c650e69a2e1117bdbb24e22a62a4d39fe37e448f.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324095848-f2a76-f6b5ac53bd541b80e1b47cb674f1d9854809dc98.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324102326-f2a76-3818038b2f27315270dc4e37c067cd43d98cf20d.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324110354-f2a76-d5cde7675cc1c97b68378a778f44eefd916be442.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324115951-f2a76-47dba0b50ae12cedb7028aff812c06414fc022da.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324122807-f2a76-cf483ee81e42710a183e3c82fb54165a64ef6aca.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141640-f2a76-131280f2336bfab387055306ecf88f2b48cbae53.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141654-2eda4-2589cb490ac521aa79509558bd0cb13916e6e51d.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141935-f2a76-0439a3725d93d42526a2c9d3ec4c821b93b8b771.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070325211904-f2a76-9a9667b1214cb27a87a1fdcc6ce1cf740122b193.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531134607-f2a76-04005616b0614ac5bb6190289a43227d24ff648f.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531150713-f2a76-7d556dae2e116b5d8bc955931afe84e602733c37.gz branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/ branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/binaries branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/boring branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/defaultrepo branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/motd branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/repos branches/trunk-reorg/thirdparty/cl-json/cl-json.asd branches/trunk-reorg/thirdparty/cl-json/doc/ branches/trunk-reorg/thirdparty/cl-json/doc/index.html branches/trunk-reorg/thirdparty/cl-json/doc/style.css branches/trunk-reorg/thirdparty/cl-json/src/ branches/trunk-reorg/thirdparty/cl-json/src/common.lisp branches/trunk-reorg/thirdparty/cl-json/src/decoder.lisp branches/trunk-reorg/thirdparty/cl-json/src/encoder.lisp branches/trunk-reorg/thirdparty/cl-json/src/json-rpc.lisp branches/trunk-reorg/thirdparty/cl-json/src/package.lisp branches/trunk-reorg/thirdparty/cl-json/src/utils.lisp branches/trunk-reorg/thirdparty/cl-json/t/ branches/trunk-reorg/thirdparty/cl-json/t/fail1.json branches/trunk-reorg/thirdparty/cl-json/t/fail10.json branches/trunk-reorg/thirdparty/cl-json/t/fail11.json branches/trunk-reorg/thirdparty/cl-json/t/fail12.json branches/trunk-reorg/thirdparty/cl-json/t/fail13.json branches/trunk-reorg/thirdparty/cl-json/t/fail14.json branches/trunk-reorg/thirdparty/cl-json/t/fail15.json branches/trunk-reorg/thirdparty/cl-json/t/fail16.json branches/trunk-reorg/thirdparty/cl-json/t/fail17.json branches/trunk-reorg/thirdparty/cl-json/t/fail18.json branches/trunk-reorg/thirdparty/cl-json/t/fail19.json branches/trunk-reorg/thirdparty/cl-json/t/fail2.json branches/trunk-reorg/thirdparty/cl-json/t/fail20.json branches/trunk-reorg/thirdparty/cl-json/t/fail21.json branches/trunk-reorg/thirdparty/cl-json/t/fail22.json branches/trunk-reorg/thirdparty/cl-json/t/fail23.json branches/trunk-reorg/thirdparty/cl-json/t/fail24.json branches/trunk-reorg/thirdparty/cl-json/t/fail3.json branches/trunk-reorg/thirdparty/cl-json/t/fail4.json branches/trunk-reorg/thirdparty/cl-json/t/fail5.json branches/trunk-reorg/thirdparty/cl-json/t/fail6.json branches/trunk-reorg/thirdparty/cl-json/t/fail7.json branches/trunk-reorg/thirdparty/cl-json/t/fail8.json branches/trunk-reorg/thirdparty/cl-json/t/fail9.json branches/trunk-reorg/thirdparty/cl-json/t/package.lisp branches/trunk-reorg/thirdparty/cl-json/t/pass1.json branches/trunk-reorg/thirdparty/cl-json/t/pass2.json branches/trunk-reorg/thirdparty/cl-json/t/pass3.json branches/trunk-reorg/thirdparty/cl-json/t/testdecoder.lisp branches/trunk-reorg/thirdparty/cl-json/t/testencoder.lisp branches/trunk-reorg/thirdparty/cl-json/t/testjson.lisp branches/trunk-reorg/thirdparty/cl-json/t/testmisc.lisp Log: add cl-json Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/cl-json.asd =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/cl-json.asd 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/cl-json.asd 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,41 @@ +;;; -*- lisp -*- + +(in-package #:cl-user) + +(defpackage #:json-system + (:use #:cl #:asdf)) + +(in-package #:json-system) + +(defsystem :cl-json + :name "cl-json" + :description "JSON in Lisp. JSON (JavaScript Object Notation) is a lightweight data-interchange format." + :version "0.3.2" + :author "Henrik Hjelte <henrik(a)evahjelte.com>" + :licence "MIT" + :components ((:static-file "cl-json.asd") + (:module :src + :components ((:file "package") + (:file "common" :depends-on ("package")) + (:file "decoder" :depends-on ("common")) + (:file "encoder" :depends-on ("common")) + (:file "utils" :depends-on ("decoder" "encoder")) + (:file "json-rpc" :depends-on ("package" "common" "utils" "encoder" "decoder"))))) + :depends-on (:parenscript)) + +(defsystem :cl-json.test + :depends-on (:cl-json :fiveam ) + :components ((:module :t + :components ((:file "package") + (:file "testjson" :depends-on ("package" "testdecoder" "testencoder" "testmisc")) + (:file "testmisc" :depends-on ("package" "testdecoder" "testencoder")) + (:file "testdecoder" :depends-on ("package")) + (:file "testencoder" :depends-on ("package")))))) + +;; Copyright (c) 2006 Henrik Hjelte +;; +;; 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. \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/index.html =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/index.html 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/index.html 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,98 @@ +<?xml version="1.0"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>CL-JSON</title> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> +</head> + +<body> + <div class="header"> + <h1>CL-JSON</h1> + <h2>A JSON parser and generator in Common-Lisp.</h2> + + </div> + + <h3>What is JSON?</h3> + +<p><a href="http://www.json.org">JSON</a> is a language independent text format for data-interchange. JSON is especially convenient in web applications, since it is a subset of the literal object notation of <a href="http://www.json.org/js.html">ECMAScript</a>. It can also be an alternative to XML. JSON has good open-source support in many languages.</p> +<h3>Why not use XML instead?</h3> +<li>Some find JSON lighter and more simple, see this <a href="http://www.json.org/xml.html">comparison.</a></li> +<h3>Why not use s-expressions instead?</h3> +<ul> +<li>Many people find parentheses difficult, but brackets and braces easy. That has led to many implementations of JSON. There is no format based on s-expressions implemented in over 20 languages (yet!).</li> +<li>A simple and very fast JSON parser in JavaScript looks like this:<pre>eval('(' + aJSONtext + ')')</pre> +Even a seasoned lisper may find it difficult to make a shorter JavaScript parser for s-expressions.</li> +</ul> + + <h3>Mailing Lists</h3> + <ul> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-json-devel"> + cl-json-devel</a><br/>for developers and users.</li> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-json-announce"> + cl-json-announce</a><br/>for announcements.</li> + + </ul> + <h3>Documentation</h3> + <p> + You can use any of these functions: + <pre> + decode-json + decode-json-strict + decode-json-from-string + encode-json + encode-json-to-string + + json-bind, use like this: + +(test test-json-bind + (json-bind (hello hi ciao) "{\"hello\":100,\"hi\":5}" + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao)))</pre> + + Json-rpc, implements the json-rpc specification. Easily add it to your favourite webserver. + <pre> + defun-json-rpc + export-as-json-rpc + clear-exported + invoke-rpc + </pre> + Tweaking + <pre> + *json-symbols-package* Default keyword, set to a package or nil for current package. + *json-object-factory* Change how objects are decoded to Lisp. + *use-strict-json-rules* + </pre> + + For examples, see the <a href="http://common-lisp.net/project/bese/FiveAM.html">FiveAM</a> based testcases. + + </p> + <h3>Where is it</h3> + <p>A <a href="http://www.darcs.net/">Darcs</a> repository is available.<pre>darcs get http://common-lisp.net/project/cl-json/darcs/cl-json +</pre> + <p>The latest release can be downloaded <a href="http://www.cliki.net/cl-json">here</a>.</p> + <p>You can also install it by asdf-install.</p> + <p>History has shown that the darcs version is probably better than the latest release.</p> + <h3>Dependencies</h3> + cl-json now depends on <a href="http://parenscript.org">parenscript</a> for some functions. + <pre> darcs get http://common-lisp.net/project/ucw/repos/parenscript </pre> + + <h3>License</h3> + <p>MIT-license</p> + <div class="footer"> + <p>Henrik Hjelte</p> 2. Feb. 2006, updated 25 march 2007. + </div> + + <div class="check"> + <a href="http://validator.w3.org/check/referer"> + Valid XHTML 1.0 Strict</a> + </div + </body> +</html> Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/style.css =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/style.css 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/doc/style.css 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,60 @@ +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + background-color: #336699; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + background-color: #336699; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + background-color: #336699; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + background-color: #FFFFFF; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + background-color: #FFFFFF; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + background-color: #FFFFFF; + text-decoration:underline; } + Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/common.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/common.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/common.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,24 @@ +(in-package :json) + +(defparameter *json-lisp-escaped-chars* + `((#\" . #\") + (#\\ . #\\) + (#\/ . #\/) + (#\b . #\Backspace) + (#\f . ,(code-char 12)) + (#\n . #\Newline) + (#\r . #\Return) + (#\t . #\Tab))) + +(defparameter *use-strict-json-rules* t) + +(defun json-escaped-char-to-lisp(json-escaped-char) + (let ((ch (cdr (assoc json-escaped-char *json-lisp-escaped-chars*)))) + (if *use-strict-json-rules* + (or ch (error 'json-parse-error)) + (or ch json-escaped-char)))) + +(defun lisp-special-char-to-json(lisp-char) + (car (rassoc lisp-char *json-lisp-escaped-chars*))) + + Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/decoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/decoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/decoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,163 @@ +(in-package :json) + +(defvar *json-symbols-package* (find-package 'keyword) "The package where json-symbols are interned. Default keyword, nil = current package") + +(defun json-intern (string) + (if *json-symbols-package* + (intern (camel-case-to-lisp string) *json-symbols-package*) + (intern (camel-case-to-lisp string)))) + +(defparameter *json-rules* nil) + +(defparameter *json-object-factory* #'(lambda () nil)) +(defparameter *json-object-factory-add-key-value* #'(lambda (obj key value) + (push (cons (json-intern key) value) + obj))) +(defparameter *json-object-factory-return* #'(lambda (obj) (nreverse obj))) +(defparameter *json-make-big-number* #'(lambda (number-string) (format nil "BIGNUMBER:~a" number-string))) + +(define-condition json-parse-error (error) ()) + +(defun decode-json-from-string (json-string) + (with-input-from-string (stream json-string) + (decode-json stream))) + +(defun decode-json (&optional (stream *standard-input*)) + "Reads a json element from stream" + (funcall (or (cdr (assoc (peek-char t stream) *json-rules*)) + #'read-json-number) + stream)) + +(defun decode-json-strict (&optional (stream *standard-input*)) + "Only objects or arrays on top level, no junk afterwards." + (assert (member (peek-char t stream) '(#\{ #\[))) + (let ((object (decode-json stream))) + (assert (eq :no-junk (peek-char t stream nil :no-junk))) + object)) + +;;----------------------- + + +(defun add-json-dispatch-rule (character fn) + (push (cons character fn) *json-rules*)) + +(add-json-dispatch-rule #\t #'(lambda (stream) (read-constant stream "true" t))) + +(add-json-dispatch-rule #\f #'(lambda (stream) (read-constant stream "false" nil))) + +(add-json-dispatch-rule #\n #'(lambda (stream) (read-constant stream "null" nil))) + +(defun read-constant (stream expected-string ret-value) + (loop for x across expected-string + for ch = (read-char stream nil nil) + always (char= ch x) + finally (return ret-value))) + +(defun read-json-string (stream) + (read-char stream) + (let ((val (read-json-chars stream '(#\")))) + (read-char stream) + val)) + +(add-json-dispatch-rule #\" #'read-json-string) + +(defun read-json-object (stream) + (read-char stream) + (let ((obj (funcall *json-object-factory*))) + (if (char= #\} (peek-char t stream)) + (read-char stream) + (loop for skip-whitepace = (peek-char t stream) + for key = (read-json-string stream) + for separator = (peek-char t stream) + for skip-separator = (assert (char= #\: (read-char stream))) + for value = (decode-json stream) + for terminator = (peek-char t stream) + for skip-terminator = (assert (member (read-char stream) '(#\, #\}))) + do (setf obj (funcall *json-object-factory-add-key-value* obj key value)) + until (char= #\} terminator))) + (funcall *json-object-factory-return* obj))) + +(add-json-dispatch-rule #\{ #'read-json-object) + +(defun read-json-array (stream) + (read-char stream) + (if (char= #\] (peek-char t stream)) + (progn (read-char stream) nil) + (loop for first-in-element = (assert (not (member (peek-char t stream) '(#\, #\])))) + for element = (decode-json stream) + for terminator = (peek-char t stream) + for skip-terminator = (assert (member (read-char stream) '(#\, #\]))) + collect element + until (char= #\] terminator)))) + +(add-json-dispatch-rule #\[ #'read-json-array) + +(defparameter *digits* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(defparameter *json-number-valid-chars* (concatenate 'list *digits* '(#\e #\E #\. #\+ #\-))) + +(defun read-json-number (stream) + (let ((number-string (read-chars-until stream + :terminator-fn #'(lambda (ch) + (not (member ch *json-number-valid-chars*)))))) + (assert (if (char= (char number-string 0) #\0) + (or (= 1 (length number-string)) (char= #\. (char number-string 1))) + t)) + (handler-case + (read-from-string number-string) + (serious-condition (e) + (let ((e-pos (or (position #\e number-string) + (position #\E number-string)))) + (if e-pos + (handler-case + (read-from-string (substitute #\l (aref number-string e-pos) number-string)) + (serious-condition () + (funcall *json-make-big-number* number-string))) + (error "Unexpected error ~S" e))))))) + +(defun read-chars-until(stream &key terminator-fn (char-converter #'(lambda (ch stream) + (declare (ignore stream)) + ch))) + (with-output-to-string (ostr) + (loop + (let ((ch (peek-char nil stream nil nil))) + (when (or (null ch) + (funcall terminator-fn ch)) + (return)) + (write-char (funcall char-converter + (read-char stream nil nil) + stream) + ostr))))) + +(defun read-n-chars (stream n) + (with-output-to-string (ostr) + (dotimes (x n) + (write-char (read-char stream) ostr)))) + +(defun read-json-chars(stream terminators) + (read-chars-until stream :terminator-fn #'(lambda (ch) + (member ch terminators)) + :char-converter #'(lambda (ch stream) + (if (char= ch #\\) + (if (char= #\u (peek-char nil stream)) + (code-char (parse-integer (read-n-chars stream 5) :start 1 :radix 16)) + (json-escaped-char-to-lisp (read-char stream))) + ch)))) + +(defun camel-case-to-lisp (string) + "Converts a string in camelCase to the same lisp-friendly syntax used in parenscript. + +(camel-case-to-string \"camelCase\") -> \"CAMEL-CASE\" +(camel-case-to-string \"CamelCase\") -> \"*CAMEL-CASE\" +(camel-case-to-string \"dojo.widget.TreeNode\") -> \"DOJO.WIDGET.*TREE-NODE\" +" + (with-output-to-string (out) + (loop for ch across string + with last-char do + (if (upper-case-p ch) + (progn + (if (and last-char (lower-case-p last-char)) + (write-char #\- out) + (write-char #\* out)) + (write-char ch out)) + (write-char (char-upcase ch) out)) + (setf last-char ch)))) Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/encoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/encoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/encoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,112 @@ +(in-package :json) + +(defparameter *symbol-to-string-fn* #'js::symbol-to-js) + +(defgeneric encode-json (object stream)) + +(defun encode-json-to-string(object) + (with-output-to-string (stream) + (encode-json object stream))) + +(defmethod encode-json((nr number) stream) + (write-json-number nr stream)) + +(defmethod encode-json((s string) stream) + (write-json-string s stream)) + +(defmethod encode-json ((c character) stream) + "JSON does not define a character type, we encode characters as strings." + (encode-json (string c) stream)) + +(defmethod encode-json((s symbol) stream) + (cond + ((null s) (write-json-chars "null" stream)) + ((eq 't s) (write-json-chars "true" stream)) + (t (write-json-string (funcall *symbol-to-string-fn* s) stream)))) + +(defmethod encode-json((s list) stream) + (handler-case + (write-string (with-output-to-string (temp) + (call-next-method s temp)) + stream) + (type-error (e) + (declare (ignore e)) + (encode-json-alist s stream)))) + +(defmethod encode-json((s sequence) stream) + (let ((first-element t)) + (write-char #\[ stream) + (map nil #'(lambda (element) + (if first-element + (setf first-element nil) + (write-char #\, stream)) + (encode-json element stream)) + s) + (write-char #\] stream))) + +(defmacro write-json-object (generator-fn stream) + (let ((strm (gensym)) + (first-element (gensym))) + `(let ((,first-element t) + (,strm ,stream)) + (write-char #\{ ,strm) + (loop + (multiple-value-bind (more name value) + (,generator-fn) + (unless more (return)) + (if ,first-element + (setf ,first-element nil) + (write-char #\, ,strm)) + (encode-json name ,strm) + (write-char #\: ,strm) + (encode-json value ,strm))) + (write-char #\} ,strm)))) + +(defmethod encode-json((h hash-table) stream) + (with-hash-table-iterator (generator h) + (write-json-object generator stream))) + +(defmacro with-alist-iterator ((generator-fn alist) &body body) + (let ((stack (gensym))) + `(let ((,stack (copy-alist ,alist))) + (flet ((,generator-fn () + (let ((cur (pop ,stack))) + (if cur + (values t (car cur) (cdr cur)) + nil)))) + ,@body)))) + +(defun encode-json-alist (alist stream) + (with-alist-iterator (gen-fn alist) + (write-json-object gen-fn stream))) + +(defun encode-json-alist-to-string(alist) + (with-output-to-string (stream) + (encode-json-alist alist stream))) + + +(defun write-json-string (s stream) + (write-char #\" stream) + (if (stringp s) + (write-json-chars s stream) + (encode-json s stream)) + (write-char #\" stream)) + +(defun write-json-chars (s stream) + (declare (inline lisp-special-char-to-json)) + (loop for ch across s + for code = (char-code ch) + for special = (lisp-special-char-to-json ch) + do + (cond + ((and special (not (char= special #\/))) + (write-char #\\ stream) + (write-char special stream)) + ((<= code #x1f) + (format stream "\\u~4,'0x" code)) + (t (write-char ch stream))))) + +(defun write-json-number (nr stream) + (if (integerp nr) + (format stream "~d" nr) + (format stream "~f" nr))) Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/json-rpc.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/json-rpc.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/json-rpc.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,79 @@ +(in-package :json-rpc) + +;; http://json-rpc.org/wiki/specification +;; http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html + +(defvar *json-rpc-functions* (make-hash-table :test #'equal)) + +(defun clear-exported () + (clrhash *json-rpc-functions*)) + +(defmacro defun-json-rpc (name lambda-list &body body) + "Defines a function and registers it as a json-rpc target." + `(progn + (defun ,name ,lambda-list ,@body) + (export-as-json-rpc #',name (string-downcase (symbol-name ',name))))) + +(defun export-as-json-rpc (func function-name) + (setf (gethash function-name *json-rpc-functions*) func)) + +(defun make-rpc-response (&key result error id) + "When the method invocation completes, the service must reply with a response. The response is a single object serialized using JSON. + +It has three properties: + + * result - The Object that was returned by the invoked method. This must be null in case there was an error invoking the method. + * error - An Error object(unspecified in json-rpc 1.0) if there was an error invoking the method. Null if there was no error. + * id - This must be the same id as the request it is responding to. " + (json:encode-json-alist-to-string + `((:result . ,result) + (:error . ,error) + (:id . ,id)))) + +(defun make-json-rpc-error-object-1.1 (message &key code error-object) + "This code is based on the Working Draft 7 August 2006 of Json-rpc 1.1 specification. + http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html +" + (let ((eo `((:name . "JSONRPCError") + (:code . ,(or code 999)) + (:message . ,message)))) + (if error-object + (append eo `((:error . ,error-object))) + eo))) + +(defun invoke-rpc (json-string) + "A remote method is invoked by sending a request to a remote service. The request is a single object serialized using JSON. + +It has three properties: + + * method - A String containing the name of the method to be invoked. + * params - An Array of objects to pass as arguments to the method. + * id - The request id. This can be of any type. It is used to match the response with the request that it is replying to. " + (json-bind (method params id) json-string + (restart-case + (let ((func (gethash method *json-rpc-functions*))) + (if func + (make-rpc-response :id id :result (restart-case (apply func params) + (use-value (value) + value))) + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 "Procedure not found")))) + (send-error (message &optional code error-object) + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 message + :code code + :error-object error-object))) + (send-error-object (error-object) + (make-rpc-response :id id :error error-object)) + (send-nothing () + nil) + (send-internal-error () + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 "Service error")))))) + +(defmacro def-restart (restart-name &rest (params)) + `(defun ,restart-name (,@params &optional condition) + (let ((restart (find-restart ',restart-name condition))) + (invoke-restart restart ,@params)))) + +(def-restart send-error (errmsg code)) +(def-restart send-error-object (errobject)) +(def-restart send-nothing ()) +(def-restart send-internal-error ()) Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/package.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,38 @@ +(defpackage :json + (:use :common-lisp) + (:export + #:*json-symbols-package* + #:*json-object-factory* + #:*json-object-factory-add-key-value* + #:*json-object-factory-return* + #:*json-make-big-number* + + #:decode-json + #:decode-json-strict + #:decode-json-from-string + + #:*use-strict-json-rules* + #:json-parse-error + + #:encode-json + #:encode-json-to-string + #:encode-json-alist + #:encode-json-alist-to-string + + #:json-bind + )) + +(defpackage :json-rpc + (:use :common-lisp :json) + (:export + #:clear-exported + #:defun-json-rpc + #:export-as-json-rpc + #:invoke-rpc + + ;; restarts + #:send-error + #:send-error-object + #:send-nothing + #:send-internal-error + )) Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/utils.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/src/utils.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,47 @@ +(in-package :json) + +;; helpers for json-bind +(defun cdas(item alist) + "Alias for (cdr (assoc item alist))" + (cdr (assoc item alist))) + +(defun last1 (lst) + (first (last lst))) + +(defmacro assoc-lookup (&rest lookuplist) + "(assoc-lookup :x :y alist) => (cdr (assoc :y (cdr (assoc :x alist))))" + (let ((alist-form (last1 lookuplist)) + (lookups (reverse (butlast lookuplist)))) + (labels ((mk-assoc-lookup (lookuplist) + (if lookuplist + `(cdas ,(first lookuplist) ,(mk-assoc-lookup (rest lookuplist))) + alist-form))) + (mk-assoc-lookup lookups)))) + +(defmacro json-bind (vars json-string-or-alist &body body) + (labels ((symbol-as-string (symbol) + (string-downcase (symbol-name symbol))) + (split-by-dots (string) + (loop for ch across string + with x + with b + do (if (char= #\. ch) + (progn + (push (concatenate 'string (nreverse b)) x) + (setf b nil)) + (push ch b)) + finally (progn + (push (concatenate 'string (nreverse b)) x) + (return (nreverse x))))) + (lookup-deep (variable) + (mapcar #'json-intern (split-by-dots (symbol-as-string variable))))) + (let ((a-list (gensym))) + `(let ((,a-list (if (stringp ,json-string-or-alist) + (decode-json-from-string ,json-string-or-alist) + ,json-string-or-alist))) + (let ,(loop for v in vars collect `(,v (assoc-lookup ,@(lookup-deep v) + ,a-list))) + ,@body))))) + + + Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail1.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail1.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail1.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +"A JSON payload should be an object or array, not a string." \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail10.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail10.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail10.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Extra value after close": true} "misplaced quoted value" \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail11.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail11.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail11.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Illegal expression": 1 + 2} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail12.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail12.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail12.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Illegal invocation": alert()} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail13.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail13.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail13.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Numbers cannot have leading zeroes": 013} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail14.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail14.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail14.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Numbers cannot be hex": 0x14} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail15.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail15.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail15.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \x15"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail16.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail16.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail16.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \'"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail17.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail17.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail17.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \017"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail18.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail18.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail18.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail19.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail19.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail19.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Missing colon" null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail2.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail2.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail2.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Unclosed array" \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail20.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail20.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail20.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Double colon":: null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail21.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail21.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail21.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Comma instead of colon", null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail22.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail22.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail22.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Colon instead of comma": false] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail23.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail23.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail23.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Bad value", truth] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail24.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail24.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail24.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +['single quote'] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail3.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail3.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail3.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{unquoted_key: "keys must be quoted} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail4.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail4.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail4.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["extra comma",] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail5.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail5.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail5.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["double extra comma",,] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail6.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail6.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail6.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[ , "<-- missing value"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail7.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail7.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail7.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Comma after the close"], \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail8.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail8.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail8.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Extra close"]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail9.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail9.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/fail9.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Extra comma": true,} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/package.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,5 @@ +(defpackage :json-test + (:use :json :json-rpc :common-lisp :5am )) + +(in-package :json-test) +(def-suite json) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass1.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass1.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass1.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,56 @@ +[ + "JSON Test Pattern pass1", + {"object with 1 member":["array with 1 element"]}, + {}, + [], + -42, + true, + false, + null, + { + "integer": 1234567890, + "real": -9876.543210, + "e": 0.123456789e-12, + "E": 1.234567890E+34, + "": 23456789012E666, + "zero": 0, + "one": 1, + "space": " ", + "quote": "\"", + "backslash": "\\", + "controls": "\b\f\n\r\t", + "slash": "/ & \/", + "alpha": "abcdefghijklmnopqrstuvwyz", + "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", + "digit": "0123456789", + "special": "`1~!@#$%^&*()_+-={':[,]}|;.</>?", + "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", + "true": true, + "false": false, + "null": null, + "array":[ ], + "object":{ }, + "address": "50 St. James Street", + "url": "http://www.JSON.org/", + "comment": "// /*  */": " ", + " s p a c e d " :[1,2 , 3 + +, + +4 , 5 , 6 ,7 ], + "compact": [1,2,3,4,5,6,7], + "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", + "quotes": "" \u0022 %22 0x22 034 "", + "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" +: "A key can be any string" + }, + 0.5 ,98.6 +, +99.44 +, + +1066 + + +,"rosebud"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass2.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass2.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass2.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass3.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass3.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/pass3.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,6 @@ +{ + "JSON Test Pattern pass3": { + "The outermost value": "must be an object or array.", + "In this test": "It is an object." + } +} Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testdecoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testdecoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testdecoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,177 @@ +(in-package :json-test) + +(in-suite json) + +;; Test decoder + +(test json-literal + (is-true (decode-json-from-string " true")) + (is-true (decode-json-from-string " true ")) + (is-true (decode-json-from-string "true ")) + (is-true (decode-json-from-string "true")) + (is-false (decode-json-from-string "trUe ")) + (is-false (decode-json-from-string "false")) + (is-false (decode-json-from-string "null")) + ) + +(test json-string + (is (string= "hello" + (decode-json-from-string " \"hello\""))) + (is (string= "new-line +returned!" + (decode-json-from-string "\"new-line\\nreturned!\""))) + (is (string= (make-string 1 :initial-element (code-char (+ (* 10 16) 11))) + (decode-json-from-string " \"\\u00ab\"")))) + +(test json-array + (is (equalp + '("hello" "hej" "ciao") + (decode-json-from-string " [ \"hello\", \"hej\", + \"ciao\" ]"))) + (is (equalp '(1 2 3) + (decode-json-from-string "[1,2,3]"))) + (is (equalp '(t nil nil) + (decode-json-from-string "[true,null,false]"))) + (is-false (decode-json-from-string "[]"))) + +(test json-object + (is (equalp '((:hello . "hej") + (:hi . "tjena")) + (decode-json-from-string " { \"hello\" : \"hej\" , + \"hi\" : \"tjena\" + }"))) + (is-false (decode-json-from-string " { } ")) + (is-false (decode-json-from-string "{}"))) + +(test json-object-factory + (let ((*json-object-factory* #'(lambda () + (make-hash-table))) + (*json-object-factory-add-key-value* #'(lambda (obj key value) + (setf (gethash (intern (string-upcase key)) obj) + value) + obj)) + (*json-object-factory-return* #'identity) + obj) + (setf obj (decode-json-from-string " { \"hello\" : \"hej\" , + \"hi\" : \"tjena\" + }")) + (is (string= "hej" (gethash 'hello obj))) + (is (string= "tjena" (gethash 'hi obj))))) + +(test json-object-camel-case + (is (equalp '((:hello-key . "hej") + (:*hi-starts-with-upper-case . "tjena")) + (decode-json-from-string " { \"helloKey\" : \"hej\" , + \"HiStartsWithUpperCase\" : \"tjena\" + }")))) + + + + +(test json-number + (is (= (decode-json-from-string "100") 100)) + (is (= (decode-json-from-string "10.01") 10.01)) + (is (= (decode-json-from-string "-2.3") -2.3)) + (is (= (decode-json-from-string "-2.3e3") -2.3e3)) + (is (= (decode-json-from-string "-3e4") -3e4)) + (is (= (decode-json-from-string "3e4") 3e4)) + #+sbcl + (is (= (decode-json-from-string "2e40") 2d40));;Coerced to double + (is (equalp (decode-json-from-string "2e444") (funcall *json-make-big-number* "2e444")))) + +(defparameter *json-test-files-path* *load-pathname*) + +(defun test-file (name) + (make-pathname :name name :type "json" :defaults *json-test-files-path*)) + +(defun decode-file (path) + (with-open-file (stream path + :direction :input) + (decode-json-strict stream))) + +;; All test files are taken from http://www.crockford.com/JSON/JSON_checker/test/ + +(test pass-1 + (decode-file (test-file "pass1"))) + +(test pass-2 + (decode-file (test-file "pass2"))) + +(test pass-3 + (decode-file (test-file "pass3"))) + +(defparameter *ignore-tests* '( + 1 ; says: "A JSON payload should be an object or array, not a string.", but who cares? + 7 ; says: ["Comma after the close"], ,but decode-file stops parsing after one object has been retrieved + 8 ; says ["Extra close"]] ,but decode-file stops parsing after one object has been retrieved + 10; says {"Extra value after close": true} "misplaced quoted value", but + ; decode-file stops parsing after one object has been retrieved + 18; says [[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]], but there is no formal limit +)) + +(defparameter *ignore-tests-strict* '( + 18; says [[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]], but there is no formal limit +)) + +(test fail-files + (dotimes (x 24) + (if (member x *ignore-tests-strict*) + (is-true t) + (5am:signals error + (decode-file (test-file (format nil "fail~a" x))))))) + +(defun contents-of-file(file) + (with-open-file (stream file :direction :input) + (let ((s (make-string (file-length stream)))) + (read-sequence s stream) + s))) + +(test decoder-performance + (let* ((json-string (contents-of-file (test-file "pass1"))) + (chars (length json-string)) + (count 1000)) + (format t "Decoding ~a varying chars from memory ~a times." chars count) + (time + (dotimes (x count) + (let ((discard-soon (decode-json-from-string json-string))) + (funcall #'identity discard-soon))))));Do something so the compiler don't optimize too much + +;;#+when-u-want-profiling +;;(defun profile-decoder-performance() +;; #+sbcl +;; (progn +;; (let ((json-string (contents-of-file (test-file "pass1"))) +;; (count 10)) +;; (format t "Parsing test-file pass1 from memory ~a times." count) +;; (sb-sprof:with-profiling () +;; (dotimes (x count) +;; (let ((discard-soon (decode-json-from-string json-string))) +;; (funcall #'identity discard-soon)))) +;; (sb-sprof:report) +;; nil))) + +(test non-strict-json + (let ((not-strictly-valid "\"right\\'s of man\"")) + (5am:signals json:json-parse-error + (json:decode-json-from-string not-strictly-valid)) + (let ((*use-strict-json-rules* nil)) + (declare (special *use-strict-json-rules*)) + (is (string= (json:decode-json-from-string not-strictly-valid) + "right's of man"))))) + +(test test*json-symbols-package* + (let ((*json-symbols-package* nil) + x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :json-test)))) + (let ((*json-symbols-package* (find-package :cl-user)) + x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :cl-user)))) + (let (x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :keyword))))) + Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testencoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testencoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testencoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,200 @@ +(in-package :json-test) +(in-suite json) + +(defmacro with-objects-as-hashtables(&body body) + ;;For testing, keys are stored as strings + `(let ((*json-object-factory* #'(lambda () + (make-hash-table :test #'equalp ))) + (*json-object-factory-add-key-value* #'(lambda (obj key value) + (setf (gethash key obj) + value) + obj)) + (*json-object-factory-return* #'identity)) + ,@body)) + +(test json-string() + (is (string= (encode-json-to-string (format nil "hello~&hello")) + "\"hello\\nhello\"")) + (is (string= (encode-json-to-string (format nil "\"aquote")) + "\"\\\"aquote\""))) + +(test json-literals + (is (string= "true" (encode-json-to-string t))) + (is (string= "null" (encode-json-to-string nil)))) + +(defun is-same-number(nr) + "If it gets decoded back ok then it was encoded ok" + (is (= nr (decode-json-from-string (encode-json-to-string nr))))) + +(test json-number + (is (string= "0" (encode-json-to-string 0))) + (is (string= "13" (encode-json-to-string 13))) + (is (string= "13.02" (encode-json-to-string 13.02))) + + (is-same-number 2e10) + (is-same-number -1.3234e-10) + (is-same-number -1280.12356) + (is-same-number 1d2) + (is-same-number 1l2) + (is-same-number 1s2) + (is-same-number 1f2) + (is-same-number 1e2)) + +(defun decode-then-encode (json) + (with-objects-as-hashtables + (assert (member (elt json 0) '(#\{ #\[ #\" ))) ;must be json + (flet ((normalize (string) + (remove #\Newline (remove #\Space string)))) + (let* ((decoded (decode-json-from-string json)) + (encoded (encode-json-to-string decoded))) +;; (format t "Json:~a~&" json) +;; (format t "Encoded:~a" encoded) + (is (string= (normalize json) + (normalize encoded))))))) + +(test test-encode-json-nathan-hawkins + (let ((foo '((a . 1) (b . 2) (c . 3)))) + (is (string= (encode-json-to-string foo) + "{\"a\":1,\"b\":2,\"c\":3}")))) + +(test test-encode-json-alist + (let ((alist `((:HELLO . 100)(:hi . 5))) + (expected "{\"hello\":100,\"hi\":5}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-two + (let ((alist `((HELLO . 100)(hi . 5))) + (expected "{\"hello\":100,\"hi\":5}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-string + (let ((alist `((:hello . "hej")(:hi . "tjena"))) + (expected "{\"hello\":\"hej\",\"hi\":\"tjena\"}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-camel-case + (let ((alist `((:hello-message . "hej")(*also-starting-with-upper . "hej"))) + (expected "{\"helloMessage\":\"hej\",\"AlsoStartingWithUpper\":\"hej\"}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test encode-pass-2 + (decode-then-encode "[[[[[[[[[[[[[[[[[[[\"Not too deep\"]]]]]]]]]]]]]]]]]]]")) + +(test encode-pass-3 + (decode-then-encode "{ + \"JSON Test Pattern pass3\": { + \"The outermost value\": \"must be an object or array.\" + } +} +")) + +;; Test inspired by the file pass1. +;; There are too many small differences just to decode-encode the whole pass1 file, +;; Instead the difficult parts are in separate tests below. + +(test controls + (decode-then-encode "\"\\\\b\\\\f\\\\n\\\\r\\\\\"")) + +(test slash + (let* ((z "\"/ & /\"") + (also-z "\"/ & \/\"") ;Extra quote + (x (encode-json-to-string z)) + (also-x (encode-json-to-string also-z)) + (y (decode-json-from-string x)) + (also-y (decode-json-from-string also-x))) + (is (string= x also-x)) + (is (string= y also-y)) + (is (string= z y)))) + + +(test quoted + (decode-then-encode "\"" %22 0x22 034 "\"")) + +(test alpha-1 + (decode-then-encode "\"abcdefghijklmnopqrstuvwyz\"")) + +(test alpha-2 + (decode-then-encode "\"ABCDEFGHIJKLMNOPQRSTUVWYZ\"")) + +(test digit + (decode-then-encode "\"0123456789\"")) + +(test special + (decode-then-encode "\"`1~!@#$%^&*()_+-={':[,]}|;.</>?\"")) + +(test hex + (decode-then-encode "\"\u0123\u4567\u89AB\uCDEF\uabcd\uef4A\"")) + +(test true + (decode-then-encode "[ true]")) + +(test false + (is (string= (encode-json-to-string (decode-json-from-string "[false]")) + "[null]")));;We dont separate between false and null +(test null + (decode-then-encode "[null]")) + +(test array + ;;Since empty lists becomes nil in lisp, they are converted back to null + (is (string= (encode-json-to-string (decode-json-from-string "[ ]")) + "null")) + ;;But you can use vectors + (is (string= (encode-json-to-string (vector 1 2)) + "[1,2]"))) + +(test character + ;;Characters are encoded to strings, but when decoded back to string + (is (string= (encode-json-to-string #\a) "\"a\""))) + + +(test hash-table-symbol + (let ((ht (make-hash-table))) + (setf (gethash 'symbols-are-now-converted-to-camel-case ht) 5) + (is (string= (encode-json-to-string ht) + "{\"symbolsAreNowConvertedToCamelCase\":5}")))) + +(test hash-table-string + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "lower x" ht) 5) + (is (string= (encode-json-to-string ht) + "{\"lower x\":5}")))) + + +(defparameter *encode-performace-test-string* + "{ + \"JSON Test Pattern pass3\": { + \"The outermost value\": \"must be an object or array.\", + \"In this test\": \"It is an object.\", + \"Performance-1\" : 123465.578, + \"Performance-2\" : 12e4, + \"Performance-2\" : \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"Performance-3\" : [\"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\"] + } +} +") + + + + + +(test encoder-performance + (with-objects-as-hashtables + (let* ((json-string *encode-performace-test-string*) + (chars (length json-string)) + (lisp-obj (decode-json-from-string json-string)) + (count 2000)) + (format t "Encoding ~a varying chars from memory ~a times." chars count) + (time + (dotimes (x count) + (let ((discard-soon (encode-json-to-string lisp-obj))) + (funcall #'identity discard-soon))))))) + + + Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testjson.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testjson.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testjson.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,2 @@ +(in-package :json-test) +(run! 'json) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testmisc.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testmisc.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/current/t/testmisc.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,50 @@ +(in-package :json-test) +(in-suite json) + +(test test-json-bind + (json-bind (hello hi ciao) "{\"hello\":100,\"hi\":5}" + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao))) + + +(test test-json-bind-advanced + (json-bind (hello-world + sub-obj.property + sub-obj.missing-property + sub-obj.even-deeper-obj.some-stuff) + "{\"helloWorld\":100,\"subObj\":{\"property\":20,\"evenDeeperObj\":{\"someStuff\":\"Guten Tag\"}}}" + (is (= hello-world 100)) + (is (= sub-obj.property 20)) + (is-false sub-obj.missing-property) + (is (string= sub-obj.even-deeper-obj.some-stuff "Guten Tag")))) + +(test test-json-bind-with-alist + (let ((the-alist (decode-json-from-string "{\"hello\":100,\"hi\":5}"))) + (json-bind (hello hi ciao) the-alist + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao)))) + +(test assoc-lookup + (is (equalp '(json::cdas widget-id (json::cdas parent data)) + (macroexpand-1 '(json::assoc-lookup parent widget-id data))))) + + +(defun-json-rpc foo (x y) + "Adds two numbers" + (+ x y)) + + +(test test-json-rpc + (let (result) + (setf result (json-rpc:invoke-rpc "{\"method\":\"foo\",\"params\":[1,2],\"id\":999}")) + (is (string= result "{\"result\":3,\"error\":null,\"id\":999}")))) + +(test test-json-rpc-unknown-fn + (let (result) + (setf result (json-rpc:invoke-rpc "{\"method\":\"secretmethod\",\"params\":[1,2],\"id\":\"my id\"}")) + (json-bind (result error id) result + (is-false result) + (is-true error) + (is (string= id "my id"))))) Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/inventories/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/inventories/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/inventories/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,70 @@ +[First version, decoder +henrik(a)evahjele.com**20060130172648] +[encoder works +henrik(a)evahjele.com**20060202142849] +[html +henrik(a)evahjelte.com**20060203193308] +[testjson +henrik(a)evahjelte.com**20060203211337] +[MIT license +henrik(a)evahjelte.com**20060205110905] +[ No form-character on openmcl +henrik(a)evahjelte.com**20060205170525] +[links refer to json.org +henrik(a)evahjelte.com**20060218114508] +[bugfix encoding hashtables +henrik(a)evahjelte.com**20060222215326] +[keyword package for keys when decoding objects +henrik(a)evahjelte.com**20060223090421] +[json-rpc +henrik(a)evahjelte.com**20060818161526] +[remove separate asdf module for json-rpc +henrik(a)evahjelte.com**20060922142524] +[symbols encoded by parenscript, 'camel-case becomes "camelCase" +henrik(a)evahjelte.com**20060922142711] +[interning of strings moved to a single function json-intern +henrik(a)evahjelte.com**20060923090745] +[decoding symbols in camelCase becomes camel-case just as in parenscript. +henrik(a)evahjelte.com**20060923091853] +[smarter json-bind allows access to nested objects with dot-notation +henrik(a)evahjelte.com**20060923103021] +[json-bind can take alist as well as string +henrik(a)evahjelte.com**20060923171022] +[bugfix to last json-bind change +henrik(a)evahjelte.com**20060924093311] +[restarts in json-rpc +Henrik Hjelte <henrik(a)evahjelte.com>**20060926135223] +[configurable to allow non-strict json (suggestion by Ben Hyde) +Henrik Hjelte <henrik(a)evahjelte.com>**20061031054156 + set *use-strict-json-rules* to nil if you want to be + generous in what json you accept.. +] +[encode characters as strings, patch by Ken Harris +Henrik Hjelte <henrik(a)evahjelte.com>**20061229094512] +[serious-condition instead of reader-error to trap number overflow +Henrik Hjelte <henrik(a)evahjelte.com>**20061229101705 + SBCL signals reader-error, Allegro signals error. + Serious-condition ought to work on all Lisp implementations +] +[show failures better +Henrik Hjelte <henrik(a)evahjelte.com>**20061229101832] +[simplify test that failed for the wrong reason +Henrik Hjelte <henrik(a)evahjelte.com>**20061229101922] +[json.asd renamed cl-json.asd, asdf cleanup by Pascal Bourguignon +Henrik Hjelte <henrik(a)evahjelte.com>**20070324093357] +[json.test renamed cl-json.test +Henrik Hjelte <henrik(a)evahjelte.com>**20070324095848] +[Failing alist test by Nathan Hawkins +Henrik Hjelte <henrik(a)evahjelte.com>**20070324102326] +[encode-json now tries dotted-list if normal list fails +Henrik Hjelte <henrik(a)evahjelte.com>**20070324110354] +[TAG 0.3.0 +henrik(a)evahjelte.com**20070324141654] +[variable json-symbols-package allows other packages besides keyword for interning json symbols +Henrik Hjelte <henrik(a)evahjelte.com>**20070324115951] +[documentation updated +Henrik Hjelte <henrik(a)evahjelte.com>**20070324122807] +[test for json-symbols-package +Henrik Hjelte <henrik(a)evahjelte.com>**20070324141640] +[version 0.3.1 +Henrik Hjelte <henrik(a)evahjelte.com>**20070324141935] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/inventory =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/inventory 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/inventory 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,9 @@ +Starting with tag: +[TAG 0.3.1 +Henrik Hjelte <henrik(a)evahjelte.com>**20070324142014] +[documented parenscript dependency +Henrik Hjelte <henrik(a)evahjelte.com>**20070325211904] +[restart functions for json-rpc +Henrik Hjelte <henrik(a)evahjelte.com>**20070531134607] +[json-rpc-error-object as in working draft fro json-rpc spec 1.1 +Henrik Hjelte <henrik(a)evahjelte.com>**20070531150713] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060130172648-1073e-418fe73231a10472a503fd6a02be8cd4fb2fae3c.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060130172648-1073e-418fe73231a10472a503fd6a02be8cd4fb2fae3c.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060202142849-1073e-1a01685d86ae410a3daf0517a12b5aefa4ad47e5.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060202142849-1073e-1a01685d86ae410a3daf0517a12b5aefa4ad47e5.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203193308-2eda4-3e8a8b08934e415ee98f432847ba99b2a0f2473b.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203193308-2eda4-3e8a8b08934e415ee98f432847ba99b2a0f2473b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203211337-2eda4-e84b2961e6d77a27f5ad145a8c86e6e1741bff86.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060203211337-2eda4-e84b2961e6d77a27f5ad145a8c86e6e1741bff86.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205110905-2eda4-d75e1b0c3492c980c371f3245f366fca64303c5b.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205110905-2eda4-d75e1b0c3492c980c371f3245f366fca64303c5b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205170525-2eda4-7a1ca0472deb835294a687b38d17c3c7c6fd99bf.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060205170525-2eda4-7a1ca0472deb835294a687b38d17c3c7c6fd99bf.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060218114508-2eda4-19149c99c1e3fa477e9428078c8080f313e15d62.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060218114508-2eda4-19149c99c1e3fa477e9428078c8080f313e15d62.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060222215326-2eda4-45a4ea19782481ca9ac576abd121369f646fbbcd.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060222215326-2eda4-45a4ea19782481ca9ac576abd121369f646fbbcd.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060223090421-2eda4-15cccaa2bee2022dd3fd03c7648749fea1afc94d.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060223090421-2eda4-15cccaa2bee2022dd3fd03c7648749fea1afc94d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060818161526-2eda4-151021eec164a7b52d9a4844bfe6a24c6b8b5a63.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060818161526-2eda4-151021eec164a7b52d9a4844bfe6a24c6b8b5a63.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142524-2eda4-3a71033e3fe281e3f9aa88777045388f6242df3d.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142524-2eda4-3a71033e3fe281e3f9aa88777045388f6242df3d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142711-2eda4-e150e8c262db6cedf82a2b5caed3d7e5aa2c958f.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060922142711-2eda4-e150e8c262db6cedf82a2b5caed3d7e5aa2c958f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923090745-2eda4-2860a46edd40564768cf5a0805a3903063442a08.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923090745-2eda4-2860a46edd40564768cf5a0805a3903063442a08.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923091853-2eda4-f86b21590e38fdb6a4461efe49be66cf33e62cf7.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923091853-2eda4-f86b21590e38fdb6a4461efe49be66cf33e62cf7.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923103021-2eda4-4c1ababe563eafb2829dde088e91471f83d059a4.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923103021-2eda4-4c1ababe563eafb2829dde088e91471f83d059a4.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923171022-2eda4-87a564361d8011f62b557e75b851012c9bc45580.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060923171022-2eda4-87a564361d8011f62b557e75b851012c9bc45580.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060924093311-2eda4-e9f67bed3e76e28d407dcbf02f47c847fb13a077.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060924093311-2eda4-e9f67bed3e76e28d407dcbf02f47c847fb13a077.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060926135223-f2a76-a2fd736ee3105a64d17620c3f7e8c7b961bdc05d.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20060926135223-f2a76-a2fd736ee3105a64d17620c3f7e8c7b961bdc05d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061031054156-f2a76-534fb5a215d2339b2244e01ce64ff840ee52a69a.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061031054156-f2a76-534fb5a215d2339b2244e01ce64ff840ee52a69a.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229094512-f2a76-979034ec4301db8ae7fd3698b4369abbb3aa2cbb.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229094512-f2a76-979034ec4301db8ae7fd3698b4369abbb3aa2cbb.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101705-f2a76-121dfafa63680808271452a8990031095330951b.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101705-f2a76-121dfafa63680808271452a8990031095330951b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101832-f2a76-cb5d7aa34b17526bcf8bffc901f6294eb8b3ef53.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101832-f2a76-cb5d7aa34b17526bcf8bffc901f6294eb8b3ef53.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101922-f2a76-1d8519ead2fbb540ebc80b00a703781043bd7932.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20061229101922-f2a76-1d8519ead2fbb540ebc80b00a703781043bd7932.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324093357-f2a76-c650e69a2e1117bdbb24e22a62a4d39fe37e448f.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324093357-f2a76-c650e69a2e1117bdbb24e22a62a4d39fe37e448f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324095848-f2a76-f6b5ac53bd541b80e1b47cb674f1d9854809dc98.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324095848-f2a76-f6b5ac53bd541b80e1b47cb674f1d9854809dc98.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324102326-f2a76-3818038b2f27315270dc4e37c067cd43d98cf20d.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324102326-f2a76-3818038b2f27315270dc4e37c067cd43d98cf20d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324110354-f2a76-d5cde7675cc1c97b68378a778f44eefd916be442.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324110354-f2a76-d5cde7675cc1c97b68378a778f44eefd916be442.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324115951-f2a76-47dba0b50ae12cedb7028aff812c06414fc022da.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324115951-f2a76-47dba0b50ae12cedb7028aff812c06414fc022da.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324122807-f2a76-cf483ee81e42710a183e3c82fb54165a64ef6aca.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324122807-f2a76-cf483ee81e42710a183e3c82fb54165a64ef6aca.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141640-f2a76-131280f2336bfab387055306ecf88f2b48cbae53.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141640-f2a76-131280f2336bfab387055306ecf88f2b48cbae53.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141654-2eda4-2589cb490ac521aa79509558bd0cb13916e6e51d.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141654-2eda4-2589cb490ac521aa79509558bd0cb13916e6e51d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141935-f2a76-0439a3725d93d42526a2c9d3ec4c821b93b8b771.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324141935-f2a76-0439a3725d93d42526a2c9d3ec4c821b93b8b771.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070324142014-f2a76-a446e4d7a4ca95e1e4cffcd7f83f62b0810c94d3.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070325211904-f2a76-9a9667b1214cb27a87a1fdcc6ce1cf740122b193.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070325211904-f2a76-9a9667b1214cb27a87a1fdcc6ce1cf740122b193.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531134607-f2a76-04005616b0614ac5bb6190289a43227d24ff648f.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531134607-f2a76-04005616b0614ac5bb6190289a43227d24ff648f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531150713-f2a76-7d556dae2e116b5d8bc955931afe84e602733c37.gz =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cl-json/_darcs/patches/20070531150713-f2a76-7d556dae2e116b5d8bc955931afe84e602733c37.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/binaries =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/binaries 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/binaries 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,39 @@ +# Binary file regexps: +\.png$ +\.PNG$ +\.gz$ +\.GZ$ +\.pdf$ +\.PDF$ +\.jpg$ +\.JPG$ +\.gif$ +\.GIF$ +\.tar$ +\.TAR$ +\.bz2$ +\.BZ2$ +\.z$ +\.Z$ +\.zip$ +\.ZIP$ +\.jar$ +\.JAR$ +\.so$ +\.SO$ +\.a$ +\.A$ +\.tgz$ +\.TGZ$ +\.jpeg$ +\.JPEG$ +\.mpg$ +\.MPG$ +\.mpeg$ +\.MPEG$ +\.iso$ +\.ISO$ +\.exe$ +\.EXE$ +\.doc$ +\.DOC$ Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/boring =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/boring 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/boring 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,34 @@ +# Boring file regexps: +\.hi$ +\.o$ +\.o\.cmd$ +# *.ko files aren't boring by default because they might +# be Korean translations rather than kernel modules. +# \.ko$ +\.ko\.cmd$ +\.mod\.c$ +(^|/)\.tmp_versions($|/) +(^|/)CVS($|/) +(^|/)RCS($|/) +~$ +#(^|/)\.[^/] +(^|/)_darcs($|/) +\.bak$ +\.BAK$ +\.orig$ +(^|/)vssver\.scc$ +\.swp$ +(^|/)MT($|/) +(^|/)\{arch\}($|/) +(^|/).arch-ids($|/) +(^|/), +\.class$ +\.prof$ +(^|/)\.DS_Store$ +(^|/)BitKeeper($|/) +(^|/)ChangeSet($|/) +(^|/)\.svn($|/) +\.py[co]$ +\# +\.cvsignore$ +(^|/)Thumbs\.db$ Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/defaultrepo =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/defaultrepo 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/defaultrepo 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +http://common-lisp.net/project/cl-json/darcs/cl-json Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/motd =================================================================== Added: branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/repos =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/repos 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/_darcs/prefs/repos 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +http://common-lisp.net/project/cl-json/darcs/cl-json Added: branches/trunk-reorg/thirdparty/cl-json/cl-json.asd =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/cl-json.asd 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/cl-json.asd 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,41 @@ +;;; -*- lisp -*- + +(in-package #:cl-user) + +(defpackage #:json-system + (:use #:cl #:asdf)) + +(in-package #:json-system) + +(defsystem :cl-json + :name "cl-json" + :description "JSON in Lisp. JSON (JavaScript Object Notation) is a lightweight data-interchange format." + :version "0.3.2" + :author "Henrik Hjelte <henrik(a)evahjelte.com>" + :licence "MIT" + :components ((:static-file "cl-json.asd") + (:module :src + :components ((:file "package") + (:file "common" :depends-on ("package")) + (:file "decoder" :depends-on ("common")) + (:file "encoder" :depends-on ("common")) + (:file "utils" :depends-on ("decoder" "encoder")) + (:file "json-rpc" :depends-on ("package" "common" "utils" "encoder" "decoder"))))) + :depends-on (:parenscript)) + +(defsystem :cl-json.test + :depends-on (:cl-json :fiveam ) + :components ((:module :t + :components ((:file "package") + (:file "testjson" :depends-on ("package" "testdecoder" "testencoder" "testmisc")) + (:file "testmisc" :depends-on ("package" "testdecoder" "testencoder")) + (:file "testdecoder" :depends-on ("package")) + (:file "testencoder" :depends-on ("package")))))) + +;; Copyright (c) 2006 Henrik Hjelte +;; +;; 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. \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/doc/index.html =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/doc/index.html 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/doc/index.html 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,98 @@ +<?xml version="1.0"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>CL-JSON</title> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> +</head> + +<body> + <div class="header"> + <h1>CL-JSON</h1> + <h2>A JSON parser and generator in Common-Lisp.</h2> + + </div> + + <h3>What is JSON?</h3> + +<p><a href="http://www.json.org">JSON</a> is a language independent text format for data-interchange. JSON is especially convenient in web applications, since it is a subset of the literal object notation of <a href="http://www.json.org/js.html">ECMAScript</a>. It can also be an alternative to XML. JSON has good open-source support in many languages.</p> +<h3>Why not use XML instead?</h3> +<li>Some find JSON lighter and more simple, see this <a href="http://www.json.org/xml.html">comparison.</a></li> +<h3>Why not use s-expressions instead?</h3> +<ul> +<li>Many people find parentheses difficult, but brackets and braces easy. That has led to many implementations of JSON. There is no format based on s-expressions implemented in over 20 languages (yet!).</li> +<li>A simple and very fast JSON parser in JavaScript looks like this:<pre>eval('(' + aJSONtext + ')')</pre> +Even a seasoned lisper may find it difficult to make a shorter JavaScript parser for s-expressions.</li> +</ul> + + <h3>Mailing Lists</h3> + <ul> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-json-devel"> + cl-json-devel</a><br/>for developers and users.</li> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-json-announce"> + cl-json-announce</a><br/>for announcements.</li> + + </ul> + <h3>Documentation</h3> + <p> + You can use any of these functions: + <pre> + decode-json + decode-json-strict + decode-json-from-string + encode-json + encode-json-to-string + + json-bind, use like this: + +(test test-json-bind + (json-bind (hello hi ciao) "{\"hello\":100,\"hi\":5}" + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao)))</pre> + + Json-rpc, implements the json-rpc specification. Easily add it to your favourite webserver. + <pre> + defun-json-rpc + export-as-json-rpc + clear-exported + invoke-rpc + </pre> + Tweaking + <pre> + *json-symbols-package* Default keyword, set to a package or nil for current package. + *json-object-factory* Change how objects are decoded to Lisp. + *use-strict-json-rules* + </pre> + + For examples, see the <a href="http://common-lisp.net/project/bese/FiveAM.html">FiveAM</a> based testcases. + + </p> + <h3>Where is it</h3> + <p>A <a href="http://www.darcs.net/">Darcs</a> repository is available.<pre>darcs get http://common-lisp.net/project/cl-json/darcs/cl-json +</pre> + <p>The latest release can be downloaded <a href="http://www.cliki.net/cl-json">here</a>.</p> + <p>You can also install it by asdf-install.</p> + <p>History has shown that the darcs version is probably better than the latest release.</p> + <h3>Dependencies</h3> + cl-json now depends on <a href="http://parenscript.org">parenscript</a> for some functions. + <pre> darcs get http://common-lisp.net/project/ucw/repos/parenscript </pre> + + <h3>License</h3> + <p>MIT-license</p> + <div class="footer"> + <p>Henrik Hjelte</p> 2. Feb. 2006, updated 25 march 2007. + </div> + + <div class="check"> + <a href="http://validator.w3.org/check/referer"> + Valid XHTML 1.0 Strict</a> + </div + </body> +</html> Added: branches/trunk-reorg/thirdparty/cl-json/doc/style.css =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/doc/style.css 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/doc/style.css 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,60 @@ +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + background-color: #336699; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + background-color: #336699; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + background-color: #336699; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + background-color: #FFFFFF; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + background-color: #FFFFFF; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + background-color: #FFFFFF; + text-decoration:underline; } + Added: branches/trunk-reorg/thirdparty/cl-json/src/common.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/common.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/common.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,24 @@ +(in-package :json) + +(defparameter *json-lisp-escaped-chars* + `((#\" . #\") + (#\\ . #\\) + (#\/ . #\/) + (#\b . #\Backspace) + (#\f . ,(code-char 12)) + (#\n . #\Newline) + (#\r . #\Return) + (#\t . #\Tab))) + +(defparameter *use-strict-json-rules* t) + +(defun json-escaped-char-to-lisp(json-escaped-char) + (let ((ch (cdr (assoc json-escaped-char *json-lisp-escaped-chars*)))) + (if *use-strict-json-rules* + (or ch (error 'json-parse-error)) + (or ch json-escaped-char)))) + +(defun lisp-special-char-to-json(lisp-char) + (car (rassoc lisp-char *json-lisp-escaped-chars*))) + + Added: branches/trunk-reorg/thirdparty/cl-json/src/decoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/decoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/decoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,163 @@ +(in-package :json) + +(defvar *json-symbols-package* (find-package 'keyword) "The package where json-symbols are interned. Default keyword, nil = current package") + +(defun json-intern (string) + (if *json-symbols-package* + (intern (camel-case-to-lisp string) *json-symbols-package*) + (intern (camel-case-to-lisp string)))) + +(defparameter *json-rules* nil) + +(defparameter *json-object-factory* #'(lambda () nil)) +(defparameter *json-object-factory-add-key-value* #'(lambda (obj key value) + (push (cons (json-intern key) value) + obj))) +(defparameter *json-object-factory-return* #'(lambda (obj) (nreverse obj))) +(defparameter *json-make-big-number* #'(lambda (number-string) (format nil "BIGNUMBER:~a" number-string))) + +(define-condition json-parse-error (error) ()) + +(defun decode-json-from-string (json-string) + (with-input-from-string (stream json-string) + (decode-json stream))) + +(defun decode-json (&optional (stream *standard-input*)) + "Reads a json element from stream" + (funcall (or (cdr (assoc (peek-char t stream) *json-rules*)) + #'read-json-number) + stream)) + +(defun decode-json-strict (&optional (stream *standard-input*)) + "Only objects or arrays on top level, no junk afterwards." + (assert (member (peek-char t stream) '(#\{ #\[))) + (let ((object (decode-json stream))) + (assert (eq :no-junk (peek-char t stream nil :no-junk))) + object)) + +;;----------------------- + + +(defun add-json-dispatch-rule (character fn) + (push (cons character fn) *json-rules*)) + +(add-json-dispatch-rule #\t #'(lambda (stream) (read-constant stream "true" t))) + +(add-json-dispatch-rule #\f #'(lambda (stream) (read-constant stream "false" nil))) + +(add-json-dispatch-rule #\n #'(lambda (stream) (read-constant stream "null" nil))) + +(defun read-constant (stream expected-string ret-value) + (loop for x across expected-string + for ch = (read-char stream nil nil) + always (char= ch x) + finally (return ret-value))) + +(defun read-json-string (stream) + (read-char stream) + (let ((val (read-json-chars stream '(#\")))) + (read-char stream) + val)) + +(add-json-dispatch-rule #\" #'read-json-string) + +(defun read-json-object (stream) + (read-char stream) + (let ((obj (funcall *json-object-factory*))) + (if (char= #\} (peek-char t stream)) + (read-char stream) + (loop for skip-whitepace = (peek-char t stream) + for key = (read-json-string stream) + for separator = (peek-char t stream) + for skip-separator = (assert (char= #\: (read-char stream))) + for value = (decode-json stream) + for terminator = (peek-char t stream) + for skip-terminator = (assert (member (read-char stream) '(#\, #\}))) + do (setf obj (funcall *json-object-factory-add-key-value* obj key value)) + until (char= #\} terminator))) + (funcall *json-object-factory-return* obj))) + +(add-json-dispatch-rule #\{ #'read-json-object) + +(defun read-json-array (stream) + (read-char stream) + (if (char= #\] (peek-char t stream)) + (progn (read-char stream) nil) + (loop for first-in-element = (assert (not (member (peek-char t stream) '(#\, #\])))) + for element = (decode-json stream) + for terminator = (peek-char t stream) + for skip-terminator = (assert (member (read-char stream) '(#\, #\]))) + collect element + until (char= #\] terminator)))) + +(add-json-dispatch-rule #\[ #'read-json-array) + +(defparameter *digits* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(defparameter *json-number-valid-chars* (concatenate 'list *digits* '(#\e #\E #\. #\+ #\-))) + +(defun read-json-number (stream) + (let ((number-string (read-chars-until stream + :terminator-fn #'(lambda (ch) + (not (member ch *json-number-valid-chars*)))))) + (assert (if (char= (char number-string 0) #\0) + (or (= 1 (length number-string)) (char= #\. (char number-string 1))) + t)) + (handler-case + (read-from-string number-string) + (serious-condition (e) + (let ((e-pos (or (position #\e number-string) + (position #\E number-string)))) + (if e-pos + (handler-case + (read-from-string (substitute #\l (aref number-string e-pos) number-string)) + (serious-condition () + (funcall *json-make-big-number* number-string))) + (error "Unexpected error ~S" e))))))) + +(defun read-chars-until(stream &key terminator-fn (char-converter #'(lambda (ch stream) + (declare (ignore stream)) + ch))) + (with-output-to-string (ostr) + (loop + (let ((ch (peek-char nil stream nil nil))) + (when (or (null ch) + (funcall terminator-fn ch)) + (return)) + (write-char (funcall char-converter + (read-char stream nil nil) + stream) + ostr))))) + +(defun read-n-chars (stream n) + (with-output-to-string (ostr) + (dotimes (x n) + (write-char (read-char stream) ostr)))) + +(defun read-json-chars(stream terminators) + (read-chars-until stream :terminator-fn #'(lambda (ch) + (member ch terminators)) + :char-converter #'(lambda (ch stream) + (if (char= ch #\\) + (if (char= #\u (peek-char nil stream)) + (code-char (parse-integer (read-n-chars stream 5) :start 1 :radix 16)) + (json-escaped-char-to-lisp (read-char stream))) + ch)))) + +(defun camel-case-to-lisp (string) + "Converts a string in camelCase to the same lisp-friendly syntax used in parenscript. + +(camel-case-to-string \"camelCase\") -> \"CAMEL-CASE\" +(camel-case-to-string \"CamelCase\") -> \"*CAMEL-CASE\" +(camel-case-to-string \"dojo.widget.TreeNode\") -> \"DOJO.WIDGET.*TREE-NODE\" +" + (with-output-to-string (out) + (loop for ch across string + with last-char do + (if (upper-case-p ch) + (progn + (if (and last-char (lower-case-p last-char)) + (write-char #\- out) + (write-char #\* out)) + (write-char ch out)) + (write-char (char-upcase ch) out)) + (setf last-char ch)))) Added: branches/trunk-reorg/thirdparty/cl-json/src/encoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/encoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/encoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,112 @@ +(in-package :json) + +(defparameter *symbol-to-string-fn* #'js::symbol-to-js) + +(defgeneric encode-json (object stream)) + +(defun encode-json-to-string(object) + (with-output-to-string (stream) + (encode-json object stream))) + +(defmethod encode-json((nr number) stream) + (write-json-number nr stream)) + +(defmethod encode-json((s string) stream) + (write-json-string s stream)) + +(defmethod encode-json ((c character) stream) + "JSON does not define a character type, we encode characters as strings." + (encode-json (string c) stream)) + +(defmethod encode-json((s symbol) stream) + (cond + ((null s) (write-json-chars "null" stream)) + ((eq 't s) (write-json-chars "true" stream)) + (t (write-json-string (funcall *symbol-to-string-fn* s) stream)))) + +(defmethod encode-json((s list) stream) + (handler-case + (write-string (with-output-to-string (temp) + (call-next-method s temp)) + stream) + (type-error (e) + (declare (ignore e)) + (encode-json-alist s stream)))) + +(defmethod encode-json((s sequence) stream) + (let ((first-element t)) + (write-char #\[ stream) + (map nil #'(lambda (element) + (if first-element + (setf first-element nil) + (write-char #\, stream)) + (encode-json element stream)) + s) + (write-char #\] stream))) + +(defmacro write-json-object (generator-fn stream) + (let ((strm (gensym)) + (first-element (gensym))) + `(let ((,first-element t) + (,strm ,stream)) + (write-char #\{ ,strm) + (loop + (multiple-value-bind (more name value) + (,generator-fn) + (unless more (return)) + (if ,first-element + (setf ,first-element nil) + (write-char #\, ,strm)) + (encode-json name ,strm) + (write-char #\: ,strm) + (encode-json value ,strm))) + (write-char #\} ,strm)))) + +(defmethod encode-json((h hash-table) stream) + (with-hash-table-iterator (generator h) + (write-json-object generator stream))) + +(defmacro with-alist-iterator ((generator-fn alist) &body body) + (let ((stack (gensym))) + `(let ((,stack (copy-alist ,alist))) + (flet ((,generator-fn () + (let ((cur (pop ,stack))) + (if cur + (values t (car cur) (cdr cur)) + nil)))) + ,@body)))) + +(defun encode-json-alist (alist stream) + (with-alist-iterator (gen-fn alist) + (write-json-object gen-fn stream))) + +(defun encode-json-alist-to-string(alist) + (with-output-to-string (stream) + (encode-json-alist alist stream))) + + +(defun write-json-string (s stream) + (write-char #\" stream) + (if (stringp s) + (write-json-chars s stream) + (encode-json s stream)) + (write-char #\" stream)) + +(defun write-json-chars (s stream) + (declare (inline lisp-special-char-to-json)) + (loop for ch across s + for code = (char-code ch) + for special = (lisp-special-char-to-json ch) + do + (cond + ((and special (not (char= special #\/))) + (write-char #\\ stream) + (write-char special stream)) + ((<= code #x1f) + (format stream "\\u~4,'0x" code)) + (t (write-char ch stream))))) + +(defun write-json-number (nr stream) + (if (integerp nr) + (format stream "~d" nr) + (format stream "~f" nr))) Added: branches/trunk-reorg/thirdparty/cl-json/src/json-rpc.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/json-rpc.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/json-rpc.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,79 @@ +(in-package :json-rpc) + +;; http://json-rpc.org/wiki/specification +;; http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html + +(defvar *json-rpc-functions* (make-hash-table :test #'equal)) + +(defun clear-exported () + (clrhash *json-rpc-functions*)) + +(defmacro defun-json-rpc (name lambda-list &body body) + "Defines a function and registers it as a json-rpc target." + `(progn + (defun ,name ,lambda-list ,@body) + (export-as-json-rpc #',name (string-downcase (symbol-name ',name))))) + +(defun export-as-json-rpc (func function-name) + (setf (gethash function-name *json-rpc-functions*) func)) + +(defun make-rpc-response (&key result error id) + "When the method invocation completes, the service must reply with a response. The response is a single object serialized using JSON. + +It has three properties: + + * result - The Object that was returned by the invoked method. This must be null in case there was an error invoking the method. + * error - An Error object(unspecified in json-rpc 1.0) if there was an error invoking the method. Null if there was no error. + * id - This must be the same id as the request it is responding to. " + (json:encode-json-alist-to-string + `((:result . ,result) + (:error . ,error) + (:id . ,id)))) + +(defun make-json-rpc-error-object-1.1 (message &key code error-object) + "This code is based on the Working Draft 7 August 2006 of Json-rpc 1.1 specification. + http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html +" + (let ((eo `((:name . "JSONRPCError") + (:code . ,(or code 999)) + (:message . ,message)))) + (if error-object + (append eo `((:error . ,error-object))) + eo))) + +(defun invoke-rpc (json-string) + "A remote method is invoked by sending a request to a remote service. The request is a single object serialized using JSON. + +It has three properties: + + * method - A String containing the name of the method to be invoked. + * params - An Array of objects to pass as arguments to the method. + * id - The request id. This can be of any type. It is used to match the response with the request that it is replying to. " + (json-bind (method params id) json-string + (restart-case + (let ((func (gethash method *json-rpc-functions*))) + (if func + (make-rpc-response :id id :result (restart-case (apply func params) + (use-value (value) + value))) + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 "Procedure not found")))) + (send-error (message &optional code error-object) + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 message + :code code + :error-object error-object))) + (send-error-object (error-object) + (make-rpc-response :id id :error error-object)) + (send-nothing () + nil) + (send-internal-error () + (make-rpc-response :id id :error (make-json-rpc-error-object-1.1 "Service error")))))) + +(defmacro def-restart (restart-name &rest (params)) + `(defun ,restart-name (,@params &optional condition) + (let ((restart (find-restart ',restart-name condition))) + (invoke-restart restart ,@params)))) + +(def-restart send-error (errmsg code)) +(def-restart send-error-object (errobject)) +(def-restart send-nothing ()) +(def-restart send-internal-error ()) Added: branches/trunk-reorg/thirdparty/cl-json/src/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/package.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,38 @@ +(defpackage :json + (:use :common-lisp) + (:export + #:*json-symbols-package* + #:*json-object-factory* + #:*json-object-factory-add-key-value* + #:*json-object-factory-return* + #:*json-make-big-number* + + #:decode-json + #:decode-json-strict + #:decode-json-from-string + + #:*use-strict-json-rules* + #:json-parse-error + + #:encode-json + #:encode-json-to-string + #:encode-json-alist + #:encode-json-alist-to-string + + #:json-bind + )) + +(defpackage :json-rpc + (:use :common-lisp :json) + (:export + #:clear-exported + #:defun-json-rpc + #:export-as-json-rpc + #:invoke-rpc + + ;; restarts + #:send-error + #:send-error-object + #:send-nothing + #:send-internal-error + )) Added: branches/trunk-reorg/thirdparty/cl-json/src/utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/src/utils.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/src/utils.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,47 @@ +(in-package :json) + +;; helpers for json-bind +(defun cdas(item alist) + "Alias for (cdr (assoc item alist))" + (cdr (assoc item alist))) + +(defun last1 (lst) + (first (last lst))) + +(defmacro assoc-lookup (&rest lookuplist) + "(assoc-lookup :x :y alist) => (cdr (assoc :y (cdr (assoc :x alist))))" + (let ((alist-form (last1 lookuplist)) + (lookups (reverse (butlast lookuplist)))) + (labels ((mk-assoc-lookup (lookuplist) + (if lookuplist + `(cdas ,(first lookuplist) ,(mk-assoc-lookup (rest lookuplist))) + alist-form))) + (mk-assoc-lookup lookups)))) + +(defmacro json-bind (vars json-string-or-alist &body body) + (labels ((symbol-as-string (symbol) + (string-downcase (symbol-name symbol))) + (split-by-dots (string) + (loop for ch across string + with x + with b + do (if (char= #\. ch) + (progn + (push (concatenate 'string (nreverse b)) x) + (setf b nil)) + (push ch b)) + finally (progn + (push (concatenate 'string (nreverse b)) x) + (return (nreverse x))))) + (lookup-deep (variable) + (mapcar #'json-intern (split-by-dots (symbol-as-string variable))))) + (let ((a-list (gensym))) + `(let ((,a-list (if (stringp ,json-string-or-alist) + (decode-json-from-string ,json-string-or-alist) + ,json-string-or-alist))) + (let ,(loop for v in vars collect `(,v (assoc-lookup ,@(lookup-deep v) + ,a-list))) + ,@body))))) + + + Added: branches/trunk-reorg/thirdparty/cl-json/t/fail1.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail1.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail1.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +"A JSON payload should be an object or array, not a string." \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail10.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail10.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail10.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Extra value after close": true} "misplaced quoted value" \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail11.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail11.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail11.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Illegal expression": 1 + 2} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail12.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail12.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail12.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Illegal invocation": alert()} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail13.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail13.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail13.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Numbers cannot have leading zeroes": 013} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail14.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail14.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail14.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Numbers cannot be hex": 0x14} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail15.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail15.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail15.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \x15"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail16.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail16.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail16.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \'"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail17.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail17.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail17.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Illegal backslash escape: \017"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail18.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail18.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail18.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail19.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail19.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail19.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Missing colon" null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail2.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail2.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail2.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Unclosed array" \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail20.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail20.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail20.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Double colon":: null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail21.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail21.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail21.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Comma instead of colon", null} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail22.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail22.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail22.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Colon instead of comma": false] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail23.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail23.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail23.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Bad value", truth] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail24.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail24.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail24.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +['single quote'] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail3.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail3.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail3.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{unquoted_key: "keys must be quoted} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail4.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail4.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail4.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["extra comma",] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail5.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail5.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail5.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["double extra comma",,] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail6.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail6.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail6.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[ , "<-- missing value"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail7.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail7.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail7.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Comma after the close"], \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail8.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail8.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail8.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +["Extra close"]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/fail9.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/fail9.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/fail9.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +{"Extra comma": true,} \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/package.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,5 @@ +(defpackage :json-test + (:use :json :json-rpc :common-lisp :5am )) + +(in-package :json-test) +(def-suite json) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/pass1.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/pass1.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/pass1.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,56 @@ +[ + "JSON Test Pattern pass1", + {"object with 1 member":["array with 1 element"]}, + {}, + [], + -42, + true, + false, + null, + { + "integer": 1234567890, + "real": -9876.543210, + "e": 0.123456789e-12, + "E": 1.234567890E+34, + "": 23456789012E666, + "zero": 0, + "one": 1, + "space": " ", + "quote": "\"", + "backslash": "\\", + "controls": "\b\f\n\r\t", + "slash": "/ & \/", + "alpha": "abcdefghijklmnopqrstuvwyz", + "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", + "digit": "0123456789", + "special": "`1~!@#$%^&*()_+-={':[,]}|;.</>?", + "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", + "true": true, + "false": false, + "null": null, + "array":[ ], + "object":{ }, + "address": "50 St. James Street", + "url": "http://www.JSON.org/", + "comment": "// /*  */": " ", + " s p a c e d " :[1,2 , 3 + +, + +4 , 5 , 6 ,7 ], + "compact": [1,2,3,4,5,6,7], + "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", + "quotes": "" \u0022 %22 0x22 034 "", + "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" +: "A key can be any string" + }, + 0.5 ,98.6 +, +99.44 +, + +1066 + + +,"rosebud"] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/pass2.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/pass2.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/pass2.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1 @@ +[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]] \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/pass3.json =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/pass3.json 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/pass3.json 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,6 @@ +{ + "JSON Test Pattern pass3": { + "The outermost value": "must be an object or array.", + "In this test": "It is an object." + } +} Added: branches/trunk-reorg/thirdparty/cl-json/t/testdecoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/testdecoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/testdecoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,177 @@ +(in-package :json-test) + +(in-suite json) + +;; Test decoder + +(test json-literal + (is-true (decode-json-from-string " true")) + (is-true (decode-json-from-string " true ")) + (is-true (decode-json-from-string "true ")) + (is-true (decode-json-from-string "true")) + (is-false (decode-json-from-string "trUe ")) + (is-false (decode-json-from-string "false")) + (is-false (decode-json-from-string "null")) + ) + +(test json-string + (is (string= "hello" + (decode-json-from-string " \"hello\""))) + (is (string= "new-line +returned!" + (decode-json-from-string "\"new-line\\nreturned!\""))) + (is (string= (make-string 1 :initial-element (code-char (+ (* 10 16) 11))) + (decode-json-from-string " \"\\u00ab\"")))) + +(test json-array + (is (equalp + '("hello" "hej" "ciao") + (decode-json-from-string " [ \"hello\", \"hej\", + \"ciao\" ]"))) + (is (equalp '(1 2 3) + (decode-json-from-string "[1,2,3]"))) + (is (equalp '(t nil nil) + (decode-json-from-string "[true,null,false]"))) + (is-false (decode-json-from-string "[]"))) + +(test json-object + (is (equalp '((:hello . "hej") + (:hi . "tjena")) + (decode-json-from-string " { \"hello\" : \"hej\" , + \"hi\" : \"tjena\" + }"))) + (is-false (decode-json-from-string " { } ")) + (is-false (decode-json-from-string "{}"))) + +(test json-object-factory + (let ((*json-object-factory* #'(lambda () + (make-hash-table))) + (*json-object-factory-add-key-value* #'(lambda (obj key value) + (setf (gethash (intern (string-upcase key)) obj) + value) + obj)) + (*json-object-factory-return* #'identity) + obj) + (setf obj (decode-json-from-string " { \"hello\" : \"hej\" , + \"hi\" : \"tjena\" + }")) + (is (string= "hej" (gethash 'hello obj))) + (is (string= "tjena" (gethash 'hi obj))))) + +(test json-object-camel-case + (is (equalp '((:hello-key . "hej") + (:*hi-starts-with-upper-case . "tjena")) + (decode-json-from-string " { \"helloKey\" : \"hej\" , + \"HiStartsWithUpperCase\" : \"tjena\" + }")))) + + + + +(test json-number + (is (= (decode-json-from-string "100") 100)) + (is (= (decode-json-from-string "10.01") 10.01)) + (is (= (decode-json-from-string "-2.3") -2.3)) + (is (= (decode-json-from-string "-2.3e3") -2.3e3)) + (is (= (decode-json-from-string "-3e4") -3e4)) + (is (= (decode-json-from-string "3e4") 3e4)) + #+sbcl + (is (= (decode-json-from-string "2e40") 2d40));;Coerced to double + (is (equalp (decode-json-from-string "2e444") (funcall *json-make-big-number* "2e444")))) + +(defparameter *json-test-files-path* *load-pathname*) + +(defun test-file (name) + (make-pathname :name name :type "json" :defaults *json-test-files-path*)) + +(defun decode-file (path) + (with-open-file (stream path + :direction :input) + (decode-json-strict stream))) + +;; All test files are taken from http://www.crockford.com/JSON/JSON_checker/test/ + +(test pass-1 + (decode-file (test-file "pass1"))) + +(test pass-2 + (decode-file (test-file "pass2"))) + +(test pass-3 + (decode-file (test-file "pass3"))) + +(defparameter *ignore-tests* '( + 1 ; says: "A JSON payload should be an object or array, not a string.", but who cares? + 7 ; says: ["Comma after the close"], ,but decode-file stops parsing after one object has been retrieved + 8 ; says ["Extra close"]] ,but decode-file stops parsing after one object has been retrieved + 10; says {"Extra value after close": true} "misplaced quoted value", but + ; decode-file stops parsing after one object has been retrieved + 18; says [[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]], but there is no formal limit +)) + +(defparameter *ignore-tests-strict* '( + 18; says [[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]], but there is no formal limit +)) + +(test fail-files + (dotimes (x 24) + (if (member x *ignore-tests-strict*) + (is-true t) + (5am:signals error + (decode-file (test-file (format nil "fail~a" x))))))) + +(defun contents-of-file(file) + (with-open-file (stream file :direction :input) + (let ((s (make-string (file-length stream)))) + (read-sequence s stream) + s))) + +(test decoder-performance + (let* ((json-string (contents-of-file (test-file "pass1"))) + (chars (length json-string)) + (count 1000)) + (format t "Decoding ~a varying chars from memory ~a times." chars count) + (time + (dotimes (x count) + (let ((discard-soon (decode-json-from-string json-string))) + (funcall #'identity discard-soon))))));Do something so the compiler don't optimize too much + +;;#+when-u-want-profiling +;;(defun profile-decoder-performance() +;; #+sbcl +;; (progn +;; (let ((json-string (contents-of-file (test-file "pass1"))) +;; (count 10)) +;; (format t "Parsing test-file pass1 from memory ~a times." count) +;; (sb-sprof:with-profiling () +;; (dotimes (x count) +;; (let ((discard-soon (decode-json-from-string json-string))) +;; (funcall #'identity discard-soon)))) +;; (sb-sprof:report) +;; nil))) + +(test non-strict-json + (let ((not-strictly-valid "\"right\\'s of man\"")) + (5am:signals json:json-parse-error + (json:decode-json-from-string not-strictly-valid)) + (let ((*use-strict-json-rules* nil)) + (declare (special *use-strict-json-rules*)) + (is (string= (json:decode-json-from-string not-strictly-valid) + "right's of man"))))) + +(test test*json-symbols-package* + (let ((*json-symbols-package* nil) + x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :json-test)))) + (let ((*json-symbols-package* (find-package :cl-user)) + x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :cl-user)))) + (let (x) + (setf x (decode-json-from-string "{\"x\":1}")) + (is (equal (symbol-package (caar x)) + (find-package :keyword))))) + Added: branches/trunk-reorg/thirdparty/cl-json/t/testencoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/testencoder.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/testencoder.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,200 @@ +(in-package :json-test) +(in-suite json) + +(defmacro with-objects-as-hashtables(&body body) + ;;For testing, keys are stored as strings + `(let ((*json-object-factory* #'(lambda () + (make-hash-table :test #'equalp ))) + (*json-object-factory-add-key-value* #'(lambda (obj key value) + (setf (gethash key obj) + value) + obj)) + (*json-object-factory-return* #'identity)) + ,@body)) + +(test json-string() + (is (string= (encode-json-to-string (format nil "hello~&hello")) + "\"hello\\nhello\"")) + (is (string= (encode-json-to-string (format nil "\"aquote")) + "\"\\\"aquote\""))) + +(test json-literals + (is (string= "true" (encode-json-to-string t))) + (is (string= "null" (encode-json-to-string nil)))) + +(defun is-same-number(nr) + "If it gets decoded back ok then it was encoded ok" + (is (= nr (decode-json-from-string (encode-json-to-string nr))))) + +(test json-number + (is (string= "0" (encode-json-to-string 0))) + (is (string= "13" (encode-json-to-string 13))) + (is (string= "13.02" (encode-json-to-string 13.02))) + + (is-same-number 2e10) + (is-same-number -1.3234e-10) + (is-same-number -1280.12356) + (is-same-number 1d2) + (is-same-number 1l2) + (is-same-number 1s2) + (is-same-number 1f2) + (is-same-number 1e2)) + +(defun decode-then-encode (json) + (with-objects-as-hashtables + (assert (member (elt json 0) '(#\{ #\[ #\" ))) ;must be json + (flet ((normalize (string) + (remove #\Newline (remove #\Space string)))) + (let* ((decoded (decode-json-from-string json)) + (encoded (encode-json-to-string decoded))) +;; (format t "Json:~a~&" json) +;; (format t "Encoded:~a" encoded) + (is (string= (normalize json) + (normalize encoded))))))) + +(test test-encode-json-nathan-hawkins + (let ((foo '((a . 1) (b . 2) (c . 3)))) + (is (string= (encode-json-to-string foo) + "{\"a\":1,\"b\":2,\"c\":3}")))) + +(test test-encode-json-alist + (let ((alist `((:HELLO . 100)(:hi . 5))) + (expected "{\"hello\":100,\"hi\":5}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-two + (let ((alist `((HELLO . 100)(hi . 5))) + (expected "{\"hello\":100,\"hi\":5}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-string + (let ((alist `((:hello . "hej")(:hi . "tjena"))) + (expected "{\"hello\":\"hej\",\"hi\":\"tjena\"}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test test-encode-json-alist-camel-case + (let ((alist `((:hello-message . "hej")(*also-starting-with-upper . "hej"))) + (expected "{\"helloMessage\":\"hej\",\"AlsoStartingWithUpper\":\"hej\"}")) + (is (string= (with-output-to-string (s) (encode-json-alist alist s)) + expected)))) + +(test encode-pass-2 + (decode-then-encode "[[[[[[[[[[[[[[[[[[[\"Not too deep\"]]]]]]]]]]]]]]]]]]]")) + +(test encode-pass-3 + (decode-then-encode "{ + \"JSON Test Pattern pass3\": { + \"The outermost value\": \"must be an object or array.\" + } +} +")) + +;; Test inspired by the file pass1. +;; There are too many small differences just to decode-encode the whole pass1 file, +;; Instead the difficult parts are in separate tests below. + +(test controls + (decode-then-encode "\"\\\\b\\\\f\\\\n\\\\r\\\\\"")) + +(test slash + (let* ((z "\"/ & /\"") + (also-z "\"/ & \/\"") ;Extra quote + (x (encode-json-to-string z)) + (also-x (encode-json-to-string also-z)) + (y (decode-json-from-string x)) + (also-y (decode-json-from-string also-x))) + (is (string= x also-x)) + (is (string= y also-y)) + (is (string= z y)))) + + +(test quoted + (decode-then-encode "\"" %22 0x22 034 "\"")) + +(test alpha-1 + (decode-then-encode "\"abcdefghijklmnopqrstuvwyz\"")) + +(test alpha-2 + (decode-then-encode "\"ABCDEFGHIJKLMNOPQRSTUVWYZ\"")) + +(test digit + (decode-then-encode "\"0123456789\"")) + +(test special + (decode-then-encode "\"`1~!@#$%^&*()_+-={':[,]}|;.</>?\"")) + +(test hex + (decode-then-encode "\"\u0123\u4567\u89AB\uCDEF\uabcd\uef4A\"")) + +(test true + (decode-then-encode "[ true]")) + +(test false + (is (string= (encode-json-to-string (decode-json-from-string "[false]")) + "[null]")));;We dont separate between false and null +(test null + (decode-then-encode "[null]")) + +(test array + ;;Since empty lists becomes nil in lisp, they are converted back to null + (is (string= (encode-json-to-string (decode-json-from-string "[ ]")) + "null")) + ;;But you can use vectors + (is (string= (encode-json-to-string (vector 1 2)) + "[1,2]"))) + +(test character + ;;Characters are encoded to strings, but when decoded back to string + (is (string= (encode-json-to-string #\a) "\"a\""))) + + +(test hash-table-symbol + (let ((ht (make-hash-table))) + (setf (gethash 'symbols-are-now-converted-to-camel-case ht) 5) + (is (string= (encode-json-to-string ht) + "{\"symbolsAreNowConvertedToCamelCase\":5}")))) + +(test hash-table-string + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "lower x" ht) 5) + (is (string= (encode-json-to-string ht) + "{\"lower x\":5}")))) + + +(defparameter *encode-performace-test-string* + "{ + \"JSON Test Pattern pass3\": { + \"The outermost value\": \"must be an object or array.\", + \"In this test\": \"It is an object.\", + \"Performance-1\" : 123465.578, + \"Performance-2\" : 12e4, + \"Performance-2\" : \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"Performance-3\" : [\"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\", + \"asdasdsadsasdasdsdasdasdasdsaaaaaaaaaaaaasdasdasdasdasdsd\"] + } +} +") + + + + + +(test encoder-performance + (with-objects-as-hashtables + (let* ((json-string *encode-performace-test-string*) + (chars (length json-string)) + (lisp-obj (decode-json-from-string json-string)) + (count 2000)) + (format t "Encoding ~a varying chars from memory ~a times." chars count) + (time + (dotimes (x count) + (let ((discard-soon (encode-json-to-string lisp-obj))) + (funcall #'identity discard-soon))))))) + + + Added: branches/trunk-reorg/thirdparty/cl-json/t/testjson.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/testjson.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/testjson.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,2 @@ +(in-package :json-test) +(run! 'json) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-json/t/testmisc.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-json/t/testmisc.lisp 2007-10-07 22:04:17 UTC (rev 2229) +++ branches/trunk-reorg/thirdparty/cl-json/t/testmisc.lisp 2007-10-07 23:18:29 UTC (rev 2230) @@ -0,0 +1,50 @@ +(in-package :json-test) +(in-suite json) + +(test test-json-bind + (json-bind (hello hi ciao) "{\"hello\":100,\"hi\":5}" + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao))) + + +(test test-json-bind-advanced + (json-bind (hello-world + sub-obj.property + sub-obj.missing-property + sub-obj.even-deeper-obj.some-stuff) + "{\"helloWorld\":100,\"subObj\":{\"property\":20,\"evenDeeperObj\":{\"someStuff\":\"Guten Tag\"}}}" + (is (= hello-world 100)) + (is (= sub-obj.property 20)) + (is-false sub-obj.missing-property) + (is (string= sub-obj.even-deeper-obj.some-stuff "Guten Tag")))) + +(test test-json-bind-with-alist + (let ((the-alist (decode-json-from-string "{\"hello\":100,\"hi\":5}"))) + (json-bind (hello hi ciao) the-alist + (is (= hello 100)) + (is (= hi 5)) + (is-false ciao)))) + +(test assoc-lookup + (is (equalp '(json::cdas widget-id (json::cdas parent data)) + (macroexpand-1 '(json::assoc-lookup parent widget-id data))))) + + +(defun-json-rpc foo (x y) + "Adds two numbers" + (+ x y)) + + +(test test-json-rpc + (let (result) + (setf result (json-rpc:invoke-rpc "{\"method\":\"foo\",\"params\":[1,2],\"id\":999}")) + (is (string= result "{\"result\":3,\"error\":null,\"id\":999}")))) + +(test test-json-rpc-unknown-fn + (let (result) + (setf result (json-rpc:invoke-rpc "{\"method\":\"secretmethod\",\"params\":[1,2],\"id\":\"my id\"}")) + (json-bind (result error id) result + (is-false result) + (is-true error) + (is (string= id "my id")))))

1 0

Jump to page: