bknr-cvs October 2007

bknr-cvs@common-lisp.net

1 participants
67 discussions

[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 08 Oct '07

08 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 08 Oct '07

08 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

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

08 Oct '07

Author: hhubner Date: 2007-10-07 18:04:17 -0400 (Sun, 07 Oct 2007) New Revision: 2229 Added: branches/trunk-reorg/projects/scrabble/src/test-store.lisp Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/rules.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp Log: make-game works now, and some xml can be generated. snapshot and restore works, but I found a very embarrasing problem with anonymous transactions and make-object. In a nutshell, one would expect to be able to group a number of make-object calls using an (anonymous) transaction in order to create a few interdependent objets. In practice, this does not work. The order of the objects as they appear in the transaction log is wrong when using an anonymous transaction, and snapshots don't work with either anonymous or named transactions. This is very embarrasing and I will need to find time to fix this soon, as it makes the store useless for many real world application scenarios. Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -24,7 +24,7 @@ (random-index (random (fill-pointer tiles)))) (setf (aref tiles i) (aref tiles random-index)) (setf (aref tiles random-index) tmp))) - (make-instance 'tile-bag :tiles tiles))) + (make-object 'tile-bag :tiles tiles))) (define-condition no-tiles-remaining (simple-error) ()) @@ -54,17 +54,45 @@ ((games :initform nil :accessor games-of)) (:metaclass persistent-class)) +(defclass participant (store-object) + ((player :initarg :player :reader player-of) + (tray :initarg :tray :accessor tray-of)) + (:metaclass persistent-class)) + +(defmethod tray-size ((participant participant)) + (length (tray-of participant))) + (defclass game (store-object) ((language :initarg :language :reader language-of) - (players :initarg :players - :reader players-of - :documentation "List of players in this game") - (board :accessor board-of) - (tile-bag :accessor tile-bag-of)) + (board :initarg :board + :accessor board-of) + (tile-bag :initarg :tile-bag + :accessor tile-bag-of) + (participants :initarg :participants + :reader participants-of + :documentation "List of participants in this game")) (:metaclass persistent-class)) -(defmethod initialize-persistent-instance :after ((game game)) - (setf (board-of game) (make-instance 'board)) - (setf (tile-bag-of game) (make-tile-bag (language-of game))) - game) \ No newline at end of file +(defun make-game (language players) + ;; Because of a serious deficiency in the BKNR datastore, we need to create all the parts of a game in seperate transactions. + ;; Only when all components have been created in the right order, restoring from either the transaction log or a snapshot + ;; will work. A real fix would involve ordering object creations in transactions so that when restoring, all objects are + ;; created before they are referenced. + (let* ((board (make-object 'board)) + (tile-bag (make-tile-bag language)) + (trays (mapcar (lambda (player) + (declare (ignore player)) + (loop for i from 0 below 7 + collect (draw-tile tile-bag))) + players)) + (participants (loop for player in players + for tray in trays + collect (make-object 'participant + :player player + :tray tray)))) + (make-object 'game + :language language + :board board + :tile-bag tile-bag + :participants participants))) Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -21,12 +21,18 @@ "REMAINING-TILE-COUNT" "PLAYER" + "GAMES-OF" + "PARTICIPANT" + "PLAYER-OF" + "TRAY-OF" + "GAME" "LANGUAGE-OF" - "PLAYERS-OF" + "PARTICIPANTS-OF" "BOARD-OF" - "TILE-BAG-OF")) + "TILE-BAG-OF" + "MAKE-GAME")) (defpackage :scrabble.graphics (:use :cl Modified: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -66,7 +66,7 @@ (defmethod at-placement ((board board) tile-placement) (at-xy board (x-of tile-placement) (y-of tile-placement))) -(defmethod put-letter ((board board) tile x y) +(deftransaction put-letter (board tile x y) (setf (aref (placed-tiles-of board) x y) tile)) (defclass tile (store-object) Added: branches/trunk-reorg/projects/scrabble/src/test-store.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/test-store.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/test-store.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -0,0 +1,9 @@ +(in-package :scrabble) + +(defun test-store () + (ignore-errors (close-store)) + (sb-ext:run-program "/bin/rm" '("-rf" "/tmp/scrabble-store/") :environment nil) + (make-instance 'mp-store :directory "/tmp/scrabble-store/") + (let ((user1 (make-user "user1" :class 'player :full-name "User Eins")) + (user2 (make-user "user2" :class 'player :full-name "User Zwei"))) + (make-game :de (list user1 user2)))) \ 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-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -2,23 +2,24 @@ (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" (char-of it)) - (attribute "value" (value-of it)))))))) + (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)))))))) -(defmethod as-xml ((player player)) - (with-element "player" - (attribute "name" (user-full-name player)))) +(defmethod as-xml ((participant participant)) + (with-element "participant" + (attribute "name" (user-full-name (player-of participant))) + (attribute "tiles" (length (tray-of participant))))) (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 (player (players-of game)) - (as-xml player)) + (dolist (participant (participants-of game)) + (as-xml participant)) (as-xml (board-of game))))

1 0

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

07 Oct '07

Author: hhubner Date: 2007-10-06 19:09:39 -0400 (Sat, 06 Oct 2007) New Revision: 2228 Added: branches/trunk-reorg/projects/scrabble/src/game-constants.lisp branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/rules.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/en/ branches/trunk-reorg/projects/scrabble/website/en/A.png branches/trunk-reorg/projects/scrabble/website/en/B.png branches/trunk-reorg/projects/scrabble/website/en/C.png branches/trunk-reorg/projects/scrabble/website/en/D.png branches/trunk-reorg/projects/scrabble/website/en/E.png branches/trunk-reorg/projects/scrabble/website/en/F.png branches/trunk-reorg/projects/scrabble/website/en/G.png branches/trunk-reorg/projects/scrabble/website/en/H.png branches/trunk-reorg/projects/scrabble/website/en/I.png branches/trunk-reorg/projects/scrabble/website/en/J.png branches/trunk-reorg/projects/scrabble/website/en/K.png branches/trunk-reorg/projects/scrabble/website/en/L.png branches/trunk-reorg/projects/scrabble/website/en/M.png branches/trunk-reorg/projects/scrabble/website/en/N.png branches/trunk-reorg/projects/scrabble/website/en/NIL.png branches/trunk-reorg/projects/scrabble/website/en/O.png branches/trunk-reorg/projects/scrabble/website/en/P.png branches/trunk-reorg/projects/scrabble/website/en/Q.png branches/trunk-reorg/projects/scrabble/website/en/R.png branches/trunk-reorg/projects/scrabble/website/en/S.png branches/trunk-reorg/projects/scrabble/website/en/T.png branches/trunk-reorg/projects/scrabble/website/en/U.png branches/trunk-reorg/projects/scrabble/website/en/V.png branches/trunk-reorg/projects/scrabble/website/en/W.png branches/trunk-reorg/projects/scrabble/website/en/X.png branches/trunk-reorg/projects/scrabble/website/en/Y.png branches/trunk-reorg/projects/scrabble/website/en/Z.png branches/trunk-reorg/projects/scrabble/website/en/charmap.xml branches/trunk-reorg/projects/scrabble/website/en/double-letter.png branches/trunk-reorg/projects/scrabble/website/en/double-word.png 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 branches/trunk-reorg/projects/scrabble/website/en/standard.png branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png branches/trunk-reorg/projects/scrabble/website/en/triple-word.png Removed: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.asd Log: Snapshot - Modularized a little, made most game objects persistent, add XML generation function for games. Added: branches/trunk-reorg/projects/scrabble/src/game-constants.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game-constants.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/game-constants.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,29 @@ +(in-package :scrabble) + +(defparameter *board-scoring* + #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) + (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) + (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) + (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) + (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) + (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) + (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) + (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) + (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) + (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) + (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) + (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) + (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) + (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) + (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word))) + +(defparameter *tile-sets* '(:de ((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6) + (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6) + (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1) + (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) + (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) + (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) + (nil 0 2)) + :en '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9) + (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6) + (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2)))) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,70 @@ +(in-package :scrabble) + +(defclass tile-bag (store-object) + ((tiles :initarg :tiles :accessor tiles-of)) + (:metaclass persistent-class)) + +(defmethod remaining-tile-count ((tile-bag tile-bag)) + (fill-pointer (tiles-of tile-bag))) + +(defmethod print-object ((tile-bag tile-bag) stream) + (print-unreadable-object (tile-bag stream :type t :identity t) + (format stream "~A letters remaining" (remaining-tile-count tile-bag)))) + +(defun make-tile-bag (language) + (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) + (mapcar (lambda (entry) + (destructuring-bind (char value count) entry + (dotimes (i count) + (vector-push-extend (make-tile char value) tiles)))) + (or (getf *tile-sets* language) + (error "language ~A not defined" language))) + (dotimes (i (fill-pointer tiles)) + (let ((tmp (aref tiles i)) + (random-index (random (fill-pointer tiles)))) + (setf (aref tiles i) (aref tiles random-index)) + (setf (aref tiles random-index) tmp))) + (make-instance 'tile-bag :tiles tiles))) + +(define-condition no-tiles-remaining (simple-error) + ()) + +(defmethod draw-tile ((tile-bag tile-bag)) + (unless (plusp (remaining-tile-count tile-bag)) + (error 'no-tiles-remaining)) + (with-slots (tiles) tile-bag + (prog1 + (aref tiles (1- (fill-pointer tiles))) + (decf (fill-pointer tiles))))) + +(defun make-move (board placed-tiles) + "Actually perform a move. BOARD contains the already placed tiles, +PLACED-TILES contains the letters for the move to make. BOARD is +modified to include the tiles placed. Returns the two values that +CALCULATE-SCORE returns for the move." + (check-move-legality board placed-tiles) + (prog1 + (mapcar (lambda (word-result) + (list (word-text word-result) (word-score word-result))) + (words-formed board placed-tiles)) + (dolist (placed-tile placed-tiles) + (put-letter board (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))))) + +(defclass player (user) + ((games :initform nil :accessor games-of)) + (:metaclass persistent-class)) + +(defclass game (store-object) + ((language :initarg :language + :reader language-of) + (players :initarg :players + :reader players-of + :documentation "List of players in this game") + (board :accessor board-of) + (tile-bag :accessor tile-bag-of)) + (:metaclass persistent-class)) + +(defmethod initialize-persistent-instance :after ((game game)) + (setf (board-of game) (make-instance 'board)) + (setf (tile-bag-of game) (make-tile-bag (language-of game))) + game) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -1,14 +1,47 @@ - -(defpackage :scrabble - (:use :cl :alexandria :anaphora :bknr.datastore) - (:export "*BOARD-SCORING*" - "*TILE-SETS*" - "FIELD-TYPE")) - -(defpackage :scrabble.graphics - (:use :cl :alexandria :vecto :scrabble) - (:shadowing-import-from :vecto "ROTATE")) - -(defpackage :scrabble.web - (:use :cl :alexandria :hunchentoot :scrabble)) + +(defpackage :scrabble + (:use :cl + :alexandria + :anaphora + :bknr.datastore + :bknr.user) + (:export "*BOARD-SCORING*" + "*TILE-SETS*" + + "FIELD-TYPE" + + "TILE" + "CHAR-OF" + "VALUE-OF" + + "BOARD" + "AT-XY" + + "TILE-BAG" + "REMAINING-TILE-COUNT" + + "PLAYER" + + "GAME" + "LANGUAGE-OF" + "PLAYERS-OF" + "BOARD-OF" + "TILE-BAG-OF")) + +(defpackage :scrabble.graphics + (:use :cl + :alexandria + :vecto + :scrabble) + (:shadowing-import-from :vecto "ROTATE")) + +(defpackage :scrabble.web + (:use :cl + :alexandria + :anaphora + :hunchentoot + :bknr.datastore + :bknr.user + :cxml + :scrabble)) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,197 @@ +(in-package :scrabble) + +(defun field-type (x y) + (or (aref *board-scoring* x y) + :standard)) + +(define-condition invalid-move (simple-error) + () + (:report (lambda (c stream) + (format stream "Invalid move: ~A" (type-of c))))) + +(defun seq (from to) + (loop for i from from upto to + collect i)) + +(defun positions-between (start-position end-position) + (if (= (first start-position) + (first end-position)) + (mapcar (lambda (y) (list (first start-position) y)) + (seq (second start-position) (second end-position))) + (mapcar (lambda (x) (list x (second start-position))) + (seq (first start-position) (first end-position))))) + +(defclass tile-placement () + ((x :reader x-of :initarg :x) + (y :reader y-of :initarg :y) + (tile :reader tile-of :initarg :tile)) + (:documentation "Represents placement of a letter tile on the board")) + +(defun make-tile-placement (x y tile) + (make-instance 'tile-placement :x x :y y :tile tile)) + +(defun make-tile-placements (list-of-moves) + (mapcar (curry #'apply 'make-tile-placement) list-of-moves)) + +(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement)) + (and (= (x-of tile-placement-1) (x-of tile-placement-2)) + (= (y-of tile-placement-1) (y-of tile-placement-2)))) + +(defmethod position-equal ((position list) (tile-placement tile-placement)) + "Return non-nil if the given POSITION is at the position of PLACED-TILE" + (and (= (first position) (x-of tile-placement)) + (= (second position) (y-of tile-placement)))) + +(defmethod position-< ((a tile-placement) (b tile-placement)) + "Compare positions of placements, for sorting" + (or (< (x-of a) (x-of b)) + (< (y-of a) (y-of b)))) + +(defclass board (store-object) + ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) + (:metaclass persistent-class)) + +(defmethod print-object ((board board) stream) + (print-unreadable-object (board stream :type t :identity t) + (terpri stream) + (dotimes (x 15) + (dotimes (y 15) + (format stream "~C " (aif (at-xy board x y) (char-of it) #\.))) + (terpri stream)))) + + +(defmethod at-xy ((board board) x y) + (aref (placed-tiles-of board) x y)) + +(defmethod at-placement ((board board) tile-placement) + (at-xy board (x-of tile-placement) (y-of tile-placement))) + +(defmethod put-letter ((board board) tile x y) + (setf (aref (placed-tiles-of board) x y) tile)) + +(defclass tile (store-object) + ((char :reader char-of :initarg :char) + (value :reader value-of :initarg :value)) + (:metaclass persistent-class)) + +(defmethod print-object ((tile tile) stream) + (print-unreadable-object (tile stream :type t :identity nil) + (with-slots (char value) tile + (format stream "~A (~A)" char value)))) + +(defun make-tile (char value) + (make-object 'tile :char char :value value)) + +(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement)) + "Check whether the given TILE-PLACEMENT on the board is adjacent to +another tile or if it is the start position." + (with-accessors ((x x-of) (y y-of)) + tile-placement + (or (and (eql x 7) + (eql y 7)) + (and (plusp x) + (at-xy board (1- x) y)) + (and (plusp y) + (at-xy board x (1- y))) + (and (< x 14) + (at-xy board (1+ x) y)) + (and (< y 14) + (at-xy board x (1+ y)))))) + +(defun placed-or-being-placed (board placed-tiles position) + (or (at-xy board (first position) (second position)) + (awhen (find position placed-tiles :test #'position-equal) + (values (tile-of it) t)))) + +(define-condition not-touching-other-tile (invalid-move) ()) +(define-condition not-in-a-row (invalid-move) ()) +(define-condition placed-on-occupied-field (invalid-move) ()) +(define-condition no-tile-placed (invalid-move) ()) +(define-condition multiple-letters-placed-on-one-field (invalid-move) ()) +(define-condition placement-with-holes (invalid-move) ()) + +(defun check-move-legality (board placed-tiles) + "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble +move. If the move is not valid, a specific INVALID-MOVE condition is +signalled. Otherwise, t is returned." + (unless placed-tiles + (error 'no-tile-placed)) + + (unless (or (apply #'= (mapcar #'x-of placed-tiles)) + (apply #'= (mapcar #'y-of placed-tiles))) + (error 'not-in-a-row)) + + (when (some (curry #'at-placement board) placed-tiles) + (error 'tile-placed-on-occupied-field)) + + (unless (equal placed-tiles + (remove-duplicates placed-tiles :test #'equal-position)) + (error 'multiple-letters-placed-on-one-field)) + + (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<)) + (start-of-placement (first placed-tiles)) + (end-of-placement (first (last placed-tiles)))) + (unless (every (curry 'placed-or-being-placed board placed-tiles) + (positions-between (list (x-of start-of-placement) (y-of start-of-placement)) + (list (x-of end-of-placement) (y-of end-of-placement)))) + (error 'placement-with-holes))) + + (unless (or (find '(7 7) placed-tiles :test #'position-equal) + (some (curry #'placed-tile-adjacent board) placed-tiles)) + (error 'not-touching-other-tile)) + + t) + +(defun words-formed% (board placed-tiles verticalp) + "Scan for words that would be formed by placing PLACED-TILES on +BOARD. VERTICALP determines the scan order, if nil, the board is +scanned horizontally, else vertically. This is called by WORDS-FORMED +below, see there for a description of the return value format." + (let (words) + (dotimes (x 15) + (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=) + (let (word is-new-word) + (dotimes (y 15) + (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y))) + (when (and word (null placed-tile)) + (when (and (cdr word) is-new-word) + (push (nreverse word) words)) + (setf word nil is-new-word nil)) + (when placed-tile + (push (list placed-tile (and being-placed (field-type x y))) word) + (when being-placed + (setf is-new-word t))))) + (when (and (cdr word) is-new-word) + (push (nreverse word) words))))) + (nreverse words))) + +(defun words-formed (board placed-tiles) + "Return list of all words formed by placing the tiles in +PLACED-TILES on the BOARD. Returns each word as a list, with each +letter of the word represented by a list (TILE FIELD-TYPE). TILE is +the tile for the letter, FIELD-TYPE is either the field type of the +field that the letter has been placed on, or NIL if the tile was +already on the board." + (append (words-formed% board placed-tiles nil) + (words-formed% board placed-tiles t))) + +(defun word-score (word-result) + "Process one word result from WORDS-FORMED and calculate the score +for the word." + (let ((factor 1) + (value 0)) + (dolist (entry word-result) + (destructuring-bind (tile field-type) entry + (incf value (value-of tile)) + (case field-type + ((:double-letter) (incf value (value-of tile))) + ((:triple-letter) (incf value (* 2 (value-of tile)))) + ((:double-word) (setf factor (* factor 2))) + ((:triple-word) (setf factor (* factor 3)))))) + (* value factor))) + +(defun word-text (word-result) + "Convert the letter in a word result returned by WORDS-FORMED to a +string." + (coerce (mapcar (compose #'char-of #'car) word-result) 'string)) + Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-06 23:09:39 UTC (rev 2228) @@ -10,9 +10,18 @@ (defsystem :scrabble :name "Scrabble" :licence "BSD" - :depends-on (:bknr-datastore :hunchentoot :cxml :vecto :alexandria :anaphora) + :depends-on (:bknr-datastore + :bknr-web + :hunchentoot + :cxml + :vecto + :alexandria + :anaphora) :serial t :components ((:file "package") - (:file "scrabble") + (:file "game-constants") + (:file "rules") + (:file "game") + (:file "web") (:file "make-html") (:file "make-letters"))) Deleted: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -1,277 +0,0 @@ -(in-package :scrabble) - -(defparameter *board-scoring* - #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) - (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) - (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) - (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) - (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) - (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) - (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) - (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) - (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) - (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) - (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) - (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) - (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word))) - -(defun field-type (x y) - (or (aref *board-scoring* x y) - :standard)) - -(defparameter *tile-sets* (make-hash-table)) - -(setf (gethash :de *tile-sets*) - '((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6) - (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6) - (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1) - (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) - (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) - (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) - (nil 0 2))) -(setf (gethash :en *tile-sets*) - '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9) - (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6) - (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2))) - -(define-condition invalid-move (simple-error) - () - (:report (lambda (c stream) - (format stream "Invalid move: ~A" (type-of c))))) - -(defun seq (from to) - (loop for i from from upto to - collect i)) - -(defun positions-between (start-position end-position) - (if (= (first start-position) - (first end-position)) - (mapcar (lambda (y) (list (first start-position) y)) - (seq (second start-position) (second end-position))) - (mapcar (lambda (x) (list x (second start-position))) - (seq (first start-position) (first end-position))))) - -(defclass tile-placement () - ((x :reader x-of :initarg :x) - (y :reader y-of :initarg :y) - (tile :reader tile-of :initarg :tile)) - (:documentation "Represents placement of a letter tile on the board")) - -(defun make-tile-placement (x y tile) - (make-instance 'tile-placement :x x :y y :tile tile)) - -(defun make-tile-placements (list-of-moves) - (mapcar (curry #'apply 'make-tile-placement) list-of-moves)) - -(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement)) - (and (= (x-of tile-placement-1) (x-of tile-placement-2)) - (= (y-of tile-placement-1) (y-of tile-placement-2)))) - -(defmethod position-equal ((position list) (tile-placement tile-placement)) - "Return non-nil if the given POSITION is at the position of PLACED-TILE" - (and (= (first position) (x-of tile-placement)) - (= (second position) (y-of tile-placement)))) - -(defmethod position-< ((a tile-placement) (b tile-placement)) - "Compare positions of placements, for sorting" - (or (< (x-of a) (x-of b)) - (< (y-of a) (y-of b)))) - -(defclass board (store-object) - ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) - (:metaclass persistent-class)) - -(defmethod print-object ((board board) stream) - (print-unreadable-object (board stream :type t :identity t) - (terpri stream) - (dotimes (x 15) - (dotimes (y 15) - (format stream "~C " (aif (at-xy board x y) (char-of it) #\.))) - (terpri stream)))) - -(defmethod at-xy ((board board) x y) - (aref (placed-tiles-of board) x y)) - -(defmethod at-placement ((board board) tile-placement) - (at-xy board (x-of tile-placement) (y-of tile-placement))) - -(defmethod put-letter ((board board) tile x y) - (setf (aref (placed-tiles-of board) x y) tile)) - -(defclass tile (store-object) - ((char :reader char-of :initarg :char) - (value :reader value-of :initarg :value)) - (:metaclass persistent-class)) - -(defmethod print-object ((tile tile) stream) - (print-unreadable-object (tile stream :type t :identity nil) - (with-slots (char value) tile - (format stream "~A (~A)" char value)))) - -(defun make-tile (char value) - (make-object 'tile :char char :value value)) - -(defclass tile-bag (store-object) - ((tiles :initarg :tiles :accessor tiles-of)) - (:metaclass persistent-class)) - -(defmethod remaining-tile-count ((tile-bag tile-bag)) - (fill-pointer (tiles-of tile-bag))) - -(defmethod print-object ((tile-bag tile-bag) stream) - (print-unreadable-object (tile-bag stream :type t :identity t) - (format stream "~A letters remaining" (remaining-tile-count tile-bag)))) - -(defun make-tile-bag (language) - (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) - (mapcar (lambda (entry) - (destructuring-bind (char value count) entry - (dotimes (i count) - (vector-push-extend (make-tile char value) tiles)))) - (or (gethash language *tile-sets*) - (error "language ~A not defined" language))) - (dotimes (i (fill-pointer tiles)) - (let ((tmp (aref tiles i)) - (random-index (random (fill-pointer tiles)))) - (setf (aref tiles i) (aref tiles random-index)) - (setf (aref tiles random-index) tmp))) - (make-instance 'tile-bag :tiles tiles))) - -(define-condition no-tiles-remaining (simple-error) - ()) - -(defmethod draw-tile ((tile-bag tile-bag)) - (unless (plusp (remaining-tile-count tile-bag)) - (error 'no-tiles-remaining)) - (with-slots (tiles) tile-bag - (prog1 - (aref tiles (1- (fill-pointer tiles))) - (decf (fill-pointer tiles))))) - -(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement)) - "Check whether the given TILE-PLACEMENT on the board is adjacent to -another tile or if it is the start position." - (with-accessors ((x x-of) (y y-of)) - tile-placement - (or (and (eql x 7) - (eql y 7)) - (and (plusp x) - (at-xy board (1- x) y)) - (and (plusp y) - (at-xy board x (1- y))) - (and (< x 14) - (at-xy board (1+ x) y)) - (and (< y 14) - (at-xy board x (1+ y)))))) - -(defun placed-or-being-placed (board placed-tiles position) - (or (at-xy board (first position) (second position)) - (awhen (find position placed-tiles :test #'position-equal) - (values (tile-of it) t)))) - -(define-condition not-touching-other-tile (invalid-move) ()) -(define-condition not-in-a-row (invalid-move) ()) -(define-condition placed-on-occupied-field (invalid-move) ()) -(define-condition no-tile-placed (invalid-move) ()) -(define-condition multiple-letters-placed-on-one-field (invalid-move) ()) -(define-condition placement-with-holes (invalid-move) ()) - -(defun check-move-legality (board placed-tiles) - "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble -move. If the move is not valid, a specific INVALID-MOVE condition is -signalled. Otherwise, t is returned." - (unless placed-tiles - (error 'no-tile-placed)) - - (unless (or (apply #'= (mapcar #'x-of placed-tiles)) - (apply #'= (mapcar #'y-of placed-tiles))) - (error 'not-in-a-row)) - - (when (some (curry #'at-placement board) placed-tiles) - (error 'tile-placed-on-occupied-field)) - - (unless (equal placed-tiles - (remove-duplicates placed-tiles :test #'equal-position)) - (error 'multiple-letters-placed-on-one-field)) - - (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<)) - (start-of-placement (first placed-tiles)) - (end-of-placement (first (last placed-tiles)))) - (unless (every (curry 'placed-or-being-placed board placed-tiles) - (positions-between (list (x-of start-of-placement) (y-of start-of-placement)) - (list (x-of end-of-placement) (y-of end-of-placement)))) - (error 'placement-with-holes))) - - (unless (or (find '(7 7) placed-tiles :test #'position-equal) - (some (curry #'placed-tile-adjacent board) placed-tiles)) - (error 'not-touching-other-tile)) - - t) - -(defun words-formed% (board placed-tiles verticalp) - "Scan for words that would be formed by placing PLACED-TILES on -BOARD. VERTICALP determines the scan order, if nil, the board is -scanned horizontally, else vertically. This is called by WORDS-FORMED -below, see there for a description of the return value format." - (let (words) - (dotimes (x 15) - (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=) - (let (word is-new-word) - (dotimes (y 15) - (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y))) - (when (and word (null placed-tile)) - (when (and (cdr word) is-new-word) - (push (nreverse word) words)) - (setf word nil is-new-word nil)) - (when placed-tile - (push (list placed-tile (and being-placed (field-type x y))) word) - (when being-placed - (setf is-new-word t))))) - (when (and (cdr word) is-new-word) - (push (nreverse word) words))))) - (nreverse words))) - -(defun words-formed (board placed-tiles) - "Return list of all words formed by placing the tiles in -PLACED-TILES on the BOARD. Returns each word as a list, with each -letter of the word represented by a list (TILE FIELD-TYPE). TILE is -the tile for the letter, FIELD-TYPE is either the field type of the -field that the letter has been placed on, or NIL if the tile was -already on the board." - (append (words-formed% board placed-tiles nil) - (words-formed% board placed-tiles t))) - -(defun word-score (word-result) - "Process one word result from WORDS-FORMED and calculate the score -for the word." - (let ((factor 1) - (value 0)) - (dolist (entry word-result) - (destructuring-bind (tile field-type) entry - (incf value (value-of tile)) - (case field-type - ((:double-letter) (incf value (value-of tile))) - ((:triple-letter) (incf value (* 2 (value-of tile)))) - ((:double-word) (setf factor (* factor 2))) - ((:triple-word) (setf factor (* factor 3)))))) - (* value factor))) - -(defun word-text (word-result) - "Convert the letter in a word result returned by WORDS-FORMED to a -string." - (coerce (mapcar (compose #'char-of #'car) word-result) 'string)) - -(defun make-move (board placed-tiles) - "Actually perform a move. BOARD contains the already placed tiles, -PLACED-TILES contains the letters for the move to make. BOARD is -modified to include the tiles placed. Returns the two values that -CALCULATE-SCORE returns for the move." - (check-move-legality board placed-tiles) - (prog1 - (mapcar (lambda (word-result) - (list (word-text word-result) (word-score word-result))) - (words-formed board placed-tiles)) - (dolist (placed-tile placed-tiles) - (put-letter board (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))))) Added: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,24 @@ +(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" (char-of it)) + (attribute "value" (value-of it)))))))) + +(defmethod as-xml ((player player)) + (with-element "player" + (attribute "name" (user-full-name player)))) + +(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 (player (players-of game)) + (as-xml player)) + (as-xml (board-of game)))) Added: branches/trunk-reorg/projects/scrabble/website/en/A.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/A.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/B.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/B.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/C.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/C.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/D.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/D.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/E.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/E.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/F.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/F.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/G.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/G.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/H.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/H.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/I.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/I.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/J.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/J.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/K.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/K.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/L.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/L.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/M.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/M.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/N.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/N.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/NIL.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/NIL.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/O.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/O.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/P.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/P.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Q.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Q.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/R.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/R.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/S.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/S.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/T.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/T.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/U.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/U.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/V.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/V.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/W.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/W.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/X.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/X.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Y.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Y.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Z.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Z.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/charmap.xml =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/charmap.xml 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/charmap.xml 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,2 @@ +<?xml version="1.0" encoding="UTF-8"?> +<chars><char filename="A.png">A</char><char filename="B.png">B</char><char filename="C.png">C</char><char filename="D.png">D</char><char filename="E.png">E</char><char filename="F.png">F</char><char filename="G.png">G</char><char filename="H.png">H</char><char filename="I.png">I</char><char filename="J.png">J</char><char filename="K.png">K</char><char filename="L.png">L</char><char filename="M.png">M</char><char filename="N.png">N</char><char filename="O.png">O</char><char filename="P.png">P</char><char filename="Q.png">Q</char><char filename="R.png">R</char><char filename="S.png">S</char><char filename="T.png">T</char><char filename="U.png">U</char><char filename="V.png">V</char><char filename="W.png">W</char><char filename="X.png">X</char><char filename="Y.png">Y</char><char filename="Z.png">Z</char><char filename="NIL.png">NIL</char></chars> \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/double-word.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-word.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.css \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.html \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.js \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/standard.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/standard.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

1 0

[bknr-cvs] r2227 - in branches/trunk-reorg/bknr: modules web/src web/src/sysclasses web/src/web
by bknr＠bknr.net 07 Oct '07

07 Oct '07

Author: hhubner Date: 2007-10-06 19:08:12 -0400 (Sat, 06 Oct 2007) New Revision: 2227 Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/host.lisp branches/trunk-reorg/bknr/web/src/web/site.lisp branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp Log: Make :bknr-web loadable with SBCL. I'm planning to switch to hunchentoot from aserve, but tha has not happened and until then, only the base components of :bknr-web are in the compile. I'm using the bknr.user now. Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd =================================================================== --- branches/trunk-reorg/bknr/modules/bknr-modules.asd 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/modules/bknr-modules.asd 2007-10-06 23:08:12 UTC (rev 2227) @@ -25,10 +25,7 @@ :bknr-utils :puri :stem - #+(or) :mime :bknr - :klammerscript - #+(not allegro) :acl-compat) :components ((:file "packages") Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd =================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd 2007-10-06 23:08:12 UTC (rev 2227) @@ -10,7 +10,7 @@ (make-pathname :name nil :type nil :version nil :defaults (parse-namestring *load-truename*))) -(defsystem :bknr +(defsystem :bknr-web :name "Baikonour - Base modules" :author "Hans Huebner <hans(a)huebner.org>" :author "Manuel Odendahl <manuel(a)bl0rg.net>" @@ -22,34 +22,25 @@ :depends-on (:cl-interpol :cl-ppcre :cl-gd - :aserve - ;:net.post-office + :kmrcl :md5 :cxml :unit-test :bknr-utils :bknr-xml + :hunchentoot + :xhtmlgen :puri - ;:stem - ;:mime - :klammerscript :bknr-datastore - :bknr-data-impex - :kmrcl - :iconv - #+(not allegro) - :acl-compat) + :bknr-data-impex) :components ((:file "packages") - - (:module "xhtmlgen" :components ((:file "xhtmlgen")) - :depends-on ("packages")) (:module "sysclasses" :components ((:file "event") (:file "user" :depends-on ("event")) (:file "cron") (:file "sysparam")) - :depends-on ("xhtmlgen")) + :depends-on ("packages")) (:module "htmlize" :components ((:file "hyperspec") (:file "htmlize" @@ -68,6 +59,7 @@ :depends-on ("parse-xml" "rss"))) :depends-on ("packages")) + #+notyet (:module "web" :components ((:file "site") ;; data (:file "host") @@ -116,8 +108,9 @@ "templates" "site" "web-utils"))) - :depends-on ("sysclasses" "packages" "xhtmlgen" "rss")) + :depends-on ("sysclasses" "packages" "rss")) + #+notyet (:module "images" :components ((:file "image") (:file "image-tags" :depends-on ("image")) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -175,12 +175,11 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :cxml-xmls :xhtml-generator :puri :md5 - :js :bknr.datastore :bknr.indices :bknr.impex @@ -189,7 +188,6 @@ :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export #:*req* #:*ent* #:*user* @@ -400,7 +398,7 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :puri :xhtml-generator :bknr.rss @@ -410,7 +408,6 @@ :bknr.utils :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export #:imageproc #:define-imageproc-handler #:image-handler ; plain images only Modified: branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -10,24 +10,24 @@ (>= hour 0) (< hour 24))) -(defconstant +day-list+ '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) +(defparameter *day-list* '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) (defun day-p (day) (or (and (numberp day) (>= day 1) (<= day 7)) (and (symbolp day) - (member day +day-list+)))) + (member day *day-list*)))) (defun day-to-number (day) (if (numberp day) day - (let ((num (position day +day-list+))) + (let ((num (position day *day-list*))) (if num (1+ num) (error "Could not find day in day-list"))))) -(defconstant +month-list+ '(:january :february :march :april :may :june :july +(defparameter *month-list* '(:january :february :march :april :may :june :july :august :september :october :november :december)) (defun month-p (month) @@ -35,12 +35,12 @@ (>= month 1) (<= month 12)) (and (symbolp month) - (member month +month-list+)))) + (member month *month-list*)))) (defun month-to-number (month) (if (numberp month) month - (let ((num (position month +month-list+))) + (let ((num (position month *month-list*))) (if num (1+ num) (error "Could not find month in month-list"))))) Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -3,6 +3,7 @@ (defclass bknr-authorizer () ()) +#+cmu (defmethod http-request-remote-host ((req http-request)) (let ((remote-host (socket:remote-host (request-socket req))) (forwarded-for (regex-replace Modified: branches/trunk-reorg/bknr/web/src/web/host.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/host.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/host.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -46,11 +46,11 @@ (host-ip-address host))) (defmethod host-ipaddr ((host host)) - (socket:dotted-to-ipaddr (host-ip-address host))) + (kmrcl::dotted-to-ipaddr (host-ip-address host))) (defun find-host (&key ip-address create ipaddr) (when ipaddr - (setf ip-address (socket:ipaddr-to-dotted ipaddr))) + (setf ip-address (kmrcl::ipaddr-to-dotted ipaddr))) (or (host-with-ipaddress ip-address) (and create (make-object 'host :ip-address ip-address)))) Modified: branches/trunk-reorg/bknr/web/src/web/site.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/site.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/site.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -6,5 +6,5 @@ (defparameter *thumbnail-max-height* 54) ;; default billboard to show on home page -(defconstant *default-billboard* "main") +(defparameter *default-billboard* "main") Modified: branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -24,7 +24,7 @@ (when (web-visitor-event-host event) (format stream " from ~a [~a]" (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event)))))) + (host-ip-address (web-visitor-event-host event))))) event) #+(or)

1 0

[bknr-cvs] r2226 - in branches/trunk-reorg/bknr/datastore/src: . data xml xml-impex
by bknr＠bknr.net 07 Oct '07

07 Oct '07

Author: hhubner Date: 2007-10-06 19:06:39 -0400 (Sat, 06 Oct 2007) New Revision: 2226 Modified: branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp Log: Use :closer-mop instead of compiler-specific MOP. Fix import glitches for bknr-xml. Support character datatype for transaction log reading/writing. Modified: branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd =================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd 2007-10-06 23:06:39 UTC (rev 2226) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) + :depends-on (:cl-interpol :cxml :closer-mop :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd =================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd 2007-10-06 23:06:39 UTC (rev 2226) @@ -17,26 +17,5 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cxml) :components ((:module "xml" :components ((:file "package") - (:file "xml"))))) - -;; -*-Lisp-*- - -(in-package :cl-user) - -(defpackage :bknr.xml.system - (:use :cl :asdf)) - -(in-package :bknr.xml.system) - -(defsystem :bknr-xml - :name "baikonour" - :author "Hans Huebner <hans(a)huebner.org>" - :author "Manuel Odendahl <manuel(a)bl0rg.net>" - :version "0" - :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" - :licence "BSD" - :description "baikonour - launchpad for lisp satellites" - :depends-on (:cl-interpol :cxml) - :components ((:module "xml" :components ((:file "package") (:file "xml"))))) Modified: branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -47,6 +47,10 @@ ;;; tail object Falls n != 0: CDR des letzten Conses ;;; ;;; ---------------------------------------------------------------- +;;; Char +;;; tag #\c +;;; data char Zeichen, mit WRITE-CHAR geschrieben +;;; ---------------------------------------------------------------- ;;; String ;;; tag #\s ;;; n %integer Anzahl der folgenden Zeichen @@ -169,6 +173,10 @@ (%write-char #\l stream) (%encode-list object stream)) +(defun encode-char (object stream) + (%write-char #\c stream) + (%write-char object stream)) + (defun %encode-string (object stream) (%encode-integer (length object) stream) #+allegro @@ -263,6 +271,7 @@ (typecase object (integer (encode-integer object stream)) (symbol (encode-symbol object stream)) + (character (encode-char object stream)) (string (encode-string object stream)) (list (encode-list object stream)) (array (encode-array object stream)) @@ -301,6 +310,9 @@ (assert (plusp n)) ;n==0 geben wir nicht aus (%decode-integer/fixed stream n))) +(defun %decode-char (stream) + (%read-char stream)) + (defun %decode-string (stream) #-allegro (let* ((n (%decode-integer stream)) @@ -395,6 +407,7 @@ (#\a (%decode-array stream)) (#\i (%decode-integer stream)) (#\y (%decode-symbol stream)) + (#\c (%decode-char stream)) (#\s (%decode-string stream)) (#\l (%decode-list stream)) (#\# (%decode-hash-table stream)) Modified: branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -61,66 +61,3 @@ (write-char #\> stream) (write-char #\Newline stream)))) -(in-package :bknr.xml) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -6,12 +6,7 @@ :ext :cl-user :cxml - #+allegro - :aclmop - #+cmu - :pcl - #+sbcl - :sb-pcl + :closer-mop :bknr.utils :bknr.xml :bknr.indices) Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -39,9 +39,9 @@ (defmethod write-to-xml ((object standard-object) &key &allow-other-keys) (cxml:with-element (string-downcase (class-name (class-of object))) - (dolist (slot (pcl:class-slots (class-of object))) - (cxml:with-element (string-downcase (symbol-name (pcl:slot-definition-name slot))) - (let ((value (slot-value object (pcl:slot-definition-name slot)))) + (dolist (slot (class-slots (class-of object))) + (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) + (let ((value (slot-value object (slot-definition-name slot)))) (when value (cxml:text (handler-case (cxml::utf8-string-to-rod (princ-to-string value))

1 0

[bknr-cvs] r2225 - in branches/trunk-reorg/thirdparty: . kmrcl-1.97
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 17:39:22 -0400 (Sat, 06 Oct 2007) New Revision: 2225 Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile branches/trunk-reorg/thirdparty/kmrcl-1.97/README branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp Removed: branches/trunk-reorg/thirdparty/kmrcl-1.72/ Log: bring kmrcl up to date Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,53 @@ +18 Sep 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.97 + * datetime.lisp: Improve output format for date-string + +10 Sep 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.96 + * byte-stream.lisp: Use without-package-locks as suggested + by Daniel Gackle. + +01 Jun 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.95 + * {datetime,package}.lisp: Add day-of-week and pretty-date-ut + +07 Jan 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.94 + * signals.lisp: Conditionalize Lispworks support to :unix *features* + +07 Jan 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.93 + * signals.lisp: Add new file for signal processing + +31 Dec 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * impl.lisp, sockets.lisp, equal.lisp, datetime.lisp: Declare ignored variables + +29 Nov 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.92 + * strings.lisp: Add uri-query-to-alist + +24 Oct 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.91 + * io.lisp: Fix output from read-file-to-string + +22 Sep 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.90 + * sockets.lisp: Commit patch from Joerg Hoehle for CLISP sockets + +04 Sep 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.89 + * kmrcl.asd, mop.lisp: Add support for CLISP MOP + * strings.lisp: Add prefixed-number-string macro with type optimization used + by prefixed-fixnum-string and prefixed-integer-string + * package.lisp: export prefixed-integer-string + +27 Jul 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.88 + * strings.lisp, package.lisp: Add binary-sequence-to-hex-string + +26 Jul 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.87 + * proceeses.lisp, sockets.lisp: Apply patch from Travis Cross + for SBCL, posted on + http://common-lisp.net/pipermail/tbnl-devel/2005-December/000524.html + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,78 @@ +Copyright (C) 2000-2006 by Kevin M. Rosenberg. + +This code is free software; you can redistribute it and/or modify it +under the terms of the version 2.1 of the GNU Lesser General Public +License as published by the Free Software Foundation, as clarified by +the Franz preamble to the LGPL found in +http://opensource.franz.com/preamble.html. The preambled is copied below. + +This code is distributed in the hope that it will be useful, +but without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. See the GNU +Lesser General Public License for more details. + +The GNU Lessor General Public License can be found in your Debian file +system in /usr/share/common-licenses/LGPL. + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,32 @@ +.PHONY: all clean test test-acl test-sbcl + +test-file:=`pwd`/run-tests.lisp +all: + +clean: + @find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \ + -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \ + -or -name "*~" -or -name ".#*" -or -name "#*#" | xargs rm -f + +test: test-alisp + +test-alisp: + alisp8 -q -L $(test-file) + +test-mlisp: + mlisp -q -L $(test-file) + +test-sbcl: + sbcl --noinform --disable-debugger --userinit $(test-file) + +test-cmucl: + lisp -init $(test-file) + +test-lw: + lw-console -init $(test-file) + +test-scl: + scl -init $(test-file) + +test-clisp: + clisp -norc -q -i $(test-file) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/README =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/README 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/README 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,6 @@ +KMRCL is a collection of utility functions. It is used as a base for +some of Kevin M. Rosenberg's Common Lisp packages. + +The web site for KMRCL is http://files.b9.com/kmrcl/ + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,106 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl-*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: attrib-class.lisp +;;;; Purpose: Defines metaclass allowing use of attributes on slots +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +;; Disable attrib class until understand changes in sbcl/cmucl +;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method +;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW? + +;;;; Defines a metaclass that allows the use of attributes (or subslots) +;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP. + +(in-package #:kmrcl) + +(defclass attributes-class (kmr-mop:standard-class) + () + (:documentation "metaclass that implements attributes on slots. Based +on example from AMOP")) + +(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition) + ((attributes :initarg :attributes :initform nil + :accessor dsd-attributes))) + +(defclass attributes-esd (kmr-mop:standard-effective-slot-definition) + ((attributes :initarg :attributes :initform nil + :accessor esd-attributes))) + +;; encapsulating macro for Lispworks +(kmr-mop:process-slot-option attributes-class :attributes) + +#+(or cmu scl sbcl openmcl) +(defmethod kmr-mop:validate-superclass ((class attributes-class) + (superclass kmr-mop:standard-class)) + t) + +(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) + (declare (ignore initargs)) + (kmr-mop:find-class 'attributes-dsd)) + +(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) + (declare (ignore initargs)) + (kmr-mop:find-class 'attributes-esd)) + +(defmethod kmr-mop:compute-effective-slot-definition + ((cl attributes-class) #+kmr-normal-cesd name dsds) + #+kmr-normal-cesd (declare (ignore name)) + (let ((esd (call-next-method))) + (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds))) + esd)) + +;; This does not work in Lispworks prior to version 4.3 + +(defmethod kmr-mop:compute-slots ((class attributes-class)) + (let* ((normal-slots (call-next-method)) + (alist (mapcar + #'(lambda (slot) + (cons (kmr-mop:slot-definition-name slot) + (mapcar #'(lambda (attr) (list attr)) + (esd-attributes slot)))) + normal-slots))) + + (cons (make-instance + 'attributes-esd + :name 'all-attributes + :initform `',alist + :initfunction #'(lambda () alist) + :allocation :instance + :documentation "Attribute bucket" + :type t + ) + normal-slots))) + +(defun slot-attribute (instance slot-name attribute) + (cdr (slot-attribute-bucket instance slot-name attribute))) + +(defun (setf slot-attribute) (new-value instance slot-name attribute) + (setf (cdr (slot-attribute-bucket instance slot-name attribute)) + new-value)) + +(defun slot-attribute-bucket (instance slot-name attribute) + (let* ((all-buckets (slot-value instance 'all-attributes)) + (slot-bucket (assoc slot-name all-buckets))) + (unless slot-bucket + (error "The slot named ~S of ~S has no attributes." + slot-name instance)) + (let ((attr-bucket (assoc attribute (cdr slot-bucket)))) + (unless attr-bucket + (error "The slot named ~S of ~S has no attributes named ~S." + slot-name instance attribute)) + attr-bucket))) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,182 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: buff-input.lisp +;;;; Purpose: Buffered line input +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(eval-when (:compile-toplevel) + (declaim (optimize (speed 3) (safety 0) (space 0) (debug 0)))) + +(defconstant +max-field+ 10000) +(defconstant +max-fields-per-line+ 20) +(defconstant +field-delim+ #\|) +(defconstant +eof-char+ #\rubout) +(defconstant +newline+ #\Newline) + +(declaim (type character +eof-char+ +field-delim+ +newline+) + (type fixnum +max-field+ +max-fields-per-line+)) + +;; Buffered fields parsing function +;; Uses fill-pointer for size + +(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+) + (max-field-len +max-field+)) + (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil))) + (dotimes (i +max-fields-per-line+) + (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil))) + bufs)) + +(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+) + (eof 'eof)) + "Read a line from a stream into a field buffers" + (declare (type base-char field-delim) + (type vector fields)) + (setf (fill-pointer fields) 0) + (do ((ifield 0 (1+ ifield)) + (linedone nil) + (is-eof nil)) + (linedone (if is-eof eof fields)) + (declare (type fixnum ifield) + (type boolean linedone is-eof)) + (let ((field (aref fields ifield))) + (declare (type base-string field)) + (do ((ipos 0) + (fielddone nil) + (rc (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (fielddone (unread-char rc strm)) + (declare (type fixnum ipos) + (type base-char rc) + (type boolean fielddone)) + (cond + ((char= rc field-delim) + (setf (fill-pointer field) ipos) + (setq fielddone t)) + ((char= rc +newline+) + (setf (fill-pointer field) ipos) + (setf (fill-pointer fields) ifield) + (setq fielddone t) + (setq linedone t)) + ((char= rc +eof-char+) + (setf (fill-pointer field) ipos) + (setf (fill-pointer fields) ifield) + (setq fielddone t) + (setq linedone t) + (setq is-eof t)) + (t + (setf (char field ipos) rc) + (incf ipos))))))) + +;; Buffered fields parsing +;; Does not use fill-pointer +;; Returns 2 values -- string array and length array +(defstruct field-buffers + (nfields 0 :type fixnum) + (buffers) + (field-lengths)) + +(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+) + (max-field-len +max-field+)) + (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil)) + (bufstruct (make-field-buffers))) + (dotimes (i +max-fields-per-line+) + (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil))) + (setf (field-buffers-buffers bufstruct) bufs) + (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+ + :element-type 'fixnum :fill-pointer nil :adjustable nil)) + (setf (field-buffers-nfields bufstruct) 0) + bufstruct)) + + +(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+) + (eof 'eof)) + "Read a line from a stream into a field buffers" + (declare (character field-delim)) + (setf (field-buffers-nfields fields) 0) + (do ((ifield 0 (1+ ifield)) + (linedone nil) + (is-eof nil)) + (linedone (if is-eof eof fields)) + (declare (fixnum ifield) + (t linedone is-eof)) + (let ((field (aref (field-buffers-buffers fields) ifield))) + (declare (simple-string field)) + (do ((ipos 0) + (fielddone nil) + (rc (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (fielddone (unread-char rc strm)) + (declare (fixnum ipos) + (character rc) + (t fielddone)) + (cond + ((char= rc field-delim) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setq fielddone t)) + ((char= rc +newline+) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setf (field-buffers-nfields fields) ifield) + (setq fielddone t) + (setq linedone t)) + ((char= rc +eof-char+) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setf (field-buffers-nfields fields) ifield) + (setq fielddone t) + (setq linedone t) + (setq is-eof t)) + (t + (setf (char field ipos) rc) + (incf ipos))))))) + +(defun bfield (fields i) + (if (>= i (field-buffers-nfields fields)) + nil + (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i)))) + +;;; Buffered line parsing function + +(defconstant +max-line+ 20000) +(let ((linebuffer (make-array +max-line+ + :element-type 'character + :fill-pointer 0))) + (defun read-buffered-line (strm eof) + "Read a line from astream into a vector buffer" + (declare (optimize (speed 3) (space 0) (safety 0))) + (let ((pos 0) + (done nil)) + (declare (fixnum pos) (type boolean done)) + (setf (fill-pointer linebuffer) 0) + (do ((c (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (done (progn + (unless (eql c +eof-char+) (unread-char c strm)) + (if (eql c +eof-char+) eof linebuffer))) + (declare (character c)) + (cond + ((>= pos +max-line+) + (warn "Line overflow") + (setf done t)) + ((char= c #\Newline) + (when (plusp pos) + (setf (fill-pointer linebuffer) (1- pos))) + (setf done t)) + ((char= +eof-char+) + (setf done t)) + (t + (setf (char linebuffer pos) c) + (incf pos))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,270 @@ +;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: byte-stream.lisp +;;;; Purpose: Byte array input/output streams +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id$ +;;;; +;;;; Works for CMUCL, SBCL, and AllergoCL only +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;; Intial CMUCL version by OnShored. Ported to SBCL by Kevin Rosenberg + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:without-package-locks + (sb-pcl::structure-class-p + (find-class (intern "FILE-STREAM" "SB-IMPL")))) + (push :old-sb-file-stream cl:*features*))) + +#+(or cmu sbcl) +(progn +(defstruct (byte-array-output-stream + (:include #+cmu system:lisp-stream + #+(and sbcl old-sb-file-stream) sb-impl::file-stream + #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream + (bout #'byte-array-bout) + (misc #'byte-array-out-misc)) + (:print-function %print-byte-array-output-stream) + (:constructor make-byte-array-output-stream ())) + ;; The buffer we throw stuff in. + (buffer (make-array 128 :element-type '(unsigned-byte 8))) + ;; Index of the next location to use. + (index 0 :type fixnum)) + +(defun %print-byte-array-output-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Byte-Array-Output Stream>" stream)) + +(setf (documentation 'make-binary-output-stream 'function) + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data.") + +(defun byte-array-bout (stream byte) + (let ((current (byte-array-output-stream-index stream)) + (workspace (byte-array-output-stream-buffer stream))) + (if (= current (length workspace)) + (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8)))) + (replace new-workspace workspace) + (setf (aref new-workspace current) byte) + (setf (byte-array-output-stream-buffer stream) new-workspace)) + (setf (aref workspace current) byte)) + (setf (byte-array-output-stream-index stream) (1+ current)))) + +(defun byte-array-out-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if (null arg1) + (byte-array-output-stream-index stream))) + (:element-type '(unsigned-byte 8)))) + +(defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function and +clears buffer." + (declare (type byte-array-output-stream stream)) + (prog1 + (dump-output-stream-data stream) + (setf (byte-array-output-stream-index stream) 0))) + +(defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (declare (type byte-array-output-stream stream)) + (let* ((length (byte-array-output-stream-index stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (byte-array-output-stream-buffer stream)) + result)) + +) ; progn + + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb-ext:without-package-locks + (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL")) + (intern "COPY-SYSTEM-AREA" "SB-KERNEL") + (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL"))) + (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + sb-vm:n-byte-bits + 1)))) + +#+(or cmu sbcl) +(progn + (defstruct (byte-array-input-stream + (:include #+cmu system:lisp-stream + ;;#+sbcl sb-impl::file-stream + #+(and sbcl old-sb-file-stream) sb-impl::file-stream + #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream + (in #'byte-array-inch) + (bin #'byte-array-binch) + (n-bin #'byte-array-stream-read-n-bytes) + (misc #'byte-array-in-misc)) + (:print-function %print-byte-array-input-stream) + ;(:constructor nil) + (:constructor internal-make-byte-array-input-stream + (byte-array current end))) + (byte-array nil :type vector) + (current nil) + (end nil)) + + +(defun %print-byte-array-input-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Byte-Array-Input Stream>" stream)) + +(defun byte-array-inch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + #+cmu + (eof-or-lose stream eof-errorp eof-value) + #+sbcl + (sb-impl::eof-or-lose stream eof-errorp eof-value) + ) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-binch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + #+cmu + (eof-or-lose stream eof-errorp eof-value) + #+sbcl + (sb-impl::eof-or-lose stream eof-errorp eof-value) + ) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp) + (declare (type byte-array-input-stream stream)) + (let* ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream)) + (available (- (byte-array-input-stream-end stream) index)) + (copy (min available requested))) + (when (plusp copy) + (setf (byte-array-input-stream-current stream) + (+ index copy)) + #+cmu + (system:without-gcing + (system::system-area-copy (system:vector-sap byte-array) + (* index vm:byte-bits) + (if (typep buffer 'system::system-area-pointer) + buffer + (system:vector-sap buffer)) + (* start vm:byte-bits) + (* copy vm:byte-bits))) + #+sbcl + (sb-sys:without-gcing + (funcall *system-copy-fn* (sb-sys:vector-sap byte-array) + (* index +system-copy-multiplier+) + (if (typep buffer 'sb-sys::system-area-pointer) + buffer + (sb-sys:vector-sap buffer)) + (* start +system-copy-multiplier+) + (* copy +system-copy-multiplier+)))) + (if (and (> requested copy) eof-errorp) + (error 'end-of-file :stream stream) + copy))) + +(defun byte-array-in-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if arg1 + (setf (byte-array-input-stream-current stream) arg1) + (byte-array-input-stream-current stream))) + (:file-length (length (byte-array-input-stream-byte-array stream))) + (:unread (decf (byte-array-input-stream-current stream))) + (:listen (or (/= (the fixnum (byte-array-input-stream-current stream)) + (the fixnum (byte-array-input-stream-end stream))) + :eof)) + (:element-type 'base-char))) + +(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer))) + "Returns an input stream which will supply the bytes of BUFFER between + Start and End in order." + (internal-make-byte-array-input-stream buffer start end)) + +) ;; progn + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :old-sb-file-stream cl:*features*))) + +;;; Simple streams implementation by Kevin Rosenberg + +#+allegro +(progn + + (defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream) + () + ) + + (defun make-byte-array-output-stream () + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data." + (make-instance 'extendable-buffer-output-stream + :buffer (make-array 128 :element-type '(unsigned-byte 8)) + :external-form :octets)) + + (defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function +and clears buffer." + (prog1 + (dump-output-stream-data stream) + (file-position stream 0))) + + (defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (force-output stream) + (let* ((length (file-position stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (slot-value stream 'excl::buffer)) + result)) + + (excl::without-package-locks + (defmethod excl:device-extend ((stream extendable-buffer-output-stream) + need action) + (declare (ignore action)) + (let* ((len (file-position stream)) + (new-len (max (+ len need) (* 2 len))) + (old-buf (slot-value stream 'excl::buffer)) + (new-buf (make-array new-len :element-type '(unsigned-byte 8)))) + (declare (fixnum len) + (optimize (speed 3) (safety 0))) + (dotimes (i len) + (setf (aref new-buf i) (aref old-buf i))) + (setf (slot-value stream 'excl::buffer) new-buf) + (setf (slot-value stream 'excl::buffer-ptr) new-len) + ) + t)) + +) + +#+allegro +(progn + (defun make-byte-array-input-stream (buffer &optional (start 0) + (end (length buffer))) + (excl:make-buffer-input-stream buffer start end :octets)) + ) ;; progn + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,315 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: color.lisp +;;;; Purpose: Functions for color +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Oct 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;; The HSV colour space has three coordinates: hue, saturation, and +;; value (sometimes called brighness) respectively. This colour system is +;; attributed to "Smith" around 1978 and used to be called the hexcone +;; colour model. The hue is an angle from 0 to 360 degrees, typically 0 +;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240 +;; degrees blue, and 300 degrees magenta. Saturation typically ranges +;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is, +;; 0 indicates grey and 1 is the pure primary colour. Value is similar to +;; luninance except it also varies the colour saturation. If the colour +;; space is represented by disks of varying lightness then the hue and +;; saturation are the equivalent to polar coordinates (r,theta) of any +;; point in the plane. The disks on the right show this for various +;; values. + +(defun hsv->rgb (h s v) + (declare (optimize (speed 3) (safety 0))) + (when (zerop s) + (return-from hsv->rgb (values v v v))) + + (while (minusp h) + (incf h 360)) + (while (>= h 360) + (decf h 360)) + + (let ((h-pos (/ h 60))) + (multiple-value-bind (h-int h-frac) (truncate h-pos) + (declare (fixnum h-int)) + (let ((p (* v (- 1 s))) + (q (* v (- 1 (* s h-frac)))) + (t_ (* v (- 1 (* s (- 1 h-frac))))) + r g b) + + (cond + ((zerop h-int) + (setf r v + g t_ + b p)) + ((= 1 h-int) + (setf r q + g v + b p)) + ((= 2 h-int) + (setf r p + g v + b t_)) + ((= 3 h-int) + (setf r p + g q + b v)) + ((= 4 h-int) + (setf r t_ + g p + b v)) + ((= 5 h-int) + (setf r v + g p + b q))) + (values r g b))))) + + +(defun hsv255->rgb255 (h s v) + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + + (when (zerop s) + (return-from hsv255->rgb255 (values v v v))) + + (locally (declare (type fixnum h s v)) + (while (minusp h) + (incf h 360)) + (while (>= h 360) + (decf h 360)) + + (let ((h-pos (/ h 60))) + (multiple-value-bind (h-int h-frac) (truncate h-pos) + (declare (fixnum h-int)) + (let* ((fs (/ s 255)) + (fv (/ v 255)) + (p (round (* 255 fv (- 1 fs)))) + (q (round (* 255 fv (- 1 (* fs h-frac))))) + (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac)))))) + r g b) + + (cond + ((zerop h-int) + (setf r v + g t_ + b p)) + ((= 1 h-int) + (setf r q + g v + b p)) + ((= 2 h-int) + (setf r p + g v + b t_)) + ((= 3 h-int) + (setf r p + g q + b v)) + ((= 4 h-int) + (setf r t_ + g p + b v)) + ((= 5 h-int) + (setf r v + g p + b q))) + (values r g b)))))) + + + +(defun rgb->hsv (r g b) + (declare (optimize (speed 3) (safety 0))) + + (let* ((min (min r g b)) + (max (max r g b)) + (delta (- max min)) + (v max) + (s 0) + (h nil)) + + (when (plusp max) + (setq s (/ delta max))) + + (when (plusp delta) + (setq h (cond + ((= max r) + (nth-value 0 (/ (- g b) delta))) + ((= max g) + (nth-value 0 (+ 2 (/ (- b r) delta)))) + (t + (nth-value 0 (+ 4 (/ (- r g) delta)))))) + (setq h (the fixnum (* 60 h))) + (when (minusp h) + (incf h 360))) + + (values h s v))) + +(defun rgb255->hsv255 (r g b) + "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255" + (declare (fixnum r g b) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + + (let* ((min (min r g b)) + (max (max r g b)) + (delta (- max min)) + (v max) + (s 0) + (h nil)) + (declare (fixnum min max delta v s) + (type (or null fixnum) h)) + + (when (plusp max) + (setq s (truncate (the fixnum (* 255 delta)) max))) + + (when (plusp delta) + (setq h (cond + ((= max r) + (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta)) + ((= max g) + (the fixnum + (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta)))) + (t + (the fixnum + (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta)))))) + (when (minusp h) + (incf h 360))) + + (values h s v))) + + +(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001)) + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (flet ((~= (a b) + (cond + ((and (null a) (null b)) + t) + ((or (null a) (null b)) + nil) + (t + (< (abs (- a b)) limit))))) + (cond + ((and (~= 0 v1) (~= 0 v2)) + t) + ((or (null h1) (null h2)) + (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2)) + t)) + (t + (when (~= h1 h2) (~= s1 s2) (~= v1 v2) + t))))) + +(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1)) + (declare (type fixnum s1 v1 s2 v2 limit) + (type (or null fixnum) h1 h2) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (flet ((~= (a b) + (declare (type (or null fixnum) a b)) + (cond + ((and (null a) (null b)) + t) + ((or (null a) (null b)) + nil) + (t + (<= (abs (the fixnum (- a b))) limit))))) + (cond + ((and (~= 0 v1) (~= 0 v2)) + t) + ((or (null h1) (null h2)) + (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2)) + t)) + (t + (when (~= h1 h2) (~= s1 s2) (~= v1 v2) + t))))) + +(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key + (hue-range 15) (value-range .2) (saturation-range 0.2) + (gray-limit 0.3) (black-limit 0.3)) + "Returns T if two HSV values are similar." + (cond + ;; all black colors are similar + ((and (<= v1 black-limit) (<= v2 black-limit)) + t) + ;; all desaturated (gray) colors are similar for a value, despite hue + ((and (<= s1 gray-limit) (<= s2 gray-limit)) + (when (<= (abs (- v1 v2)) value-range) + t)) + (t + (when (and (<= (abs (hue-difference h1 h2)) hue-range) + (<= (abs (- v1 v2)) value-range) + (<= (abs (- s1 s2)) saturation-range)) + t)))) + + +(defun hsv255-similar (h1 s1 v1 h2 s2 v2 + &key (hue-range 15) (value-range 50) (saturation-range 50) + (gray-limit 75) (black-limit 75)) + "Returns T if two HSV values are similar." + (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range + gray-limit black-limit) + (type (or null fixnum) h1 h2) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (cond + ;; all black colors are similar + ((and (<= v1 black-limit) (<= v2 black-limit)) + t) + ;; all desaturated (gray) colors are similar for a value, despite hue + ((and (<= s1 gray-limit) (<= s2 gray-limit)) + (when (<= (abs (- v1 v2)) value-range) + t)) + (t + (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range) + (<= (abs (- v1 v2)) value-range) + (<= (abs (- s1 s2)) saturation-range)) + t)))) + + + +(defun hue-difference (h1 h2) + "Return difference between two hues around 360 degree circle" + (cond + ((and (null h1) (null h2)) + t) + ((or (null h1) (null h2)) + 360) + (t + (let ((diff (- h2 h1))) + (cond + ((< diff -180) + (+ 360 diff) + ) + ((> diff 180) + (- (- 360 diff))) + (t + diff)))))) + + +(defun hue-difference-fixnum (h1 h2) + "Return difference between two hues around 360 degree circle" + (cond + ((and (null h1) (null h2)) + t) + ((or (null h1) (null h2)) + 360) + (t + (locally (declare (type fixnum h1 h2)) + (let ((diff (- h2 h1))) + (cond + ((< diff -180) + (+ 360 diff) + ) + ((> diff 180) + (- (- 360 diff))) + (t + diff))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,50 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: console.lisp +;;;; Purpose: Console interactiion +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;;a +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defvar *console-msgs* t) + +(defvar *console-msgs-types* nil) + +(defun cmsg (template &rest args) + "Format output to console" + (when *console-msgs* + (setq template (concatenate 'string "~&;; " template "~%")) + (apply #'format t template args))) + +(defun cmsg-c (condition template &rest args) + "Push CONDITION keywords into *console-msgs-types* to print console msgs + for that CONDITION. TEMPLATE and ARGS function identically to + (format t TEMPLATE ARGS) " + (when (or (member :verbose *console-msgs-types*) + (member condition *console-msgs-types*)) + (apply #'cmsg template args))) + +(defun cmsg-add (condition) + (pushnew condition *console-msgs-types*)) + +(defun cmsg-remove (condition) + (setf *console-msgs-types* (remove condition *console-msgs-types*))) + +(defun fixme (template &rest args) + "Format output to console" + (setq template (concatenate 'string "~&;; ** FIXME ** " template "~%")) + (apply #'format t template args) + (values)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,157 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: datetime.lisp +;;;; Purpose: Date & Time functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; Formatting functions + +(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0)) + (multiple-value-bind (sec min hr dy mn yr wkday) + (decode-universal-time + (encode-universal-time s m hour day month year)) + (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + wkday) + (elt '("January" "February" "March" "April" "May" "June" + "July" "August" "September" "October" "November" + "December") + (1- mn)) + (format nil "~A" dy) + (format nil "~A" yr) + (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec)))) + +(defun pretty-date-ut (&optional (tm (get-universal-time))) + (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm) + (pretty-date yr mn dy hr min sec))) + +(defun date-string (ut) + (if (typep ut 'integer) + (multiple-value-bind (sec min hr day mon year dow daylight-p zone) + (decode-universal-time ut) + (declare (ignore daylight-p zone)) + (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" + dow + day + (1- mon) + year + hr min sec)))) + +(defun print-seconds (secs) + (print-float-units secs "sec")) + +(defun print-float-units (val unit) + (cond + ((< val 1d-6) + (format t "~,2,9F nano~A" val unit)) + ((< val 1d-3) + (format t "~,2,6F micro~A" val unit)) + ((< val 1) + (format t "~,2,3F milli~A" val unit)) + ((> val 1d9) + (format t "~,2,-9F giga~A" val unit)) + ((> val 1d6) + (format t "~,2,-6F mega~A" val unit)) + ((> val 1d3) + (format t "~,2,-3F kilo~A" val unit)) + (t + (format t "~,2F ~A" val unit)))) + +(defconstant +posix-epoch+ + (encode-universal-time 0 0 0 1 1 1970 0)) + +(defun posix-time-to-utime (time) + (+ time +posix-epoch+)) + +(defun utime-to-posix-time (utime) + (- utime +posix-epoch+)) + +;; Monthnames taken from net-telent-date to support lml2 + +(defvar *monthnames* + '((1 . "January") + (2 . "February") + (3 . "March") + (4 . "April") + (5 . "May") + (6 . "June") + (7 . "July") + (8 . "August") + (9 . "September") + (10 . "October") + (11 . "November") + (12 . "December"))) + +(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space)) + "Print the name of the month (1=January) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A" + (declare (ignore colon-p)) + (let ((monthstring (cdr (assoc arg *monthnames*)))) + (if (not monthstring) (return-from monthname nil)) + (let ((truncate (if width (min width (length monthstring)) nil))) + (format stream + (if at-p "~V,V,V,V@A" "~V,V,V,VA") + mincol colinc minpad padchar + (subseq monthstring 0 truncate))))) + +(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4)) + +(defun day-of-week (year month day) + "Day of week calculation using Zeller's Congruence. +Input: The year y, month m (1 ≤ m ≤ 12) and day d (1 ≤ d ≤ 31). +Output: n - the day of the week (Sunday = 0, Saturday = 6)." + + (when (< month 3) + (decf year)) + (mod + (+ year (floor year 4) (- (floor year 100)) (floor year 400) + (aref +zellers-adj+ (1- month)) day) + 7)) + +;;;; Daylight Saving Time calculations + +;; Daylight Saving Time begins for most of the United States at 2 +;; a.m. on the first Sunday of April. Time reverts to standard time at +;; 2 a.m. on the last Sunday of October. In the U.S., each time zone +;; switches at a different time. + +;; In the European Union, Summer Time begins and ends at 1 am +;; Universal Time (Greenwich Mean Time). It starts the last Sunday in +;; March, and ends the last Sunday in October. In the EU, all time +;; zones change at the same moment. + +;; Spring forward, Fall back +;; During DST, clocks are turned forward an hour, effectively moving +;; an hour of daylight from the morning to the evening. + +;; United States European Union + +;; Year DST Begins DST Ends Summertime Summertime +;; at 2 a.m. at 2 a.m. period begins period ends +;; at 1 a.m. UT at 1 a.m. UT +;; ---------------------------------------------------------- +;; 2000 April 2 October 29 March 26 October 29 +;; 2001 April 1 October 28 March 25 October 28 +;; 2002 April 7 October 27 March 31 October 27 +;; 2003 April 6 October 26 March 30 October 26 +;; 2004 April 4 October 31 March 28 October 31 +;; 2005 April 3 October 30 March 27 October 30 +;; 2006 April 2 October 29 March 26 October 29 +;; 2007 April 1 October 28 March 25 October 28 +;; 2008 April 6 October 26 March 30 October 26 + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,110 @@ +(in-package kmrcl) + +(defpackage docbook + (:use #:cl #:cl-who #:kmrcl) + (:export + #:docbook-file + #:docbook-stream + #:xml-file->sexp-file + )) +(in-package docbook) + +(defmacro docbook-stream (stream tree) + `(progn + (print-prologue ,stream) + (write-char #\Newline ,stream) + (let (cl-who::*indent* t) + (cl-who:with-html-output (,stream) ,tree)))) + +(defun print-prologue (stream) + (write-string "<?xml version='1.0' ?> " stream) + (write-char #\Newline stream) + (write-string "<!DOCTYPE book PUBLIC \"-//OASIS//DTD DocBook XML V4.2//EN\"" stream) + (write-char #\Newline stream) + (write-string " \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\" [" stream) + (write-char #\Newline stream) + (write-string "<!ENTITY % myents SYSTEM \"entities.xml\">" stream) + (write-char #\Newline stream) + (write-string "%myents;" stream) + (write-char #\Newline stream) + (write-string "]>" stream) + (write-char #\Newline stream)) + +(defmacro docbook-file (name tree) + (let ((%name (gensym))) + `(let ((,%name ,name)) + (with-open-file (stream ,%name :direction :output + :if-exists :supersede) + (docbook-stream stream ,tree)) + (values)))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'pxml) + (require 'uri)) + +(defun is-whitespace-string (s) + (and (stringp s) + (kmrcl:is-string-whitespace s))) + +(defun atom-processor (a) + (when a + (typecase a + (symbol + (nth-value 0 (kmrcl:ensure-keyword a))) + (string + (kmrcl:collapse-whitespace a)) + (t + a)))) + +(defun entity-callback (var token &optional public) + (declare (ignore token public)) + (cond + ((and (net.uri:uri-scheme var) + (string= "http" (net.uri:uri-scheme var))) + nil) + (t + (let ((path (net.uri:uri-path var))) + (if (probe-file path) + (ignore-errors (open path)) + (make-string-input-stream + (let ((*print-circle* nil)) + (format nil "<!ENTITY ~A '~A'>" path path)))))))) + +#+allegro +(defun xml-file->sexp-file (file &key (preprocess nil)) + (let* ((path (etypecase file + (string (parse-namestring file)) + (pathname file))) + (new-path (make-pathname :defaults path + :type "sexp")) + raw-sexp) + + (if preprocess + (multiple-value-bind (xml error status) + (kmrcl:command-output (format nil + "sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\"" + "catalog-debian.xml" + (namestring (make-pathname :defaults (if (pathname-directory path) + path + *default-pathname-defaults*) + :name nil :type nil)) + (namestring path))) + (unless (and (zerop status) (or (null error) (zerop (length error)))) + (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A" + path status error)) + (setq raw-sexp (net.xml.parser:parse-xml + (apply #'concatenate 'string xml) + :content-only nil))) + (with-open-file (input path :direction :input) + (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback)))) + + (with-open-file (output new-path :direction :output + :if-exists :supersede) + (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string + raw-sexp + #'atom-processor))) + (write filtered :stream output :pretty t)))) + (values)) + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,138 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: equal.lisp +;;;; Purpose: Generalized equal function for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + + +(defun generalized-equal (obj1 obj2) + (if (not (equal (type-of obj1) (type-of obj2))) + (progn + (terpri) + (describe obj1) + (describe obj2) + nil) + (typecase obj1 + (double-float + (let ((diff (abs (/ (- obj1 obj2) obj1)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t))) + (complex + (and (generalized-equal (realpart obj1) (realpart obj2)) + (generalized-equal (imagpart obj1) (imagpart obj2)))) + (structure-object + (generalized-equal-fielded-object obj1 obj2)) + (standard-object + (generalized-equal-fielded-object obj1 obj2)) + (hash-table + (generalized-equal-hash-table obj1 obj2) + ) + (function + (generalized-equal-function obj1 obj2)) + (string + (string= obj1 obj2)) + (array + (generalized-equal-array obj1 obj2)) + (t + (equal obj1 obj2))))) + + +(defun generalized-equal-function (obj1 obj2) + (string= (function-to-string obj1) (function-to-string obj2))) + +(defun generalized-equal-array (obj1 obj2) + (block test + (when (not (= (array-total-size obj1) (array-total-size obj2))) + (return-from test nil)) + (dotimes (i (array-total-size obj1)) + (unless (generalized-equal (aref obj1 i) (aref obj2 i)) + (return-from test nil))) + (return-from test t))) + +(defun generalized-equal-hash-table (obj1 obj2) + (block test + (when (not (= (hash-table-count obj1) (hash-table-count obj2))) + (return-from test nil)) + (maphash + #'(lambda (k v) + (multiple-value-bind (value found) (gethash k obj2) + (unless (and found (generalized-equal v value)) + (return-from test nil)))) + obj1) + (return-from test t))) + +(defun generalized-equal-fielded-object (obj1 obj2) + (block test + (when (not (equal (class-of obj1) (class-of obj2))) + (return-from test nil)) + (dolist (field (class-slot-names (class-name (class-of obj1)))) + (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field)) + (return-from test nil))) + (return-from test t))) + +(defun class-slot-names (c-name) + "Given a CLASS-NAME, returns a list of the slots in the class." + #+(or allegro cmu lispworks sbcl scl) + (mapcar #'kmr-mop:slot-definition-name + (kmr-mop:class-slots (kmr-mop:find-class c-name))) + #+(and mcl (not openmcl)) + (let* ((class (find-class c-name nil))) + (when (typep class 'standard-class) + (nconc (mapcar #'car (ccl:class-instance-slots class)) + (mapcar #'car (ccl:class-class-slots class))))) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore c-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (error "class-slot-names is not defined on this platform") + ) + +(defun structure-slot-names (s-name) + "Given a STRUCTURE-NAME, returns a list of the slots in the structure." + #+allegro (class-slot-names s-name) + #+lispworks (structure:structure-class-slot-names + (find-class s-name)) + #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name + (kmr-mop:class-slots (kmr-mop:find-class s-name))) + #+scl (mapcar #'kernel:dsd-name + (kernel:dd-slots + (kernel:layout-info + (kernel:class-layout (find-class s-name))))) + #+(and mcl (not openmcl)) + (let* ((sd (gethash s-name ccl::%defstructs%)) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore s-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (error "structure-slot-names is not defined on this platform") + ) + +(defun function-to-string (obj) + "Returns the lambda code for a function. Relies on +Allegro implementation-dependent features." + (multiple-value-bind (lambda closurep name) (function-lambda-expression obj) + (declare (ignore closurep)) + (if lambda + (format nil "#'~s" lambda) + (if name + (format nil "#'~s" name) + (progn + (print obj) + (break)))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,53 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: functions.lisp +;;;; Purpose: Function routines for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(defun memo-proc (fn) + "Memoize results of call to fn, returns a closure with hash-table" + (let ((cache (make-hash-table :test #'equal))) + #'(lambda (&rest args) + (multiple-value-bind (val foundp) (gethash args cache) + (if foundp + val + (setf (gethash args cache) (apply fn args))))))) + +(defun memoize (fn-name) + (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name)))) + +(defmacro defun-memo (fn args &body body) + "Define a memoized function" + `(memoize (defun ,fn ,args . ,body))) + +(defmacro _f (op place &rest args) + (multiple-value-bind (vars forms var set access) + (get-setf-expansion place) + `(let* (,@(mapcar #'list vars forms) + (,(car var) (,op ,access ,@args))) + ,set))) + +(defun compose (&rest fns) + (if fns + (let ((fn1 (car (last fns))) + (fns (butlast fns))) + #'(lambda (&rest args) + (reduce #'funcall fns + :from-end t + :initial-value (apply fn1 args)))) + #'identity)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,61 @@ +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(in-package #:kmrcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,148 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: impl.lisp +;;;; Purpose: Implementation Dependent routines for kmrcl +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun canonicalize-directory-name (filename) + (flet ((un-unspecific (value) + (if (eq value :unspecific) nil value))) + (let* ((path (pathname filename)) + (name (un-unspecific (pathname-name path))) + (type (un-unspecific (pathname-type path))) + (new-dir + (cond ((and name type) (list (concatenate 'string name "." type))) + (name (list name)) + (type (list type)) + (t nil)))) + (if new-dir + (make-pathname + :directory (append (un-unspecific (pathname-directory path)) + new-dir) + :name nil :type nil :version nil :defaults path) + path)))) + + +(defun probe-directory (filename &key (error-if-does-not-exist nil)) + (let* ((path (canonicalize-directory-name filename)) + (probe + #+allegro (excl:probe-directory path) + #+clisp (values + (ignore-errors + (#+lisp=cl ext:probe-directory + #-lisp=cl lisp:probe-directory + path))) + #+(or cmu scl) (when (eq :directory + (unix:unix-file-kind (namestring path))) + path) + #+lispworks (when (lw:file-directory-p path) + path) + #+sbcl (when (eq :directory + (sb-unix:unix-file-kind (namestring path))) + path) + #-(or allegro clisp cmu lispworks sbcl scl) + (probe-file path))) + (if probe + probe + (when error-if-does-not-exist + (error "Directory ~A does not exist." filename))))) + +(defun cwd (&optional dir) + "Change directory and set default pathname" + (cond + ((not (null dir)) + (when (and (typep dir 'logical-pathname) + (translate-logical-pathname dir)) + (setq dir (translate-logical-pathname dir))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + #+allegro (excl:chdir dir) + #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir) + #+(or cmu scl) (setf (ext:default-directory) dir) + #+cormanlisp (ccl:set-current-directory dir) + #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir) + #+openmcl (ccl:cwd dir) + #+gcl (si:chdir dir) + #+lispworks (hcl:change-directory dir) + (setq cl:*default-pathname-defaults* dir)) + (t + (let ((dir + #+allegro (excl:current-directory) + #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) + #+(or cmu scl) (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd/) + #+cormanlisp (ccl:get-current-directory) + #+lispworks (hcl:get-working-directory) + #+mcl (ccl:mac-default-directory) + #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + dir)))) + + + +(defun quit (&optional (code 0)) + "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." + #+allegro (excl:exit code :quiet t) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+mcl (ccl:quit code) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + + +(defun command-line-arguments () + #+allegro (system:command-line-arguments) + #+sbcl sb-ext:*posix-argv* + ) + +(defun copy-file (from to &key link overwrite preserve-symbolic-links + (preserve-time t) remove-destination force verbose) + #+allegro (sys:copy-file from to :link link :overwrite overwrite + :preserve-symbolic-links preserve-symbolic-links + :preserve-time preserve-time + :remove-destination remove-destination + :force force :verbose verbose) + #-allegro + (declare (ignore verbose preserve-symbolic-links overwrite)) + (cond + ((and (typep from 'stream) (typep to 'stream)) + (copy-binary-stream from to)) + ((not (probe-file from)) + (error "File ~A does not exist." from)) + ((eq link :hard) + (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to))) + (link + (multiple-value-bind (stdout stderr status) + (command-output "ln -f ~A ~A" (namestring from) (namestring to)) + (declare (ignore stdout stderr)) + ;; try symbolic if command failed + (unless (zerop status) + (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to))))) + (t + (when (and (or force remove-destination) (probe-file to)) + (delete-file to)) + (let* ((options (if preserve-time + "-p" + "")) + (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to)))) + (run-shell-command cmd))))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,329 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: io.lisp +;;;; Purpose: Input/Output functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun print-file-contents (file &optional (strm *standard-output*)) + "Opens a reads a file. Returns the contents as a single string" + (when (probe-file file) + (let ((eof (cons 'eof nil))) + (with-open-file (in file :direction :input) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (write-string line strm) + (write-char #\newline strm)))))) + +(defun read-stream-to-string (in) + (with-output-to-string (out) + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + +(defun read-file-to-string (file) + "Opens a reads a file. Returns the contents as a single string" + (with-open-file (in file :direction :input) + (read-stream-to-string in))) + +(defun read-file-to-usb8-array (file) + "Opens a reads a file. Returns the contents as single unsigned-byte array" + (with-open-file (in file :direction :input :element-type '(unsigned-byte 8)) + (let* ((file-len (file-length in)) + (usb8 (make-array file-len :element-type '(unsigned-byte 8))) + (pos (read-sequence usb8 in))) + (unless (= file-len pos) + (error "Length read (~D) doesn't match file length (~D)~%" pos file-len)) + usb8))) + + +(defun read-stream-to-strings (in) + (let ((lines '()) + (eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (push line lines)) + (nreverse lines))) + +(defun read-file-to-strings (file) + "Opens a reads a file. Returns the contents as a list of strings" + (with-open-file (in file :direction :input) + (read-stream-to-strings in))) + +(defun file-subst (old new file1 file2) + (with-open-file (in file1 :direction :input) + (with-open-file (out file2 :direction :output + :if-exists :supersede) + (stream-subst old new in out)))) + +(defun print-n-chars (char n stream) + (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0))) + (dotimes (i n) + (declare (fixnum i)) + (write-char char stream))) + +(defun print-n-strings (str n stream) + (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0))) + (dotimes (i n) + (declare (fixnum i)) + (write-string str stream))) + +(defun indent-spaces (n &optional (stream *standard-output*)) + "Indent n*2 spaces to output stream" + (print-n-chars #\space (+ n n) stream)) + + +(defun indent-html-spaces (n &optional (stream *standard-output*)) + "Indent n*2 html spaces to output stream" + (print-n-strings " " (+ n n) stream)) + + +(defun print-list (l &optional (output *standard-output*)) + "Print a list to a stream" + (format output "~{~A~%~}" l)) + +(defun print-rows (rows &optional (ostrm *standard-output*)) + "Print a list of list rows to a stream" + (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r))) + + +;; Buffered stream substitute + +(defstruct buf + vec (start -1) (used -1) (new -1) (end -1)) + +(defun bref (buf n) + (svref (buf-vec buf) + (mod n (length (buf-vec buf))))) + +(defun (setf bref) (val buf n) + (setf (svref (buf-vec buf) + (mod n (length (buf-vec buf)))) + val)) + +(defun new-buf (len) + (make-buf :vec (make-array len))) + +(defun buf-insert (x b) + (setf (bref b (incf (buf-end b))) x)) + +(defun buf-pop (b) + (prog1 + (bref b (incf (buf-start b))) + (setf (buf-used b) (buf-start b) + (buf-new b) (buf-end b)))) + +(defun buf-next (b) + (when (< (buf-used b) (buf-new b)) + (bref b (incf (buf-used b))))) + +(defun buf-reset (b) + (setf (buf-used b) (buf-start b) + (buf-new b) (buf-end b))) + +(defun buf-clear (b) + (setf (buf-start b) -1 (buf-used b) -1 + (buf-new b) -1 (buf-end b) -1)) + +(defun buf-flush (b str) + (do ((i (1+ (buf-used b)) (1+ i))) + ((> i (buf-end b))) + (princ (bref b i) str))) + + +(defun stream-subst (old new in out) + (declare (string old new)) + (let* ((pos 0) + (len (length old)) + (buf (new-buf len)) + (from-buf nil)) + (declare (fixnum pos len)) + (do ((c (read-char in nil :eof) + (or (setf from-buf (buf-next buf)) + (read-char in nil :eof)))) + ((eql c :eof)) + (declare (character c)) + (cond ((char= c (char old pos)) + (incf pos) + (cond ((= pos len) ; 3 + (princ new out) + (setf pos 0) + (buf-clear buf)) + ((not from-buf) ; 2 + (buf-insert c buf)))) + ((zerop pos) ; 1 + (princ c out) + (when from-buf + (buf-pop buf) + (buf-reset buf))) + (t ; 4 + (unless from-buf + (buf-insert c buf)) + (princ (buf-pop buf) out) + (buf-reset buf) + (setf pos 0)))) + (buf-flush buf out))) + +(declaim (inline write-fixnum)) +(defun write-fixnum (n s) + #+allegro (excl::print-fixnum s 10 n) + #-allegro (write-string (write-to-string n) s)) + + + + +(defun null-output-stream () + (when (probe-file #p"/dev/null") + (open #p"/dev/null" :direction :output :if-exists :overwrite)) + ) + + +(defun directory-tree (filename) + "Returns a tree of pathnames for sub-directories of a directory" + (let* ((root (canonicalize-directory-name filename)) + (subdirs (loop for path in (directory + (make-pathname :name :wild + :type :wild + :defaults root)) + when (probe-directory path) + collect (canonicalize-directory-name path)))) + (when (find nil subdirs) + (error "~A" subdirs)) + (when (null root) + (error "~A" root)) + (if subdirs + (cons root (mapcar #'directory-tree subdirs)) + (if (probe-directory root) + (list root) + (error "root not directory ~A" root))))) + + +(defmacro with-utime-decoding ((utime &optional zone) &body body) + "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time" + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + ,@body)) + +(defvar +datetime-number-strings+ + (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil + :initial-contents + '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11" + "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23" + "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35" + "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47" + "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59" + "60"))) + +(defun is-dst (utime) + (with-utime-decoding (utime) + daylight-p)) + + +(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body) + (with-gensyms (zone) + `(let* ((,zone (cond + ((eq :utc ,utc-offset) + 0) + ((null utc-offset) + nil) + (t + (if (is-dst ,utime) + (1- (- ,utc-offset)) + (- ,utc-offset)))))) + (if ,zone + (with-utime-decoding (,utime ,zone) + ,@body) + (with-utime-decoding (,utime) + ,@body))))) + + +(defun write-utime-hms (utime &key utc-offset stream) + (if stream + (write-utime-hms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hms-stream utime s utc-offset)))) + +(defun write-utime-hms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-hm (utime &key utc-offset stream) + (if stream + (write-utime-hm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hm-stream utime s utc-offset)))) + +(defun write-utime-hm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + + +(defun write-utime-ymdhms (utime &key stream utc-offset) + (if stream + (write-utime-ymdhms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhms-stream utime s utc-offset)))) + +(defun write-utime-ymdhms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-ymdhm (utime &key stream utc-offset) + (if stream + (write-utime-ymdhm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhm-stream utime s utc-offset)))) + +(defun write-utime-ymdhm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + +(defun copy-binary-stream (in out &key (chunk-size 16384)) + (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8))) + (pos (read-sequence buf in) (read-sequence buf in))) + ((zerop pos)) + (write-sequence buf out :end pos))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,26 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl-tests.asd +;;;; Purpose: ASDF system definitionf for kmrcl testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(defpackage #:kmrcl-tests-system + (:use #:asdf #:cl)) +(in-package #:kmrcl-tests-system) + +(defsystem kmrcl-tests + :depends-on (:rt :kmrcl) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:regression-test))) + (error "test-op failed"))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,67 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl.asd +;;;; Purpose: ASDF system definition for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:cl-user) +(defpackage #:kmrcl-system (:use #:asdf #:cl)) +(in-package #:kmrcl-system) + +#+(or allegro cmu clisp lispworks sbcl scl openmcl) +(pushnew :kmr-mop cl:*features*) + +(defsystem kmrcl + :name "kmrcl" + :author "Kevin M. Rosenberg <kevin(a)rosenberg.net>" + :maintainer "Kevin M. Rosenberg <kmr(a)debian.org>" + :licence "LLGPL" + :depends-on (#+sbcl sb-posix) + :components + ((:file "package") + (:file "ifstar" :depends-on ("package")) + (:file "byte-stream" :depends-on ("package")) + (:file "macros" :depends-on ("package")) + (:file "functions" :depends-on ("macros")) + (:file "lists" :depends-on ("macros")) + (:file "seqs" :depends-on ("macros")) + (:file "impl" :depends-on ("macros")) + (:file "io" :depends-on ("macros" "impl")) + (:file "console" :depends-on ("macros")) + (:file "strings" :depends-on ("macros" "seqs")) + (:file "strmatch" :depends-on ("strings")) + (:file "buff-input" :depends-on ("macros")) + (:file "random" :depends-on ("macros")) + (:file "symbols" :depends-on ("macros")) + (:file "datetime" :depends-on ("macros")) + (:file "math" :depends-on ("macros")) + (:file "color" :depends-on ("macros")) + #+kmr-mop (:file "mop" :depends-on ("macros")) + ;; #+kmr-mop (:file "attrib-class" :depends-on ("seqs" "mop")) + (:file "equal" :depends-on ("macros" #+kmr-mop "mop")) + (:file "web-utils" :depends-on ("macros" "strings")) + (:file "xml-utils" :depends-on ("macros")) + (:file "sockets" :depends-on ("strings")) + (:file "processes" :depends-on ("macros")) + (:file "listener" :depends-on ("sockets" "processes" "console")) + (:file "repl" :depends-on ("listener" "strings")) + (:file "os" :depends-on ("macros" "impl")) + (:file "signals" :depends-on ("package")) + )) + +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl)))) + (operate 'load-op 'kmrcl-tests) + (operate 'test-op 'kmrcl-tests :force t)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,288 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: listener.lisp +;;;; Purpose: Listener and worker processes +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jun 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;;; Variables and data structures for Listener + +(defvar *listener-count* 0 + "used to name listeners") + +(defvar *worker-count* 0 + "used to name workers") + +(defvar *active-listeners* nil + "List of active listeners") + +(defclass listener () + ((port :initarg :port :accessor port) + (function :initarg :function :accessor listener-function + :initform nil) + (function-args :initarg :function-args :accessor function-args + :initform nil) + (process :initarg :process :accessor process :initform nil) + (socket :initarg :socket :accessor socket :initform nil) + (workers :initform nil :accessor workers + :documentation "list of worker threads") + (name :initform "" :accessor name :initarg :name) + (base-name :initform "listener" :accessor base-name :initarg :base-name) + (wait :initform nil :accessor wait :initarg :wait) + (timeout :initform nil :accessor timeout :initarg :timeout) + (number-fixed-workers :initform nil :accessor number-fixed-workers + :initarg :number-fixed-workers) + (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors) + (remote-host-checker :initform nil :accessor remote-host-checker + :initarg :remote-host-checker) + (format :initform :text :accessor listener-format :initarg :format))) + +(defclass fixed-worker () + ((listener :initarg :listener :accessor listener :initform nil) + (name :initarg :name :accessor name :initform nil) + (process :initarg :process :accessor process :initform nil))) + +(defclass worker (fixed-worker) + ((connection :initarg :connection :accessor connection :initform nil) + (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil))) + + +(defmethod print-object ((obj listener) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port obj)))) + +(defmethod print-object ((obj fixed-worker) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port (listener obj))))) + +;; High-level API + +(defun init/listener (listener state) + (check-type listener listener) + (case state + (:start + (when (member listener *active-listeners*) + (cmsg "~&listener ~A already initialized" listener) + (return-from init/listener)) + (when (listener-startup listener) + (push listener *active-listeners*) + listener)) + (:stop + (unless (member listener *active-listeners*) + (cmsg "~&listener ~A is not in active list" listener) + (return-from init/listener listener)) + (listener-shutdown listener) + (setq *active-listeners* (remove listener *active-listeners*))) + (:restart + (init/listener listener :stop) + (init/listener listener :start)))) + +(defun stop-all/listener () + (dolist (listener *active-listeners*) + (ignore-errors + (init/listener listener :stop)))) + +(defun listener-startup (listener) + (handler-case + (progn + (setf (name listener) (next-server-name (base-name listener))) + (make-socket-server listener)) + (error (e) + (format t "~&Error while trying to start listener on port ~A~& ~A" + (port listener) e) + (decf *listener-count*) + nil) + (:no-error (res) + (declare (ignore res)) + listener))) + +(defun listener-shutdown (listener) + (dolist (worker (workers listener)) + (when (and (typep worker 'worker) + (connection worker)) + (errorset (close-active-socket + (connection worker)) nil) + (setf (connection worker) nil)) + (when (process worker) + (errorset (destroy-process (process worker)) nil) + (setf (process worker) nil))) + (setf (workers listener) nil) + (with-slots (process socket) listener + (when socket + (errorset (close-passive-socket socket) nil) + (setf socket nil)) + (when process + (errorset (destroy-process process) nil) + (setf process nil)))) + +;; Low-level functions + +(defun next-server-name (base-name) + (format nil "~D-~A-socket-server" (incf *listener-count*) base-name)) + +(defun next-worker-name (base-name) + (format nil "~D-~A-worker" (incf *worker-count*) base-name)) + +(defun make-socket-server (listener) + #+lispworks + (progn + (setf (process listener) + (comm:start-up-server :process-name (name listener) + :service (port listener) + :function + #'(lambda (handle) + (lw-worker handle listener))))) + #-lispworks + (progn + (setf (socket listener) (create-inet-listener + (port listener) + :format (listener-format listener))) + (if (number-fixed-workers listener) + (start-fixed-number-of-workers listener) + (setf (process listener) (make-process + (name listener) + #'(lambda () + (start-socket-server listener)))))) + listener) + + +(defmethod initialize-instance :after + ((self worker) &key listener connection name &allow-other-keys) + (flet ((do-work () + (apply (listener-function listener) + connection + (function-args listener)))) + (unless connection + (error "connection not provided to modlisp-worker")) + (setf (slot-value self 'listener) listener) + (setf (slot-value self 'name) name) + (setf (slot-value self 'connection) connection) + (setf (slot-value self 'thread-fun) + #'(lambda () + (unwind-protect + (if (catch-errors listener) + (handler-case + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work)) + (error (e) + (cmsg "Error ~A [~A]" e name))) + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work))) + (progn + (errorset (finish-output connection) nil) + (errorset (close-active-socket connection) nil) + (cmsg-c :threads "~A ended" name) + (setf (workers listener) + (remove self (workers listener))))))))) + +(defun accept-and-check-tcp-connection (listener) + (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener)) + (when (and (remote-host-checker listener) + (not (funcall (remote-host-checker listener) + (remote-host socket)))) + (cmsg-c :thread "Deny connection from ~A" (remote-host conn)) + (errorset (close-active-socket conn) nil) + (setq conn nil)) + conn)) + +(defun start-socket-server (listener) + (unwind-protect + (loop + (let ((connection (accept-and-check-tcp-connection listener))) + (when connection + (if (wait listener) + (unwind-protect + (apply (listener-function listener) + connection + (function-args listener)) + (progn + (errorset (finish-output connection) nil) + (errorset (close-active-socket connection) nil))) + (let ((worker (make-instance 'worker :listener listener + :connection connection + :name (next-worker-name + (base-name listener))))) + (setf (process worker) + (make-process (name worker) (thread-fun worker))) + (push worker (workers listener))))))) + (errorset (close-passive-socket (socket listener)) nil))) + +#+lispworks +(defun lw-worker (handle listener) + (let ((connection (make-instance 'comm:socket-stream + :socket handle + :direction :io + :element-type 'base-char))) + (if (wait listener) + (progn + (apply (listener-function listener) + connection + (function-args listener)) + (finish-output connection)) + (let ((worker (make-instance 'worker :listener listener + :connection connection + :name (next-worker-name + (base-name listener))))) + (setf (process worker) + (make-process (name worker) (thread-fun worker))) + (push worker (workers listener)))))) + +;; Fixed pool of workers + +(defun start-fixed-number-of-workers (listener) + (dotimes (i (number-fixed-workers listener)) + (let ((name (next-worker-name (base-name listener)))) + (push + (make-instance 'fixed-worker + :name name + :listener listener + :process + (make-process + name #'(lambda () (fixed-worker name listener)))) + (workers listener))))) + + +(defun fixed-worker (name listener) + (loop + (let ((connection (accept-and-check-tcp-connection listener))) + (when connection + (flet ((do-work () + (apply (listener-function listener) + connection + (function-args listener)))) + (unwind-protect + (handler-case + (if (catch-errors listener) + (handler-case + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work)) + (error (e) + (cmsg "Error ~A [~A]" e name))) + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work))) + (error (e) + (format t "Error: ~A" e))) + (errorset (finish-output connection) nil) + (errorset (close connection) nil))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,203 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: lists.lisp +;;;; Purpose: Functions for lists for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun mklist (obj) + "Make into list if atom" + (if (listp obj) obj (list obj))) + +(defun map-and-remove-nils (fn lst) + "mao a list by function, eliminate elements where fn returns nil" + (let ((acc nil)) + (dolist (x lst (nreverse acc)) + (let ((val (funcall fn x))) + (when val (push val acc)))))) + +(defun filter (fn lst) + "Filter a list by function, eliminate elements where fn returns nil" + (let ((acc nil)) + (dolist (x lst (nreverse acc)) + (when (funcall fn x) + (push x acc))))) + +(defun appendnew (l1 l2) + "Append two lists, filtering out elem from second list that are already in first list" + (dolist (elem l2 l1) + (unless (find elem l1) + (setq l1 (append l1 (list elem)))))) + +(defun remove-from-tree-if (pred tree &optional atom-processor) + "Strip from tree of atoms that satistify predicate" + (if (atom tree) + (unless (funcall pred tree) + (if atom-processor + (funcall atom-processor tree) + tree)) + (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor)) + (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor))) + (cond + ((and car-strip (atom (cadr tree)) (null cdr-strip)) + (list car-strip)) + ((and car-strip cdr-strip) + (cons car-strip cdr-strip)) + (car-strip + car-strip) + (cdr-strip + cdr-strip))))) + +(defun find-tree (sym tree) + "Finds an atom as a car in tree and returns cdr tree at that positions" + (if (or (null tree) (atom tree)) + nil + (if (eql sym (car tree)) + (cdr tree) + (aif (find-tree sym (car tree)) + it + (aif (find-tree sym (cdr tree)) + it + nil))))) + +(defun flatten (lis) + (cond ((atom lis) lis) + ((listp (car lis)) + (append (flatten (car lis)) (flatten (cdr lis)))) + (t (append (list (car lis)) (flatten (cdr lis)))))) + +;;; Keyword functions + +(defun remove-keyword (key arglist) + (loop for sublist = arglist then rest until (null sublist) + for (elt arg . rest) = sublist + unless (eq key elt) append (list elt arg))) + +(defun remove-keywords (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))) + +(defun mapappend (func seq) + (apply #'append (mapcar func seq))) + +(defun mapcar-append-string-nontailrec (func v) + "Concatenate results of mapcar lambda calls" + (aif (car v) + (concatenate 'string (funcall func it) + (mapcar-append-string-nontailrec func (cdr v))) + "")) + + +(defun mapcar-append-string (func v &optional (accum "")) + "Concatenate results of mapcar lambda calls" + (aif (car v) + (mapcar-append-string + func + (cdr v) + (concatenate 'string accum (funcall func it))) + accum)) + +(defun mapcar2-append-string-nontailrec (func la lb) + "Concatenate results of mapcar lambda call's over two lists" + (let ((a (car la)) + (b (car lb))) + (if (and a b) + (concatenate 'string (funcall func a b) + (mapcar2-append-string-nontailrec func (cdr la) (cdr lb))) + ""))) + +(defun mapcar2-append-string (func la lb &optional (accum "")) + "Concatenate results of mapcar lambda call's over two lists" + (let ((a (car la)) + (b (car lb))) + (if (and a b) + (mapcar2-append-string func (cdr la) (cdr lb) + (concatenate 'string accum (funcall func a b))) + accum))) + +(defun append-sublists (list) + "Takes a list of lists and appends all sublists" + (let ((results (car list))) + (dolist (elem (cdr list) results) + (setq results (append results elem))))) + + +;; alists and plists + +(defun alist-elem-p (elem) + (and (consp elem) (atom (car elem)) (atom (cdr elem)))) + +(defun alistp (alist) + (when (listp alist) + (dolist (elem alist) + (unless (alist-elem-p elem) + (return-from alistp nil))) + t)) + +(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity)) + "Macro to support below (setf get-alist)" + (let ((elem (gensym "ELEM-")) + (val (gensym "VAL-"))) + `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)) + (,val ,value)) + (cond + (,elem + (setf (cdr ,elem) ,val)) + (,alist + (setf (cdr (last ,alist)) (list (cons ,akey ,val)))) + (t + (setf ,alist (list (cons ,akey ,val))))) + ,alist))) + +(defun get-alist (key alist &key (test #'eql)) + (cdr (assoc key alist :test test))) + +(defun (setf get-alist) (value key alist &key (test #'eql)) + "This won't work if the alist is NIL." + (update-alist key value alist :test test) + value) + +(defun alist-plist (alist) + (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist))) + +(defun plist-alist (plist) + (do ((alist '()) + (pl plist (cddr pl))) + ((null pl) alist) + (setq alist (acons (car pl) (cadr pl) alist)))) + +(defmacro update-plist (pkey value plist &key (test '#'eql)) + "Macro to support below (setf get-alist)" + (let ((pos (gensym))) + `(let ((,pos (member ,pkey ,plist :test ,test))) + (if ,pos + (progn + (setf (cadr ,pos) ,value) + ,plist) + (setf ,plist (append ,plist (list ,pkey ,value))))))) + + +(defun unique-slot-values (list slot &key (test 'eql)) + (let ((uniq '())) + (dolist (item list (nreverse uniq)) + (let ((value (slot-value item slot))) + (unless (find value uniq :test test) + (push value uniq)))))) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,279 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: gentils.lisp +;;;; Purpose: Main general utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defmacro let-when ((var test-form) &body body) + `(let ((,var ,test-form)) + (when ,var ,@body))) + +(defmacro let-if ((var test-form) if-true &optional if-false) + `(let ((,var ,test-form)) + (if ,var ,if-true ,if-false))) + +;; Anaphoric macros + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(defmacro awhen (test-form &body body) + `(aif ,test-form + (progn ,@body))) + +(defmacro awhile (expr &body body) + `(do ((it ,expr ,expr)) + ((not it)) + ,@body)) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro acond (&rest clauses) + (if (null clauses) + nil + (let ((cl1 (car clauses)) + (sym (gensym))) + `(let ((,sym ,(car cl1))) + (if ,sym + (let ((it ,sym)) ,@(cdr cl1)) + (acond ,@(cdr clauses))))))) + +(defmacro alambda (parms &body body) + `(labels ((self ,parms ,@body)) + #'self)) + +(defmacro aif2 (test &optional then else) + (let ((win (gensym))) + `(multiple-value-bind (it ,win) ,test + (if (or it ,win) ,then ,else)))) + +(defmacro awhen2 (test &body body) + `(aif2 ,test + (progn ,@body))) + +(defmacro awhile2 (test &body body) + (let ((flag (gensym))) + `(let ((,flag t)) + (while ,flag + (aif2 ,test + (progn ,@body) + (setq ,flag nil)))))) + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (let ((cl1 (car clauses)) + (val (gensym)) + (win (gensym))) + `(multiple-value-bind (,val ,win) ,(car cl1) + (if (or ,val ,win) + (let ((it ,val)) ,@(cdr cl1)) + (acond2 ,@(cdr clauses))))))) + +(defmacro mac (expr) +"Expand a macro" + `(pprint (macroexpand-1 ',expr))) + +(defmacro print-form-and-results (form) + `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form)) + + +;;; Loop macros + +(defmacro until (test &body body) + `(do () + (,test) + ,@body)) + +(defmacro while (test &body body) + `(do () + ((not ,test)) + ,@body)) + +(defmacro for ((var start stop) &body body) + (let ((gstop (gensym))) + `(do ((,var ,start (1+ ,var)) + (,gstop ,stop)) + ((> ,var ,gstop)) + ,@body))) + +(defmacro with-each-stream-line ((var stream) &body body) + (let ((eof (gensym)) + (eof-value (gensym)) + (strm (gensym))) + `(let ((,strm ,stream) + (,eof ',eof-value)) + (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) + ((eql ,var ,eof)) + ,@body)))) + +(defmacro with-each-file-line ((var file) &body body) + (let ((stream (gensym))) + `(with-open-file (,stream ,file :direction :input) + (with-each-stream-line (,var ,stream) + ,@body)))) + + +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) + +(defmacro mean (&rest args) + `(/ (+ ,@args) ,(length args))) + +(defmacro with-gensyms (syms &body body) + `(let ,(mapcar #'(lambda (s) `(,s (gensym))) + syms) + ,@body)) + + +(defmacro time-seconds (&body body) + (let ((t1 (gensym))) + `(let ((,t1 (get-internal-real-time))) + (values + (progn ,@body) + (coerce (/ (- (get-internal-real-time) ,t1) + internal-time-units-per-second) + 'double-float))))) + +(defmacro time-iterations (n &body body) + (let ((i (gensym)) + (count (gensym))) + `(progn + (let ((,count ,n)) + (format t "~&Test with ~d iterations: ~W" ,count (quote ,body)) + (let ((t1 (get-internal-real-time))) + (dotimes (,i ,count) + ,@body) + (let* ((t2 (get-internal-real-time)) + (secs (coerce (/ (- t2 t1) + internal-time-units-per-second) + 'double-float))) + (format t "~&Total time: ") + (print-seconds secs) + (format t ", time per iteration: ") + (print-seconds (coerce (/ secs ,n) 'double-float)))))))) + +(defmacro mv-bind (vars form &body body) + `(multiple-value-bind ,vars ,form + ,@body)) + +;; From USENET +(defmacro deflex (var val &optional (doc nil docp)) + "Defines a top level (global) lexical VAR with initial value VAL, + which is assigned unconditionally as with DEFPARAMETER. If a DOC + string is provided, it is attached to both the name |VAR| and the + name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of + kind 'VARIABLE. The new VAR will have lexical scope and thus may + be shadowed by LET bindings without affecting its global value." + (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-))) + (s1 (symbol-name var)) + (p1 (symbol-package var)) + (s2 (load-time-value (symbol-name '#:*))) + (backing-var (intern (concatenate 'string s0 s1 s2) p1))) + `(progn + (defparameter ,backing-var ,val ,@(when docp `(,doc))) + ,@(when docp + `((setf (documentation ',var 'variable) ,doc))) + (define-symbol-macro ,var ,backing-var)))) + +(defmacro def-cached-vector (name element-type) + (let ((get-name (concat-symbol "get-" name "-vector")) + (release-name (concat-symbol "release-" name "-vector")) + (table-name (concat-symbol "*cached-" name "-table*")) + (lock-name (concat-symbol "*cached-" name "-lock*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,table-name (make-hash-table :test 'equal)) + (defvar ,lock-name (kmrcl::make-lock ,name)) + + (defun ,get-name (size) + (kmrcl::with-lock-held (,lock-name) + (let ((buffers (gethash (cons size ,element-type) ,table-name))) + (if buffers + (let ((buffer (pop buffers))) + (setf (gethash (cons size ,element-type) ,table-name) buffers) + buffer) + (make-array size :element-type ,element-type))))) + + (defun ,release-name (buffer) + (kmrcl::with-lock-held (,lock-name) + (let ((buffers (gethash (cons (array-total-size buffer) + ,element-type) + ,table-name))) + (setf (gethash (cons (array-total-size buffer) + ,element-type) ,table-name) + (cons buffer buffers)))))))) + +(defmacro def-cached-instance (name) + (let* ((new-name (concat-symbol "new-" name "-instance")) + (release-name (concat-symbol "release-" name "-instance")) + (cache-name (concat-symbol "*cached-" name "-instance-table*")) + (lock-name (concat-symbol "*cached-" name "-instance-lock*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,cache-name nil) + (defvar ,lock-name (kmrcl::make-lock ',name)) + + (defun ,new-name () + (kmrcl::with-lock-held (,lock-name) + (if ,cache-name + (pop ,cache-name) + (make-instance ',name)))) + + (defun ,release-name (instance) + (kmrcl::with-lock-held (,lock-name) + (push instance ,cache-name)))))) + +(defmacro with-ignore-errors (&rest forms) + `(progn + ,@(mapcar + (lambda (x) (list 'ignore-errors x)) + forms))) + +(defmacro ppmx (form) + "Pretty prints the macro expansion of FORM." + `(let* ((exp1 (macroexpand-1 ',form)) + (exp (macroexpand exp1)) + (*print-circle* nil)) + (cond ((equal exp exp1) + (format t "~&Macro expansion:") + (pprint exp)) + (t (format t "~&First step of expansion:") + (pprint exp1) + (format t "~%~%Final expansion:") + (pprint exp))) + (format t "~%~%") + (values))) + +(defmacro defconstant* (sym value &optional doc) + "Ensure VALUE is evaluated only once." + `(defconstant ,sym (if (boundp ',sym) + (symbol-value ',sym) + ,value) + ,@(when doc (list doc)))) + +(defmacro defvar-unbound (sym &optional (doc "")) + "defvar with a documentation string." + `(progn + (defvar ,sym) + (setf (documentation ',sym 'variable) ,doc))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,110 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: math.lisp +;;;; Purpose: General purpose math functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Nov 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + +(defun deriv (f dx) + #'(lambda (x) + (/ (- (funcall f (+ x dx)) (funcall f x)) + dx))) + +(defun sin^ (x) + (funcall (deriv #'sin 1d-8) x)) + +;;; (sin^ pi) + +(defmacro ensure-integer (obj) + "Ensure object is an integer. If it is a string, then parse it" + `(if (stringp ,obj) + (parse-integer ,obj) + ,obj)) + +(defun histogram (v n-bins &key min max) + (declare (fixnum n-bins)) + (when (listp v) + (setq v (coerce v 'vector))) + (when (zerop (length v)) + (return-from histogram (values nil nil nil)) ) + (let ((n (length v)) + (bins (make-array n-bins :element-type 'integer :initial-element 0)) + found-min found-max) + (declare (fixnum n)) + (unless (and min max) + (setq found-min (aref v 0) + found-max (aref v 0)) + (loop for i fixnum from 1 to (1- n) + do + (let ((x (aref v i))) + (cond + ((> x found-max) + (setq found-max x)) + ((< x found-min) + (setq found-min x))))) + (unless min + (setq min found-min)) + (unless max + (setq max found-max))) + (let ((width (/ (- max min) n-bins))) + (setq width (+ width (* double-float-epsilon width))) + (dotimes (i n) + (let ((bin (nth-value 0 (truncate (- (aref v i) min) width)))) + (declare (fixnum bin)) + (when (and (not (minusp bin)) + (< bin n-bins)) + (incf (aref bins bin)))))) + (values bins min max))) + + +(defun fixnum-width () + (nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5)))) + +(defun scaled-epsilon (float &optional (operation '+)) + "Return the smallest number that would return a value different from + FLOAT if OPERATION were applied to FLOAT and this number. OPERATION + should be either + or -, and defauls to +." + (multiple-value-bind (significand exponent) + (decode-float float) + (multiple-value-bind (1.0-significand 1.0-exponent) + (decode-float (float 1.0 float)) + (if (and (eq operation '-) + (= significand 1.0-significand)) + (scale-float (typecase float + (short-float short-float-negative-epsilon) + (single-float single-float-negative-epsilon) + (double-float double-float-negative-epsilon) + (long-float long-float-negative-epsilon)) + (- exponent 1.0-exponent)) + (scale-float (typecase float + (short-float short-float-epsilon) + (single-float single-float-epsilon) + (double-float double-float-epsilon) + (long-float long-float-epsilon)) + (- exponent 1.0-exponent)))))) + +(defun sinc (x) + (if (zerop x) + 1d0 + (let ((x (coerce x 'double-float))) + (/ (sin x) x)))) + + +(defun numbers-within-percentage (a b percent) + "Determines if two numbers are equal within a percentage difference." + (let ((abs-diff (* 0.01 percent 0.5 (+ (abs a) (abs b))))) + (< (abs (- a b)) abs-diff))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,187 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mop.lisp +;;;; Purpose: Imports standard MOP symbols into KMRCL +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +;;; This file imports MOP symbols into KMR-MOP packages and then +;;; re-exports them to hide differences in MOP implementations. + +(in-package #:cl-user) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (find-package 'sb-mop) + (pushnew :kmr-sbcl-mop cl:*features*) + (pushnew :kmr-sbcl-pcl cl:*features*))) + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (eq (symbol-package 'pcl:find-class) + (find-package 'common-lisp)) + (pushnew :kmr-cmucl-mop cl:*features*) + (pushnew :kmr-cmucl-pcl cl:*features*))) + +(defpackage #:kmr-mop + (:use + #:cl + #:kmrcl + #+kmr-sbcl-mop #:sb-mop + #+kmr-cmucl-mop #:mop + #+allegro #:mop + #+lispworks #:clos + #+clisp #:clos + #+scl #:clos + #+openmcl #:openmcl-mop + ) + ) + +(in-package #:kmr-mop) + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) + +(defmacro process-class-option (metaclass slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class ,metaclass) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) + (list name `',value)) + #-lispworks + (declare (ignore metaclass slot-name required)) + ) + +(defmacro process-slot-option (metaclass slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class ,metaclass) + (option (eql ,slot-name)) + value + already-processed-options + slot) + (list* option `',value already-processed-options)) + #-lispworks + (declare (ignore metaclass slot-name)) + ) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + #+allegro + '(excl::compute-effective-slot-definition-initargs) + #+lispworks + '(clos::compute-effective-slot-definition-initargs) + #+clisp + '(clos::compute-effective-slot-definition-initargs) + #+sbcl + '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of + #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name + #+kmr-sbcl-mop class-slots #-kmr-sbcl-mop sb-pcl:class-slots + #+kmr-sbcl-mop find-class #-kmr-sbcl-mop sb-pcl:find-class + sb-pcl::standard-class + sb-pcl:slot-definition-name sb-pcl::finalize-inheritance + sb-pcl::standard-direct-slot-definition + sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass + sb-pcl::direct-slot-definition-class + sb-pcl::effective-slot-definition-class + sb-pcl::compute-effective-slot-definition + sb-pcl:class-direct-slots + sb-pcl::compute-effective-slot-definition-initargs + sb-pcl::slot-value-using-class + sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer + sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list + sb-pcl::compute-slots) + #+cmu + '(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class + pcl::slot-definition-name pcl:finalize-inheritance + pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition + pcl::validate-superclass pcl:direct-slot-definition-class pcl::effective-slot-definition-class + pcl:compute-effective-slot-definition + pcl:class-direct-slots + pcl::compute-effective-slot-definition-initargs + pcl::slot-value-using-class + pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer + pcl:make-method-lambda pcl:generic-function-lambda-list + pcl::compute-slots) + #+scl + '(class-of class-name class-slots find-class clos::standard-class + clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::effective-slot-definition-class + clos:class-direct-slots + clos::validate-superclass clos:direct-slot-definition-class + clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs + clos::slot-value-using-class + clos::class-prototype clos:generic-function-method-class clos:intern-eql-specializer + clos:make-method-lambda clos:generic-function-lambda-list + clos::compute-slots + ;; note: make-method-lambda is not fbound + ) + #+openmcl + '(openmcl-mop::slot-definition-name openmcl-mop:finalize-inheritance + openmcl-mop::standard-direct-slot-definition openmcl-mop::standard-effective-slot-definition + openmcl-mop::validate-superclass openmcl-mop:direct-slot-definition-class openmcl-mop::effective-slot-definition-class + openmcl-mop:compute-effective-slot-definition + openmcl-mop:class-direct-slots + openmcl-mop::compute-effective-slot-definition-initargs + openmcl-mop::slot-value-using-class + openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer + openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list + openmcl-mop::compute-slots) )) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(class-of class-name class-slots find-class + standard-class + slot-definition-name finalize-inheritance + standard-direct-slot-definition + standard-effective-slot-definition validate-superclass + compute-effective-slot-definition-initargs + direct-slot-definition-class effective-slot-definition-class + compute-effective-slot-definition + slot-value-using-class + class-prototype generic-function-method-class intern-eql-specializer + make-method-lambda generic-function-lambda-list + compute-slots + class-direct-slots + ;; KMR-MOP encapsulating macros + process-slot-option + process-class-option)) + + #+sbcl + (if (find-package 'sb-mop) + (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*)) + (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*))) + + #+cmu + (if (find-package 'mop) + (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*)) + (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :kmr-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :kmr-normal-dsdc cl:*features*)) + + ) ;; eval-when Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,179 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: os.lisp +;;;; Purpose: Operating System utilities +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jul 2003 +;;;; +;;;; $Id$ +;;;; +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (let* ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (sb-impl::process-output process))) + (error (read-stream-to-string (sb-impl::process-error process)))) + (close (sb-impl::process-output process)) + (close (sb-impl::process-error process)) + (values + output + error + (sb-impl::process-exit-code process))) + + + #+(or cmu scl) + (let* ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (ext::process-output process))) + (error (read-stream-to-string (ext::process-error process)))) + (close (ext::process-output process)) + (close (ext::process-error process)) + + (values + output + error + (ext::process-exit-code process))) + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status)) + + #+lispworks + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :prefix "" + :show-cmd nil + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output))) + + #+clisp + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t)) + + #+openmcl + (let* ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t)) + (output (read-stream-to-string (ccl::external-process-output-stream process))) + (error (read-stream-to-string (ccl::external-process-error-stream process)))) + (close (ccl::external-process-output-stream process)) + (close (ccl::external-process-error-stream process)) + (values output + error + (nth-value 1 (ccl::external-process-status process)))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "COMMAND-OUTPUT not implemented for this Lisp") + + )) + +(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, +returns (VALUES output-string pid)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + + #+allegro + (excl:run-shell-command command :input nil :output nil + :wait t) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :show-cmd nil + :prefix "" + :output-stream nil) + + #+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 nil + :wait t))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + + )) + +(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force) + #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist + :quiet quiet :force force) + #-(or allegro) (declare (ignore force)) + #-(or allegro) (cond + ((probe-directory dir) + (let ((cmd (format nil "rm -rf ~A" (namestring dir)))) + (unless quiet + (format *trace-output* ";; ~A" cmd)) + (command-output cmd))) + ((eq if-does-not-exist :error) + (error "Directory ~A does not exist [delete-directory-and-files]." dir)))) + +(defun file-size (file) + (when (probe-file file) + #+allegro (let ((stat (excl.osi:stat (namestring file)))) + (excl.osi:stat-size stat)) + #-allegro + (with-open-file (in file :direction :input) + (file-length in)))) + +(defun getpid () + "Return the PID of the lisp process." + #+allegro (excl::getpid) + #+(and lispworks win32) (win32:get-current-process-id) + #+(and lispworks (not win32)) (system::getpid) + #+sbcl (sb-posix:getpid) + #+cmu (unix:unix-getpid) + #+openmcl (ccl::getpid) + #+(and clisp unix) (system::process-id) + #+(and clisp win32) (cond ((find-package :win32) + (funcall (find-symbol "GetCurrentProcessId" + :win32))) + (t + (system::getenv "PID"))) + ) + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,324 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for kmrcl package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:kmrcl + (:nicknames #:kl) + (:use #:cl) + (:export + #:ensure-integer + #:mklist + #:filter + #:map-and-remove-nils + #:appendnew + #:memo-proc + #:memoize + #:defun-memo + #:_f + #:compose + #:until + #:while + #:for + + ;; strings.lisp + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + #:mapappend + #:mapcar-append-string + #:mapcar2-append-string + #:position-char + #:position-not-char + #:delimited-string-to-list + #:string-delimited-string-to-list + #:list-to-delimited-string + #:prefixed-fixnum-string + #:prefixed-integer-string + #:integer-string + #:fast-string-search + #:string-substitute + #:string-to-list-skip-delimiter + #:string-starts-with + #:count-string-char + #:count-string-char-if + #:hexchar + #:charhex + #:encode-uri-string + #:decode-uri-string + #:uri-query-to-alist + #:non-alphanumericp + #:random-string + #:first-char + #:last-char + #:ensure-string + #:string-right-trim-one-char + #:string-strip-ending + #:string-maybe-shorten + #:string-elide + #:shrink-vector + #:collapse-whitespace + #:string->list + #:trim-non-alphanumeric + #:binary-sequence-to-hex-string + + ;; io.lisp + #:indent-spaces + #:indent-html-spaces + #:print-n-chars + #:print-n-strings + #:print-list + #:print-rows + #:write-fixnum + #:file-subst + #:stream-subst + #:null-output-stream + #:directory-tree + #:write-utime-hms + #:write-utime-hm + #:write-utime-ymdhms + #:write-utime-ymdhm + #:write-utime-hms-stream + #:write-utime-hm-stream + #:write-utime-ymdhms-stream + #:write-utime-ymdhm-stream + #:with-utime-decoding + #:with-utime-decoding-utc-offset + #:is-dst + #:year + #:month + #:day-of-month + #:hour + #:minute + #:second + #:daylight-p + #:zone + #:day-of-month + #:day-of-week + #:+datetime-number-strings+ + #:utc-offset + #:copy-binary-stream + + ;; impl.lisp + #:probe-directory + #:cwd + #:quit + #:command-line-arguments + #:copy-file + #:run-shell-command + + ;; lists.lisp + #:remove-from-tree-if + #:find-tree + #:with-each-file-line + #:with-each-stream-line + #:remove-keyword + #:remove-keywords + #:append-sublists + #:alist-elem-p + #:alistp + #:get-alist + #:update-alist + #:alist-plist + #:plist-alist + #:update-plist + #:get-plist + #:flatten + #:unique-slot-values + + ;; seq.lisp + #:nsubseq + + ;; math.lisp + #:ensure-integer + #:histogram + #:fixnum-width + #:scaled-epsilon + #:sinc + #:numbers-within-percentage + + ;; macros.lisp + #:time-iterations + #:time-seconds + #:in + #:mean + #:with-gensyms + #:let-if + #:let-when + #:aif + #:awhen + #:awhile + #:aand + #:acond + #:alambda + #:it + #:mac + #:mv-bind + #:deflex + #:def-cached-vector + #:def-cached-instance + #:with-ignore-errors + #:ppmx + #:defconstant* + #:defvar-unbound + + ;; files.lisp + #:print-file-contents + #:read-stream-to-string + #:read-file-to-string + #:read-file-to-usb8-array + #:read-stream-to-strings + #:read-file-to-strings + + ;; strings.lisp + #:string-append + #:count-string-words + #:substitute-string-for-char + #:string-trim-last-character + #:nstring-trim-last-character + #:string-hash + #:is-string-empty + #:is-char-whitespace + #:not-whitespace-char + #:is-string-whitespace + #:string-invert + #:escape-xml-string + #:make-usb8-array + #:usb8-array-to-string + #:string-to-usb8-array + #:substitute-chars-strings + #:add-sql-quotes + #:escape-backslashes + #:concat-separated-strings + #:print-separated-strings + #:lex-string + #:split-alphanumeric-string + + ;; strmatch.lisp + #:score-multiword-match + #:multiword-match + + ;; symbols.lisp + #:ensure-keyword + #:ensure-keyword-upcase + #:ensure-keyword-default-case + #:concat-symbol + #:concat-symbol-pkg + #:show + #:show-variables + #:show-functions + + ;; From attrib-class.lisp + #:attributes-class + #:slot-attribute + #:slot-attributes + + #:generalized-equal + + ;; From buffered input + + #:make-fields-buffer + #:read-buffered-fields + + ;; From datetime.lisp + #:pretty-date-ut + #:pretty-date + #:date-string + #:print-float-units + #:print-seconds + #:posix-time-to-utime + #:utime-to-posix-time + + ;; From random.lisp + #:seed-random-generator + #:random-choice + + ;; From repl.lisp + #:make-repl + #:init/repl + + ;; From web-utils + #:*base-url* + #:base-url! + #:make-url + #:*standard-html-header* + #:*standard-xhtml-header* + #:*standard-xml-header* + #:user-agent-ie-p + #:decode-uri-query-string + #:split-uri-query-string + + ;; From xml-utils + #:sgml-header-stream + #:xml-tag-contents + #:positions-xml-tag-contents + #:cdata-string + #:write-cdata + + ;; From console + #:*console-msgs* + #:cmsg + #:cmsg-c + #:cmsg-add + #:cmsg-remove + #:fixme + + ;; byte-stream + #:make-binary-array-output-stream + #:get-output-stream-data + #:dump-output-stream-data + #:make-byte-array-input-stream + + ;; sockets.lisp + #:make-active-socket + #:close-active-socket + + ;; listener.lisp + #:init/listener + #:stop-all/listener + #:listener + + ;; fformat.lisp + #:fformat + + ;; os.lisp + #:command-output + #:run-shell-command-output-stream + #:delete-directory-and-files + #:file-size + #:getpid + + ;; color.lisp + #:rgb->hsv + #:rgb255->hsv255 + #:hsv->rgb + #:hsv255->rgb255 + #:hsv-equal + #:hsv255-equal + #:hsv-similar + #:hsv255-similar + #:hue-difference + #:hue-difference-fixnum + + ;; signals.lisp + #:set-signal-handler + #:remove-signal-handler + )) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,76 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: processes.lisp +;;;; Purpose: Multiprocessing functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +(defun make-process (name func) + #+allegro (mp:process-run-function name func) + #+cmu (mp:make-process func :name name) + #+lispworks (mp:process-run-function name nil func) + #+sb-thread (sb-thread:make-thread func :name name) + #+openmcl (ccl:process-run-function name func) + #-(or allegro cmu lispworks sb-thread openmcl) (funcall func) + ) + +(defun destroy-process (process) + #+cmu (mp:destroy-process process) + #+allegro (mp:process-kill process) + #+sb-thread (sb-thread:destroy-thread process) + #+lispworks (mp:process-kill process) + #+openmcl (ccl:process-kill process) + ) + +(defun make-lock (name) + #+allegro (mp:make-process-lock :name name) + #+cmu (mp:make-lock name) + #+lispworks (mp:make-lock :name name) + #+sb-thread (sb-thread:make-mutex :name name) + #+openmcl (ccl:make-lock name) + ) + +(defmacro with-lock-held ((lock) &body body) + #+allegro + `(mp:with-process-lock (,lock) ,@body) + #+cmu + `(mp:with-lock-held (,lock) ,@body) + #+lispworks + `(mp:with-lock (,lock) ,@body) + #+sb-thread + `(sb-thread:with-recursive-lock (,lock) ,@body) + #+openmcl + `(ccl:with-lock-grabbed (,lock) ,@body) + #-(or allegro cmu lispworks sb-thread openmcl) + `(progn ,@body) + ) + + +(defmacro with-timeout ((seconds) &body body) + #+allegro + `(mp:with-timeout (,seconds) ,@body) + #+cmu + `(mp:with-timeout (,seconds) ,@body) + #+sb-thread + `(sb-ext:with-timeout ,seconds ,@body) + #+openmcl + `(ccl:process-wait-with-timeout "waiting" + (* ,seconds ccl:*ticks-per-second*) + #'(lambda () + ,@body) nil) + #-(or allegro cmu sb-thread openmcl) + `(progn ,@body) + ) + +(defun process-sleep (n) + #+allegro (mp:process-sleep n) + #-allegro (sleep n)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,47 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: random.lisp +;;;; Purpose: Random number functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun seed-random-generator () + "Evaluate a random number of items" + (let ((randfile (make-pathname + :directory '(:absolute "dev") + :name "urandom"))) + (setf *random-state* (make-random-state t)) + (if (probe-file randfile) + (with-open-file + (rfs randfile :element-type 'unsigned-byte) + (let* + ;; ((seed (char-code (read-char rfs)))) + ((seed (read-byte rfs))) + ;;(format t "Randomizing!~%") + (loop + for item from 1 to seed + do (loop + for it from 0 to (+ (read-byte rfs) 5) + do (random 65536)))))))) + + +(defmacro random-choice (&rest exprs) + `(case (random ,(length exprs)) + ,@(let ((key -1)) + (mapcar #'(lambda (expr) + `(,(incf key) ,expr)) + exprs)))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,96 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: repl.lisp +;;;; Purpose: A repl server +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defconstant +default-repl-server-port+ 4000) + +(defclass repl () + ((listener :initarg :listener :accessor listener + :initform nil))) + +(defun make-repl (&key (port +default-repl-server-port+) + announce user-checker remote-host-checker) + (make-instance 'listener + :port port + :base-name "repl" + :function 'repl-worker + :function-args (list user-checker announce) + :format :text + :wait nil + :remote-host-checker remote-host-checker + :catch-errors nil)) + +(defun init/repl (repl state) + (init/listener repl state)) + + +(defun repl-worker (conn user-checker announce) + (when announce + (format conn "~A~%" announce) + (force-output conn)) + (when user-checker + (let (login password) + (format conn "login: ") + (finish-output conn) + (setq login (read-socket-line conn)) + (format conn "password: ") + (finish-output conn) + (setq password (read-socket-line conn)) + (unless (funcall user-checker login password) + (format conn "Invalid login~%") + (finish-output conn) + (return-from repl-worker)))) + #+allegro + (tpl::start-interactive-top-level + conn + #'tpl::top-level-read-eval-print-loop + nil) + #-allegro + (repl-on-stream conn) + ) + +(defun read-socket-line (stream) + (string-right-trim-one-char #\return + (read-line stream nil nil))) + +(defun print-prompt (stream) + (format stream "~&~A> " (package-name *package*)) + (force-output stream)) + +(defun repl-on-stream (stream) + (let ((*standard-input* stream) + (*standard-output* stream) + (*terminal-io* stream) + (*debug-io* stream)) + #| + #+sbcl + (if (and (find-package 'sb-aclrepl) + (fboundp (intern "REPL-FUN" "SB-ACLREPL"))) + (sb-aclrepl::repl-fun) + (%repl)) + #-sbcl + |# + (%repl))) + +(defun %repl () + (loop + (print-prompt *standard-output*) + (let ((form (read *standard-input*))) + (format *standard-output* "~&~S~%" (eval form))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,24 @@ +(in-package #:cl-user) +(defpackage #:run-tests (:use #:cl)) +(in-package #:run-tests) + +(require 'rt) +(load "kmrcl.asd") +(load "kmrcl-tests.asd") +(asdf:oos 'asdf:test-op 'kmrcl) + +(defun quit (&optional (code 0)) + "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." + #+allegro (excl:exit code) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+mcl (ccl:quit code) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + +(quit) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,28 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: seqs.lisp +;;;; Purpose: Sequence functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + + +(defun nsubseq (sequence start &optional end) + "Return a subsequence by pointing to location in original sequence" + (unless end (setq end (length sequence))) + (make-array (- end start) + :element-type (array-element-type sequence) + :displaced-to sequence + :displaced-index-offset start)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,74 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: signals.lisp +;;;; Purpose: Signal processing functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jan 2007 +;;;; +;;;; $Id: processes.lisp 10985 2006-07-26 18:52:03Z kevin $ +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun signal-key-to-number (sig) + "These signals and numbers are only valid on POSIX systems, perhaps +some are Linux-specific." + (case sig + (:hup 1) + (:int 2) + (:quit 3) + (:kill 9) + (:usr1 10) + (:usr2 12) + (:pipe 13) + (:alrm 14) + (:term 15) + (t + (error "Signal ~A not known." sig)))) + + +(defun set-signal-handler (sig handler) + "Sets the handler for a signal to a function. Where possible, returns +the old handler for the function for later restoration with remove-signal-handler +below. + +To be portable, signal handlers should use (&rest dummy) function signatures +and ignore the value. They should return T to tell some Lisp implementations (Allegro) +that the signal was successfully handled." + (let ((signum (etypecase sig + (integer sig) + (keyword (signal-key-to-number sig))))) + #+allegro (excl:add-signal-handler signum handler) + #+cmu (system:enable-interrupt signum handler) + #+(and lispworks unix) + ;; non-documented method to get old handler, works in lispworks 5 + (let ((old-handler (when (and (boundp 'system::*signal-handler-functions*) + (typep system::*signal-handler-functions* 'array)) + (aref system::*signal-handler-functions* signum)))) + (system:set-signal-handler signum handler) + old-handler) + #+sbcl (sb-sys:enable-interrupt signum handler) + #-(or allegro cmu (and lispworks unix) sbcl) + (declare (ignore sig handler)) + #-(or allegro cmu (and lispworks unix) sbcl) + (warn "Signal setting not supported on this platform."))) + +(defun remove-signal-handler (sig &optional old-handler) + "Removes a handler from signal. Tries, when possible, to restore old-handler." + (let ((signum (etypecase sig + (integer sig) + (keyword (signal-key-to-number sig))))) + ;; allegro automatically restores old handler, because set-signal-handler above + ;; actually pushes the new handler onto a list of handlers + #+allegro (declare (ignore old-handler)) + #+allegro (excl:remove-signal-handler signum) + #+cmu (system:enable-interrupt signum (or old-handler :default)) + ;; lispworks removes handler if old-handler is nil + #+(and lispworks unix) (system:set-signal-handler signum old-handler) + #+sbcl (sb-sys:enable-interrupt signum (or old-handler :default)) + #-(or allegro cmu (and lispworks unix) sbcl) + (declare (ignore sig handler)) + #-(or allegro cmu (and lispworks unix) sbcl) + (warn "Signal setting not supported on this platform."))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,219 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sockets.lisp +;;;; Purpose: Socket functions +;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve +;;;; Date Started: Jun 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (require :sb-bsd-sockets) + #+lispworks (require "comm") + #+allegro (require :socket)) + + +#+sbcl +(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil)) + "Create, bind and listen to an inet socket on *:PORT. +setsockopt SO_REUSEADDR if :reuse is not nil" + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (if reuse + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) + (sb-bsd-sockets:socket-bind + socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port) + (sb-bsd-sockets:socket-listen socket 15) + socket)) + +(defun create-inet-listener (port &key (format :text) (reuse-address t)) + #+cmu (declare (ignore format reuse-address)) + #+cmu (ext:create-inet-listener port) + #+allegro + (socket:make-socket :connect :passive :local-port port :format format + :address-family + (if (stringp port) + :file + (if (or (null port) (integerp port)) + :internet + (error "illegal value for port: ~s" port))) + :reuse-address reuse-address) + #+sbcl (declare (ignore format)) + #+sbcl (listen-to-inet-port :port port :reuse reuse-address) + #+clisp (declare (ignore format reuse-address)) + #+clisp (ext:socket-server port) + #+openmcl + (declare (ignore format)) + #+openmcl + (ccl:make-socket :connect :passive :local-port port + :reuse-address reuse-address) + #-(or allegro clisp cmu sbcl openmcl) + (warn "create-inet-listener not supported on this implementation") + ) + +(defun make-fd-stream (socket &key input output element-type) + #+cmu + (sys:make-fd-stream socket :input input :output output + :element-type element-type) + #+sbcl + (sb-bsd-sockets:socket-make-stream socket :input input :output output + :element-type element-type) + #-(or cmu sbcl) (declare (ignore input output element-type)) + #-(or cmu sbcl) socket + ) + + +(defun accept-tcp-connection (listener) + "Returns (VALUES stream socket)" + #+allegro + (let ((sock (socket:accept-connection listener))) + (values sock sock)) + #+clisp + (let ((sock (ext:socket-accept listener))) + (values sock sock)) + #+cmu + (progn + (mp:process-wait-until-fd-usable listener :input) + (let ((sock (nth-value 0 (ext:accept-tcp-connection listener)))) + (values (sys:make-fd-stream sock :input t :output t) sock))) + #+sbcl + (when (sb-sys:wait-until-fd-usable + (sb-bsd-sockets:socket-file-descriptor listener) :input) + (let ((sock (sb-bsd-sockets:socket-accept listener))) + (values + (sb-bsd-sockets:socket-make-stream + sock :element-type :default :input t :output t) + sock))) + #+openmcl + (let ((sock (ccl:accept-connection listener :wait t))) + (values sock sock)) + #-(or allegro clisp cmu sbcl openmcl) + (warn "accept-tcp-connection not supported on this implementation") + ) + + +(defmacro errorset (form display) + `(handler-case + ,form + (error (e) + (declare (ignorable e)) + (when ,display + (format t "~&Error: ~A~%" e))))) + +(defun close-passive-socket (socket) + #+allegro (close socket) + #+clisp (ext:socket-server-close socket) + #+cmu (unix:unix-close socket) + #+sbcl (sb-unix:unix-close + (sb-bsd-sockets:socket-file-descriptor socket)) + #+openmcl (close socket) + #-(or allegro clisp cmu sbcl openmcl) + (warn "close-passive-socket not supported on this implementation") + ) + + +(defun close-active-socket (socket) + #+sbcl (sb-bsd-sockets:socket-close socket) + #-sbcl (close socket)) + +(defun ipaddr-to-dotted (ipaddr &key values) + "Convert from 32-bit integer to dotted string." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun dotted-to-ipaddr (dotted &key (errorp t)) + "Convert from dotted string to 32-bit integer." + (declare (string dotted)) + (if errorp + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll)))) + (ignore-errors + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll))))))) + +#+sbcl +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (sb-bsd-sockets:host-ent-name + (sb-bsd-sockets:get-host-by-address + (sb-bsd-sockets:make-inet-address ipaddr)))) + +#+sbcl +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (sb-bsd-sockets:host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + + +(defun make-active-socket (server port) + "Returns (VALUES STREAM SOCKET)" + #+allegro + (let ((sock (socket:make-socket :remote-host server + :remote-port port))) + (values sock sock)) + #+lispworks + (let ((sock (comm:open-tcp-stream server port))) + (values sock sock)) + #+sbcl + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port) + (values + (sb-bsd-sockets:socket-make-stream + sock :input t :output t :element-type :default) + sock)) + #+cmu + (let ((sock (ext:connect-to-inet-socket server port))) + (values + (sys:make-fd-stream sock :input t :output t :element-type 'base-char) + sock)) + #+clisp + (let ((sock (ext:socket-connect port server))) + (values sock sock)) + #+openmcl + (let ((sock (ccl:make-socket :remote-host server :remote-port port ))) + (values sock sock)) + ) + +(defun ipaddr-array-to-dotted (array) + (format nil "~{~D~^.~}" (coerce array 'list)) + #+ignore + (format nil "~D.~D.~D.~D" + (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array))) + +(defun remote-host (socket) + #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket)) + #+lispworks (nth-value 0 (comm:get-socket-peer-address socket)) + #+sbcl (ipaddr-array-to-dotted + (nth-value 0 (sb-bsd-sockets:socket-peername socket))) + #+cmu (nth-value 0 (ext:get-peer-host-and-port socket)) + #+clisp (let* ((peer (ext:socket-stream-peer socket t)) + (stop (position #\Space peer))) + ;; 2.37-2.39 had do-not-resolve-p backwards + (if stop (subseq peer 0 stop) peer)) + #+openmcl (ccl:remote-host socket) + ) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,706 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.lisp +;;;; Purpose: Strings utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + +;;; Strings + +(defmacro string-append (outputstr &rest args) + `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) + +(defun list-to-string (lst) + "Converts a list to a string, doesn't include any delimiters between elements" + (format nil "~{~A~}" lst)) + +(defun count-string-words (str) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (let ((n-words 0) + (in-word nil)) + (declare (fixnum n-words)) + (do* ((len (length str)) + (i 0 (1+ i))) + ((= i len) n-words) + (declare (fixnum i)) + (if (alphanumericp (schar str i)) + (unless in-word + (incf n-words) + (setq in-word t)) + (setq in-word nil))))) + +;; From Larry Hunter with modifications +(defun position-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (schar string i)) (return i)))) + +(defun position-not-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char/= char (schar string i)) (return i)))) + +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + "split a string with delimiter" + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + + +(defun list-to-delimited-string (list &optional (separator " ")) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list)) + +(defun string-invert (str) + "Invert case of a string" + (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0)) + (simple-string str)) + (let ((up nil) (down nil)) + (block skip + (loop for char of-type character across str do + (cond ((upper-case-p char) + (if down (return-from skip str) (setf up t))) + ((lower-case-p char) + (if up (return-from skip str) (setf down t))))) + (if up (string-downcase str) (string-upcase str))))) + +(defun add-sql-quotes (s) + (substitute-string-for-char s #\' "''")) + +(defun escape-backslashes (s) + (substitute-string-for-char s #\\ "\\\\")) + +(defun substitute-string-for-char (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + +(defun string-substitute (string substring replacement-string) + "String substitute by Larry Hunter. Obtained from Google" + (let ((substring-length (length substring)) + (last-end 0) + (new-string "")) + (do ((next-start + (search substring string) + (search substring string :start2 last-end))) + ((null next-start) + (concatenate 'string new-string (subseq string last-end))) + (setq new-string + (concatenate 'string + new-string + (subseq string last-end next-start) + replacement-string)) + (setq last-end (+ next-start substring-length))))) + +(defun string-trim-last-character (s) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (subseq s 0 (1- len)) + s))) + +(defun nstring-trim-last-character (s) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (nsubseq s 0 (1- len)) + s))) + +(defun string-hash (str &optional (bitmask 65535)) + (let ((hash 0)) + (declare (fixnum hash) + (simple-string str)) + (dotimes (i (length str)) + (declare (fixnum i)) + (setq hash (+ hash (char-code (char str i))))) + (logand hash bitmask))) + +(defun is-string-empty (str) + (zerop (length str))) + +(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed + #+allegro #\%space + #+lispworks #\No-Break-Space)) + +(defun is-char-whitespace (c) + (declare (character c) (optimize (speed 3) (safety 0))) + (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) + (char= c #\Linefeed) + #+allegro (char= c #\%space) + #+lispworks (char= c #\No-Break-Space))) + +(defun is-string-whitespace (str) + "Return t if string is all whitespace" + (every #'is-char-whitespace str)) + +(defun string-right-trim-whitespace (str) + (string-right-trim *whitespace-chars* str)) + +(defun string-left-trim-whitespace (str) + (string-left-trim *whitespace-chars* str)) + +(defun string-trim-whitespace (str) + (string-trim *whitespace-chars* str)) + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + +(defun escape-xml-string (string) + "Escape invalid XML characters" + (substitute-chars-strings string '((#\& . "&") (#\< . "<")))) + +(defun make-usb8-array (len) + (make-array len :element-type '(unsigned-byte 8))) + +(defun usb8-array-to-string (vec &key (start 0) end) + (declare (type (simple-array (unsigned-byte 8) (*)) vec) + (fixnum start)) + (unless end + (setq end (length vec))) + (let* ((len (- end start)) + (str (make-string len))) + (declare (fixnum len) + (simple-string str) + (optimize (speed 3) (safety 0))) + (do ((i 0 (1+ i))) + ((= i len) str) + (declare (fixnum i)) + (setf (schar str i) (code-char (aref vec (the fixnum (+ i start)))))))) + +(defun string-to-usb8-array (str) + (declare (simple-string str)) + (let* ((len (length str)) + (vec (make-usb8-array len))) + (declare (fixnum len) + (type (simple-array (unsigned-byte 8) (*)) vec) + (optimize (speed 3))) + (do ((i 0 (1+ i))) + ((= i len) vec) + (declare (fixnum i)) + (setf (aref vec i) (char-code (schar str i)))))) + +(defun concat-separated-strings (separator &rest lists) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") + (append-sublists lists))) + +(defun only-null-list-elements-p (lst) + (or (null lst) (every #'null lst))) + +(defun print-separated-strings (strm separator &rest lists) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) + (compilation-speed 0))) + (do* ((rest-lists lists (cdr rest-lists)) + (list (car rest-lists) (car rest-lists)) + (last-list (only-null-list-elements-p (cdr rest-lists)) + (only-null-list-elements-p (cdr rest-lists)))) + ((null rest-lists) strm) + (do* ((lst list (cdr lst)) + (elem (car lst) (car lst)) + (last-elem (null (cdr lst)) (null (cdr lst)))) + ((null lst)) + (write-string elem strm) + (unless (and last-elem last-list) + (write-string separator strm))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-prefixed-number-string (fn-name type &optional doc) + `(defun ,fn-name (num pchar len) + ,@(when (stringp doc) (list doc)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum len) + (,type num)) + (when pchar + (incf len)) + (do* ((zero-code (char-code #\0)) + (result (make-string len :initial-element #\0)) + (minus? (minusp num)) + (val (if minus? (- num) num) + (nth-value 0 (floor val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when pchar + (setf (schar result 0) pchar)) + (when minus? (setf (schar result (if pchar 1 0)) #\-)) + result) + (declare (,type val) + (fixnum mod zero-code pos) + (boolean minus?) + (simple-string result)) + (setf (schar result pos) (code-char (the fixnum (+ zero-code mod)))))))) + +(def-prefixed-number-string prefixed-fixnum-string fixnum + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present. LEN must be a fixnum.") + +(def-prefixed-number-string prefixed-integer-string integer + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present. LEN must be an integer.") + +(defun integer-string (num len) + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present." + (declare (optimize (speed 3) (safety 0) (space 0)) + (type fixnum len) + (type integer num)) + (do* ((zero-code (char-code #\0)) + (result (make-string len :initial-element #\0)) + (minus? (minusp num)) + (val (if minus? (- 0 num) num) + (nth-value 0 (floor val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when minus? (setf (schar result 0) #\-)) + result) + (declare (fixnum mod zero-code pos) (simple-string result) (integer val)) + (setf (schar result pos) (code-char (+ zero-code mod))))) + +(defun fast-string-search (substr str substr-length startpos endpos) + "Optimized search for a substring in a simple-string" + (declare (simple-string substr str) + (fixnum substr-length startpos endpos) + (optimize (speed 3) (space 0) (safety 0))) + (do* ((pos startpos (1+ pos)) + (lastpos (- endpos substr-length))) + ((> pos lastpos) nil) + (declare (fixnum pos lastpos)) + (do ((i 0 (1+ i))) + ((= i substr-length) + (return-from fast-string-search pos)) + (declare (fixnum i)) + (unless (char= (schar str (+ i pos)) (schar substr i)) + (return nil))))) + +(defun string-delimited-string-to-list (str substr) + "splits a string delimited by substr into a list of strings" + (declare (simple-string str substr) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) + (debug 0))) + (do* ((substr-len (length substr)) + (strlen (length str)) + (output '()) + (pos 0) + (end (fast-string-search substr str substr-len pos strlen) + (fast-string-search substr str substr-len pos strlen))) + ((null end) + (when (< pos strlen) + (push (subseq str pos) output)) + (nreverse output)) + (declare (fixnum strlen substr-len pos) + (type (or fixnum null) end)) + (push (subseq str pos end) output) + (setq pos (+ end substr-len)))) + +(defun string-to-list-skip-delimiter (str &optional (delim #\space)) + "Return a list of strings, delimited by spaces, skipping spaces." + (declare (simple-string str) + (optimize (speed 0) (space 0) (safety 0))) + (do* ((results '()) + (end (length str)) + (i (position-not-char delim str 0 end) + (position-not-char delim str j end)) + (j (when i (position-char delim str i end)) + (when i (position-char delim str i end)))) + ((or (null i) (null j)) + (when (and i (< i end)) + (push (subseq str i end) results)) + (nreverse results)) + (declare (fixnum end) + (type (or fixnum null) i j)) + (push (subseq str i j) results))) + +(defun string-starts-with (start str) + (and (>= (length str) (length start)) + (string-equal start str :end2 (length start)))) + +(defun count-string-char (s c) + "Return a count of the number of times a character appears in a string" + (declare (simple-string s) + (character c) + (optimize (speed 3) (safety 0))) + (do ((len (length s)) + (i 0 (1+ i)) + (count 0)) + ((= i len) count) + (declare (fixnum i len count)) + (when (char= (schar s i) c) + (incf count)))) + +(defun count-string-char-if (pred s) + "Return a count of the number of times a predicate is true +for characters in a string" + (declare (simple-string s) + (type (or function symbol) pred) + (optimize (speed 3) (safety 0) (space 0))) + (do ((len (length s)) + (i 0 (1+ i)) + (count 0)) + ((= i len) count) + (declare (fixnum i len count)) + (when (funcall pred (schar s i)) + (incf count)))) + + +;;; URL Encoding + +(defun non-alphanumericp (ch) + (not (alphanumericp ch))) + +(defvar +hex-chars+ "0123456789ABCDEF") +(declaim (type simple-string +hex-chars+)) + +(defun hexchar (n) + (declare (type (integer 0 15) n)) + (schar +hex-chars+ n)) + +(defconstant* +char-code-lower-a+ (char-code #\a)) +(defconstant* +char-code-upper-a+ (char-code #\A)) +(defconstant* +char-code-0+ (char-code #\0)) +(declaim (type fixnum +char-code-0+ +char-code-upper-a+ + +char-code-0)) + +(defun charhex (ch) + "convert hex character to decimal" + (let ((code (char-code (char-upcase ch)))) + (declare (fixnum ch)) + (if (>= code +char-code-upper-a+) + (+ 10 (- code +char-code-upper-a+)) + (- code +char-code-0+)))) + +(defun binary-sequence-to-hex-string (seq) + (let ((list (etypecase seq + (list seq) + (sequence (map 'list #'identity seq))))) + (string-downcase (format nil "~{~2,'0X~}" list)))) + +(defun encode-uri-string (query) + "Escape non-alphanumeric characters for URI fields" + (declare (simple-string query) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((count (count-string-char-if #'non-alphanumericp query)) + (len (length query)) + (new-len (+ len (* 2 count))) + (str (make-string new-len)) + (spos 0 (1+ spos)) + (dpos 0 (1+ dpos))) + ((= spos len) str) + (declare (fixnum count len new-len spos dpos) + (simple-string str)) + (let ((ch (schar query spos))) + (if (non-alphanumericp ch) + (let ((c (char-code ch))) + (setf (schar str dpos) #\%) + (incf dpos) + (setf (schar str dpos) (hexchar (logand (ash c -4) 15))) + (incf dpos) + (setf (schar str dpos) (hexchar (logand c 15)))) + (setf (schar str dpos) ch))))) + +(defun decode-uri-string (query) + "Unescape non-alphanumeric characters for URI fields" + (declare (simple-string query) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((count (count-string-char query #\%)) + (len (length query)) + (new-len (- len (* 2 count))) + (str (make-string new-len)) + (spos 0 (1+ spos)) + (dpos 0 (1+ dpos))) + ((= spos len) str) + (declare (fixnum count len new-len spos dpos) + (simple-string str)) + (let ((ch (schar query spos))) + (if (char= #\% ch) + (let ((c1 (charhex (schar query (1+ spos)))) + (c2 (charhex (schar query (+ spos 2))))) + (declare (fixnum c1 c2)) + (setf (schar str dpos) + (code-char (logior c2 (ash c1 4)))) + (incf spos 2)) + (setf (schar str dpos) ch))))) + + +(defun uri-query-to-alist (query) + "Converts non-decoded URI query to an alist of settings" + (mapcar (lambda (set) + (let ((lst (kmrcl:delimited-string-to-list set #\=))) + (cons (first lst) (second lst)))) + (kmrcl:delimited-string-to-list + (kmrcl:decode-uri-string query) #\&))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +unambiguous-charset+ + "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ") + (defconstant* +unambiguous-length+ (length +unambiguous-charset+))) + +(defun random-char (&optional (set :lower-alpha)) + (ecase set + (:lower-alpha + (code-char (+ +char-code-lower-a+ (random 26)))) + (:lower-alphanumeric + (let ((n (random 36))) + (if (>= n 26) + (code-char (+ +char-code-0+ (- n 26))) + (code-char (+ +char-code-lower-a+ n))))) + (:upper-alpha + (code-char (+ +char-code-upper-a+ (random 26)))) + (:unambiguous + (schar +unambiguous-charset+ (random +unambiguous-length+))) + (:upper-lower-alpha + (let ((n (random 52))) + (if (>= n 26) + (code-char (+ +char-code-upper-a+ (- n 26))) + (code-char (+ +char-code-lower-a+ n))))))) + + +(defun random-string (&key (length 10) (set :lower-alpha)) + "Returns a random lower-case string." + (declare (optimize (speed 3))) + (let ((s (make-string length))) + (declare (simple-string s)) + (dotimes (i length s) + (setf (schar s i) (random-char set))))) + + +(defun first-char (s) + (declare (simple-string s)) + (when (and (stringp s) (plusp (length s))) + (schar s 0))) + +(defun last-char (s) + (declare (simple-string s)) + (when (stringp s) + (let ((len (length s))) + (when (plusp len)) + (schar s (1- len))))) + +(defun ensure-string (v) + (typecase v + (string v) + (character (string v)) + (symbol (symbol-name v)) + (otherwise (write-to-string v)))) + +(defun string-right-trim-one-char (char str) + (declare (simple-string str)) + (let* ((len (length str)) + (last (1- len))) + (declare (fixnum len last)) + (if (char= char (schar str last)) + (subseq str 0 last) + str))) + + +(defun string-strip-ending (str endings) + (if (stringp endings) + (setq endings (list endings))) + (let ((len (length str))) + (dolist (ending endings str) + (when (and (>= len (length ending)) + (string-equal ending + (subseq str (- len + (length ending))))) + (return-from string-strip-ending + (subseq str 0 (- len (length ending)))))))) + + +(defun string-maybe-shorten (str maxlen) + (string-elide str maxlen :end)) + +(defun string-elide (str maxlen position) + (declare (fixnum maxlen)) + (let ((len (length str))) + (declare (fixnum len)) + (cond + ((<= len maxlen) + str) + ((<= maxlen 3) + "...") + ((eq position :middle) + (multiple-value-bind (mid remain) (truncate maxlen 2) + (let ((end1 (- mid 1)) + (start2 (- len (- mid 2) remain))) + (concatenate 'string (subseq str 0 end1) "..." (subseq str start2))))) + ((or (eq position :end) t) + (concatenate 'string (subseq str 0 (- maxlen 3)) "..."))))) + +(defun shrink-vector (str size) + #+allegro + (excl::.primcall 'sys::shrink-svector str size) + #+cmu + (lisp::shrink-vector str size) + #+lispworks + (system::shrink-vector$vector str size) + #+sbcl + (sb-kernel:shrink-vector str size) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + +(defun lex-string (string &key (whitespace '(#\space #\newline))) + "Separates a string at whitespace and returns a list of strings" + (flet ((is-sep (char) (member char whitespace :test #'char=))) + (let ((tokens nil)) + (do* ((token-start + (position-if-not #'is-sep string) + (when token-end + (position-if-not #'is-sep string :start (1+ token-end)))) + (token-end + (when token-start + (position-if #'is-sep string :start token-start)) + (when token-start + (position-if #'is-sep string :start token-start)))) + ((null token-start) (nreverse tokens)) + (push (subseq string token-start token-end) tokens))))) + +(defun split-alphanumeric-string (string) + "Separates a string at any non-alphanumeric chararacter" + (declare (simple-string string) + (optimize (speed 3) (safety 0))) + (flet ((is-sep (char) + (declare (character char)) + (and (non-alphanumericp char) + (not (char= #\_ char))))) + (let ((tokens nil)) + (do* ((token-start + (position-if-not #'is-sep string) + (when token-end + (position-if-not #'is-sep string :start (1+ token-end)))) + (token-end + (when token-start + (position-if #'is-sep string :start token-start)) + (when token-start + (position-if #'is-sep string :start token-start)))) + ((null token-start) (nreverse tokens)) + (push (subseq string token-start token-end) tokens))))) + + +(defun trim-non-alphanumeric (word) + "Strip non-alphanumeric characters from beginning and end of a word." + (declare (simple-string word) + (optimize (speed 3) (safety 0) (space 0))) + (let* ((start 0) + (len (length word)) + (end len)) + (declare (fixnum start end len)) + (do ((done nil)) + ((or done (= start end))) + (if (alphanumericp (schar word start)) + (setq done t) + (incf start))) + (when (> end start) + (do ((done nil)) + ((or done (= start end))) + (if (alphanumericp (schar word (1- end))) + (setq done t) + (decf end)))) + (if (or (plusp start) (/= len end)) + (subseq word start end) + word))) + + +(defun collapse-whitespace (s) + "Convert multiple whitespace characters to a single space character." + (declare (simple-string s) + (optimize (speed 3) (safety 0))) + (with-output-to-string (stream) + (do ((pos 0 (1+ pos)) + (in-white nil) + (len (length s))) + ((= pos len)) + (declare (fixnum pos len)) + (let ((c (schar s pos))) + (declare (character c)) + (cond + ((kl:is-char-whitespace c) + (unless in-white + (write-char #\space stream)) + (setq in-white t)) + (t + (setq in-white nil) + (write-char c stream))))))) + +(defun string->list (string) + (let ((eof (list nil))) + (with-input-from-string (stream string) + (do ((x (read stream nil eof) (read stream nil eof)) + (l nil (cons x l))) + ((eq x eof) (nreverse l)))))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,80 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.lisp +;;;; Purpose: Strings utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +(defun score-multiword-match (s1 s2) + "Score a match between two strings with s1 being reference string. +S1 can be a string or a list or strings/conses" + (let* ((word-list-1 (if (stringp s1) + (split-alphanumeric-string s1) + s1)) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2)) + (unmatched n1) + (score 0)) + (declare (fixnum n1 n2 score unmatched)) + (decf score (* 4 (abs (- n1 n2)))) + (dotimes (iword n1) + (declare (fixnum iword)) + (let ((w1 (nth iword word-list-1)) + pos) + (cond + ((consp w1) + (let ((first t)) + (dotimes (i-alt (length w1)) + (setq pos + (position (nth i-alt w1) word-list-2 + :test #'string-equal)) + (when pos + (incf score (- 30 + (if first 0 5) + (abs (- iword pos)))) + (decf unmatched) + (return)) + (setq first nil)))) + ((stringp w1) + (kmrcl:awhen (position w1 word-list-2 + :test #'string-equal) + (incf score (- 30 (abs (- kmrcl::it iword)))) + (decf unmatched)))))) + (decf score (* 4 unmatched)) + score)) + + +(defun multiword-match (s1 s2) + "Matches two multiword strings, ignores case, word position, punctuation" + (let* ((word-list-1 (split-alphanumeric-string s1)) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2))) + (when (= n1 n2) + ;; remove each word from word-list-2 as walk word-list-1 + (dolist (w word-list-1) + (let ((p (position w word-list-2 :test #'string-equal))) + (unless p + (return-from multiword-match nil)) + (setf (nth p word-list-2) ""))) + t))) + + + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,147 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cl-symbols.lisp +;;;; Purpose: Returns all defined Common Lisp symbols +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun cl-symbols () + (append (cl-variables) (cl-functions))) + +(defun cl-variables () + (let ((vars '())) + (do-symbols (s 'common-lisp) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) 'common-lisp) + (when (and (or (eq status :external) + (eq status :internal)) + (boundp sym)) + (push sym vars)))) + (nreverse vars))) + +(defun cl-functions () + (let ((funcs '())) + (do-symbols (s 'common-lisp) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) 'common-lisp) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym)) + (push sym funcs)))) + (nreverse funcs))) + +;;; Symbol functions + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :kmrcl-lowercase-reader *features*)) + (when (not (string= (symbol-name '#:a) + (symbol-name '#:A))) + (pushnew :kmrcl-case-sensitive *features*))) + +(defun string-default-case (str) + #+(and (not kmrcl-lowercase-reader)) (string-upcase str) + #+(and kmrcl-lowercase-reader) (string-downcase str)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :kmrcl-lowercase-reader *features*)) + (setq cl:*features* (delete :kmrcl-case-sensitive *features*))) + +(defun concat-symbol-pkg (pkg &rest args) + (declare (dynamic-extent args)) + (flet ((stringify (arg) + (etypecase arg + (string + (string-upcase arg)) + (symbol + (symbol-name arg))))) + (let ((str (apply #'concatenate 'string (mapcar #'stringify args)))) + (nth-value 0 (intern (string-default-case str) + (if pkg pkg *package*)))))) + + +(defun concat-symbol (&rest args) + (apply #'concat-symbol-pkg nil args)) + +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (nth-value 0 (intern (string-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +(defun ensure-keyword-upcase (desig) + (nth-value 0 (intern (string-upcase + (symbol-name (ensure-keyword desig))) :keyword))) + +(defun ensure-keyword-default-case (desig) + (nth-value 0 (intern (string-default-case + (symbol-name (ensure-keyword desig))) :keyword))) + +(defun show (&optional (what :variables) (package *package*)) + (ecase what + (:variables (show-variables package)) + (:functions (show-functions package)))) + +(defun show-variables (package) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (boundp sym)) + (format t "~&Symbol ~S~T -> ~S~%" + sym + (symbol-value sym)))))) + +(defun show-functions (package) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym)) + (format t "~&Function ~S~T -> ~S~%" + sym + (symbol-function sym)))))) + +(defun find-test-generic-functions (instance) + "Return a list of symbols for generic functions specialized on the +class of an instance and whose name begins with the string 'test-'" + (let ((res) + (package (symbol-package (class-name (class-of instance))))) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym) + (eq (symbol-package sym) package) + (> (length (symbol-name sym)) 5) + (string-equal "test-" (subseq (symbol-name sym) 0 5)) + (typep (symbol-function sym) 'generic-function) + (plusp + (length + (compute-applicable-methods + (ensure-generic-function sym) + (list instance))))) + (push sym res)))) + (nreverse res))) + +(defun run-tests-for-instance (instance) + (dolist (gf-name(find-test-generic-functions instance)) + (funcall gf-name instance)) + (values)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,493 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl-tests.lisp +;;;; Purpose: kmrcl tests file +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:cl) +(defpackage #:kmrcl-tests + (:use #:kmrcl #:cl #:rtest)) +(in-package #:kmrcl-tests) + +(rem-all-tests) + + +(deftest :str.0 (substitute-chars-strings "" nil) "") +(deftest :str.1 (substitute-chars-strings "abcd" nil) "abcd") +(deftest :str.2 (substitute-chars-strings "abcd" nil) "abcd") +(deftest :str.3 (substitute-chars-strings "abcd" '((#\j . "ef"))) "abcd") +(deftest :str.4 (substitute-chars-strings "abcd" '((#\a . "ef"))) "efbcd") +(deftest :str.5 + (substitute-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi"))) + "efbcd") +(deftest :str.6 + (substitute-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi"))) + "efbcghi") + +(deftest :str.7 (escape-xml-string "") "") +(deftest :str.8 (escape-xml-string "abcd") "abcd") +(deftest :str.9 (escape-xml-string "ab&cd") "ab&cd") +(deftest :str.10 (escape-xml-string "ab&cd<") "ab&cd<") +(deftest :str.12 (string-trim-last-character "") "") +(deftest :str.13 (string-trim-last-character "a") "") +(deftest :str.14 (string-trim-last-character "ab") "a") +(deftest :str.15 (nstring-trim-last-character "") "") +(deftest :str.16 (nstring-trim-last-character "a") "") +(deftest :str.17 (nstring-trim-last-character "ab") "a") + +(deftest :str.18 (delimited-string-to-list "ab|cd|ef" #\|) + ("ab" "cd" "ef")) +(deftest :str.19 (delimited-string-to-list "ab|cd|ef" #\| t) + ("ab" "cd" "ef")) +(deftest :str.20 (delimited-string-to-list "") ("")) +(deftest :str.21 (delimited-string-to-list "" #\space t) ("")) +(deftest :str.22 (delimited-string-to-list "ab") ("ab")) +(deftest :str.23 (delimited-string-to-list "ab" #\space t) ("ab")) +(deftest :str.24 (delimited-string-to-list "ab|" #\|) ("ab" "")) +(deftest :str.25 (delimited-string-to-list "ab|" #\| t) ("ab")) + +(deftest :sdstl.1 (string-delimited-string-to-list "ab|cd|ef" "|a") + ("ab|cd|ef")) +(deftest :sdstl.2 (string-delimited-string-to-list "ab|cd|ef" "|") + ("ab" "cd" "ef")) +(deftest :sdstl.3 (string-delimited-string-to-list "ab|cd|ef" "cd") + ("ab|" "|ef")) +(deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab") + ("" "|cd|ef")) + +(deftest :hexstr.1 (binary-sequence-to-hex-string ()) + "") + +(deftest :hexstr.2 (binary-sequence-to-hex-string #()) + "") + +(deftest :hexstr.3 (binary-sequence-to-hex-string #(165)) + "a5" +) + +(deftest :hexstr.4 (binary-sequence-to-hex-string (list 165)) + "a5") + +(deftest :hexstr.5 (binary-sequence-to-hex-string #(165 86)) + "a556") + +(deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d)) +(deftest :apsl.2 (append-sublists nil) nil) +(deftest :apsl.3 (append-sublists '((a b))) (a b)) +(deftest :apsl.4 (append-sublists '((a))) (a)) +(deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g))) + +(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil)) + "") + +(deftest :pss.1 + (with-output-to-string (s) (print-separated-strings s "|" '("ab")) ) + "ab") + +(deftest :pss.2 + (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd"))) + "ab|cd") + +(deftest :pss.3 + (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd") nil)) + "ab|cd") + +(deftest :pss.4 + (with-output-to-string (s) + (print-separated-strings s "|" '("ab" "cd") nil nil)) + "ab|cd") + +(deftest :pss.5 + (with-output-to-string (s) + (print-separated-strings s "|" '("ab" "cd") nil '("ef") nil)) + "ab|cd|ef") + +(deftest :css.0 (concat-separated-strings "|" nil) "") +(deftest :css.1 (concat-separated-strings "|" nil nil) "") +(deftest :css.2 (concat-separated-strings "|" '("ab")) "ab") +(deftest :css.3 (concat-separated-strings "|" '("ab" "cd")) "ab|cd") +(deftest :css.4 (concat-separated-strings "|" '("ab" "cd") nil) "ab|cd") +(deftest :css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef") + +(deftest :f.1 (map-and-remove-nils #'(lambda (x) (when (oddp x) (* x x))) + '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81)) +(deftest :f.2 (filter #'(lambda (x) (when (oddp x) (* x x))) + '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9)) +(deftest :an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f)) + + +(deftest :pxml.1 + (xml-tag-contents "tag1" "<tag>Test</tag>") + nil nil nil) + +(deftest :pxml.2 + (xml-tag-contents "tag" "<tag>Test</tag>") + "Test" 15 nil) + +(deftest :pxml.3 + (xml-tag-contents "tag" "<tag >Test</tag>") + "Test" 17 nil) + +(deftest :pxml.4 + (xml-tag-contents "tag" "<tag a=\"b\"></tag>") + "" 17 ("a=\"b\"")) + +(deftest :pxml.5 + (xml-tag-contents "tag" "<tag a=\"b\" >Test</tag>") + "Test" 22 ("a=\"b\"")) + +(deftest :pxml.6 + (xml-tag-contents "tag" "<tag a=\"b\" c=\"ab\">Test</tag>") + "Test" 29 ("a=\"b\"" "c=\"ab\"")) + +(deftest :pxml.7 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test</taga>") + nil nil nil) + +(deftest :pxml.8 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test<tag>ab</tag></taga>") + "ab" 37 nil) + +(deftest :pxml.9 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test<tag>ab</ag></taga>") + nil nil nil) + +(deftest :fss.1 (fast-string-search "" "" 0 0 0) 0) +(deftest :fss.2 (fast-string-search "" "abc" 0 0 2) 0) +(deftest :fss.3 (fast-string-search "abc" "" 3 0 0) nil) +(deftest :fss.4 (fast-string-search "abc" "abcde" 3 0 4) 0) +(deftest :fss.5 (fast-string-search "abc" "012abcde" 3 0 7) 3) +(deftest :fss.6 (fast-string-search "abc" "012abcde" 3 0 7) 3) +(deftest :fss.7 (fast-string-search "abc" "012abcde" 3 3 7) 3) +(deftest :fss.8 (fast-string-search "abc" "012abcde" 3 4 7) nil) +(deftest :fss.9 (fast-string-search "abcde" "012abcde" 5 3 8) 3) +(deftest :fss.9b (cl:search "abcde" "012abcde" :start2 3 :end2 8) 3) +(deftest :fss.10 (fast-string-search "abcde" "012abcde" 5 3 7) nil) +(deftest :fss.10b (cl:search "abcde" "012abcde" :start2 3 :end2 7) nil) + +(deftest :stlsd.1 (string-to-list-skip-delimiter "") ()) +(deftest :stlsd.2 (string-to-list-skip-delimiter "abc") ("abc")) +(deftest :stlsd.3 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.4 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.5 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.6 (string-to-list-skip-delimiter "ab c ") ("ab" "c")) +(deftest :stlsd.7 (string-to-list-skip-delimiter " ab c ") ("ab" "c")) +(deftest :stlsd.8 (string-to-list-skip-delimiter "ab,,c" #\,) ("ab" "c")) +(deftest :stlsd.9 (string-to-list-skip-delimiter "ab,,c,," #\,) ("ab" "c")) +(deftest :stlsd.10 (string-to-list-skip-delimiter " ab") ("ab")) + +(deftest :csc.1 (count-string-char "" #\a) 0) +(deftest :csc.2 (count-string-char "abc" #\d) 0) +(deftest :csc.3 (count-string-char "abc" #\b) 1) +(deftest :csc.4 (count-string-char "abcb" #\b) 2) + +(deftest :duqs.1 (decode-uri-query-string "") "") +(deftest :duqs.2 (decode-uri-query-string "abc") "abc") +(deftest :duqs.3 (decode-uri-query-string "abc+") "abc ") +(deftest :duqs.4 (decode-uri-query-string "abc+d") "abc d") +(deftest :duqs.5 (decode-uri-query-string "abc%20d") "abc d") + +(deftest :sse.1 (string-strip-ending "" nil) "") +(deftest :sse.2 (string-strip-ending "abc" nil) "abc") +(deftest :sse.3 (string-strip-ending "abc" "ab") "abc") +(deftest :sse.4 (string-strip-ending "abc" '("ab")) "abc") +(deftest :sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab") + + +(defun test-color-conversion () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv->rgb h s v) + (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b) + (unless (hsv-equal h s v h2 s2 v2) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + (float r) (float g) (float b) + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float s2) (float v) (float v2)) + (return-from test-color-conversion nil)))))))) + t) + +(defun test-color-conversion-float-255 () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv->rgb h s v) + (setf r (round (* 255 r)) + g (round (* 255 g)) + b (round (* 255 b))) + (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b) + (unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255) + :hue-range 10 :saturation-range .1 + :value-range 1 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + r g b + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float (/ s2 255)) (float v) (float (/ v2 255))) + (return-from test-color-conversion-float-255 nil)))))))) + t) + +(defun test-color-conversion-255-float () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv255->rgb255 h (truncate (* 255 s)) + (truncate (* 255 v))) + (setf r (/ r 255) + g (/ g 255) + b (/ b 255)) + + (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b) + (unless (hsv-similar h s v h2 s2 v2 + :hue-range 10 :saturation-range .1 + :value-range 1 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + r g b + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float (/ s2 255)) (float v) (float (/ v2 255))) + (return-from test-color-conversion-255-float nil)))))))) + t) + +(defun test-color-conversion-255 () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (truncate (* 255 (/ is 10)))) + (v (truncate (* 255 (/ iv 10))))) + (multiple-value-bind (r g b) (hsv255->rgb255 h s v) + (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b) + (unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5 + :value-range 5 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~D ~D ~D |~ + ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%" + r g b + h h2 s s2 v v2) + (return-from test-color-conversion-255 nil)))))))) + t) + +(deftest :color.conv (test-color-conversion) t) +(deftest :color.conv.float.255 (test-color-conversion-float-255) t) +(deftest :color.conv.255.float (test-color-conversion-255-float) t) +(deftest :color.conv.255 (test-color-conversion-255) t) + +(deftest :hue.diff.1 (hue-difference 10 10) 0) +(deftest :hue.diff.2 (hue-difference 10 9) -1) +(deftest :hue.diff.3 (hue-difference 9 10) 1) +(deftest :hue.diff.4 (hue-difference 10 nil) 360) +(deftest :hue.diff.5 (hue-difference nil 1) 360) +(deftest :hue.diff.7 (hue-difference 10 190) 180) +(deftest :hue.diff.8 (hue-difference 190 10) -180) +(deftest :hue.diff.9 (hue-difference 1 359) -2) +(deftest :hue.diff.10 (hue-difference 1 182) -179) +(deftest :hue.diff.11 (hue-difference 1 270) -91) + +(deftest :hsv.sim.1 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 5 + :value-range 0 :saturation-range 0 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.2 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 15 + :value-range 0 :saturation-range 0 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.3 (hsv-similar 100 .5 .5 110 .5 .6 :hue-range 15 + :value-range .2 :saturation-range 0 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.4 (hsv-similar 100 .5 .5 110 .5 .8 :hue-range 15 + :value-range 0.2 :saturation-range 0 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.5 (hsv-similar 100 .5 .5 110 .6 .6 :hue-range 15 + :value-range 0.2 :saturation-range .2 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.6 (hsv-similar 100 .5 .5 110 .6 .8 :hue-range 15 + :value-range 0.2 :saturation-range .2 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.7 (hsv-similar 100 .5 .05 110 .6 .01 :hue-range 0 + :value-range 0 :saturation-range 0 + :black-limit .1 :gray-limit 0) t) +(deftest :hsv.sim.8 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0 + :value-range 0.2 :saturation-range 0 + :black-limit 0 :gray-limit .1) t) +(deftest :hsv.sim.9 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0 + :value-range 0.05 :saturation-range 0 + :black-limit 0 :gray-limit .1) nil) + +#+ignore +(progn +(deftest :dst.1 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 2 4 2000)) t) +(deftest :dst.2 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 1 4 2000)) nil) +(deftest :dst.3 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 3 4 2000)) nil) +(deftest :dst.4 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 31 10 2004)) t) +(deftest :dst.5 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 30 10 2004)) nil) +(deftest :dst.6 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 1 11 2000)) nil) +) + + +(deftest :ekdc.1 + (ensure-keyword-default-case (read-from-string "TYPE")) :type) + +(deftest :ekdc.2 + (ensure-keyword-default-case (read-from-string "type")) :type) + + +(deftest :se.1 + (string-elide "A Test string" 10 :end) "A Test ..." ) + +(deftest :se.2 + (string-elide "A Test string" 13 :end) "A Test string") + +(deftest :se.3 + (string-elide "A Test string" 11 :end) "A Test s..." ) + +(deftest :se.4 + (string-elide "A Test string" 2 :middle) "...") + +(deftest :se.5 + (string-elide "A Test string" 11 :middle) "A Te...ring") + +(deftest :se.6 + (string-elide "A Test string" 12 :middle) "A Tes...ring") + +(deftest :url.1 + (make-url "pg") + "pg") + +(deftest :url.2 + (make-url "pg" :anchor "now") + "pg#now") + +(deftest :url.3 + (make-url "pg" :vars '(("a" . "5"))) + "pg?a=5") + +(deftest :url.4 + (make-url "pg" :anchor "then" :vars '(("a" . "5") ("b" . "pi"))) + "pg?a=5&b=pi#then") + +(defclass test-unique () + ((a :initarg :a) + (b :initarg :b))) + + +(deftest :unique.1 + (let ((list (list (make-instance 'test-unique :a 1 :b 1) + (make-instance 'test-unique :a 2 :b 2) + (make-instance 'test-unique :a 3 :b 2)))) + (values + (unique-slot-values list 'a) + (unique-slot-values list 'b))) + (1 2 3) (1 2)) + +(deftest :unique.2 + (unique-slot-values nil 'a) + nil) + +(deftest :nwp.1 + (numbers-within-percentage 1. 1.1 9) + nil) + +(deftest :nwp.2 + (numbers-within-percentage 1. 1.1 11) + t) + +(deftest :pfs.1 (prefixed-fixnum-string 0 #\A 5) "A00000") + +(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001") + +(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021") + +(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134") + + ;;; MOP Testing + +;; Disable attrib class until understand changes in sbcl/cmucl +;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method +;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW? + +#+ignore +(progn +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package '#:kmr-mop) + (pushnew :kmrtest-mop cl:*features*))) + +#+kmrtest-mop +(setf (find-class 'monitored-credit-rating) nil) +#+kmrtest-mop +(setf (find-class 'credit-rating) nil) + +#+kmrtest-mop +(defclass credit-rating () + ((level :attributes (date-set time-set)) + (id :attributes (person-setting))) + #+lispworks (:optimize-slot-access nil) + (:metaclass attributes-class)) + + +#+kmrtest-mop +(defclass monitored-credit-rating () + ((level :attributes (last-checked interval date-set)) + (cc :initarg :cc) + (id :attributes (verified))) + (:metaclass attributes-class)) + +#+kmrtest-mop +(deftest :attrib.mop.1 + (let ((cr (make-instance 'credit-rating))) + (slot-attribute cr 'level 'date-set)) + nil) + +#+kmrtest-mop +(deftest :attrib.mop.2 + (let ((cr (make-instance 'credit-rating))) + (setf (slot-attribute cr 'level 'date-set) "12/15/1990") + (let ((result (slot-attribute cr 'level 'date-set))) + (setf (slot-attribute cr 'level 'date-set) nil) + result)) + "12/15/1990") + +#+kmrtest-mop +(deftest :attrib.mop.3 + (let ((mcr (make-instance 'monitored-credit-rating))) + (setf (slot-attribute mcr 'level 'date-set) "01/05/2002") + (let ((result (slot-attribute mcr 'level 'date-set))) + (setf (slot-attribute mcr 'level 'date-set) nil) + result)) + "01/05/2002") + + +#+kmrtest-mop +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :kmrtest-mop cl:*features*))) + +) ;; progn Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,107 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: web-utils.lisp +;;;; Purpose: Basic web utility functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; HTML/XML constants + +(defvar *standard-xml-header* + #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%")) + +(defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">") + +(defvar *standard-xhtml-header* + #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")) + + +;;; User agent functions + +(defun user-agent-ie-p (agent) + "Takes a user-agent string and returns T for Internet Explorer." + (or (string-starts-with "Microsoft" agent) + (string-starts-with "Internet Explore" agent) + (search "Safari" agent) + (search "MSIE" agent))) + +;;; URL Functions + +(defvar *base-url* "") +(defun base-url! (url) + (setq *base-url* url)) + +(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor) + (let ((amp (case format + (:html + "&") + ((:xml :ie-xml) + "&")))) + (concatenate 'string + base-dir page-name + (if vars + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cdr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cdr var)) + (concatenate 'string + amp (string-downcase (car var)) "=" (cdr var)))) + (rest vars)))) + "") + (if anchor + (concatenate 'string "#" anchor) + "")))) + +(defun decode-uri-query-string (s) + "Decode a URI query string field" + (declare (simple-string s) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((old-len (length s)) + (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%))))) + (new (make-string new-len)) + (p-old 0) + (p-new 0 (1+ p-new))) + ((= p-new new-len) new) + (declare (simple-string new) + (fixnum p-old p-new old-len new-len)) + (let ((c (schar s p-old))) + (when (char= c #\+) + (setq c #\space)) + (case c + (#\% + (unless (>= old-len (+ p-old 3)) + (error "#\% not followed by enough characters")) + (setf (schar new p-new) + (code-char + (parse-integer (subseq s (1+ p-old) (+ p-old 3)) + :radix 16))) + (incf p-old 3)) + (t + (setf (schar new p-new) c) + (incf p-old)))))) + +(defun split-uri-query-string (s) + (mapcar + (lambda (pair) + (let ((pos (position #\= pair))) + (when pos + (cons (subseq pair 0 pos) + (when (> (length pair) pos) + (decode-uri-query-string (subseq pair (1+ pos)))))))) + (delimited-string-to-list s #\&))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,176 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: xml-utils.lisp +;;;; Purpose: XML utilities +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; XML Extraction Functions + +(defun find-start-tag (tag taglen xmlstr start end) + "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)" + (declare (simple-string tag xmlstr) + (fixnum taglen start end) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((search-str (concatenate 'string "<" tag)) + (search-len (1+ taglen)) + (bracketpos (fast-string-search search-str xmlstr search-len start end) + (fast-string-search search-str xmlstr search-len start end))) + ((null bracketpos) nil) + (let* ((endtag (+ bracketpos 1 taglen)) + (char-after-tag (schar xmlstr endtag))) + (when (or (char= #\> char-after-tag) + (char= #\space char-after-tag)) + (if (char= #\> char-after-tag) + (return-from find-start-tag (values (1+ endtag) nil)) + (let ((endbrack (position-char #\> xmlstr (1+ endtag) end))) + (if endbrack + (return-from find-start-tag + (values (1+ endbrack) + (string-to-list-skip-delimiter + (subseq xmlstr endtag endbrack)))) + (values nil nil))))) + (setq start endtag)))) + + +(defun find-end-tag (tag taglen xmlstr start end) + (fast-string-search + (concatenate 'string "</" tag ">") xmlstr + (+ taglen 3) start end)) + +(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) + (end-xmlstr (length xmlstr))) + "Returns three values: the start and end positions of contents between + the xml tags and the position following the close of the end tag." + (let* ((taglen (length tag))) + (multiple-value-bind (start attributes) + (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr) + (unless start + (return-from positions-xml-tag-contents (values nil nil nil nil))) + (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr))) + (unless end + (return-from positions-xml-tag-contents (values nil nil nil nil))) + (values start end (+ end taglen 3) attributes))))) + + +(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) + (end-xmlstr (length xmlstr))) + "Returns two values: the string between XML start and end tag +and position of character following end tag." + (multiple-value-bind + (startpos endpos nextpos attributes) + (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr) + (if (and startpos endpos) + (values (subseq xmlstr startpos endpos) nextpos attributes) + (values nil nil nil)))) + +(defun cdata-string (str) + (concatenate 'string "<![CDATA[" str "]]>")) + +(defun write-cdata (str s) + (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0))) + (do ((len (length str)) + (i 0 (1+ i))) + ((= i len) str) + (declare (fixnum i len)) + (let ((c (schar str i))) + (case c + (#\< (write-string "<" s)) + (#\& (write-string "&" s)) + (t (write-char c s)))))) + +(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding) + (format stream "<?xml version=\"~A\"~A~A ?>~%" + version + (if encoding + (format nil " encoding=\"~A\"" encoding) + "" + ) + (if standalone + (format nil " standalone=\"~A\"" standalone) + ""))) + +(defun doctype-stream (stream top-element availability registered organization type + label language url entities) + (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element + availability (if registered "+" "-") organization type label language) + + (when url + (write-char #\space stream) + (write-char #\" stream) + (write-string url stream) + (write-char #\" stream)) + + (when entities + (format stream " [~%~A~%]" entities)) + + (write-char #\> stream) + (write-char #\newline stream)) + +(defun doctype-format (stream format &key top-element (availability "PUBLIC") + (registered nil) organization (type "DTD") label + (language "EN") url entities) + (case format + ((:xhtml11 :xhtml) + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language + (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd") + entities)) + (:xhtml10-strict + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd") + entities)) + (:xhtml10-transitional + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd") + entities)) + (:xhtml-frameset + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd") + entities)) + (:html2 + (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities)) + (:html3 + (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities)) + (:html3.2 + (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities)) + ((:html :html4) + (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities)) + ((:docbook :docbook42) + (doctype-stream stream (if top-element top-element "book") + availability registered "OASIS" type "Docbook XML 4.2" language + (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd") + entities)) + (t + (unless top-element (warn "Missing top-element in doctype-format")) + (unless organization (warn "Missing organization in doctype-format")) + (unless label (warn "Missing label in doctype-format")) + (doctype-stream stream top-element availability registered organization type label language url + entities)))) + + +(defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0") + top-element (availability "PUBLIC") registered organization (type "DTD") + label (language "EN") url) + (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook) + (xml-declaration-stream stream :version version :encoding encoding :standalone standalone)) + (unless (eq :xml format) + (doctype-format stream format :top-element top-element + :availability availability :registered registered + :organization organization :type type :label label :language language + :url url :entities entities)) + stream) +

1 0

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

06 Oct '07

Author: hhubner Date: 2007-10-06 17:23:47 -0400 (Sat, 06 Oct 2007) New Revision: 2224 Removed: branches/trunk-reorg/thirdparty/uffi/ Log: remove uffi, using cffi now

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs October 2007