├── 2077.pdf ├── 2444.html ├── 9781590592397.jpg ├── LICENSE.txt ├── README.md ├── contributing.md └── practicals ├── Chapter03 ├── packages.lisp ├── simple-database.asd └── simple-database.lisp ├── Chapter08 ├── macro-utilities.asd ├── macro-utilities.lisp └── packages.lisp ├── Chapter09 ├── packages.lisp ├── test-framework.asd └── test.lisp ├── Chapter15 ├── packages.lisp ├── pathnames.asd └── pathnames.lisp ├── Chapter23 ├── packages.lisp ├── spam.asd └── spam.lisp ├── Chapter24 ├── binary-data.asd ├── binary-data.lisp └── packages.lisp ├── Chapter25 ├── id3v2.asd ├── id3v2.lisp └── packages.lisp ├── Chapter26 ├── allegroserve.lisp ├── html-infrastructure.lisp ├── packages.lisp └── url-function.asd ├── Chapter27 ├── database.lisp ├── mp3-database.asd ├── mp3-database.lisp └── packages.lisp ├── Chapter28 ├── packages.lisp ├── shoutcast.asd ├── shoutcast.lisp └── song-source.lisp ├── Chapter29 ├── mp3-browser.asd ├── mp3-browser.css ├── mp3-browser.lisp ├── packages.lisp └── playlist.lisp ├── Chapter31 ├── README.txt ├── css.lisp ├── embed-foo-with-conditions-and-restarts.lisp ├── html.asd ├── html.lisp └── packages.lisp ├── Chapter32 └── profiler.lisp ├── LICENSE ├── README.txt ├── libraries └── cl-ppcre-1.2.3 │ ├── CHANGELOG │ ├── README │ ├── api.lisp │ ├── cl-ppcre-test.asd │ ├── cl-ppcre-test.system │ ├── cl-ppcre.asd │ ├── cl-ppcre.system │ ├── closures.lisp │ ├── convert.lisp │ ├── doc │ ├── benchmarks.2002-12-22.txt │ └── index.html │ ├── errors.lisp │ ├── lexer.lisp │ ├── load.lisp │ ├── optimize.lisp │ ├── packages.lisp │ ├── parser.lisp │ ├── perltest.pl │ ├── ppcre-tests.lisp │ ├── regex-class.lisp │ ├── repetition-closures.lisp │ ├── scanner.lisp │ ├── specials.lisp │ ├── testdata │ ├── testinput │ └── util.lisp └── practicals.asd /2077.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/2077.pdf -------------------------------------------------------------------------------- /2444.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/2444.html -------------------------------------------------------------------------------- /9781590592397.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/9781590592397.jpg -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/LICENSE.txt -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Practical Common Lisp*](http://www.apress.com/9781590592397) by Peter Seibel (Apress, 2005). 4 | 5 | ![Cover image](9781590592397.jpg) 6 | 7 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 8 | 9 | ## Releases 10 | 11 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 12 | 13 | ## Contributions 14 | 15 | See the file Contributing.md for more information on how you can contribute to this repository. 16 | -------------------------------------------------------------------------------- /contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! -------------------------------------------------------------------------------- /practicals/Chapter03/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.simple-db (:use :cl)) 4 | -------------------------------------------------------------------------------- /practicals/Chapter03/simple-database.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.simple-database-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.simple-database-system) 3 | 4 | (defsystem simple-database 5 | :name "simple-database" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Simple s-expression database." 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "simple-database" :depends-on ("packages")))) 15 | 16 | 17 | -------------------------------------------------------------------------------- /practicals/Chapter03/simple-database.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.simple-db) 2 | 3 | (defvar *db* nil) 4 | 5 | (defun make-cd (title artist rating ripped) 6 | (list :title title :artist artist :rating rating :ripped ripped)) 7 | 8 | (defun add-record (cd) (push cd *db*)) 9 | 10 | (defun dump-db () 11 | (dolist (cd *db*) 12 | (format t "~{~a:~10t~a~%~}~%" cd))) 13 | 14 | (defun prompt-read (prompt) 15 | (format *query-io* "~a: " prompt) 16 | (force-output *query-io*) 17 | (read-line *query-io*)) 18 | 19 | (defun prompt-for-cd () 20 | (make-cd 21 | (prompt-read "Title") 22 | (prompt-read "Artist") 23 | (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0) 24 | (y-or-n-p "Ripped [y/n]: "))) 25 | 26 | (defun add-cds () 27 | (loop (add-record (prompt-for-cd)) 28 | (if (not (y-or-n-p "Another? [y/n]: ")) (return)))) 29 | 30 | (defun save-db (filename) 31 | (with-open-file (out filename 32 | :direction :output 33 | :if-exists :supersede) 34 | (with-standard-io-syntax 35 | (print *db* out)))) 36 | 37 | (defun load-db (filename) 38 | (with-open-file (in filename) 39 | (with-standard-io-syntax 40 | (setf *db* (read in))))) 41 | 42 | (defun clear-db () (setq *db* nil)) 43 | 44 | (defun select (selector-fn) 45 | (remove-if-not selector-fn *db*)) 46 | 47 | (defmacro where (&rest clauses) 48 | `#'(lambda (cd) (and ,@(make-comparisons-list clauses)))) 49 | 50 | (defun make-comparisons-list (fields) 51 | (loop while fields 52 | collecting (make-comparison-expr (pop fields) (pop fields)))) 53 | 54 | (defun make-comparison-expr (field value) 55 | `(equal (getf cd ,field) ,value)) 56 | 57 | 58 | (defun update (selector-fn &key title artist rating (ripped nil ripped-p)) 59 | (setf *db* 60 | (mapcar 61 | #'(lambda (row) 62 | (when (funcall selector-fn row) 63 | (if title (setf (getf row :title) title)) 64 | (if artist (setf (getf row :artist) artist)) 65 | (if rating (setf (getf row :rating) rating)) 66 | (if ripped-p (setf (getf row :ripped) ripped))) 67 | row) *db*))) 68 | 69 | (defun delete-rows (selector-fn) 70 | (setf *db* (remove-if selector-fn *db*))) 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /practicals/Chapter08/macro-utilities.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.macro-utilities-system) 3 | 4 | (defsystem macro-utilities 5 | :name "macro-utilities" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Utilities for writing macros" 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "macro-utilities" :depends-on ("packages"))) 15 | :depends-on ()) 16 | 17 | 18 | -------------------------------------------------------------------------------- /practicals/Chapter08/macro-utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.macro-utilities) 2 | 3 | (defmacro with-gensyms ((&rest names) &body body) 4 | `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) 5 | ,@body)) 6 | 7 | (defmacro once-only ((&rest names) &body body) 8 | (let ((gensyms (loop for n in names collect (gensym (string n))))) 9 | `(let (,@(loop for g in gensyms collect `(,g (gensym)))) 10 | `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) 11 | ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) 12 | ,@body))))) 13 | 14 | (defun spliceable (value) 15 | (if value (list value))) 16 | 17 | (defmacro ppme (form &environment env) 18 | (progn 19 | (write (macroexpand-1 form env) 20 | :length nil 21 | :level nil 22 | :circle nil 23 | :pretty t 24 | :gensym nil 25 | :right-margin 83 26 | :case :downcase) 27 | nil)) 28 | 29 | -------------------------------------------------------------------------------- /practicals/Chapter08/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.macro-utilities 4 | (:use :common-lisp) 5 | (:export 6 | :with-gensyms 7 | :with-gensymed-defuns 8 | :once-only 9 | :spliceable 10 | :ppme)) 11 | 12 | -------------------------------------------------------------------------------- /practicals/Chapter09/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.test 4 | (:use :common-lisp :com.gigamonkeys.macro-utilities) 5 | (:export :deftest :check)) 6 | -------------------------------------------------------------------------------- /practicals/Chapter09/test-framework.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.test-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.test-system) 3 | 4 | (defsystem test-framework 5 | :name "test-framework" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Simple unit test framework for Common Lisp" 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "test" :depends-on ("packages"))) 15 | :depends-on (:macro-utilities)) 16 | -------------------------------------------------------------------------------- /practicals/Chapter09/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.test) 2 | 3 | (defvar *test-name* nil) 4 | 5 | (defmacro deftest (name parameters &body body) 6 | "Define a test function. Within a test function we can call other 7 | test functions or use `check' to run individual test cases." 8 | `(defun ,name ,parameters 9 | (let ((*test-name* (append *test-name* (list ',name)))) 10 | ,@body))) 11 | 12 | (defmacro check (&body forms) 13 | "Run each expression in `forms' as a test case." 14 | `(combine-results 15 | ,@(loop for f in forms collect `(report-result ,f ',f)))) 16 | 17 | (defmacro combine-results (&body forms) 18 | "Combine the results (as booleans) of evaluating `forms' in order." 19 | (with-gensyms (result) 20 | `(let ((,result t)) 21 | ,@(loop for f in forms collect `(unless ,f (setf ,result nil))) 22 | ,result))) 23 | 24 | (defun report-result (result form) 25 | "Report the results of a single test case. Called by `check'." 26 | (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form) 27 | result) 28 | -------------------------------------------------------------------------------- /practicals/Chapter15/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.pathnames 4 | (:use :common-lisp) 5 | (:export 6 | :list-directory 7 | :file-exists-p 8 | :directory-pathname-p 9 | :file-pathname-p 10 | :pathname-as-directory 11 | :pathname-as-file 12 | :walk-directory 13 | :directory-p 14 | :file-p)) 15 | -------------------------------------------------------------------------------- /practicals/Chapter15/pathnames.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.pathnames-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.pathnames-system) 3 | 4 | (defsystem pathnames 5 | :name "pathnames" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Portable pathname manipulation functions." 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "pathnames" :depends-on ("packages")))) 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /practicals/Chapter15/pathnames.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:com.gigamonkeys.pathnames) 2 | 3 | (defun list-directory (dirname) 4 | "Return a list of the contents of the directory named by dirname. 5 | Names of subdirectories will be returned in `directory normal 6 | form'. Unlike CL:DIRECTORY, LIST-DIRECTORY does not accept 7 | wildcard pathnames; `dirname' should simply be a pathname that 8 | names a directory. It can be in either file or directory form." 9 | (when (wild-pathname-p dirname) 10 | (error "Can only list concrete directory names.")) 11 | 12 | (let ((wildcard (directory-wildcard dirname))) 13 | 14 | #+(or sbcl cmu lispworks) 15 | ;; SBCL, CMUCL, and Lispworks return subdirectories in directory 16 | ;; form just the way we want. 17 | (directory wildcard) 18 | 19 | #+openmcl 20 | ;; OpenMCl by default doesn't return subdirectories at all. But 21 | ;; when prodded to do so with the special argument :directories, 22 | ;; it returns them in directory form. 23 | (directory wildcard :directories t) 24 | 25 | #+allegro 26 | ;; Allegro normally return directories in file form but we can 27 | ;; change that with the :directories-are-files argument. 28 | (directory wildcard :directories-are-files nil) 29 | 30 | #+clisp 31 | ;; CLISP has a particularly idiosyncratic view of things. But we 32 | ;; can bludgeon even it into doing what we want. 33 | (nconc 34 | ;; CLISP won't list files without an extension when :type is 35 | ;; wild so we make a special wildcard for it. 36 | (directory wildcard) 37 | ;; And CLISP doesn't consider subdirectories to match unless 38 | ;; there is a :wild in the directory component. 39 | (directory (clisp-subdirectories-wildcard wildcard))) 40 | 41 | #-(or sbcl cmu lispworks openmcl allegro clisp) 42 | (error "list-directory not implemented"))) 43 | 44 | 45 | 46 | 47 | (defun file-exists-p (pathname) 48 | "Similar to CL:PROBE-FILE except it always returns directory names 49 | in `directory normal form'. Returns truename which will be in 50 | `directory form' if file named is, in fact, a directory." 51 | 52 | #+(or sbcl lispworks openmcl) 53 | ;; These implementations do "The Right Thing" as far as we are 54 | ;; concerned. They return a truename of the file or directory if it 55 | ;; exists and the truename of a directory is in directory normal 56 | ;; form. 57 | (probe-file pathname) 58 | 59 | #+(or allegro cmu) 60 | ;; These implementations accept the name of a directory in either 61 | ;; form and return the name in the form given. However the name of a 62 | ;; file must be given in file form. So we try first with a directory 63 | ;; name which will return NIL if either the file doesn't exist at 64 | ;; all or exists and is not a directory. Then we try with a file 65 | ;; form name. 66 | (or (probe-file (pathname-as-directory pathname)) 67 | (probe-file pathname)) 68 | 69 | #+clisp 70 | ;; Once again CLISP takes a particularly unforgiving approach, 71 | ;; signalling ERRORs at the slightest provocation. 72 | 73 | ;; pathname in file form and actually a file -- (probe-file file) ==> truename 74 | ;; pathname in file form and doesn't exist -- (probe-file file) ==> NIL 75 | ;; pathname in dir form and actually a directory -- (probe-directory file) ==> truename 76 | ;; pathname in dir form and doesn't exist -- (probe-directory file) ==> NIL 77 | 78 | ;; pathname in file form and actually a directory -- (probe-file file) ==> ERROR 79 | ;; pathname in dir form and actually a file -- (probe-directory file) ==> ERROR 80 | (or (ignore-errors 81 | ;; PROBE-FILE will return the truename if file exists and is a 82 | ;; file or NIL if it doesn't exist at all. If it exists but is 83 | ;; a directory PROBE-FILE will signal an error which we 84 | ;; ignore. 85 | (probe-file (pathname-as-file pathname))) 86 | (ignore-errors 87 | ;; PROBE-DIRECTORY returns T if the file exists and is a 88 | ;; directory or NIL if it doesn't exist at all. If it exists 89 | ;; but is a file, PROBE-DIRECTORY will signal an error. 90 | (let ((directory-form (pathname-as-directory pathname))) 91 | (when (ext:probe-directory directory-form) 92 | directory-form)))) 93 | 94 | 95 | #-(or sbcl cmu lispworks openmcl allegro clisp) 96 | (error "list-directory not implemented")) 97 | 98 | (defun directory-wildcard (dirname) 99 | (make-pathname 100 | :name :wild 101 | :type #-clisp :wild #+clisp nil 102 | :defaults (pathname-as-directory dirname))) 103 | 104 | #+clisp 105 | (defun clisp-subdirectories-wildcard (wildcard) 106 | (make-pathname 107 | :directory (append (pathname-directory wildcard) (list :wild)) 108 | :name nil 109 | :type nil 110 | :defaults wildcard)) 111 | 112 | 113 | (defun directory-pathname-p (p) 114 | "Is the given pathname the name of a directory? This function can 115 | usefully be used to test whether a name returned by LIST-DIRECTORIES 116 | or passed to the function in WALK-DIRECTORY is the name of a directory 117 | in the file system since they always return names in `directory normal 118 | form'." 119 | (flet ((component-present-p (value) 120 | (and value (not (eql value :unspecific))))) 121 | (and 122 | (not (component-present-p (pathname-name p))) 123 | (not (component-present-p (pathname-type p))) 124 | p))) 125 | 126 | 127 | (defun file-pathname-p (p) 128 | (unless (directory-pathname-p p) p)) 129 | 130 | (defun pathname-as-directory (name) 131 | "Return a pathname reperesenting the given pathname in 132 | `directory normal form', i.e. with all the name elements in the 133 | directory component and NIL in the name and type components. Can 134 | not be used on wild pathnames because there's not portable way to 135 | convert wildcards in the name and type into a single directory 136 | component. Returns its argument if name and type are both nil or 137 | :unspecific." 138 | (let ((pathname (pathname name))) 139 | (when (wild-pathname-p pathname) 140 | (error "Can't reliably convert wild pathnames.")) 141 | (if (not (directory-pathname-p name)) 142 | (make-pathname 143 | :directory (append (or (pathname-directory pathname) (list :relative)) 144 | (list (file-namestring pathname))) 145 | :name nil 146 | :type nil 147 | :defaults pathname) 148 | pathname))) 149 | 150 | (defun pathname-as-file (name) 151 | "Return a pathname reperesenting the given pathname in `file form', 152 | i.e. with the name elements in the name and type component. Can't 153 | convert wild pathnames because of problems mapping wild directory 154 | component into name and type components. Returns its argument if 155 | it is already in file form." 156 | (let ((pathname (pathname name))) 157 | (when (wild-pathname-p pathname) 158 | (error "Can't reliably convert wild pathnames.")) 159 | (if (directory-pathname-p name) 160 | (let* ((directory (pathname-directory pathname)) 161 | (name-and-type (pathname (first (last directory))))) 162 | (make-pathname 163 | :directory (butlast directory) 164 | :name (pathname-name name-and-type) 165 | :type (pathname-type name-and-type) 166 | :defaults pathname)) 167 | pathname))) 168 | 169 | (defun walk-directory (dirname fn &key directories (test (constantly t))) 170 | "Walk a directory invoking `fn' on each pathname found. If `test' is 171 | supplied fn is invoked only on pathnames for which `test' returns 172 | true. If `directories' is t invokes `test' and `fn' on directory 173 | pathnames as well." 174 | (labels 175 | ((walk (name) 176 | (cond 177 | ((directory-pathname-p name) 178 | (when (and directories (funcall test name)) 179 | (funcall fn name)) 180 | (dolist (x (list-directory name)) (walk x))) 181 | ((funcall test name) (funcall fn name))))) 182 | (walk (pathname-as-directory dirname)))) 183 | 184 | (defun directory-p (name) 185 | "Is `name' the name of an existing directory." 186 | (let ((truename (file-exists-p name))) 187 | (and truename (directory-pathname-p name)))) 188 | 189 | (defun file-p (name) 190 | "Is `name' the name of an existing file, i.e. not a directory." 191 | (let ((truename (file-exists-p name))) 192 | (and truename (file-pathname-p name)))) 193 | 194 | 195 | -------------------------------------------------------------------------------- /practicals/Chapter23/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.spam 4 | (:use :common-lisp 5 | :com.gigamonkeys.test 6 | :com.gigamonkeys.pathnames)) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /practicals/Chapter23/spam.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.spam-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.spam-system) 3 | 4 | (defsystem spam 5 | :name "spam" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Spam filter" 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "spam" :depends-on ("packages"))) 15 | :depends-on (:cl-ppcre :pathnames)) 16 | 17 | 18 | -------------------------------------------------------------------------------- /practicals/Chapter23/spam.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.spam) 2 | 3 | (defvar *feature-database* (make-hash-table :test #'equal)) 4 | (defvar *total-spams* 0) 5 | (defvar *total-hams* 0) 6 | 7 | (defparameter *max-ham-score* .4) 8 | (defparameter *min-spam-score* .6) 9 | 10 | (defparameter *max-chars* (* 10 1024)) 11 | (defparameter *corpus* (make-array 1000 :adjustable t :fill-pointer 0)) 12 | 13 | (defun classify (text) 14 | "Classify the text of a message as SPAM, HAM, or UNSURE." 15 | (classification (score (extract-features text)))) 16 | 17 | 18 | (defclass word-feature () 19 | ((word 20 | :initarg :word 21 | :accessor word 22 | :initform (error "Must supply :word") 23 | :documentation "The word this feature represents.") 24 | (spam-count 25 | :initarg :spam-count 26 | :accessor spam-count 27 | :initform 0 28 | :documentation "Number of spams we have seen this feature in.") 29 | (ham-count 30 | :initarg :ham-count 31 | :accessor ham-count 32 | :initform 0 33 | :documentation "Number of hams we have seen this feature in."))) 34 | 35 | (defun intern-feature (word) 36 | (or (gethash word *feature-database*) 37 | (setf (gethash word *feature-database*) 38 | (make-instance 'word-feature :word word)))) 39 | 40 | (defun extract-words (text) 41 | (delete-duplicates 42 | (cl-ppcre:all-matches-as-strings "[a-zA-Z]{3,}" text) 43 | :test #'string=)) 44 | 45 | (defun extract-features (text) 46 | (mapcar #'intern-feature (extract-words text))) 47 | 48 | (defmethod print-object ((object word-feature) stream) 49 | (print-unreadable-object (object stream :type t) 50 | (with-slots (word ham-count spam-count) object 51 | (format stream "~s :hams ~d :spams ~d" word ham-count spam-count)))) 52 | 53 | (defun train (text type) 54 | (dolist (feature (extract-features text)) 55 | (increment-count feature type)) 56 | (increment-total-count type)) 57 | 58 | (defun increment-count (feature type) 59 | (ecase type 60 | (ham (incf (ham-count feature))) 61 | (spam (incf (spam-count feature))))) 62 | 63 | (defun increment-total-count (type) 64 | (ecase type 65 | (ham (incf *total-hams*)) 66 | (spam (incf *total-spams*)))) 67 | 68 | (defun clear-database () 69 | (setf 70 | *feature-database* (make-hash-table :test #'equal) 71 | *total-spams* 0 72 | *total-hams* 0)) 73 | 74 | (defun spam-probability (feature) 75 | "Basic probability that a feature with the given relative 76 | frequencies will appear in a spam assuming spams and hams are 77 | otherwise equally probable. One of the two frequencies must be 78 | non-zero." 79 | (with-slots (spam-count ham-count) feature 80 | (let ((spam-frequency (/ spam-count (max 1 *total-spams*))) 81 | (ham-frequency (/ ham-count (max 1 *total-hams*)))) 82 | (/ spam-frequency (+ spam-frequency ham-frequency))))) 83 | 84 | 85 | (defun bayesian-spam-probability (feature &optional 86 | (assumed-probability 1/2) 87 | (weight 1)) 88 | "Bayesian adjustment of a given probability given the number of 89 | data points that went into it, an assumed probability, and a 90 | weight we give that assumed probability." 91 | (let ((basic-probability (spam-probability feature)) 92 | (data-points (+ (spam-count feature) (ham-count feature)))) 93 | (/ (+ (* weight assumed-probability) 94 | (* data-points basic-probability)) 95 | (+ weight data-points)))) 96 | 97 | (defun score (features) 98 | (let ((spam-probs ()) (ham-probs ()) (number-of-probs 0)) 99 | (dolist (feature features) 100 | (unless (untrained-p feature) 101 | (let ((spam-prob (float (bayesian-spam-probability feature) 0.0d0))) 102 | (push spam-prob spam-probs) 103 | (push (- 1.0d0 spam-prob) ham-probs) 104 | (incf number-of-probs)))) 105 | (let ((h (- 1 (fisher spam-probs number-of-probs))) 106 | (s (- 1 (fisher ham-probs number-of-probs)))) 107 | (/ (+ (- 1 h) s) 2.0d0)))) 108 | 109 | (defun untrained-p (feature) 110 | (with-slots (spam-count ham-count) feature 111 | (and (zerop spam-count) (zerop ham-count)))) 112 | 113 | (defun fisher (probs number-of-probs) 114 | "The Fisher computation described by Robinson." 115 | (inverse-chi-square 116 | (* -2 (reduce #'+ probs :key #'log)) 117 | (* 2 number-of-probs))) 118 | 119 | (defun inverse-chi-square (value degrees-of-freedom) 120 | "Probability that chi-square >= value with given degrees-of-freedom. 121 | Based on Gary Robinson's Python implementation." 122 | (assert (evenp degrees-of-freedom)) 123 | ;; Due to rounding errors in the multiplication and exponentiation 124 | ;; the sum computed in the loop may end up a shade above 1.0 which 125 | ;; we can't have since it's supposed to represent a probability. 126 | (min 127 | (loop with m = (/ value 2) 128 | for i below (/ degrees-of-freedom 2) 129 | for prob = (exp (- m)) then (* prob (/ m i)) 130 | summing prob) 131 | 1.0)) 132 | 133 | (defun classification (score) 134 | (values 135 | (cond 136 | ((<= score *max-ham-score*) 'ham) 137 | ((>= score *min-spam-score*) 'spam) 138 | (t 'unsure)) 139 | score)) 140 | 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | ;;; Test rig 144 | 145 | (defun add-file-to-corpus (filename type corpus) 146 | (vector-push-extend (list filename type) corpus)) 147 | 148 | (defun add-directory-to-corpus (dir type corpus) 149 | (dolist (filename (list-directory dir)) 150 | (add-file-to-corpus filename type corpus))) 151 | 152 | (defun test-classifier (corpus testing-fraction) 153 | (clear-database) 154 | (let* ((shuffled (shuffle-vector corpus)) 155 | (size (length corpus)) 156 | (train-on (floor (* size (- 1 testing-fraction))))) 157 | (train-from-corpus shuffled :start 0 :end train-on) 158 | (test-from-corpus shuffled :start train-on))) 159 | 160 | (defun train-from-corpus (corpus &key (start 0) end) 161 | (loop for idx from start below (or end (length corpus)) do 162 | (destructuring-bind (file type) (aref corpus idx) 163 | (train (start-of-file file *max-chars*) type)))) 164 | 165 | (defun test-from-corpus (corpus &key (start 0) end) 166 | (loop for idx from start below (or end (length corpus)) collect 167 | (destructuring-bind (file type) (aref corpus idx) 168 | (multiple-value-bind (classification score) 169 | (classify (start-of-file file *max-chars*)) 170 | (list 171 | :file file 172 | :type type 173 | :classification classification 174 | :score score))))) 175 | 176 | (defun nshuffle-vector (vector) 177 | "Shuffle a vector in place using Fisher-Yates algorithm." 178 | (loop for idx downfrom (1- (length vector)) to 1 179 | for other = (random (1+ idx)) 180 | do (unless (= idx other) 181 | (rotatef (aref vector idx) (aref vector other)))) 182 | vector) 183 | 184 | (defun shuffle-vector (vector) 185 | "Return a shuffled copy of vector." 186 | (nshuffle-vector (copy-seq vector))) 187 | 188 | (defun start-of-file (file max-chars) 189 | (with-open-file (in file) 190 | (let* ((length (min (file-length in) max-chars)) 191 | (text (make-string length)) 192 | (read (read-sequence text in))) 193 | (if (< read length) 194 | (subseq text 0 read) 195 | text)))) 196 | 197 | 198 | (defun result-type (result) 199 | (destructuring-bind (&key type classification &allow-other-keys) result 200 | (ecase type 201 | (ham 202 | (ecase classification 203 | (ham 'correct) 204 | (spam 'false-positive) 205 | (unsure 'missed-ham))) 206 | (spam 207 | (ecase classification 208 | (ham 'false-negative) 209 | (spam 'correct) 210 | (unsure 'missed-spam)))))) 211 | 212 | (defun false-positive-p (result) 213 | (eql (result-type result) 'false-positive)) 214 | 215 | (defun false-negative-p (result) 216 | (eql (result-type result) 'false-negative)) 217 | 218 | (defun missed-ham-p (result) 219 | (eql (result-type result) 'missed-ham)) 220 | 221 | (defun missed-spam-p (result) 222 | (eql (result-type result) 'missed-spam)) 223 | 224 | (defun correct-p (result) 225 | (eql (result-type result) 'correct)) 226 | 227 | (defun analyze-results (results) 228 | (let* ((keys '(total correct false-positive 229 | false-negative missed-ham missed-spam)) 230 | (counts (loop for x in keys collect (cons x 0)))) 231 | (dolist (item results) 232 | (incf (cdr (assoc 'total counts))) 233 | (incf (cdr (assoc (result-type item) counts)))) 234 | (loop with total = (cdr (assoc 'total counts)) 235 | for (label . count) in counts 236 | do (format t "~&~@(~a~):~20t~5d~,5t: ~6,2f%~%" 237 | label count (* 100 (/ count total)))))) 238 | 239 | (defun explain-classification (file) 240 | (let* ((text (start-of-file file *max-chars*)) 241 | (features (extract-features text)) 242 | (score (score features)) 243 | (classification (classification score))) 244 | (show-summary file text classification score) 245 | (dolist (feature (sorted-interesting features)) 246 | (show-feature feature)))) 247 | 248 | (defun show-summary (file text classification score) 249 | (format t "~&~a" file) 250 | (format t "~2%~a~2%" text) 251 | (format t "Classified as ~a with score of ~,5f~%" classification score)) 252 | 253 | (defun show-feature (feature) 254 | (with-slots (word ham-count spam-count) feature 255 | (format 256 | t "~&~2t~a~30thams: ~5d; spams: ~5d;~,10tprob: ~,f~%" 257 | word ham-count spam-count (bayesian-spam-probability feature)))) 258 | 259 | (defun sorted-interesting (features) 260 | (sort (remove-if #'untrained-p features) #'< :key #'bayesian-spam-probability)) 261 | -------------------------------------------------------------------------------- /practicals/Chapter24/binary-data.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.binary-data-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.binary-data-system) 3 | 4 | (defsystem binary-data 5 | :name "binary-data" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "Parser for binary data files. " 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "binary-data" :depends-on ("packages"))) 15 | :depends-on (:macro-utilities)) 16 | 17 | 18 | -------------------------------------------------------------------------------- /practicals/Chapter24/binary-data.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.binary-data) 2 | 3 | (defvar *in-progress-objects* nil) 4 | 5 | (defconstant +null+ (code-char 0)) 6 | 7 | (defgeneric read-value (type stream &key) 8 | (:documentation "Read a value of the given type from the stream.")) 9 | 10 | (defgeneric write-value (type stream value &key) 11 | (:documentation "Write a value as the given type to the stream.")) 12 | 13 | (defgeneric read-object (object stream) 14 | (:method-combination progn :most-specific-last) 15 | (:documentation "Fill in the slots of object from stream.")) 16 | 17 | (defgeneric write-object (object stream) 18 | (:method-combination progn :most-specific-last) 19 | (:documentation "Write out the slots of object to the stream.")) 20 | 21 | (defmethod read-value ((type symbol) stream &key) 22 | (let ((object (make-instance type))) 23 | (read-object object stream) 24 | object)) 25 | 26 | (defmethod write-value ((type symbol) stream value &key) 27 | (assert (typep value type)) 28 | (write-object value stream)) 29 | 30 | 31 | ;;; Binary types 32 | 33 | (defmacro define-binary-type (name (&rest args) &body spec) 34 | (with-gensyms (type stream value) 35 | `(progn 36 | (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) 37 | (declare (ignorable ,@args)) 38 | ,(type-reader-body spec stream)) 39 | (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) 40 | (declare (ignorable ,@args)) 41 | ,(type-writer-body spec stream value))))) 42 | 43 | (defun type-reader-body (spec stream) 44 | (ecase (length spec) 45 | (1 (destructuring-bind (type &rest args) (mklist (first spec)) 46 | `(read-value ',type ,stream ,@args))) 47 | (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) 48 | `(let ((,in ,stream)) ,@body))))) 49 | 50 | (defun type-writer-body (spec stream value) 51 | (ecase (length spec) 52 | (1 (destructuring-bind (type &rest args) (mklist (first spec)) 53 | `(write-value ',type ,stream ,value ,@args))) 54 | (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) 55 | `(let ((,out ,stream) (,v ,value)) ,@body))))) 56 | 57 | 58 | ;;; Binary classes 59 | 60 | (defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) 61 | (with-gensyms (objectvar streamvar) 62 | `(progn 63 | (eval-when (:compile-toplevel :load-toplevel :execute) 64 | (setf (get ',name 'slots) ',(mapcar #'first slots)) 65 | (setf (get ',name 'superclasses) ',superclasses)) 66 | 67 | (defclass ,name ,superclasses 68 | ,(mapcar #'slot->defclass-slot slots)) 69 | 70 | ,read-method 71 | 72 | (defmethod write-object progn ((,objectvar ,name) ,streamvar) 73 | (declare (ignorable ,streamvar)) 74 | (with-slots ,(new-class-all-slots slots superclasses) ,objectvar 75 | ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) 76 | 77 | (defmacro define-binary-class (name (&rest superclasses) slots) 78 | (with-gensyms (objectvar streamvar) 79 | `(define-generic-binary-class ,name ,superclasses ,slots 80 | (defmethod read-object progn ((,objectvar ,name) ,streamvar) 81 | (declare (ignorable ,streamvar)) 82 | (with-slots ,(new-class-all-slots slots superclasses) ,objectvar 83 | ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) 84 | 85 | (defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) 86 | (with-gensyms (typevar objectvar streamvar) 87 | `(define-generic-binary-class ,name ,superclasses ,slots 88 | (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) 89 | (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) 90 | (let ((,objectvar 91 | (make-instance 92 | ,@(or (cdr (assoc :dispatch options)) 93 | (error "Must supply :disptach form.")) 94 | ,@(mapcan #'slot->keyword-arg slots)))) 95 | (read-object ,objectvar ,streamvar) 96 | ,objectvar)))))) 97 | 98 | (defun as-keyword (sym) (intern (string sym) :keyword)) 99 | 100 | (defun normalize-slot-spec (spec) 101 | (list (first spec) (mklist (second spec)))) 102 | 103 | (defun mklist (x) (if (listp x) x (list x))) 104 | 105 | (defun slot->defclass-slot (spec) 106 | (let ((name (first spec))) 107 | `(,name :initarg ,(as-keyword name) :accessor ,name))) 108 | 109 | (defun slot->read-value (spec stream) 110 | (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) 111 | `(setf ,name (read-value ',type ,stream ,@args)))) 112 | 113 | (defun slot->write-value (spec stream) 114 | (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) 115 | `(write-value ',type ,stream ,name ,@args))) 116 | 117 | (defun slot->binding (spec stream) 118 | (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) 119 | `(,name (read-value ',type ,stream ,@args)))) 120 | 121 | (defun slot->keyword-arg (spec) 122 | (let ((name (first spec))) 123 | `(,(as-keyword name) ,name))) 124 | 125 | ;;; Keeping track of inherited slots 126 | 127 | (defun direct-slots (name) 128 | (copy-list (get name 'slots))) 129 | 130 | (defun inherited-slots (name) 131 | (loop for super in (get name 'superclasses) 132 | nconc (direct-slots super) 133 | nconc (inherited-slots super))) 134 | 135 | (defun all-slots (name) 136 | (nconc (direct-slots name) (inherited-slots name))) 137 | 138 | (defun new-class-all-slots (slots superclasses) 139 | "Like all slots but works while compiling a new class before slots 140 | and superclasses have been saved." 141 | (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) 142 | 143 | ;;; In progress Object stack 144 | 145 | (defun current-binary-object () 146 | (first *in-progress-objects*)) 147 | 148 | (defun parent-of-type (type) 149 | (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) 150 | 151 | (defmethod read-object :around (object stream) 152 | (declare (ignore stream)) 153 | (let ((*in-progress-objects* (cons object *in-progress-objects*))) 154 | (call-next-method))) 155 | 156 | (defmethod write-object :around (object stream) 157 | (declare (ignore stream)) 158 | (let ((*in-progress-objects* (cons object *in-progress-objects*))) 159 | (call-next-method))) 160 | 161 | -------------------------------------------------------------------------------- /practicals/Chapter24/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.binary-data 4 | (:use :common-lisp :com.gigamonkeys.macro-utilities) 5 | (:export :define-binary-class 6 | :define-tagged-binary-class 7 | :define-binary-type 8 | :read-value 9 | :write-value 10 | :*in-progress-objects* 11 | :parent-of-type 12 | :current-binary-object 13 | :+null+)) 14 | -------------------------------------------------------------------------------- /practicals/Chapter25/id3v2.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.id3v2-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.id3v2-system) 3 | 4 | (defsystem id3v2 5 | :name "id3" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "ID3v2 parser. " 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "id3v2" :depends-on ("packages"))) 15 | :depends-on (:binary-data :pathnames)) 16 | -------------------------------------------------------------------------------- /practicals/Chapter25/id3v2.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:com.gigamonkeys.id3v2) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; A few basic types 5 | 6 | (define-binary-type unsigned-integer (bytes bits-per-byte) 7 | (:reader (in) 8 | (loop with value = 0 9 | for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do 10 | (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) 11 | finally (return value))) 12 | (:writer (out value) 13 | (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte 14 | do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) 15 | 16 | (define-binary-type u1 () (unsigned-integer :bytes 1 :bits-per-byte 8)) 17 | (define-binary-type u2 () (unsigned-integer :bytes 2 :bits-per-byte 8)) 18 | (define-binary-type u3 () (unsigned-integer :bytes 3 :bits-per-byte 8)) 19 | (define-binary-type u4 () (unsigned-integer :bytes 4 :bits-per-byte 8)) 20 | (define-binary-type id3-tag-size () (unsigned-integer :bytes 4 :bits-per-byte 7)) 21 | 22 | ;;; Strings 23 | 24 | (define-binary-type generic-string (length character-type) 25 | (:reader (in) 26 | (let ((string (make-string length))) 27 | (dotimes (i length) 28 | (setf (char string i) (read-value character-type in))) 29 | string)) 30 | (:writer (out string) 31 | (dotimes (i length) 32 | (write-value character-type out (char string i))))) 33 | 34 | (define-binary-type generic-terminated-string (terminator character-type) 35 | (:reader (in) 36 | (with-output-to-string (s) 37 | (loop for char = (read-value character-type in) 38 | until (char= char terminator) do (write-char char s)))) 39 | (:writer (out string) 40 | (loop for char across string 41 | do (write-value character-type out char) 42 | finally (write-value character-type out terminator)))) 43 | 44 | ;;; ISO-8859-1 strings 45 | 46 | (define-binary-type iso-8859-1-char () 47 | (:reader (in) 48 | (let ((code (read-byte in))) 49 | (or (code-char code) 50 | (error "Character code ~d not supported" code)))) 51 | (:writer (out char) 52 | (let ((code (char-code char))) 53 | (if (<= 0 code #xff) 54 | (write-byte code out) 55 | (error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code))))) 56 | 57 | (define-binary-type iso-8859-1-string (length) 58 | (generic-string :length length :character-type 'iso-8859-1-char)) 59 | 60 | (define-binary-type iso-8859-1-terminated-string (terminator) 61 | (generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char)) 62 | 63 | ;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.) 64 | 65 | ;;; Define a binary type for reading a UCS-2 character relative to a 66 | ;;; particular byte ordering as indicated by the BOM value. 67 | ;; v2.3 specifies that the BOM should be present. v2.2 is silent 68 | ;; though it is arguably inherent in the definition of UCS-2) Length 69 | ;; is in bytes. On the write side, since we don't have any way of 70 | ;; knowing what BOM was used to read the string we just pick one. 71 | ;; This does mean roundtrip transparency could be broken. 72 | 73 | (define-binary-type ucs-2-char (swap) 74 | (:reader (in) 75 | (let ((code (read-value 'u2 in))) 76 | (when swap (setf code (swap-bytes code))) 77 | (or (code-char code) (error "Character code ~d not supported" code)))) 78 | (:writer (out char) 79 | (let ((code (char-code char))) 80 | (unless (<= 0 code #xffff) 81 | (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code)) 82 | (when swap (setf code (swap-bytes code))) 83 | (write-value 'u2 out code)))) 84 | 85 | (defun swap-bytes (code) 86 | (assert (<= code #xffff)) 87 | (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code)) 88 | code) 89 | 90 | 91 | (define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil)) 92 | 93 | (define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t)) 94 | 95 | (defun ucs-2-char-type (byte-order-mark) 96 | (ecase byte-order-mark 97 | (#xfeff 'ucs-2-char-big-endian) 98 | (#xfffe 'ucs-2-char-little-endian))) 99 | 100 | (define-binary-type ucs-2-string (length) 101 | (:reader (in) 102 | (let ((byte-order-mark (read-value 'u2 in)) 103 | (characters (1- (/ length 2)))) 104 | (read-value 105 | 'generic-string in 106 | :length characters 107 | :character-type (ucs-2-char-type byte-order-mark)))) 108 | (:writer (out string) 109 | (write-value 'u2 out #xfeff) 110 | (write-value 111 | 'generic-string out string 112 | :length (length string) 113 | :character-type (ucs-2-char-type #xfeff)))) 114 | 115 | (define-binary-type ucs-2-terminated-string (terminator) 116 | (:reader (in) 117 | (let ((byte-order-mark (read-value 'u2 in))) 118 | (read-value 119 | 'generic-terminated-string in 120 | :terminator terminator 121 | :character-type (ucs-2-char-type byte-order-mark)))) 122 | (:writer (out string) 123 | (write-value 'u2 out #xfeff) 124 | (write-value 125 | 'generic-terminated-string out string 126 | :terminator terminator 127 | :character-type (ucs-2-char-type #xfeff)))) 128 | 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | ;;; ID3 tag class 132 | 133 | ;;; Handle ID3v2.2 and ID3v2.3 (but not ID3v2.4 since it mostly just 134 | ;;; requires a bunch more string encoding foo.) (Well, we can mostly 135 | ;;; read v2.4 tags as v2.3 tags.) 136 | 137 | (define-tagged-binary-class id3-tag () 138 | ((identifier (iso-8859-1-string :length 3)) 139 | (major-version u1) 140 | (revision u1) 141 | (flags u1) 142 | (size id3-tag-size)) 143 | (:dispatch 144 | (ecase major-version 145 | (2 'id3v2.2-tag) 146 | (3 'id3v2.3-tag)))) 147 | 148 | (define-binary-class id3v2.2-tag (id3-tag) 149 | ((frames (id3-frames :tag-size size :frame-type 'id3v2.2-frame)))) 150 | 151 | (define-binary-class id3v2.3-tag (id3-tag) 152 | ((extended-header-size (optional :type 'u4 :if (extended-p flags))) 153 | (extra-flags (optional :type 'u2 :if (extended-p flags))) 154 | (padding-size (optional :type 'u4 :if (extended-p flags))) 155 | (crc (optional :type 'u4 :if (crc-p flags extra-flags))) 156 | (frames (id3-frames :tag-size size :frame-type 'id3v2.3-frame)))) 157 | 158 | 159 | (defun extended-p (flags) (logbitp 6 flags)) 160 | 161 | (defun crc-p (flags extra-flags) 162 | (and (extended-p flags) (logbitp 15 extra-flags))) 163 | 164 | (define-binary-type optional (type if) 165 | (:reader (in) 166 | (when if (read-value type in))) 167 | (:writer (out value) 168 | (when if (write-value type out value)))) 169 | 170 | 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | ;;; ID3 frames 173 | 174 | (define-tagged-binary-class id3v2.2-frame () 175 | ((id (frame-id :length 3)) 176 | (size u3)) 177 | (:dispatch (find-frame-class id))) 178 | 179 | (define-tagged-binary-class id3v2.3-frame () 180 | ((id (frame-id :length 4)) 181 | (size u4) 182 | (flags u2) 183 | (decompressed-size (optional :type 'u4 :if (frame-compressed-p flags))) 184 | (encryption-scheme (optional :type 'u1 :if (frame-encrypted-p flags))) 185 | (grouping-identity (optional :type 'u1 :if (frame-grouped-p flags)))) 186 | (:dispatch (find-frame-class id))) 187 | 188 | (defun frame-compressed-p (flags) (logbitp 7 flags)) 189 | 190 | (defun frame-encrypted-p (flags) (logbitp 6 flags)) 191 | 192 | (defun frame-grouped-p (flags) (logbitp 5 flags)) 193 | 194 | ;;; find-frame 195 | 196 | (defun find-frame-class (name) 197 | (cond 198 | ((and (char= (char name 0) #\T) 199 | (not (member name '("TXX" "TXXX") :test #'string=))) 200 | (ecase (length name) 201 | (3 'text-info-frame-v2.2) 202 | (4 'text-info-frame-v2.3))) 203 | ((string= name "COM") 'comment-frame-v2.2) 204 | ((string= name "COMM") 'comment-frame-v2.3) 205 | (t 206 | (ecase (length name) 207 | (3 'generic-frame-v2.2) 208 | (4 'generic-frame-v2.3))))) 209 | 210 | ;;; id3-frames 211 | 212 | (define-binary-type id3-frames (tag-size frame-type) 213 | (:reader (in) 214 | (loop with to-read = tag-size 215 | while (plusp to-read) 216 | for frame = (read-frame frame-type in) 217 | while frame 218 | do (decf to-read (+ (frame-header-size frame) (size frame))) 219 | collect frame 220 | finally (loop repeat (1- to-read) do (read-byte in)))) 221 | (:writer (out frames) 222 | (loop with to-write = tag-size 223 | for frame in frames 224 | do (write-value frame-type out frame) 225 | (decf to-write (+ (frame-header-size frame) (size frame))) 226 | finally (loop repeat to-write do (write-byte 0 out))))) 227 | 228 | (defgeneric frame-header-size (frame)) 229 | 230 | (defmethod frame-header-size ((frame id3v2.2-frame)) 6) 231 | 232 | (defmethod frame-header-size ((frame id3v2.3-frame)) 10) 233 | 234 | (defun read-frame (frame-type in) 235 | (handler-case (read-value frame-type in) 236 | (in-padding () nil))) 237 | 238 | (define-condition in-padding () ()) 239 | 240 | (define-binary-type frame-id (length) 241 | (:reader (in) 242 | (let ((first-byte (read-byte in))) 243 | (when (= first-byte 0) (signal 'in-padding)) 244 | (let ((rest (read-value 'iso-8859-1-string in :length (1- length)))) 245 | (concatenate 246 | 'string (string (code-char first-byte)) rest)))) 247 | (:writer (out id) 248 | (write-value 'iso-8859-1-string out id :length length))) 249 | 250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 251 | ;;; Generic frames 252 | 253 | (define-binary-class generic-frame () 254 | ((data (raw-bytes :size (data-bytes (current-binary-object)))))) 255 | 256 | (defgeneric data-bytes (frame)) 257 | 258 | (defmethod data-bytes ((frame id3v2.2-frame)) 259 | (size frame)) 260 | 261 | (defmethod data-bytes ((frame id3v2.3-frame)) 262 | (let ((flags (flags frame))) 263 | (- (size frame) 264 | (if (frame-compressed-p flags) 4 0) 265 | (if (frame-encrypted-p flags) 1 0) 266 | (if (frame-grouped-p flags) 1 0)))) 267 | 268 | 269 | (define-binary-class generic-frame-v2.2 (id3v2.2-frame generic-frame) ()) 270 | 271 | (define-binary-class generic-frame-v2.3 (id3v2.3-frame generic-frame) ()) 272 | 273 | (define-binary-type raw-bytes (size) 274 | (:reader (in) 275 | (let ((buf (make-array size :element-type '(unsigned-byte 8)))) 276 | (read-sequence buf in) 277 | buf)) 278 | (:writer (out buf) 279 | (write-sequence buf out))) 280 | 281 | 282 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 283 | ;;; Text info and comment frames 284 | 285 | (define-binary-class text-info-frame () 286 | ((encoding u1) 287 | (information (id3-encoded-string :encoding encoding :length (bytes-left 1))))) 288 | 289 | (define-binary-class comment-frame () 290 | ((encoding u1) 291 | (language (iso-8859-1-string :length 3)) 292 | (description (id3-encoded-string :encoding encoding :terminator +null+)) 293 | (text (id3-encoded-string 294 | :encoding encoding 295 | :length (bytes-left 296 | (+ 1 ;; encoding 297 | 3 ;; language 298 | (encoded-string-length description encoding t))))))) 299 | 300 | (defun bytes-left (bytes-read) 301 | (- (size (current-binary-object)) bytes-read)) 302 | 303 | (defun encoded-string-length (string encoding terminated) 304 | (let ((characters (+ (length string) (if terminated 1 0)))) 305 | (* characters (ecase encoding (0 1) (1 2))))) 306 | 307 | (defmethod (setf information) :after (value (frame text-info-frame)) 308 | (declare (ignore value)) 309 | (with-slots (encoding size information) frame 310 | (setf size (encoded-string-length information encoding nil)))) 311 | 312 | (define-binary-class text-info-frame-v2.2 (id3v2.2-frame text-info-frame) ()) 313 | 314 | (define-binary-class text-info-frame-v2.3 (id3v2.3-frame text-info-frame) ()) 315 | 316 | (define-binary-class comment-frame-v2.2 (id3v2.2-frame comment-frame) ()) 317 | 318 | (define-binary-class comment-frame-v2.3 (id3v2.3-frame comment-frame) ()) 319 | 320 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 321 | ;;; ID3 encoded string 322 | 323 | (define-binary-type id3-encoded-string (encoding length terminator) 324 | (:reader (in) 325 | (multiple-value-bind (type keyword arg) 326 | (string-args encoding length terminator) 327 | (read-value type in keyword arg))) 328 | (:writer (out string) 329 | (multiple-value-bind (type keyword arg) 330 | (string-args encoding length terminator) 331 | (write-value type out string keyword arg)))) 332 | 333 | (defun string-args (encoding length terminator) 334 | (cond 335 | (length 336 | (values (non-terminated-type encoding) :length length)) 337 | (terminator 338 | (values (terminated-type encoding) :terminator terminator)))) 339 | 340 | (defun non-terminated-type (encoding) 341 | (ecase encoding 342 | (0 'iso-8859-1-string) 343 | (1 'ucs-2-string))) 344 | 345 | (defun terminated-type (encoding) 346 | (ecase encoding 347 | (0 'iso-8859-1-terminated-string) 348 | (1 'ucs-2-terminated-string))) 349 | 350 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 351 | ;;; Application code 352 | 353 | (defun mp3-p (file) 354 | (and 355 | (not (directory-pathname-p file)) 356 | (string-equal "mp3" (pathname-type file)))) 357 | 358 | (defun id3-p (file) 359 | (with-open-file (in file) 360 | (string= "ID3" (read-value 'iso-8859-1-string in :length 3)))) 361 | 362 | (defun read-id3 (file) 363 | (with-open-file (in file :element-type '(unsigned-byte 8)) 364 | (read-value 'id3-tag in))) 365 | 366 | (defun show-tag-header (file) 367 | (with-slots (identifier major-version revision flags size) (read-id3 file) 368 | (format t "~a ~d.~d ~8,'0b ~d bytes -- ~a~%" 369 | identifier major-version revision flags size (enough-namestring file)))) 370 | 371 | (defun show-tag-headers (dir) 372 | (walk-directory dir #'show-tag-header :test #'mp3-p)) 373 | 374 | (defun count-versions (dir) 375 | (let ((versions (mapcar #'(lambda (x) (cons x 0)) '(2 3 4)))) 376 | (flet ((count-version (file) 377 | (incf (cdr (assoc (major-version (read-id3 file)) versions))))) 378 | (walk-directory dir #'count-version :test #'mp3-p)) 379 | versions)) 380 | 381 | (defun frame-types (file) 382 | (delete-duplicates (mapcar #'id (frames (read-id3 file))) :test #'string=)) 383 | 384 | (defun frame-types-in-dir (dir) 385 | (let ((ids ())) 386 | (flet ((collect (file) 387 | (setf ids (nunion ids (frame-types file) :test #'string=)))) 388 | (walk-directory dir #'collect :test #'mp3-p)) 389 | ids)) 390 | 391 | (defun frame-name-member (id) 392 | (cond 393 | ((member id '("COM" "COMM") :test #'string=) "Comment") 394 | ((member id '("TAL" "TALB") :test #'string=) "Album") 395 | ((member id '("TCM" "TCOM") :test #'string=) "Composer") 396 | ((member id '("TCO" "TCON") :test #'string=) "Genre") 397 | ((member id '("TEN" "TENC") :test #'string=) "Encoding program") 398 | ((member id '("TP1" "TPE1") :test #'string=) "Artist") 399 | ((member id '("TPA" "TPOS") :test #'string=) "Part of set") 400 | ((member id '("TRK" "TRCK") :test #'string=) "Track") 401 | ((member id '("TT2" "TIT2") :test #'string=) "Song") 402 | ((member id '("TYE" "TYER") :test #'string=) "Year") 403 | (t id))) 404 | 405 | ;; As a hack in the ID3 format the string in a text info frame can 406 | ;; have an embedded null. Programs are not supposed to display any 407 | ;; information beyond the null. SUBSEQ and POSITION work together 408 | ;; nicely in this case since a NIL third argument to SUBSEQ is 409 | ;; equivalent to the length of the string. 410 | 411 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 412 | ;;; Extracting information from ID3 tag 413 | 414 | (defun find-frame (id3 ids) 415 | (find-if #'(lambda (x) (find (id x) ids :test #'string=)) (frames id3))) 416 | 417 | (defun get-text-info (id3 &rest ids) 418 | (let ((frame (find-frame id3 ids))) 419 | (when frame (upto-null (information frame))))) 420 | 421 | (defun upto-null (string) 422 | (subseq string 0 (position +null+ string))) 423 | 424 | (defmethod information ((frame generic-frame-v2.3)) 425 | (with-output-to-string (s) 426 | (loop for byte across (data frame) do 427 | (format s "~2,'0x" byte)))) 428 | 429 | (defun album (id3) (get-text-info id3 "TAL" "TALB")) 430 | 431 | (defun composer (id3) (get-text-info id3 "TCM" "TCOM")) 432 | 433 | (defun genre (id3) (get-text-info id3 "TCO" "TCON")) 434 | 435 | (defun encoding-program (id3) (get-text-info id3 "TEN" "TENC")) 436 | 437 | (defun artist (id3) (get-text-info id3 "TP1" "TPE1")) 438 | 439 | (defun part-of-set (id3) (get-text-info id3 "TPA" "TPOS")) 440 | 441 | (defun track (id3) (get-text-info id3 "TRK" "TRCK")) 442 | 443 | (defun song (id3) (get-text-info id3 "TT2" "TIT2")) 444 | 445 | (defun year (id3) (get-text-info id3 "TYE" "TYER" "TDRC")) 446 | 447 | ;;; The first version of the ID3 format used a single byte to encode 448 | ;;; the genre. There were originally 80 official v1 genres. The makers 449 | ;;; of Winamp extended the list. 450 | 451 | (defun translated-genre (id3) 452 | (let ((genre (genre id3))) 453 | (if (and genre (char= #\( (char genre 0))) 454 | (translate-v1-genre genre) 455 | genre))) 456 | 457 | (defparameter *id3-v1-genres* 458 | #( 459 | ;; These are the official ID3v1 genres. 460 | "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk" "Grunge" 461 | "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other" "Pop" "R&B" "Rap" 462 | "Reggae" "Rock" "Techno" "Industrial" "Alternative" "Ska" 463 | "Death Metal" "Pranks" "Soundtrack" "Euro-Techno" "Ambient" 464 | "Trip-Hop" "Vocal" "Jazz+Funk" "Fusion" "Trance" "Classical" 465 | "Instrumental" "Acid" "House" "Game" "Sound Clip" "Gospel" "Noise" 466 | "AlternRock" "Bass" "Soul" "Punk" "Space" "Meditative" 467 | "Instrumental Pop" "Instrumental Rock" "Ethnic" "Gothic" "Darkwave" 468 | "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance" "Dream" 469 | "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40" "Christian Rap" 470 | "Pop/Funk" "Jungle" "Native American" "Cabaret" "New Wave" 471 | "Psychadelic" "Rave" "Showtunes" "Trailer" "Lo-Fi" "Tribal" 472 | "Acid Punk" "Acid Jazz" "Polka" "Retro" "Musical" "Rock & Roll" 473 | "Hard Rock" 474 | 475 | ;; These were made up by the authors of Winamp but backported into 476 | ;; the ID3 spec. 477 | "Folk" "Folk-Rock" "National Folk" "Swing" "Fast Fusion" 478 | "Bebob" "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde" 479 | "Gothic Rock" "Progressive Rock" "Psychedelic Rock" "Symphonic Rock" 480 | "Slow Rock" "Big Band" "Chorus" "Easy Listening" "Acoustic" "Humour" 481 | "Speech" "Chanson" "Opera" "Chamber Music" "Sonata" "Symphony" 482 | "Booty Bass" "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" 483 | "Tango" "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul" 484 | "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella" "Euro-House" 485 | "Dance Hall" 486 | 487 | ;; These were also invented by the Winamp folks but ignored by the 488 | ;; ID3 authors. 489 | "Goa" "Drum & Bass" "Club-House" "Hardcore" "Terror" "Indie" 490 | "BritPop" "Negerpunk" "Polsk Punk" "Beat" "Christian Gangsta Rap" 491 | "Heavy Metal" "Black Metal" "Crossover" "Contemporary Christian" 492 | "Christian Rock" "Merengue" "Salsa" "Thrash Metal" "Anime" "Jpop" 493 | "Synthpop")) 494 | 495 | 496 | (defun translate-v1-genre (genre) 497 | (aref *id3-v1-genres* (parse-integer genre :start 1 :junk-allowed t))) 498 | 499 | 500 | 501 | ;;; Local Variables: 502 | ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(define-binary-type\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) 503 | ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(define-binary-class\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) 504 | ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(define-tagged-binary-class\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) 505 | ;;; eval: (put 'define-binary-type 'common-lisp-indent-function '(6 4 &rest (&whole 2 4 2))) 506 | ;;; eval: (put 'define-binary-class 'common-lisp-indent-function (get 'defclass 'common-lisp-indent-function)) 507 | ;;; eval: (put 'define-tagged-binary-class 'common-lisp-indent-function (get 'defclass 'common-lisp-indent-function)) 508 | ;;; eval: (put 'walk-mp3s 'common-lisp-indent-function (get 'with-output-to-string 'common-lisp-indent-function)) 509 | ;;; End: 510 | 511 | 512 | -------------------------------------------------------------------------------- /practicals/Chapter25/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.id3v2 4 | (:use :common-lisp 5 | :com.gigamonkeys.binary-data 6 | :com.gigamonkeys.pathnames) 7 | (:export 8 | :read-id3 9 | :mp3-p 10 | :id3-p 11 | :album 12 | :composer 13 | :genre 14 | :encoding-program 15 | :artist 16 | :part-of-set 17 | :track 18 | :song 19 | :year 20 | :size 21 | :translated-genre)) 22 | -------------------------------------------------------------------------------- /practicals/Chapter26/allegroserve.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file contains the demonstration code used in Chapter 26. This 2 | ;;; file is not loaded as part of the url-function system. 3 | 4 | (require :aserve) 5 | 6 | (defpackage :com.gigamonkeys.web 7 | (:use :cl :net.aserve :com.gigamonkeys.html :com.gigamonkeys.url-function)) 8 | 9 | (in-package :com.gigamonkeys.web) 10 | 11 | (start :port 2001) 12 | 13 | (publish :path "/random-number" :function 'random-number) 14 | 15 | (defun random-number (request entity) 16 | (with-http-response (request entity :content-type "text/html") 17 | (with-http-body (request entity) 18 | (format 19 | (request-reply-stream request) 20 | "~@ 21 | Random~@ 22 | ~@ 23 |

Random number: ~d

~@ 24 | ~@ 25 | ~@ 26 | " 27 | (random 1000))))) 28 | 29 | (defun random-number (request entity) 30 | (with-http-response (request entity :content-type "text/html") 31 | (with-http-body (request entity) 32 | (with-html-output ((request-reply-stream request)) 33 | (html 34 | (:html 35 | (:head (:title "Random")) 36 | (:body 37 | (:p "Random number: " (:print (random 1000)))))))))) 38 | 39 | (publish :path "/show-query-params" :function 'show-query-params) 40 | 41 | (defun show-query-params (request entity) 42 | (with-http-response (request entity :content-type "text/html") 43 | (with-http-body (request entity) 44 | (with-html-output ((request-reply-stream request)) 45 | (html 46 | (:standard-page 47 | (:title "Query Parameters") 48 | (if (request-query request) 49 | (html 50 | (:table :border 1 51 | (loop for (k . v) in (request-query request) 52 | do (html (:tr (:td k) (:td v)))))) 53 | (html (:p "No query parameters."))))))))) 54 | 55 | (publish :path "/simple-form" :function 'simple-form) 56 | 57 | (defun simple-form (request entity) 58 | (with-http-response (request entity :content-type "text/html") 59 | (with-http-body (request entity) 60 | (with-html-output ((request-reply-stream request)) 61 | (html 62 | (:html 63 | (:head (:title "Simple Form")) 64 | (:body 65 | (:form :method "POST" :action "/show-query-params" 66 | (:table 67 | (:tr (:td "Foo") 68 | (:td (:input :name "foo" :size 20))) 69 | (:tr (:td "Password") 70 | (:td (:input :name "password" :type "password" :size 20)))) 71 | (:p (:input :name "submit" :type "submit" :value "Okay") 72 | (:input ::type "reset" :value "Reset")))))))))) 73 | 74 | (defun random-number (request entity) 75 | (with-http-response (request entity :content-type "text/html") 76 | (with-http-body (request entity) 77 | (with-html-output ((request-reply-stream request)) 78 | (let* ((limit-string (or (request-query-value "limit" request) "")) 79 | (limit (or (parse-integer limit-string :junk-allowed t) 1000))) 80 | (html 81 | (:html 82 | (:head (:title "Random")) 83 | (:body 84 | (:p "Random number: " (:print (random limit))))))))))) 85 | 86 | (defun show-cookies (request entity) 87 | (with-http-response (request entity :content-type "text/html") 88 | (with-http-body (request entity) 89 | (with-html-output ((request-reply-stream request)) 90 | (html 91 | (:standard-page 92 | (:title "Cookies") 93 | (if (null (get-cookie-values request)) 94 | (html (:p "No cookies.")) 95 | (html 96 | (:table 97 | (loop for (key . value) in (get-cookie-values request) 98 | do (html (:tr (:td key) (:td value))))))))))))) 99 | 100 | (publish :path "/show-cookies" :function 'show-cookies) 101 | 102 | 103 | 104 | (defun set-cookie (request entity) 105 | (with-http-response (request entity :content-type "text/html") 106 | (set-cookie-header request :name "MyCookie" :value "A cookie value") 107 | (with-http-body (request entity) 108 | (with-html-output ((request-reply-stream request)) 109 | (html 110 | (:standard-page 111 | (:title "Set Cookie") 112 | (:p "Cookie set.") 113 | (:p (:a :href "/show-cookies" "Look at cookie jar.")))))))) 114 | 115 | (publish :path "/set-cookie" :function 'set-cookie) 116 | 117 | (defmethod string->type ((type (eql 'integer)) value) 118 | (parse-integer (or value "") :junk-allowed t)) 119 | 120 | (define-url-function random-number (request (limit integer 1000)) 121 | (:html 122 | (:head (:title "Random")) 123 | (:body 124 | (:p "Random number: " (:print (random limit)))))) 125 | -------------------------------------------------------------------------------- /practicals/Chapter26/html-infrastructure.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.url-function) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; API 5 | 6 | (defmacro define-url-function (name (request &rest params) &body body) 7 | (with-gensyms (entity) 8 | (let ((params (mapcar #'normalize-param params))) 9 | `(progn 10 | (defun ,name (,request ,entity) 11 | (with-http-response (,request ,entity :content-type "text/html") 12 | (let* (,@(param-bindings name request params)) 13 | ,@(set-cookies-code name request params) 14 | (with-http-body (,request ,entity) 15 | (with-html-output ((request-reply-stream ,request)) 16 | (html ,@body)))))) 17 | (publish :path ,(format nil "/~(~a~)" name) :function ',name))))) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;;; Compiler code 21 | 22 | (defun normalize-param (param) 23 | (etypecase param 24 | (list param) 25 | (symbol `(,param string nil nil)))) 26 | 27 | (defun param-bindings (function-name request params) 28 | (loop for param in params 29 | collect (param-binding function-name request param))) 30 | 31 | (defun param-binding (function-name request param) 32 | (destructuring-bind (name type &optional default sticky) param 33 | (let ((query-name (symbol->query-name name)) 34 | (cookie-name (symbol->cookie-name function-name name sticky))) 35 | `(,name (or 36 | (string->type ',type (request-query-value ,query-name ,request)) 37 | ,@(if cookie-name 38 | (list `(string->type ',type (get-cookie-value ,request ,cookie-name)))) 39 | ,default))))) 40 | 41 | (defun symbol->query-name (sym) 42 | (string-downcase sym)) 43 | 44 | (defun symbol->cookie-name (function-name sym sticky) 45 | (let ((package-name (package-name (symbol-package function-name)))) 46 | (when sticky 47 | (ecase sticky 48 | (:global 49 | (string-downcase sym)) 50 | (:package 51 | (format nil "~(~a:~a~)" package-name sym)) 52 | (:local 53 | (format nil "~(~a:~a:~a~)" package-name function-name sym)))))) 54 | 55 | (defun set-cookies-code (function-name request params) 56 | (loop for param in params 57 | when (set-cookie-code function-name request param) collect it)) 58 | 59 | (defun set-cookie-code (function-name request param) 60 | (destructuring-bind (name type &optional default sticky) param 61 | (declare (ignore type default)) 62 | (if sticky 63 | `(when ,name 64 | (set-cookie-header 65 | ,request 66 | :name ,(symbol->cookie-name function-name name sticky) 67 | :value (princ-to-string ,name)))))) 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | ;;; Runtime 71 | 72 | (defgeneric string->type (type value)) 73 | 74 | (defmethod string->type ((type (eql 'string)) value) 75 | (and (plusp (length value)) value)) 76 | 77 | (defun get-cookie-value (request name) 78 | (cdr (assoc name (get-cookie-values request) :test #'string=))) 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /practicals/Chapter26/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.url-function 4 | (:use :common-lisp 5 | :net.aserve 6 | :com.gigamonkeys.html 7 | :com.gigamonkeys.macro-utilities) 8 | (:export :define-url-function 9 | :string->type)) 10 | 11 | -------------------------------------------------------------------------------- /practicals/Chapter26/url-function.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.url-function-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.url-function-system) 3 | 4 | (require :aserve) 5 | 6 | (defsystem url-function 7 | :name "url-function" 8 | :author "Peter Seibel " 9 | :version "0.1" 10 | :maintainer "Peter Seibel " 11 | :licence "BSD" 12 | :description "define-url-function macro for AllegroServe" 13 | :long-description "" 14 | :components 15 | ((:file "packages") 16 | (:file "html-infrastructure" :depends-on ("packages"))) 17 | :depends-on (:html :macro-utilities)) 18 | 19 | 20 | -------------------------------------------------------------------------------- /practicals/Chapter27/database.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.mp3-database) 2 | 3 | (defparameter *default-table-size* 100) 4 | 5 | (defclass table () 6 | ((rows :accessor rows :initarg :rows :initform (make-rows)) 7 | (schema :accessor schema :initarg :schema))) 8 | 9 | (defun make-rows (&optional (size *default-table-size*)) 10 | (make-array size :adjustable t :fill-pointer 0)) 11 | 12 | (defclass column () 13 | ((name 14 | :reader name 15 | :initarg :name) 16 | (equality-predicate 17 | :reader equality-predicate 18 | :initarg :equality-predicate) 19 | (comparator 20 | :reader comparator 21 | :initarg :comparator) 22 | (default-value 23 | :reader default-value 24 | :initarg :default-value 25 | :initform nil) 26 | (value-normalizer 27 | :reader value-normalizer 28 | :initarg :value-normalizer 29 | :initform #'(lambda (v column) (declare (ignore column)) v)))) 30 | 31 | (defclass interned-values-column (column) 32 | ((interned-values 33 | :reader interned-values 34 | :initform (make-hash-table :test #'equal)) 35 | (equality-predicate :initform #'eql) 36 | (value-normalizer :initform #'intern-for-column))) 37 | 38 | (defun intern-for-column (value column) 39 | (let ((hash (interned-values column))) 40 | (or (gethash (not-nullable value column) hash) 41 | (setf (gethash value hash) value)))) 42 | 43 | ;;; Schemas 44 | 45 | (defgeneric make-column (name type &optional default-value)) 46 | 47 | (defun make-schema (spec) 48 | (mapcar #'(lambda (column-spec) (apply #'make-column column-spec)) spec)) 49 | 50 | (defun find-column (column-name schema) 51 | (or (find column-name schema :key #'name) 52 | (error "No column: ~a in schema: ~a" column-name schema))) 53 | 54 | ;;; Column constructors 55 | 56 | (defmethod make-column (name (type (eql 'string)) &optional default-value) 57 | (make-instance 58 | 'column 59 | :name name 60 | :comparator #'string< 61 | :equality-predicate #'string= 62 | :default-value default-value 63 | :value-normalizer #'not-nullable)) 64 | 65 | (defmethod make-column (name (type (eql 'number)) &optional default-value) 66 | (make-instance 67 | 'column 68 | :name name 69 | :comparator #'< 70 | :equality-predicate #'= 71 | :default-value default-value)) 72 | 73 | (defmethod make-column (name (type (eql 'interned-string)) &optional default-value) 74 | (make-instance 75 | 'interned-values-column 76 | :name name 77 | :comparator #'string< 78 | :default-value default-value)) 79 | 80 | (defun not-nullable (value column) 81 | (or value (error "Column ~a can't be null" (name column)))) 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | ;;; INSERT-ROW 85 | 86 | (defun insert-row (names-and-values table) 87 | (vector-push-extend (normalize-row names-and-values (schema table)) (rows table))) 88 | 89 | (defun normalize-row (names-and-values schema) 90 | (loop 91 | for column in schema 92 | for name = (name column) 93 | for value = (or (getf names-and-values name) (default-value column)) 94 | collect name 95 | collect (normalize-for-column value column))) 96 | 97 | (defun normalize-for-column (value column) 98 | (funcall (value-normalizer column) value column)) 99 | 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | ;;; SELECT 102 | 103 | (defun select (&key (columns t) from where distinct order-by) 104 | (let ((rows (rows from)) 105 | (schema (schema from))) 106 | 107 | (when where 108 | (setf rows (restrict-rows rows where))) 109 | 110 | (unless (eql columns 't) 111 | (setf schema (extract-schema (mklist columns) schema)) 112 | (setf rows (project-columns rows schema))) 113 | 114 | (when distinct 115 | (setf rows (distinct-rows rows schema))) 116 | 117 | (when order-by 118 | (setf rows (sorted-rows rows schema (mklist order-by)))) 119 | 120 | (make-instance 'table :rows rows :schema schema))) 121 | 122 | (defun restrict-rows (rows where) 123 | (remove-if-not where rows)) 124 | 125 | (defun project-columns (rows schema) 126 | (map 'vector (extractor schema) rows)) 127 | 128 | (defun distinct-rows (rows schema) 129 | (remove-duplicates rows :test (row-equality-tester schema))) 130 | 131 | (defun sorted-rows (rows schema order-by) 132 | (sort (copy-seq rows) (row-comparator order-by schema))) 133 | 134 | ;;; where-clause builders 135 | 136 | (defun matching (table &rest names-and-values) 137 | "Build a where function that matches rows with the given column values." 138 | (let ((matchers (column-matchers (schema table) names-and-values))) 139 | #'(lambda (row) 140 | (every #'(lambda (matcher) (funcall matcher row)) matchers)))) 141 | 142 | (defun column-matchers (schema names-and-values) 143 | (loop for (name value) on names-and-values by #'cddr 144 | when value collect 145 | (column-matcher (find-column name schema) value))) 146 | 147 | (defun column-matcher (column value) 148 | (let ((name (name column)) 149 | (predicate (equality-predicate column)) 150 | (normalized (normalize-for-column value column))) 151 | #'(lambda (row) (funcall predicate (getf row name) normalized)))) 152 | 153 | (defun in (column-name table) 154 | "Build a where function that matches rows in which the value of 155 | the named column is in the given table" 156 | (let ((test (equality-predicate (find-column column-name (schema table)))) 157 | (values (map 'list #'(lambda (r) (getf r column-name)) (rows table)))) 158 | #'(lambda (row) 159 | (member (getf row column-name) values :test test)))) 160 | 161 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 162 | ;;; Table info and utilities 163 | 164 | (defun column-value (row column-name) 165 | (getf row column-name)) 166 | 167 | (defmacro do-rows ((row table) &body body) 168 | `(loop for ,row across (rows ,table) do ,@body)) 169 | 170 | (defun map-rows (fn table) 171 | (loop for row across (rows table) collect (funcall fn row))) 172 | 173 | (defun table-size (table) 174 | (length (rows table))) 175 | 176 | (defun nth-row (n table) 177 | (aref (rows table) n)) 178 | 179 | (defmacro with-column-values ((&rest vars) row &body body) 180 | (once-only (row) 181 | `(let ,(column-bindings vars row) ,@body))) 182 | 183 | (defun column-bindings (vars row) 184 | (loop for v in vars collect `(,v (column-value ,row ,(as-keyword v))))) 185 | 186 | (defun as-keyword (symbol) 187 | (intern (symbol-name symbol) :keyword)) 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | ;;; DELETE-ROWS, DELETE-ALL-ROWS 191 | 192 | (defun delete-rows (&key from where) 193 | (loop 194 | with rows = (rows from) 195 | with store-idx = 0 196 | for read-idx from 0 197 | for row across rows 198 | do (setf (aref rows read-idx) nil) 199 | unless (funcall where row) do 200 | (setf (aref rows store-idx) row) 201 | (incf store-idx) 202 | finally (setf (fill-pointer rows) store-idx))) 203 | 204 | (defun delete-all-rows (table) 205 | (setf (rows table) (make-rows *default-table-size*))) 206 | 207 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 208 | ;;; SORT-ROWS 209 | 210 | (defun sort-rows (table &rest column-names) 211 | (setf (rows table) (sort (rows table) (row-comparator column-names (schema table)))) 212 | table) 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | ;;; RANDOM-SELECTION and SHUFFLE-TABLE 216 | 217 | 218 | (defun shuffle-table (table) 219 | (nshuffle-vector (rows table)) 220 | table) 221 | 222 | (defun nshuffle-vector (vector) 223 | "Shuffle a vector in place." 224 | (loop for idx downfrom (1- (length vector)) to 1 225 | for other = (random (1+ idx)) 226 | do (unless (= idx other) 227 | (rotatef (aref vector idx) (aref vector other)))) 228 | vector) 229 | 230 | (defun random-selection (table n) 231 | (make-instance 232 | 'table 233 | :schema (schema table) 234 | :rows (nshuffle-vector (random-sample (rows table) n)))) 235 | 236 | (defun random-sample (vector n) 237 | "Based on Algorithm S from Knuth. TAOCP, vol. 2. p. 142" 238 | (loop with selected = (make-array n :fill-pointer 0) 239 | for idx from 0 240 | do 241 | (loop 242 | with to-select = (- n (length selected)) 243 | for remaining = (- (length vector) idx) 244 | while (>= (* remaining (random 1.0)) to-select) 245 | do (incf idx)) 246 | (vector-push (aref vector idx) selected) 247 | when (= (length selected) n) return selected)) 248 | 249 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 | ;;; Helpers 251 | 252 | (defun mklist (thing) 253 | (if (listp thing) thing (list thing))) 254 | 255 | (defun extract-schema (column-names schema) 256 | (loop for c in column-names collect (find-column c schema))) 257 | 258 | (defun extractor (schema) 259 | (let ((names (mapcar #'name schema))) 260 | #'(lambda (row) 261 | (loop for c in names collect c collect (getf row c))))) 262 | 263 | (defun row-equality-tester (schema) 264 | (let ((names (mapcar #'name schema)) 265 | (tests (mapcar #'equality-predicate schema))) 266 | #'(lambda (a b) 267 | (loop for name in names and test in tests 268 | always (funcall test (getf a name) (getf b name)))))) 269 | 270 | (defun row-comparator (column-names schema) 271 | (let ((comparators (mapcar #'comparator (extract-schema column-names schema)))) 272 | #'(lambda (a b) 273 | (loop 274 | for name in column-names 275 | for comparator in comparators 276 | for a-value = (getf a name) 277 | for b-value = (getf b name) 278 | when (funcall comparator a-value b-value) return t 279 | when (funcall comparator b-value a-value) return nil 280 | finally (return nil))))) 281 | 282 | 283 | -------------------------------------------------------------------------------- /practicals/Chapter27/mp3-database.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.mp3-database-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.mp3-database-system) 3 | 4 | (defsystem mp3-database 5 | :name "mp3-database" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "In-memory MP3 Database." 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "database" :depends-on ("packages")) 15 | (:file "mp3-database" :depends-on ("packages" "database"))) 16 | :depends-on (:pathnames :macro-utilities :id3v2)) 17 | 18 | 19 | -------------------------------------------------------------------------------- /practicals/Chapter27/mp3-database.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.mp3-database) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; Load database 5 | 6 | (defparameter *mp3-schema* 7 | (make-schema 8 | '((:file string) 9 | (:genre interned-string "Unknown") 10 | (:artist interned-string "Unknown") 11 | (:album interned-string "Unknown") 12 | (:song string) 13 | (:track number 0) 14 | (:year number 0) 15 | (:id3-size number)))) 16 | 17 | (defparameter *mp3s* (make-instance 'table :schema *mp3-schema*)) 18 | 19 | (defun load-database (dir db) 20 | (let ((count 0)) 21 | (walk-directory 22 | dir 23 | #'(lambda (file) 24 | (princ #\.) 25 | (incf count) 26 | (insert-row (file->row file) db)) 27 | :test #'mp3-p) 28 | (format t "~&Loaded ~d files into database." count))) 29 | 30 | (defun file->row (file) 31 | (let ((id3 (read-id3 file))) 32 | (list 33 | :file (namestring (truename file)) 34 | :genre (translated-genre id3) 35 | :artist (artist id3) 36 | :album (album id3) 37 | :song (song id3) 38 | :track (parse-track (track id3)) 39 | :year (parse-year (year id3)) 40 | :id3-size (size id3)))) 41 | 42 | (defun parse-track (track) 43 | (when track (parse-integer track :end (position #\/ track)))) 44 | 45 | (defun parse-year (year) 46 | (when year (parse-integer year))) 47 | -------------------------------------------------------------------------------- /practicals/Chapter27/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.mp3-database 4 | (:use :common-lisp 5 | :com.gigamonkeys.pathnames 6 | :com.gigamonkeys.macro-utilities 7 | :com.gigamonkeys.id3v2) 8 | (:export :*default-table-size* 9 | :*mp3-schema* 10 | :*mp3s* 11 | :column 12 | :column-value 13 | :delete-all-rows 14 | :delete-rows 15 | :do-rows 16 | :extract-schema 17 | :in 18 | :insert-row 19 | :load-database 20 | :make-column 21 | :make-schema 22 | :map-rows 23 | :matching 24 | :not-nullable 25 | :nth-row 26 | :random-selection 27 | :schema 28 | :select 29 | :shuffle-table 30 | :sort-rows 31 | :table 32 | :table-size 33 | :with-column-values)) 34 | -------------------------------------------------------------------------------- /practicals/Chapter28/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.shoutcast 4 | (:use :common-lisp 5 | :net.aserve 6 | :com.gigamonkeys.id3v2) 7 | (:export :song 8 | :file 9 | :title 10 | :id3-size 11 | :find-song-source 12 | :current-song 13 | :still-current-p 14 | :maybe-move-to-next-song 15 | :*song-source-type*)) 16 | 17 | -------------------------------------------------------------------------------- /practicals/Chapter28/shoutcast.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.shoutcast-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.shoutcast-system) 3 | 4 | (require :aserve) 5 | 6 | (defsystem shoutcast 7 | :name "shoutcast" 8 | :author "Peter Seibel " 9 | :version "0.1" 10 | :maintainer "Peter Seibel " 11 | :licence "BSD" 12 | :description "Shoutcast server." 13 | :long-description "Shoutcast server that runs in AllegroServe" 14 | :components 15 | ((:file "packages") 16 | (:file "song-source" :depends-on ("packages")) 17 | (:file "shoutcast" :depends-on ("packages"))) 18 | :depends-on (:html :pathnames :macro-utilities :id3v2 :mp3-database :url-function)) 19 | 20 | 21 | -------------------------------------------------------------------------------- /practicals/Chapter28/shoutcast.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.shoutcast) 2 | 3 | (defparameter *metadata-interval* (expt 2 12)) 4 | (defparameter *timeout-seconds* (* 60 60 24 7 52 10)) 5 | (defparameter *song-source-type* 'singleton) 6 | 7 | (publish :path "/stream.mp3" :function 'shoutcast) 8 | 9 | (defun shoutcast (request entity) 10 | (with-http-response 11 | (request entity :content-type "audio/MP3" :timeout *timeout-seconds*) 12 | (prepare-icy-response request *metadata-interval*) 13 | (let ((wants-metadata-p (header-slot-value request :icy-metadata))) 14 | (with-http-body (request entity) 15 | (play-songs 16 | (request-socket request) 17 | (find-song-source *song-source-type* request) 18 | (if wants-metadata-p *metadata-interval*)))))) 19 | 20 | (defun prepare-icy-response (request metadata-interval) 21 | (setf (request-reply-protocol-string request) "ICY") 22 | (loop for (k v) in (reverse 23 | `((:|icy-metaint| ,(princ-to-string metadata-interval)) 24 | (:|icy-notice1| "
This stream blah blah blah
") 25 | (:|icy-notice2| "More blah") 26 | (:|icy-name| "MyLispShoutcastServer") 27 | (:|icy-genre| "Unknown") 28 | (:|icy-url| ,(request-uri request)) 29 | (:|icy-pub| "1"))) 30 | do (setf (reply-header-slot-value request k) v)) 31 | ;; iTunes, despite claiming to speak HTTP/1.1, doesn't understand 32 | ;; chunked Transfer-encoding. Grrr. So we just turn it off. 33 | (turn-off-chunked-transfer-encoding request)) 34 | 35 | (defun turn-off-chunked-transfer-encoding (request) 36 | ;; We have to use a bit of knowledge about AllegroServe's internals 37 | ;; to do this. 38 | (setf (request-reply-strategy request) 39 | (remove :chunked (request-reply-strategy request)))) 40 | 41 | (defun play-songs (stream song-source metadata-interval) 42 | (handler-case 43 | (loop 44 | for next-metadata = metadata-interval 45 | then (play-current 46 | stream 47 | song-source 48 | next-metadata 49 | metadata-interval) 50 | while next-metadata) 51 | (error (e) (format *trace-output* "Caught error in play-songs: ~a" e)))) 52 | 53 | 54 | ;;; Simple version of play current 55 | (defun play-current (out song-source next-metadata metadata-interval) 56 | (let ((song (current-song song-source))) 57 | (when song 58 | (let ((metadata (make-icy-metadata (title song)))) 59 | (with-open-file (mp3 (file song)) 60 | (unless (file-position mp3 (id3-size song)) 61 | (error "Can't skip to position ~d in ~a" (id3-size song) (file song))) 62 | (loop for byte = (read-byte mp3 nil nil) 63 | while (and byte (still-current-p song song-source)) do 64 | (write-byte byte out) 65 | (decf next-metadata) 66 | when (and (zerop next-metadata) metadata-interval) do 67 | (write-sequence metadata out) 68 | (setf next-metadata metadata-interval)) 69 | 70 | (maybe-move-to-next-song song song-source))) 71 | next-metadata))) 72 | 73 | ;;; i/o efficient version of play-current 74 | #+(or) 75 | (defun play-current (out song-source next-metadata metadata-interval) 76 | (let ((song (current-song song-source))) 77 | (when song 78 | (let ((metadata (make-icy-metadata (title song))) 79 | (buffer (make-array size :element-type '(unsigned-byte 8)))) 80 | (with-open-file (mp3 (file song)) 81 | (labels ((write-buffer (start end) 82 | (if metadata-interval 83 | (write-buffer-with-metadata start end) 84 | (write-sequence buffer out :start start :end end))) 85 | 86 | (write-buffer-with-metadata (start end) 87 | (cond 88 | ((> next-metadata (- end start)) 89 | (write-sequence buffer out :start start :end end) 90 | (decf next-metadata (- end start))) 91 | (t 92 | (let ((middle (+ start next-metadata))) 93 | (write-sequence buffer out :start start :end middle) 94 | (write-sequence metadata out) 95 | (setf next-metadata metadata-interval) 96 | (write-buffer-with-metadata middle end)))))) 97 | 98 | (multiple-value-bind (skip-blocks skip-bytes) 99 | (floor (id3-size song) (length buffer)) 100 | 101 | (unless (file-position mp3 (* skip-blocks (length buffer))) 102 | (error "Couldn't skip over ~d ~d byte blocks." 103 | skip-blocks (length buffer))) 104 | 105 | (loop for end = (read-sequence buffer mp3) 106 | for start = skip-bytes then 0 107 | do (write-buffer start end) 108 | while (and (= end (length buffer)) 109 | (still-current-p song song-source))) 110 | 111 | (maybe-move-to-next-song song song-source))))) 112 | next-metadata))) 113 | 114 | (defun make-icy-metadata (title) 115 | (let* ((text (format nil "StreamTitle='~a';" (substitute #\Space #\' title))) 116 | (blocks (ceiling (length text) 16)) 117 | (buffer (make-array (1+ (* blocks 16)) 118 | :element-type '(unsigned-byte 8) 119 | :initial-element 0))) 120 | (setf (aref buffer 0) blocks) 121 | (loop 122 | for char across text 123 | for i from 1 124 | do (setf (aref buffer i) (char-code char))) 125 | buffer)) 126 | 127 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /practicals/Chapter28/song-source.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.shoutcast) 2 | 3 | (defclass song () 4 | ((file :reader file :initarg :file) 5 | (title :reader title :initarg :title) 6 | (id3-size :reader id3-size :initarg :id3-size))) 7 | 8 | (defgeneric find-song-source (type request) 9 | (:documentation "Find the song-source of the given type for the given request.")) 10 | 11 | (defgeneric current-song (source) 12 | (:documentation "Return the currently playing song or NIL.")) 13 | 14 | (defgeneric still-current-p (song source) 15 | (:documentation 16 | "Return true if the song given is the same as the current-song.")) 17 | 18 | (defgeneric maybe-move-to-next-song (song source) 19 | (:documentation 20 | "If the given song is still the current one update the value 21 | returned by current-song.")) 22 | 23 | ;;; Singleton implementation 24 | 25 | (defclass simple-song-queue () 26 | ((songs :accessor songs :initform (make-array 10 :adjustable t :fill-pointer 0)) 27 | (index :accessor index :initform 0))) 28 | 29 | (defparameter *songs* (make-instance 'simple-song-queue)) 30 | 31 | (defmethod find-song-source ((type (eql 'singleton)) request) 32 | (declare (ignore request)) 33 | *songs*) 34 | 35 | (defmethod current-song ((source simple-song-queue)) 36 | (when (array-in-bounds-p (songs source) (index source)) 37 | (aref (songs source) (index source)))) 38 | 39 | (defmethod still-current-p (song (source simple-song-queue)) 40 | (eql song (current-song source))) 41 | 42 | (defmethod maybe-move-to-next-song (song (source simple-song-queue)) 43 | (when (still-current-p song source) 44 | (incf (index source)))) 45 | 46 | (defun add-file-to-songs (file) 47 | (vector-push-extend (file->song file) (songs *songs*))) 48 | 49 | (defun file->song (file) 50 | (let ((id3 (read-id3 file))) 51 | (make-instance 52 | 'song 53 | :file (namestring (truename file)) 54 | :title (format nil "~a by ~a from ~a" (song id3) (artist id3) (album id3)) 55 | :id3-size (size id3)))) 56 | -------------------------------------------------------------------------------- /practicals/Chapter29/mp3-browser.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.mp3-browser-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.mp3-browser-system) 3 | 4 | (require :aserve) 5 | 6 | (defclass css-file (static-file) ()) 7 | (defmethod source-file-type ((c css-file) (s module)) "css") 8 | 9 | (defsystem mp3-browser 10 | :name "mp3-browser" 11 | :author "Peter Seibel " 12 | :version "1.0" 13 | :maintainer "Peter Seibel " 14 | :licence "BSD" 15 | :description "AllegroServe-based user interface for Shoutcast server." 16 | :long-description "" 17 | :components 18 | ((:file "packages") 19 | (:file "playlist" :depends-on ("packages")) 20 | (:file "mp3-browser" :depends-on ("packages" "playlist")) 21 | (:css-file "mp3-browser")) 22 | :depends-on (:id3v2 :mp3-database :shoutcast :url-function :html)) 23 | 24 | 25 | -------------------------------------------------------------------------------- /practicals/Chapter29/mp3-browser.css: -------------------------------------------------------------------------------- 1 | body { font-size: 10pt; font-family: sans-serif; } 2 | h1.title { font-size: 18pt; } 3 | table.playlist { width: 100%; font-size: 8pt; } 4 | table.playlist tr { background-color: #dddddd; } 5 | table.playlist tr.normal { background-color: #ffddff; } 6 | table.playlist tr.now-playing { background-color: #ccbbee; } 7 | table.playlist tr td { padding: 2pt; } 8 | table.all-playlists { font-size: 10pt; } 9 | table.all-playlists tr td + td { padding-left: 12pt; padding-right: 12pt; } 10 | table.all-playlists td + td { text-align: center; } 11 | tr:first-child { font-weight: bold; } 12 | p.toolbar { font-weight: bold; text-align: center; } 13 | p.playlist-toolbar { font-size: 9pt; text-align: center; } 14 | p.footer { font-style: italic; text-align: right; } 15 | -------------------------------------------------------------------------------- /practicals/Chapter29/mp3-browser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.mp3-browser) 2 | 3 | (defvar *major-version* 1) 4 | (defvar *minor-version* 0) 5 | 6 | (defparameter *mp3-dir* nil) 7 | 8 | (defparameter *mp3-css* 9 | (when *load-pathname* (make-pathname :name "mp3-browser" :type "css" :defaults *load-pathname*))) 10 | 11 | (defun configure-mp3-browser (&optional force) 12 | (unless (or *mp3-dir* force) 13 | (format t "Enter root directory of MP3 collection: ") 14 | (force-output *standard-output*) 15 | (setf *mp3-dir* (read))) 16 | (unless (or *mp3-css* force) 17 | (format t "Enter full filename of mp3-browser.css: ") 18 | (force-output *standard-output*) 19 | (setf *mp3-css* (read)))) 20 | 21 | (defun start-mp3-browser () 22 | (unless (and *mp3-dir* *mp3-css*) 23 | (configure-mp3-browser)) 24 | (load-database *mp3-dir* *mp3s*) 25 | (publish-file :path "/mp3-browser.css" :file *mp3-css* :content-type "text/css") 26 | (setf *song-source-type* 'playlist) 27 | (net.aserve::debug-on :notrap) 28 | (net.aserve:start :port 2001)) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; Parameter types for url functions 32 | 33 | (defmethod string->type ((type (eql 'integer)) value) 34 | (parse-integer (or value "") :junk-allowed t)) 35 | 36 | (defmethod string->type ((type (eql 'keyword)) value) 37 | (and (plusp (length value)) (intern (string-upcase value) :keyword))) 38 | 39 | (defun safe-read-from-string (string) 40 | (let ((*read-eval* nil)) (ignore-errors (read-from-string string)))) 41 | 42 | (defmethod string->type ((type (eql 'base-64-list)) value) 43 | (let ((obj (base64->obj value))) 44 | (if (listp obj) obj nil))) 45 | 46 | (defmacro with-safe-io-syntax (&body body) 47 | `(with-standard-io-syntax 48 | (let ((*read-eval* nil)) 49 | ,@body))) 50 | 51 | (defun obj->base64 (obj) 52 | (base64-encode (with-safe-io-syntax (write-to-string obj)))) 53 | 54 | (defun base64->obj (string) 55 | (ignore-errors 56 | (with-safe-io-syntax (read-from-string (base64-decode string))))) 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;;; Standard page layout 60 | 61 | (define-html-macro :mp3-browser-page ((&key title (header title)) &body body) 62 | `(:html 63 | (:head 64 | (:title ,title) 65 | (:link :rel "stylesheet" :type "text/css" :href "mp3-browser.css")) 66 | (:body 67 | (standard-header) 68 | (when ,header (html (:h1 :class "title" ,header))) 69 | ,@body 70 | (standard-footer)))) 71 | 72 | (defun link (target &rest attributes) 73 | (html 74 | (:attribute 75 | (:format "~a~@[?~{~(~a~)=~a~^&~}~]" target (mapcar #'urlencode attributes))))) 76 | 77 | (defun urlencode (string) 78 | (net.aserve::encode-form-urlencoded string)) 79 | 80 | (defparameter *random-amount* 25) 81 | 82 | (defun standard-header () 83 | (html 84 | ((:p :class "toolbar") 85 | "[" (:a :href (link "/browse" :what "genre") "All genres") "] " 86 | "[" (:a :href (link "/browse" :what "genre" :random *random-amount*) "Random genres") "] " 87 | "[" (:a :href (link "/browse" :what "artist") "All artists") "] " 88 | "[" (:a :href (link "/browse":what "artist" :random *random-amount*) "Random artists") "] " 89 | "[" (:a :href (link "/browse":what "album") "All albums") "] " 90 | "[" (:a :href (link "/browse":what "album" :random *random-amount*) "Random albums") "] " 91 | "[" (:a :href (link "/browse" :what "song" :random *random-amount*) "Random songs") "] " 92 | "[" (:a :href (link "/playlist") "Playlist") "] " 93 | "[" (:a :href (link "/all-playlists") "All playlists") "]"))) 94 | 95 | (defun standard-footer () 96 | (html (:hr) ((:p :class "footer") "MP3 Browser v" *major-version* "." *minor-version*))) 97 | 98 | (define-html-macro :table-row (&attributes attrs &rest values) 99 | `(:tr ,@attrs ,@(loop for v in values collect `(:td ,v)))) 100 | 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | ;;; MP3 Browser 103 | 104 | (define-url-function browse 105 | (request (what keyword :genre) genre artist album (random integer)) 106 | 107 | (let* ((values (values-for-page what genre artist album random)) 108 | (title (browse-page-title what random genre artist album)) 109 | (single-column (if (eql what :song) :file what)) 110 | (values-string (values->base-64 single-column values))) 111 | (html 112 | (:mp3-browser-page 113 | (:title title) 114 | ((:form :method "POST" :action "playlist") 115 | (:input :name "values" :type "hidden" :value values-string) 116 | (:input :name "what" :type "hidden" :value single-column) 117 | (:input :name "action" :type "hidden" :value :add-songs) 118 | (:input :name "submit" :type "submit" :value "Add all")) 119 | (:ul (do-rows (row values) (list-item-for-page what row))))))) 120 | 121 | (define-url-function playlist 122 | (request 123 | (playlist-id string (playlist-id request) :package) 124 | (action keyword) ; Playlist manipulation action 125 | (what keyword :file) ; for :add-songs action 126 | (values base-64-list) ; " 127 | file ; for :add-songs and :delete-songs actions 128 | genre ; for :delete-songs action 129 | artist ; " 130 | album ; " 131 | (order-by keyword) ; for :sort action 132 | (shuffle keyword) ; for :shuffle action 133 | (repeat keyword)) ; for :set-repeat action 134 | 135 | (let ((playlist (lookup-playlist playlist-id))) 136 | (with-playlist-locked (playlist) 137 | 138 | (case action 139 | (:add-songs (add-songs playlist what (or values (list file)))) 140 | (:delete-songs (delete-songs 141 | playlist 142 | :file file :genre genre 143 | :artist artist :album album)) 144 | (:clear (clear-playlist playlist)) 145 | (:sort (sort-playlist playlist order-by)) 146 | (:shuffle (shuffle-playlist playlist shuffle)) 147 | (:set-repeat (setf (repeat playlist) repeat))) 148 | 149 | (html 150 | (:mp3-browser-page 151 | (:title (:format "Playlist - ~a" (id playlist)) :header nil) 152 | (playlist-toolbar playlist) 153 | (if (empty-p playlist) 154 | (html (:p (:i "Empty."))) 155 | (html 156 | ((:table :class "playlist") 157 | (:table-row "#" "Song" "Album" "Artist" "Genre") 158 | (let ((idx 0) 159 | (current-idx (current-idx playlist))) 160 | (do-rows (row (songs-table playlist)) 161 | (with-column-values (track file song album artist genre) row 162 | (let ((row-style (if (= idx current-idx) "now-playing" "normal"))) 163 | (html 164 | ((:table-row :class row-style) 165 | track 166 | (:progn song (delete-songs-link :file file)) 167 | (:progn album (delete-songs-link :album album)) 168 | (:progn artist (delete-songs-link :artist artist)) 169 | (:progn genre (delete-songs-link :genre genre))))) 170 | (incf idx)))))))))))) 171 | 172 | (define-url-function all-playlists (request) 173 | (:mp3-browser-page 174 | (:title "All Playlists") 175 | ((:table :class "all-playlists") 176 | (:table-row "Playlist" "# Songs" "Most recent user agent") 177 | (with-process-lock (*playlists-lock*) 178 | (loop for playlist being the hash-values of *playlists* do 179 | (html 180 | (:table-row 181 | (:a :href (link "playlist" :playlist-id (id playlist)) (:print (id playlist))) 182 | (:print (table-size (songs-table playlist))) 183 | (:print (user-agent playlist))))))))) 184 | 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | ;;; Helper functions 187 | 188 | (defun values-for-page (what genre artist album random) 189 | (let ((values 190 | (select 191 | :from *mp3s* 192 | :columns (if (eql what :song) t what) 193 | :where (matching *mp3s* :genre genre :artist artist :album album) 194 | :distinct (not (eql what :song)) 195 | :order-by (if (eql what :song) '(:album :track) what)))) 196 | (if random (random-selection values random) values))) 197 | 198 | (defun browse-page-title (what random genre artist album) 199 | (with-output-to-string (s) 200 | (when random (format s "~:(~r~) Random " random)) 201 | (format s "~:(~a~p~)" what random) 202 | (when (or genre artist album) 203 | (when (not (eql what :song)) (princ " with songs" s)) 204 | (when genre (format s " in genre ~a" genre)) 205 | (when artist (format s " by artist ~a" artist)) 206 | (when album (format s " on album ~a" album))))) 207 | 208 | (defun list-item-for-page (what row) 209 | (if (eql what :song) 210 | (with-column-values (song file album artist genre) row 211 | (html 212 | (:li 213 | (:a :href (link "playlist" :file file :action "add-songs") (:b song)) " from " 214 | (:a :href (link "browse" :what :song :album album) album) " by " 215 | (:a :href (link "browse" :what :song :artist artist) artist) " in genre " 216 | (:a :href (link "browse" :what :song :genre genre) genre)))) 217 | (let ((value (column-value row what))) 218 | (html 219 | (:li value " - " 220 | (browse-link :genre what value) 221 | (browse-link :artist what value) 222 | (browse-link :album what value) 223 | (browse-link :song what value)))))) 224 | 225 | (defun browse-link (new-what what value) 226 | (unless (eql new-what what) 227 | (html 228 | "[" 229 | (:a :href (link "browse" :what new-what what value) (:format "~(~as~)" new-what)) 230 | "] "))) 231 | 232 | (defun playlist-toolbar (playlist) 233 | (let ((current-repeat (repeat playlist)) 234 | (current-sort (ordering playlist)) 235 | (current-shuffle (shuffle playlist))) 236 | (html 237 | (:p :class "playlist-toolbar" 238 | (:i "Sort by:") 239 | " [ " 240 | (sort-playlist-button "genre" current-sort) " | " 241 | (sort-playlist-button "artist" current-sort) " | " 242 | (sort-playlist-button "album" current-sort) " | " 243 | (sort-playlist-button "song" current-sort) " ] " 244 | (:i "Shuffle by:") 245 | " [ " 246 | (playlist-shuffle-button "none" current-shuffle) " | " 247 | (playlist-shuffle-button "song" current-shuffle) " | " 248 | (playlist-shuffle-button "album" current-shuffle) " ] " 249 | (:i "Repeat:") 250 | " [ " 251 | (playlist-repeat-button "none" current-repeat) " | " 252 | (playlist-repeat-button "song" current-repeat) " | " 253 | (playlist-repeat-button "all" current-repeat) " ] " 254 | "[ " (:a :href (link "playlist" :action "clear") "Clear") " ] ")))) 255 | 256 | (defun playlist-button (action argument new-value current-value) 257 | (let ((label (string-capitalize new-value))) 258 | (if (string-equal new-value current-value) 259 | (html (:b label)) 260 | (html (:a :href (link "playlist" :action action argument new-value) label))))) 261 | 262 | (defun sort-playlist-button (order-by current-sort) 263 | (playlist-button :sort :order-by order-by current-sort)) 264 | 265 | (defun playlist-shuffle-button (shuffle current-shuffle) 266 | (playlist-button :shuffle :shuffle shuffle current-shuffle)) 267 | 268 | (defun playlist-repeat-button (repeat current-repeat) 269 | (playlist-button :set-repeat :repeat repeat current-repeat)) 270 | 271 | (defun delete-songs-link (what value) 272 | (html " [" (:a :href (link "playlist" :action :delete-songs what value) "x") "]")) 273 | 274 | (defun values->base-64 (column values-table) 275 | (flet ((value (r) (column-value r column))) 276 | (obj->base64 (map-rows #'value values-table)))) 277 | 278 | 279 | -------------------------------------------------------------------------------- /practicals/Chapter29/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.mp3-browser 4 | (:use :common-lisp 5 | :net.aserve 6 | :com.gigamonkeys.html 7 | :com.gigamonkeys.shoutcast 8 | :com.gigamonkeys.url-function 9 | :com.gigamonkeys.mp3-database 10 | :com.gigamonkeys.id3v2) 11 | (:import-from :acl-socket 12 | :ipaddr-to-dotted 13 | :remote-host) 14 | (:import-from :multiprocessing 15 | :make-process-lock 16 | :with-process-lock) 17 | (:export :start-mp3-browser)) 18 | 19 | 20 | -------------------------------------------------------------------------------- /practicals/Chapter29/playlist.lisp: -------------------------------------------------------------------------------- 1 | (in-package :com.gigamonkeys.mp3-browser) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; Two versions of silence 5 | 6 | ;; Set this variable to the filename of an MP3 of silence. 7 | (defparameter *silence-mp3* nil) 8 | 9 | (defun make-silent-song (title &optional (file *silence-mp3*)) 10 | (make-instance 11 | 'song 12 | :file file 13 | :title title 14 | :id3-size (if (id3-p file) (size (read-id3 file)) 0))) 15 | 16 | (defparameter *empty-playlist-song* (make-silent-song "Playlist empty.")) 17 | 18 | (defparameter *end-of-playlist-song* (make-silent-song "At end of playlist.")) 19 | 20 | (defclass playlist () 21 | ((id :accessor id :initarg :id) 22 | (songs-table :accessor songs-table :initform (make-playlist-table)) 23 | (current-song :accessor current-song :initform *empty-playlist-song*) 24 | (current-idx :accessor current-idx :initform 0) 25 | (ordering :accessor ordering :initform :album) 26 | (shuffle :accessor shuffle :initform :none) 27 | (repeat :accessor repeat :initform :none) 28 | (user-agent :accessor user-agent :initform "Unknown") 29 | (lock :reader lock :initform (make-process-lock)))) 30 | 31 | (defun make-playlist-table () 32 | (make-instance 'table :schema *mp3-schema*)) 33 | 34 | (defmacro with-playlist-locked ((playlist) &body body) 35 | `(with-process-lock ((lock ,playlist)) 36 | ,@body)) 37 | 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;;; find-song-source 40 | 41 | (defvar *playlists* (make-hash-table :test #'equal)) 42 | (defparameter *playlists-lock* (make-process-lock :name "playlists-lock")) 43 | 44 | (defmethod find-song-source ((type (eql 'playlist)) request) 45 | (let ((playlist (lookup-playlist (playlist-id request)))) 46 | (with-playlist-locked (playlist) 47 | (let ((user-agent (header-slot-value request :user-agent))) 48 | (when user-agent (setf (user-agent playlist) user-agent)))) 49 | playlist)) 50 | 51 | (defun lookup-playlist (id) 52 | (with-process-lock (*playlists-lock*) 53 | (or (gethash id *playlists*) 54 | (setf (gethash id *playlists*) (make-instance 'playlist :id id))))) 55 | 56 | (defun playlist-id (request) 57 | (ipaddr-to-dotted (remote-host (request-socket request)))) 58 | 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | ;;; song-source implementation 61 | 62 | (defmethod current-song :around ((playlist playlist)) 63 | (with-playlist-locked (playlist) (call-next-method))) 64 | 65 | (defmethod still-current-p (song (playlist playlist)) 66 | (with-playlist-locked (playlist) 67 | (eql song (current-song playlist)))) 68 | 69 | (defmethod maybe-move-to-next-song (song (playlist playlist)) 70 | (with-playlist-locked (playlist) 71 | (when (still-current-p song playlist) 72 | (unless (at-end-p playlist) 73 | (ecase (repeat playlist) 74 | (:song) ; nothing changes 75 | (:none (incf (current-idx playlist))) 76 | (:all (setf (current-idx playlist) 77 | (mod (1+ (current-idx playlist)) 78 | (table-size (songs-table playlist))))))) 79 | (update-current-if-necessary playlist)))) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;; Internals 83 | 84 | ;;; update-current-if-necessary 85 | 86 | (defun update-current-if-necessary (playlist) 87 | (unless (equal (file (current-song playlist)) 88 | (file-for-current-idx playlist)) 89 | (reset-current-song playlist))) 90 | 91 | (defun file-for-current-idx (playlist) 92 | (if (at-end-p playlist) 93 | nil 94 | (column-value (nth-row (current-idx playlist) (songs-table playlist)) :file))) 95 | 96 | (defun at-end-p (playlist) 97 | (>= (current-idx playlist) (table-size (songs-table playlist)))) 98 | 99 | (defun reset-current-song (playlist) 100 | (setf 101 | (current-song playlist) 102 | (cond 103 | ((empty-p playlist) *empty-playlist-song*) 104 | ((at-end-p playlist) *end-of-playlist-song*) 105 | (t (row->song (nth-row (current-idx playlist) (songs-table playlist))))))) 106 | 107 | (defun row->song (song-db-entry) 108 | (with-column-values (file song artist album id3-size) song-db-entry 109 | (make-instance 110 | 'song 111 | :file file 112 | :title (format nil "~a by ~a from ~a" song artist album) 113 | :id3-size id3-size))) 114 | 115 | (defun empty-p (playlist) 116 | (zerop (table-size (songs-table playlist)))) 117 | 118 | 119 | ;;; Playlist manipulation functions called from mp3-browser.lisp 120 | 121 | (defun add-songs (playlist column-name values) 122 | (let ((table (make-instance 123 | 'table 124 | :schema (extract-schema (list column-name) (schema *mp3s*))))) 125 | (dolist (v values) (insert-row (list column-name v) table)) 126 | (do-rows (row (select :from *mp3s* :where (in column-name table))) 127 | (insert-row row (songs-table playlist)))) 128 | (update-current-if-necessary playlist)) 129 | 130 | (defun delete-songs (playlist &rest names-and-values) 131 | (delete-rows 132 | :from (songs-table playlist) 133 | :where (apply #'matching (songs-table playlist) names-and-values)) 134 | (setf (current-idx playlist) (or (position-of-current playlist) 0)) 135 | (update-current-if-necessary playlist)) 136 | 137 | (defun clear-playlist (playlist) 138 | (delete-all-rows (songs-table playlist)) 139 | (setf (current-idx playlist) 0) 140 | (update-current-if-necessary playlist)) 141 | 142 | (defun sort-playlist (playlist ordering) 143 | (setf (ordering playlist) ordering) 144 | (setf (shuffle playlist) :none) 145 | (order-playlist playlist) 146 | (setf (current-idx playlist) (position-of-current playlist))) 147 | 148 | (defun shuffle-playlist (playlist shuffle) 149 | (setf (shuffle playlist) shuffle) 150 | (case shuffle 151 | (:none (order-playlist playlist)) 152 | (:song (shuffle-by-song playlist)) 153 | (:album (shuffle-by-album playlist))) 154 | (setf (current-idx playlist) (position-of-current playlist))) 155 | 156 | (defmethod (setf repeat) :after (value (playlist playlist)) 157 | (if (and (at-end-p playlist) (not (empty-p playlist))) 158 | (ecase value 159 | (:song (setf (current-idx playlist) (1- (table-size (songs-table playlist))))) 160 | (:none) 161 | (:all (setf (current-idx playlist) 0))) 162 | (update-current-if-necessary playlist))) 163 | 164 | ;;; Shuffling helpers 165 | 166 | (defun position-of-current (playlist) 167 | (let* ((table (songs-table playlist)) 168 | (matcher (matching table :file (file (current-song playlist)))) 169 | (pos 0)) 170 | (do-rows (row table) 171 | (when (funcall matcher row) 172 | (return-from position-of-current pos)) 173 | (incf pos)))) 174 | 175 | (defun order-playlist (playlist) 176 | (apply #'sort-rows (songs-table playlist) 177 | (case (ordering playlist) 178 | (:genre '(:genre :album :track)) 179 | (:artist '(:artist :album :track)) 180 | (:album '(:album :track)) 181 | (:song '(:song))))) 182 | 183 | (defun shuffle-by-song (playlist) 184 | (shuffle-table (songs-table playlist))) 185 | 186 | (defun shuffle-by-album (playlist) 187 | (let ((new-table (make-playlist-table))) 188 | (do-rows (album-row (shuffled-album-names playlist)) 189 | (do-rows (song (songs-for-album playlist (column-value album-row :album))) 190 | (insert-row song new-table))) 191 | (setf (songs-table playlist) new-table))) 192 | 193 | (defun shuffled-album-names (playlist) 194 | (shuffle-table 195 | (select 196 | :columns :album 197 | :from (songs-table playlist) 198 | :distinct t))) 199 | 200 | (defun songs-for-album (playlist album) 201 | (select 202 | :from (songs-table playlist) 203 | :where (matching (songs-table playlist) :album album) 204 | :order-by :track)) 205 | 206 | 207 | 208 | 209 | 210 | -------------------------------------------------------------------------------- /practicals/Chapter31/README.txt: -------------------------------------------------------------------------------- 1 | The file css.lisp contains support for generating CSS output. To ues it add 2 | 3 | (:file "css" :depends-on ("packages" "html")) 4 | 5 | to html.asd and export :define-css-macro, :css, and :emit-css in packages.lisp. 6 | 7 | The file embed-foo-with-conditions-and-restarts.lisp contains the code discussed 8 | in the sidebar in Chatper 30. 9 | -------------------------------------------------------------------------------- /practicals/Chapter31/css.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:com.gigamonkeys.html) 2 | 3 | ;;; CSS support 4 | 5 | ;; For stylesheets 6 | (define-html-special-operator css-style (processor &rest body) 7 | (dolist (sexp body) 8 | (if (eql (first sexp) :import) 9 | (emit-css-import processor sexp) 10 | (process-css processor sexp)))) 11 | 12 | (defun emit-css-import (processor sexp) 13 | (let ((url (second sexp))) 14 | (freshline processor) 15 | (raw-string processor "@import ") 16 | (cond 17 | ((consp url) 18 | (raw-string processor "url(") 19 | (raw-string processor (second url)) 20 | (raw-string processor ")")) 21 | (t (raw-string processor (format nil "\"~a\"" url)))) 22 | (raw-string processor ";"))) 23 | 24 | (defun process-css (processor sexp) 25 | (destructuring-bind (selector &rest attributes) sexp 26 | (freshline processor) 27 | (emit-css-selector processor selector) 28 | (freshline processor) 29 | (raw-string processor "{") 30 | (indent processor) 31 | (freshline processor) 32 | (loop for (k v) on attributes by #'cddr do 33 | (process-css-key-or-value processor k) 34 | (raw-string processor ": ") 35 | (process-css-key-or-value processor v) 36 | (raw-string processor ";") 37 | (freshline processor)) 38 | (unindent processor) 39 | (freshline processor) 40 | (raw-string processor "}") 41 | (freshline processor))) 42 | 43 | (defun emit-css-selector (processor selector) 44 | (cond 45 | ((atom selector) 46 | (raw-string processor (string selector))) 47 | ((and (consp selector) (member (first selector) '(or and adjacent))) 48 | (loop with separator = (case (first selector) (or ", ") (and " ") (adjacent " + ")) 49 | for (x . rest) on (rest selector) 50 | do (emit-css-selector processor x) 51 | when rest do (raw-string processor separator))) 52 | (t 53 | (multiple-value-bind (tag class pseudo-class id) (parse-selector selector) 54 | (when tag 55 | (embed-value processor (string tag))) 56 | (when class 57 | (embed-value processor (format nil ".~a" class))) 58 | (when pseudo-class 59 | (embed-value processor (format nil ":~a" pseudo-class))) 60 | (when id 61 | (embed-value processor (format nil "#~a" id))))))) 62 | 63 | (defun parse-selector (selector) 64 | (if (member (first selector) '(:class :pseudo-class :id)) 65 | (destructuring-bind (&key class pseudo-class id) selector 66 | (values nil class pseudo-class id)) 67 | (destructuring-bind (tag &key class pseudo-class id) selector 68 | (values tag class pseudo-class id)))) 69 | 70 | (defun process-css-key-or-value (processor form) 71 | (if (keywordp form) 72 | (embed-value processor (string-downcase form)) 73 | (process processor form))) 74 | 75 | -------------------------------------------------------------------------------- /practicals/Chapter31/embed-foo-with-conditions-and-restarts.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:com.gigamonkeys.html) 2 | 3 | ;; Conditions 4 | 5 | (define-condition embedded-lisp-in-interpreter (error) 6 | ((form :initarg :form :reader form))) 7 | 8 | (define-condition value-in-interpreter (embedded-lisp-in-interpreter) () 9 | (:report 10 | (lambda (c s) 11 | (format s "Can't embed values when interpreting. Value: ~s" (form c))))) 12 | 13 | (define-condition code-in-interpreter (embedded-lisp-in-interpreter) () 14 | (:report 15 | (lambda (c s) 16 | (format s "Can't embed code when interpreting. Code: ~s" (form c))))) 17 | 18 | ;; Implementation with restarts provided 19 | 20 | (defmethod embed-value ((pp html-pretty-printer) value) 21 | (restart-case (error 'value-in-interpreter :form value) 22 | (evaluate () 23 | :report (lambda (s) (format s "EVAL ~s in null lexical environment." value)) 24 | (raw-string pp (escape (princ-to-string (eval value)) *escapes*) t)))) 25 | 26 | (defmethod embed-code ((pp html-pretty-printer) code) 27 | (restart-case (error 'code-in-interpreter :form code) 28 | (evaluate () 29 | :report (lambda (s) (format s "EVAL ~s in null lexical environment." code)) 30 | (eval code)))) 31 | 32 | ;; Restart functions 33 | 34 | (defun evaluate (&optional condition) 35 | (declare (ignore condition)) 36 | (invoke-restart 'evaluate)) 37 | 38 | (defun eval-dynamic-variables (&optional condition) 39 | (when (and (symbolp (form condition)) (boundp (form condition))) 40 | (evaluate))) 41 | 42 | (defun eval-code (&optional condition) 43 | (when (consp (form condition)) 44 | (evaluate))) 45 | 46 | ;; Macro to automate binding of handlers to invoke evaluate restart. 47 | 48 | (defmacro with-dynamic-evaluation ((&key values code) &body body) 49 | `(handler-bind ( 50 | ,@(if values `((value-in-interpreter #'evaluate))) 51 | ,@(if code `((code-in-interpreter #'evaluate)))) 52 | ,@body)) 53 | 54 | 55 | -------------------------------------------------------------------------------- /practicals/Chapter31/html.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.html-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.html-system) 3 | 4 | (defsystem html 5 | :name "html" 6 | :author "Peter Seibel " 7 | :version "1.0" 8 | :maintainer "Peter Seibel " 9 | :licence "BSD" 10 | :description "HTML and CSS generation from sexps." 11 | :long-description "" 12 | :components 13 | ((:file "packages") 14 | (:file "html" :depends-on ("packages")) 15 | (:file "css" :depends-on ("packages" "html"))) 16 | :depends-on (:macro-utilities)) 17 | 18 | -------------------------------------------------------------------------------- /practicals/Chapter31/html.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:com.gigamonkeys.html) 2 | 3 | (defvar *pretty* t) 4 | (defvar *html-output* *standard-output*) 5 | (defvar *html-pretty-printer* nil) 6 | 7 | (defparameter *xhtml* nil) 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;;; Public API 11 | 12 | (defmacro with-html-output ((stream &key (pretty *pretty*)) &body body) 13 | `(let* ((*html-output* ,stream) 14 | (*pretty* ,pretty)) 15 | ,@body)) 16 | 17 | (defmacro with-html-to-file ((file &key (pretty *pretty*)) &body body) 18 | (with-gensyms (stream) 19 | `(with-open-file (,stream ,file :direction :output :if-exists :supersede) 20 | (with-html-output (,stream :pretty ,pretty) 21 | ,@body)))) 22 | 23 | (defmacro in-html-style (syntax) 24 | (eval-when (:compile-toplevel :load-toplevel :execute) 25 | (case syntax 26 | (:html (setf *xhtml* nil)) 27 | (:xhtml (setf *xhtml* t))))) 28 | 29 | (defun emit-html (sexp) (process (get-pretty-printer) sexp)) 30 | 31 | (defmacro html (&whole whole &body body) 32 | (declare (ignore body)) 33 | `(if *pretty* 34 | (macrolet ((html (&body body) (codegen-html (sexp->ops body) t))) 35 | (let ((*html-pretty-printer* (get-pretty-printer))) ,whole)) 36 | (macrolet ((html (&body body) (codegen-html (sexp->ops body) nil))) 37 | ,whole))) 38 | 39 | ;;; Helpers for public API 40 | 41 | (defun get-pretty-printer () 42 | (or *html-pretty-printer* 43 | (make-instance 44 | 'html-pretty-printer 45 | :printer (make-instance 'indenting-printer :out *html-output*)))) 46 | 47 | (defun codegen-html (ops pretty) 48 | (let ((*pretty* pretty)) 49 | `(progn ,@(generate-code (optimize-static-output ops)) nil))) 50 | 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;;; String escaping 54 | 55 | (defparameter *element-escapes* "<>&") 56 | (defparameter *attribute-escapes* "<>&\"'") 57 | (defvar *escapes* *element-escapes*) 58 | 59 | (defun escape-char (char) 60 | (case char 61 | (#\& "&") 62 | (#\< "<") 63 | (#\> ">") 64 | (#\' "'") 65 | (#\" """) 66 | (t (format nil "&#~d;" (char-code char))))) 67 | 68 | (defun escape (in to-escape) 69 | (flet ((needs-escape-p (char) (find char to-escape))) 70 | (with-output-to-string (out) 71 | (loop for start = 0 then (1+ pos) 72 | for pos = (position-if #'needs-escape-p in :start start) 73 | do (write-sequence in out :start start :end pos) 74 | when pos do (write-sequence (escape-char (char in pos)) out) 75 | while pos)))) 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | ;;; indenting-printer 79 | 80 | (defclass indenting-printer () 81 | ((out :accessor out :initarg :out) 82 | (beginning-of-line-p :accessor beginning-of-line-p :initform t) 83 | (indentation :accessor indentation :initform 0) 84 | (indenting-p :accessor indenting-p :initform t))) 85 | 86 | (defun emit (ip string) 87 | (loop for start = 0 then (1+ pos) 88 | for pos = (position #\Newline string :start start) 89 | do (emit/no-newlines ip string :start start :end pos) 90 | when pos do (emit-newline ip) 91 | while pos)) 92 | 93 | (defun emit/no-newlines (ip string &key (start 0) end) 94 | (indent-if-necessary ip) 95 | (write-sequence string (out ip) :start start :end end) 96 | (unless (zerop (- (or end (length string)) start)) 97 | (setf (beginning-of-line-p ip) nil))) 98 | 99 | (defun emit-newline (ip) 100 | (write-char #\Newline (out ip)) 101 | (setf (beginning-of-line-p ip) t)) 102 | 103 | (defun emit-freshline (ip) 104 | (unless (beginning-of-line-p ip) (emit-newline ip))) 105 | 106 | (defun indent-if-necessary (ip) 107 | (when (and (beginning-of-line-p ip) (indenting-p ip)) 108 | (loop repeat (indentation ip) do (write-char #\Space (out ip))) 109 | (setf (beginning-of-line-p ip) nil))) 110 | 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | ;;; html processor interface 113 | 114 | (defgeneric raw-string (processor string &optional check-for-newlines)) 115 | 116 | (defgeneric newline (processor)) 117 | 118 | (defgeneric freshline (processor)) 119 | 120 | (defgeneric indent (processor)) 121 | 122 | (defgeneric unindent (processor)) 123 | 124 | (defgeneric toggle-indenting (processor)) 125 | 126 | (defgeneric embed-value (processor value)) 127 | 128 | (defgeneric embed-code (processor code)) 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | ;;; html-pretty-printer 132 | 133 | (defclass html-pretty-printer () 134 | ((printer :accessor printer :initarg :printer) 135 | (tab-width :accessor tab-width :initarg :tab-width :initform 2))) 136 | 137 | (defmethod raw-string ((pp html-pretty-printer) string &optional newlines-p) 138 | (if newlines-p 139 | (emit (printer pp) string) 140 | (emit/no-newlines (printer pp) string))) 141 | 142 | (defmethod newline ((pp html-pretty-printer)) 143 | (emit-newline (printer pp))) 144 | 145 | (defmethod freshline ((pp html-pretty-printer)) 146 | (when *pretty* (emit-freshline (printer pp)))) 147 | 148 | (defmethod indent ((pp html-pretty-printer)) 149 | (when *pretty* 150 | (incf (indentation (printer pp)) (tab-width pp)))) 151 | 152 | (defmethod unindent ((pp html-pretty-printer)) 153 | (when *pretty* 154 | (decf (indentation (printer pp)) (tab-width pp)))) 155 | 156 | (defmethod toggle-indenting ((pp html-pretty-printer)) 157 | (when *pretty* 158 | (with-slots (indenting-p) (printer pp) 159 | (setf indenting-p (not indenting-p))))) 160 | 161 | (defmethod embed-value ((pp html-pretty-printer) value) 162 | (error "Can't embed values when interpreting. Value: ~s" value)) 163 | 164 | (defmethod embed-code ((pp html-pretty-printer) code) 165 | (error "Can't embed code when interpreting. Code: ~s" code)) 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | ;;; Ops buffer 169 | 170 | (defun make-op-buffer () (make-array 10 :adjustable t :fill-pointer 0)) 171 | 172 | (defun push-op (op ops-buffer) (vector-push-extend op ops-buffer)) 173 | 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | ;;; Compiler 176 | 177 | (defclass html-compiler () 178 | ((ops :accessor ops :initform (make-op-buffer)))) 179 | 180 | (defmethod raw-string ((compiler html-compiler) string &optional newlines-p) 181 | (push-op `(:raw-string ,string ,newlines-p) (ops compiler))) 182 | 183 | (defmethod newline ((compiler html-compiler)) 184 | (push-op '(:newline) (ops compiler))) 185 | 186 | (defmethod freshline ((compiler html-compiler)) 187 | (push-op '(:freshline) (ops compiler))) 188 | 189 | (defmethod indent ((compiler html-compiler)) 190 | (push-op `(:indent) (ops compiler))) 191 | 192 | (defmethod unindent ((compiler html-compiler)) 193 | (push-op `(:unindent) (ops compiler))) 194 | 195 | (defmethod toggle-indenting ((compiler html-compiler)) 196 | (push-op `(:toggle-indenting) (ops compiler))) 197 | 198 | (defmethod embed-value ((compiler html-compiler) value) 199 | (push-op `(:embed-value ,value ,*escapes*) (ops compiler))) 200 | 201 | (defmethod embed-code ((compiler html-compiler) code) 202 | (push-op `(:embed-code ,code) (ops compiler))) 203 | 204 | (defun sexp->ops (body) 205 | (loop with compiler = (make-instance 'html-compiler) 206 | for form in body do (process compiler form) 207 | finally (return (ops compiler)))) 208 | 209 | (defun optimize-static-output (ops) 210 | (let ((new-ops (make-op-buffer))) 211 | (with-output-to-string (buf) 212 | (flet ((add-op (op) 213 | (compile-buffer buf new-ops) 214 | (push-op op new-ops))) 215 | (loop for op across ops do 216 | (ecase (first op) 217 | (:raw-string (write-sequence (second op) buf)) 218 | ((:newline :embed-value :embed-code) (add-op op)) 219 | ((:indent :unindent :freshline :toggle-indenting) 220 | (when *pretty* (add-op op))))) 221 | (compile-buffer buf new-ops))) 222 | new-ops)) 223 | 224 | (defun compile-buffer (buf ops) 225 | "Compile a string possibly containing newlines into a sequence of 226 | :raw-string and :newline ops." 227 | (loop with str = (get-output-stream-string buf) 228 | for start = 0 then (1+ pos) 229 | for pos = (position #\Newline str :start start) 230 | when (< start (length str)) 231 | do (push-op `(:raw-string ,(subseq str start pos) nil) ops) 232 | when pos do (push-op '(:newline) ops) 233 | while pos)) 234 | 235 | (defun generate-code (ops) 236 | (loop for op across ops collect (apply #'op->code op))) 237 | 238 | (defgeneric op->code (op &rest operands)) 239 | 240 | (defmethod op->code ((op (eql :raw-string)) &rest operands) 241 | (destructuring-bind (string check-for-newlines) operands 242 | (if *pretty* 243 | `(raw-string *html-pretty-printer* ,string ,check-for-newlines) 244 | `(write-sequence ,string *html-output*)))) 245 | 246 | (defmethod op->code ((op (eql :newline)) &rest operands) 247 | (if *pretty* 248 | `(newline *html-pretty-printer*) 249 | `(write-char #\Newline *html-output*))) 250 | 251 | (defmethod op->code ((op (eql :freshline)) &rest operands) 252 | (if *pretty* 253 | `(freshline *html-pretty-printer*) 254 | (error "Bad op when not pretty-printing: ~a" op))) 255 | 256 | (defmethod op->code ((op (eql :indent)) &rest operands) 257 | (if *pretty* 258 | `(indent *html-pretty-printer*) 259 | (error "Bad op when not pretty-printing: ~a" op))) 260 | 261 | (defmethod op->code ((op (eql :unindent)) &rest operands) 262 | (if *pretty* 263 | `(unindent *html-pretty-printer*) 264 | (error "Bad op when not pretty-printing: ~a" op))) 265 | 266 | (defmethod op->code ((op (eql :toggle-indenting)) &rest operands) 267 | (if *pretty* 268 | `(toggle-indenting *html-pretty-printer*) 269 | (error "Bad op when not pretty-printing: ~a" op))) 270 | 271 | (defmethod op->code ((op (eql :embed-value)) &rest operands) 272 | (destructuring-bind (value escapes) operands 273 | (if *pretty* 274 | (if escapes 275 | `(raw-string *html-pretty-printer* (escape (princ-to-string ,value) ,escapes) t) 276 | `(raw-string *html-pretty-printer* (princ-to-string ,value) t)) 277 | (if escapes 278 | `(write-sequence (escape (princ-to-string ,value) ,escapes) *html-output*) 279 | `(princ ,value *html-output*))))) 280 | 281 | (defmethod op->code ((op (eql :embed-code)) &rest operands) 282 | (first operands)) 283 | 284 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | ;;; HTML processor. 286 | 287 | (defun process (processor form) 288 | (cond 289 | ((special-form-p form) (process-special-form processor form)) 290 | ((macro-form-p form) (process processor (expand-macro-form form))) 291 | ((sexp-html-p form) (process-sexp-html processor form)) 292 | ((consp form) (embed-code processor form)) 293 | (t (embed-value processor form)))) 294 | 295 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 296 | ;;; Language syntax 297 | 298 | (defun sexp-html-p (form) 299 | (or (self-evaluating-p form) (cons-form-p form))) 300 | 301 | (defun self-evaluating-p (form) 302 | (and (atom form) (if (symbolp form) (keywordp form) t))) 303 | 304 | (defun cons-form-p (form &optional (test #'keywordp)) 305 | (and (consp form) 306 | (or (funcall test (car form)) 307 | (and (consp (car form)) (funcall test (caar form)))))) 308 | 309 | (defun macro-form-p (form) 310 | (cons-form-p form #'(lambda (x) (and (symbolp x) (get x 'html-macro))))) 311 | 312 | (defun special-form-p (form) 313 | (and (consp form) (symbolp (car form)) (get (car form) 'html-special-operator))) 314 | 315 | (defun parse-cons-form (sexp) 316 | (if (consp (first sexp)) 317 | (parse-explicit-attributes-sexp sexp) 318 | (parse-implicit-attributes-sexp sexp))) 319 | 320 | (defun parse-explicit-attributes-sexp (sexp) 321 | (destructuring-bind ((tag &rest attributes) &body body) sexp 322 | (values tag attributes body))) 323 | 324 | (defun parse-implicit-attributes-sexp (sexp) 325 | (loop with tag = (first sexp) 326 | for rest on (rest sexp) by #'cddr 327 | while (and (keywordp (first rest)) (second rest)) 328 | when (second rest) 329 | collect (first rest) into attributes and 330 | collect (second rest) into attributes 331 | end 332 | finally (return (values tag attributes rest)))) 333 | 334 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 335 | ;;; SEXP-HTML 336 | 337 | (defparameter *block-elements* 338 | '(:body :colgroup :dl :fieldset :form :head :html :map :noscript :object 339 | :ol :optgroup :pre :script :select :style :table :tbody :tfoot :thead 340 | :tr :ul)) 341 | 342 | (defparameter *paragraph-elements* 343 | '(:area :base :blockquote :br :button :caption :col :dd :div :dt :h1 344 | :h2 :h3 :h4 :h5 :h6 :hr :input :li :link :meta :option :p :param 345 | :td :textarea :th :title)) 346 | 347 | (defparameter *inline-elements* 348 | '(:a :abbr :acronym :address :b :bdo :big :cite :code :del :dfn :em 349 | :i :img :ins :kbd :label :legend :q :samp :small :span :strong :sub 350 | :sup :tt :var)) 351 | 352 | (defparameter *empty-elements* 353 | '(:area :base :br :col :hr :img :input :link :meta :param)) 354 | 355 | (defparameter *preserve-whitespace-elements* '(:pre :script :style)) 356 | 357 | (defun process-sexp-html (processor form) 358 | (if (self-evaluating-p form) 359 | (raw-string processor (escape (princ-to-string form) *escapes*) t) 360 | (process-cons-sexp-html processor form))) 361 | 362 | (defun process-cons-sexp-html (processor form) 363 | (when (string= *escapes* *attribute-escapes*) 364 | (error "Can't use cons forms in attributes: ~a" form)) 365 | (multiple-value-bind (tag attributes body) (parse-cons-form form) 366 | (emit-open-tag processor tag body attributes) 367 | (emit-element-body processor tag body) 368 | (emit-close-tag processor tag body))) 369 | 370 | (defun emit-open-tag (processor tag body-p attributes) 371 | (when (or (paragraph-element-p tag) (block-element-p tag)) 372 | (freshline processor)) 373 | (raw-string processor (format nil "<~(~a~)" tag)) 374 | (emit-attributes processor attributes) 375 | (raw-string processor (if (and *xhtml* (not body-p)) "/>" ">"))) 376 | 377 | (defun emit-attributes (processor attributes) 378 | (loop for (k v) on attributes by #'cddr do 379 | (raw-string processor (format nil " ~(~a~)='" k)) 380 | (let ((*escapes* *attribute-escapes*)) 381 | (process processor (if (eql v t) (string-downcase k) v))) 382 | (raw-string processor "'"))) 383 | 384 | (defun emit-element-body (processor tag body) 385 | (when (block-element-p tag) 386 | (freshline processor) 387 | (indent processor)) 388 | (when (preserve-whitespace-p tag) (toggle-indenting processor)) 389 | (dolist (item body) (process processor item)) 390 | (when (preserve-whitespace-p tag) (toggle-indenting processor)) 391 | (when (block-element-p tag) 392 | (unindent processor) 393 | (freshline processor))) 394 | 395 | (defun emit-close-tag (processor tag body-p) 396 | (unless (and (or *xhtml* (empty-element-p tag)) (not body-p)) 397 | (raw-string processor (format nil "" tag))) 398 | (when (or (paragraph-element-p tag) (block-element-p tag)) 399 | (freshline processor))) 400 | 401 | (defun block-element-p (tag) (find tag *block-elements*)) 402 | 403 | (defun paragraph-element-p (tag) (find tag *paragraph-elements*)) 404 | 405 | (defun empty-element-p (tag) (find tag *empty-elements*)) 406 | 407 | (defun preserve-whitespace-p (tag) (find tag *preserve-whitespace-elements*)) 408 | 409 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 410 | ;;; Special operators 411 | 412 | (defmacro define-html-special-operator (name (processor &rest other-parameters) &body body) 413 | `(eval-when (:compile-toplevel :load-toplevel :execute) 414 | (setf (get ',name 'html-special-operator) 415 | (lambda (,processor ,@other-parameters) ,@body)))) 416 | 417 | (defun process-special-form (processor form) 418 | (apply (get (car form) 'html-special-operator) processor (rest form))) 419 | 420 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 421 | ;;; Macros 422 | 423 | (defmacro define-html-macro (name (&rest args) &body body) 424 | (multiple-value-bind (attribute-var args) 425 | (parse-html-macro-lambda-list args) 426 | (if attribute-var 427 | (generate-macro-with-attributes name attribute-var args body) 428 | (generate-macro-no-attributes name args body)))) 429 | 430 | (defun generate-macro-with-attributes (name attribute-args args body) 431 | (with-gensyms (attributes form-body) 432 | (if (symbolp attribute-args) (setf attribute-args `(&rest ,attribute-args))) 433 | `(eval-when (:compile-toplevel :load-toplevel :execute) 434 | (setf (get ',name 'html-macro-wants-attributes) t) 435 | (setf (get ',name 'html-macro) 436 | (lambda (,attributes ,form-body) 437 | (destructuring-bind (,@attribute-args) ,attributes 438 | (destructuring-bind (,@args) ,form-body 439 | ,@body))))))) 440 | 441 | (defun generate-macro-no-attributes (name args body) 442 | (with-gensyms (form-body) 443 | `(eval-when (:compile-toplevel :load-toplevel :execute) 444 | (setf (get ',name 'html-macro-wants-attributes) nil) 445 | (setf (get ',name 'html-macro) 446 | (lambda (,form-body) 447 | (destructuring-bind (,@args) ,form-body ,@body)))))) 448 | 449 | (defun parse-html-macro-lambda-list (args) 450 | "Parse a lambda list that can include the &attributes lambda-list-keyword." 451 | (let ((attr-cons (member '&attributes args))) 452 | (values 453 | (cadr attr-cons) 454 | (nconc (ldiff args attr-cons) (cddr attr-cons))))) 455 | 456 | (defun expand-macro-form (form) 457 | (if (or (consp (first form)) 458 | (get (first form) 'html-macro-wants-attributes)) 459 | (multiple-value-bind (tag attributes body) (parse-cons-form form) 460 | (funcall (get tag 'html-macro) attributes body)) 461 | (destructuring-bind (tag &body body) form 462 | (funcall (get tag 'html-macro) body)))) 463 | 464 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 465 | ;;; Special Forms 466 | 467 | (define-html-special-operator :print (processor form) 468 | (cond 469 | ((self-evaluating-p form) 470 | (warn "Redundant :print of self-evaluating form ~s" form) 471 | (process-sexp-html processor form)) 472 | (t 473 | (embed-value processor form)))) 474 | 475 | (define-html-special-operator :format (processor &rest args) 476 | (if (every #'self-evaluating-p args) 477 | (process-sexp-html processor (apply #'format nil args)) 478 | (embed-value processor `(format nil ,@args)))) 479 | 480 | (define-html-special-operator :progn (processor &rest body) 481 | (loop for exp in body do (process processor exp))) 482 | 483 | (define-html-special-operator :noescape (processor &rest body) 484 | (let ((*escapes* nil)) 485 | (loop for exp in body do (process processor exp)))) 486 | 487 | (define-html-special-operator :attribute (processor &rest body) 488 | (let ((*escapes* *attribute-escapes*)) 489 | (loop for exp in body do (process processor exp)))) 490 | 491 | (define-html-special-operator :newline (processor) 492 | (newline processor)) 493 | -------------------------------------------------------------------------------- /practicals/Chapter31/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :com.gigamonkeys.html 4 | (:use :common-lisp :com.gigamonkeys.macro-utilities) 5 | (:export :with-html-output 6 | :with-html-to-file 7 | :in-html-style 8 | :define-html-macro 9 | :define-css-macro 10 | :css 11 | :html 12 | :emit-css 13 | :emit-html 14 | :&attributes)) 15 | -------------------------------------------------------------------------------- /practicals/Chapter32/profiler.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defparameter *timing-data* ()) 4 | 5 | (defmacro with-timing (label &body body) 6 | (with-gensyms (start) 7 | `(let ((,start (get-internal-run-time))) 8 | (unwind-protect (progn ,@body) 9 | (push (list ',label ,start (get-internal-run-time)) *timing-data*))))) 10 | 11 | (defun clear-timing-data () 12 | (setf *timing-data* ())) 13 | 14 | (defun show-timing-data () 15 | (loop for (label time count time-per %-of-total) in (compile-timing-data) do 16 | (format t "~3d% ~a: ~d ticks over ~d calls for ~d per.~%" 17 | %-of-total label time count time-per))) 18 | 19 | (defun compile-timing-data () 20 | (loop with timing-table = (make-hash-table) 21 | with count-table = (make-hash-table) 22 | for (label start end) in *timing-data* 23 | for time = (- end start) 24 | summing time into total 25 | do 26 | (incf (gethash label timing-table 0) time) 27 | (incf (gethash label count-table 0)) 28 | finally 29 | (return 30 | (sort 31 | (loop for label being the hash-keys in timing-table collect 32 | (let ((time (gethash label timing-table)) 33 | (count (gethash label count-table))) 34 | (list label time count (round (/ time count)) (round (* 100 (/ time total)))))) 35 | #'> :key #'fifth)))) 36 | 37 | 38 | -------------------------------------------------------------------------------- /practicals/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005, Peter Seibel All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of the Peter Seibel nor the names of its 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /practicals/README.txt: -------------------------------------------------------------------------------- 1 | This directory contains the source code for _Practical Common Lisp_. You may use 2 | and redestribute this software the terms of the license in file LICENSE. 3 | 4 | The code is designed to be loaded with Another System Definition Facility (ASDF) 5 | and each chapter directory contains its own ASD file. You can either add the 6 | name of each ChapterXX directory to ASDF:*CENTRAL-REGISTRY* or you can create 7 | symlinks to the ASD files in those directories in a directory that is already 8 | named in ASDF:*CENTRAL-REGISTRY*. If you also add this directory to the central 9 | registry or create a symlink to the file practicals.asd, you can then load all 10 | the practicals code by typing: 11 | 12 | (asdf:oos 'asdf:load-op :practicals) 13 | 14 | at the REPL. You can also load the code for individual chapters by loading the 15 | system of the same name as the ASD file in each ChapterXX directory. 16 | 17 | ./Chapter03/simple-database.asd 18 | ./Chapter08/macro-utilities.asd 19 | ./Chapter09/test-framework.asd 20 | ./Chapter15/pathnames.asd 21 | ./Chapter23/spam.asd 22 | ./Chapter24/binary-data.asd 23 | ./Chapter25/id3v2.asd 24 | ./Chapter26/url-function.asd 25 | ./Chapter27/mp3-database.asd 26 | ./Chapter28/shoutcast.asd 27 | ./Chapter29/mp3-browser.asd 28 | ./Chapter31/html.asd 29 | 30 | Thus to load the test framework code from Chapter 9, you'd type: 31 | 32 | (asdf:oos 'asdf:load-op :test-framework) 33 | 34 | at the REPL. (Note that Chapter31/ contains the code for both Chapters 30 and 35 | 31.) 36 | 37 | Alternatively, you can download the Practical Common Lisp, Lisp in a Box 38 | distribution from: 39 | 40 | http://www.gigamonkeys.com/book/lispbox/ 41 | 42 | which provides the easy-to install Emacs + SLIME Lisp development environment 43 | discussed in the book. That distribution contains all the book's code already 44 | set up to be loaded with ASDF. 45 | 46 | --Peter Seibel 47 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/CHANGELOG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/practicals/libraries/cl-ppcre-1.2.3/CHANGELOG -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/README: -------------------------------------------------------------------------------- 1 | Complete documentation for CL-PPCRE can be found in the 'doc' 2 | directory. 3 | 4 | CL-PPCRE also supports Nikodemus Siivola's HYPERDOC, see 5 | and 6 | . 7 | 8 | 1. Installation 9 | 10 | 1.1. Probably the easiest way is 11 | 12 | (load "/path/to/cl-ppcre/load.lisp") 13 | 14 | This should compile and load CL-PPCRE on most Common Lisp 15 | implementations. 16 | 17 | 1.2. With MK:DEFSYSTEM you can make a symbolic link from 18 | 'cl-ppcre.system' and 'cl-ppcre-test.system' to your central registry 19 | (which by default is in '/usr/local/lisp/Registry/') and then issue 20 | the command 21 | 22 | (mk:compile-system "cl-ppcre") 23 | 24 | Note that this relies on TRUENAME returning the original file a 25 | symbolic link is pointing to. This will only work with AllegroCL 26 | 6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO). 27 | 28 | 1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way 29 | (use the .asd files instead of the .system files). 30 | 31 | 2. Test 32 | 33 | CL-PPCRE comes with a test suite that can be used to check its 34 | compatibility with Perl's regex syntax. See the documentation on how 35 | to use this test suite for benchmarks and on how to write your own 36 | tests. 37 | 38 | 2.1. If you've used 'load.lisp' to load CL-PPCRE you already have the 39 | test suite loaded and can start the default tests with 40 | 41 | (cl-ppcre-test:test) 42 | 43 | 2.2. With MK:DEFSYSTEM you need to compile the 'cl-ppcre-test' system 44 | as well before you can proceed as in 2.1. 45 | 46 | 2.3. Same for ASDF. 47 | 48 | Depending on your machine and your CL implementation the default test 49 | will take between a few seconds and a couple of minutes. (It will 50 | print a dot for every tenth test case while it proceeds to give some 51 | visual feedback.) It should exactly report three 'errors' (662, 790, 52 | and 1439) which are explained in the documentation. 53 | 54 | MCL might report an error for the ninth test case which is also 55 | explained in the docs. 56 | 57 | Genera notes (thanks to Patrick O'Donnell): Some more tests will fail 58 | because characters like #\Return, #\Linefeed, or #\Tab have encodings 59 | which differ from Perl's (and thus CL-PPCRE's) expectations. 60 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/cl-ppcre-test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.asd,v 1.6 2004/04/20 11:37:35 edi Exp $ 3 | 4 | ;;; This ASDF system definition was kindly provided by Marco Baringer. 5 | 6 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 7 | 8 | ;;; Redistribution and use in source and binary forms, with or without 9 | ;;; modification, are permitted provided that the following conditions 10 | ;;; are met: 11 | 12 | ;;; * Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | 15 | ;;; * Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials 18 | ;;; provided with the distribution. 19 | 20 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 21 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 24 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 26 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | (defpackage #:cl-ppcre-test.system 33 | (:use #:cl 34 | #:asdf)) 35 | 36 | (in-package #:cl-ppcre-test.system) 37 | 38 | (defsystem #:cl-ppcre-test 39 | :depends-on (#:cl-ppcre) 40 | :components ((:file "ppcre-tests"))) 41 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/cl-ppcre-test.system: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.system,v 1.8 2004/04/20 11:37:35 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package #:cl-user) 31 | 32 | (defparameter *cl-ppcre-test-base-directory* 33 | (make-pathname :name nil :type nil :version nil 34 | :defaults (parse-namestring *load-truename*))) 35 | 36 | (mk:defsystem #:cl-ppcre-test 37 | :source-pathname *cl-ppcre-test-base-directory* 38 | :source-extension "lisp" 39 | :depends-on (#:cl-ppcre) 40 | :components ((:file "ppcre-tests"))) 41 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/cl-ppcre.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.asd,v 1.9 2005/01/24 14:06:38 edi Exp $ 3 | 4 | ;;; This ASDF system definition was kindly provided by Marco Baringer. 5 | 6 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 7 | 8 | ;;; Redistribution and use in source and binary forms, with or without 9 | ;;; modification, are permitted provided that the following conditions 10 | ;;; are met: 11 | 12 | ;;; * Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | 15 | ;;; * Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials 18 | ;;; provided with the distribution. 19 | 20 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 21 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 24 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 26 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | (defpackage #:cl-ppcre.system 33 | (:use #:cl 34 | #:asdf)) 35 | 36 | (in-package #:cl-ppcre.system) 37 | 38 | (defsystem #:cl-ppcre 39 | :serial t 40 | :components ((:file "packages") 41 | (:file "specials") 42 | (:file "util") 43 | (:file "errors") 44 | #-:use-acl-regexp2-engine 45 | (:file "lexer") 46 | #-:use-acl-regexp2-engine 47 | (:file "parser") 48 | #-:use-acl-regexp2-engine 49 | (:file "regex-class") 50 | #-:use-acl-regexp2-engine 51 | (:file "convert") 52 | #-:use-acl-regexp2-engine 53 | (:file "optimize") 54 | #-:use-acl-regexp2-engine 55 | (:file "closures") 56 | #-:use-acl-regexp2-engine 57 | (:file "repetition-closures") 58 | #-:use-acl-regexp2-engine 59 | (:file "scanner") 60 | (:file "api"))) 61 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/cl-ppcre.system: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.system,v 1.10 2005/01/24 20:22:27 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package #:cl-user) 31 | 32 | (defparameter *cl-ppcre-base-directory* 33 | (make-pathname :name nil :type nil :version nil 34 | :defaults (parse-namestring *load-truename*))) 35 | 36 | (mk:defsystem #:cl-ppcre 37 | :source-pathname *cl-ppcre-base-directory* 38 | :source-extension "lisp" 39 | :components ((:file "packages") 40 | (:file "specials" :depends-on ("packages")) 41 | (:file "util" :depends-on ("packages")) 42 | (:file "errors" :depends-on ("util")) 43 | #-:use-acl-regexp2-engine 44 | (:file "lexer" :depends-on ("errors" "specials")) 45 | #-:use-acl-regexp2-engine 46 | (:file "parser" :depends-on ("lexer")) 47 | #-:use-acl-regexp2-engine 48 | (:file "regex-class" :depends-on ("parser")) 49 | #-:use-acl-regexp2-engine 50 | (:file "convert" :depends-on ("regex-class")) 51 | #-:use-acl-regexp2-engine 52 | (:file "optimize" :depends-on ("convert")) 53 | #-:use-acl-regexp2-engine 54 | (:file "closures" :depends-on ("optimize" "specials")) 55 | #-:use-acl-regexp2-engine 56 | (:file "repetition-closures" :depends-on ("closures")) 57 | #-:use-acl-regexp2-engine 58 | (:file "scanner" :depends-on ("repetition-closures")) 59 | (:file "api" :depends-on ("scanner")))) 60 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/errors.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/errors.lisp,v 1.13 2004/09/30 09:58:42 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package #:cl-ppcre) 31 | 32 | (defvar *syntax-error-string* nil 33 | "The string which caused the syntax error.") 34 | 35 | (define-condition ppcre-error (simple-error) 36 | () 37 | (:documentation "All errors signaled by CL-PPCRE are of 38 | this type.")) 39 | 40 | (define-condition ppcre-syntax-error (ppcre-error) 41 | ((string :initarg :string 42 | :reader ppcre-syntax-error-string) 43 | (pos :initarg :pos 44 | :reader ppcre-syntax-error-pos)) 45 | (:default-initargs 46 | :pos nil 47 | :string *syntax-error-string*) 48 | (:report (lambda (condition stream) 49 | (format stream "~?~@[ at position ~A~]~@[ in string ~S~]" 50 | (simple-condition-format-control condition) 51 | (simple-condition-format-arguments condition) 52 | (ppcre-syntax-error-pos condition) 53 | (ppcre-syntax-error-string condition)))) 54 | (:documentation "Signaled if CL-PPCRE's parser encounters an error 55 | when trying to parse a regex string or to convert a parse tree into 56 | its internal representation.")) 57 | 58 | (setf (documentation 'ppcre-syntax-error-string 'function) 59 | "Returns the string the parser was parsing when the error was 60 | encountered \(or NIL if the error happened while trying to convert a 61 | parse tree).") 62 | 63 | (setf (documentation 'ppcre-syntax-error-pos 'function) 64 | "Returns the position within the string where the error occured 65 | \(or NIL if the error happened while trying to convert a parse tree") 66 | 67 | (define-condition ppcre-invocation-error (ppcre-error) 68 | () 69 | (:documentation "Signaled when CL-PPCRE functions are 70 | invoked with wrong arguments.")) 71 | 72 | (defmacro signal-ppcre-syntax-error* (pos format-control &rest format-arguments) 73 | `(error 'ppcre-syntax-error 74 | :pos ,pos 75 | :format-control ,format-control 76 | :format-arguments (list ,@format-arguments))) 77 | 78 | (defmacro signal-ppcre-syntax-error (format-control &rest format-arguments) 79 | `(signal-ppcre-syntax-error* nil ,format-control ,@format-arguments)) 80 | 81 | (defmacro signal-ppcre-invocation-error (format-control &rest format-arguments) 82 | `(error 'ppcre-invocation-error 83 | :format-control ,format-control 84 | :format-arguments (list ,@format-arguments))) 85 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/load.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/load.lisp,v 1.12 2005/02/02 18:34:30 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-user) 31 | 32 | (let ((cl-ppcre-base-directory 33 | (make-pathname :name nil :type nil :version nil 34 | :defaults (parse-namestring *load-truename*))) 35 | must-compile) 36 | (with-compilation-unit () 37 | (dolist (file '("packages" 38 | "specials" 39 | "util" 40 | "errors" 41 | #-:use-acl-regexp2-engine "lexer" 42 | #-:use-acl-regexp2-engine "parser" 43 | #-:use-acl-regexp2-engine "regex-class" 44 | #-:use-acl-regexp2-engine "convert" 45 | #-:use-acl-regexp2-engine "optimize" 46 | #-:use-acl-regexp2-engine "closures" 47 | #-:use-acl-regexp2-engine "repetition-closures" 48 | #-:use-acl-regexp2-engine "scanner" 49 | "api" 50 | "ppcre-tests")) 51 | (let ((pathname (make-pathname :name file :type "lisp" :version nil 52 | :defaults cl-ppcre-base-directory))) 53 | ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD 54 | ;; will yield compiled functions anyway 55 | #-:cormanlisp 56 | (let ((compiled-pathname (compile-file-pathname pathname))) 57 | (unless (and (not must-compile) 58 | (probe-file compiled-pathname) 59 | (< (file-write-date pathname) 60 | (file-write-date compiled-pathname))) 61 | (setq must-compile t) 62 | (compile-file pathname)) 63 | (setq pathname compiled-pathname)) 64 | (load pathname))))) 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/packages.lisp,v 1.17 2004/09/30 09:58:42 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-user) 31 | 32 | #-:cormanlisp 33 | (defpackage #:cl-ppcre 34 | (:nicknames #:ppcre) 35 | #+genera (:shadowing-import-from #:common-lisp #:lambda #:simple-string #:string) 36 | (:use #-genera #:cl #+genera #:future-common-lisp) 37 | (:export #:create-scanner 38 | #:parse-tree-synonym 39 | #:define-parse-tree-synonym 40 | #:scan 41 | #:scan-to-strings 42 | #:do-scans 43 | #:do-matches 44 | #:do-matches-as-strings 45 | #:all-matches 46 | #:all-matches-as-strings 47 | #:split 48 | #:regex-replace 49 | #:regex-replace-all 50 | #:regex-apropos 51 | #:regex-apropos-list 52 | #:quote-meta-chars 53 | #:*regex-char-code-limit* 54 | #:*use-bmh-matchers* 55 | #:*allow-quoting* 56 | #:ppcre-error 57 | #:ppcre-invocation-error 58 | #:ppcre-syntax-error 59 | #:ppcre-syntax-error-string 60 | #:ppcre-syntax-error-pos 61 | #:register-groups-bind 62 | #:do-register-groups)) 63 | 64 | #+:cormanlisp 65 | (defpackage "CL-PPCRE" 66 | (:nicknames "PPCRE") 67 | (:use "CL") 68 | (:export "CREATE-SCANNER" 69 | "PARSE-TREE-SYNONYM" 70 | "DEFINE-PARSE-TREE-SYNONYM" 71 | "SCAN" 72 | "SCAN-TO-STRINGS" 73 | "DO-SCANS" 74 | "DO-MATCHES" 75 | "DO-MATCHES-AS-STRINGS" 76 | "ALL-MATCHES" 77 | "ALL-MATCHES-AS-STRINGS" 78 | "SPLIT" 79 | "REGEX-REPLACE" 80 | "REGEX-REPLACE-ALL" 81 | "REGEX-APROPOS" 82 | "REGEX-APROPOS-LIST" 83 | "QUOTE-META-CHARS" 84 | "*REGEX-CHAR-CODE-LIMIT*" 85 | "*USE-BMH-MATCHERS*" 86 | "*ALLOW-QUOTING*" 87 | "PPCRE-ERROR" 88 | "PPCRE-INVOCATION-ERROR" 89 | "PPCRE-SYNTAX-ERROR" 90 | "PPCRE-SYNTAX-ERROR-STRING" 91 | "PPCRE-SYNTAX-ERROR-POS" 92 | "REGISTER-GROUPS-BIND" 93 | "DO-REGISTER-GROUPS")) 94 | 95 | #-:cormanlisp 96 | (defpackage #:cl-ppcre-test 97 | #+genera (:shadowing-import-from #:common-lisp #:lambda) 98 | (:use #-genera #:cl #+genera #:future-common-lisp #:cl-ppcre) 99 | (:export #:test)) 100 | 101 | #+:cormanlisp 102 | (defpackage "CL-PPCRE-TEST" 103 | (:use "CL" "CL-PPCRE") 104 | (:export "TEST")) 105 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/parser.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/parser.lisp,v 1.17 2004/04/20 11:37:36 edi Exp $ 3 | 4 | ;;; The parser will - with the help of the lexer - parse a regex 5 | ;;; string and convert it into a "parse tree" (see docs for details 6 | ;;; about the syntax of these trees). Note that the lexer might return 7 | ;;; illegal parse trees. It is assumed that the conversion process 8 | ;;; later on will track them down. 9 | 10 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 11 | 12 | ;;; Redistribution and use in source and binary forms, with or without 13 | ;;; modification, are permitted provided that the following conditions 14 | ;;; are met: 15 | 16 | ;;; * Redistributions of source code must retain the above copyright 17 | ;;; notice, this list of conditions and the following disclaimer. 18 | 19 | ;;; * Redistributions in binary form must reproduce the above 20 | ;;; copyright notice, this list of conditions and the following 21 | ;;; disclaimer in the documentation and/or other materials 22 | ;;; provided with the distribution. 23 | 24 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 25 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 26 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 27 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 28 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 30 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 31 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 32 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 33 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 34 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package #:cl-ppcre) 37 | 38 | (defun group (lexer) 39 | (declare (optimize speed 40 | (safety 0) 41 | (space 0) 42 | (debug 0) 43 | (compilation-speed 0) 44 | #+:lispworks (hcl:fixnum-safety 0))) 45 | "Parses and consumes a . 46 | The productions are: -> \"(\"\")\" 47 | \"(?:\"\")\" 48 | \"(?<\"\")\" 49 | \"(?:\"\")\" 50 | \"(?=\"\")\" 51 | \"(?!\"\")\" 52 | \"(?<=\"\")\" 53 | \"(?\")\" 54 | \"(?(\"\")\"\")\" 55 | \"(?(\"\")\"\")\" 56 | 57 | where is parsed by the lexer function MAYBE-PARSE-FLAGS. 58 | Will return or ( ) where 59 | is one of six keywords - see source for details." 60 | (multiple-value-bind (open-token flags) 61 | (get-token lexer) 62 | (cond ((eq open-token :open-paren-paren) 63 | ;; special case for conditional regular expressions; note 64 | ;; that at this point we accept a couple of illegal 65 | ;; combinations which'll be sorted out later by the 66 | ;; converter 67 | (let* ((open-paren-pos (car (lexer-last-pos lexer))) 68 | ;; check if what follows "(?(" is a number 69 | (number (try-number lexer :no-whitespace-p t)) 70 | ;; make changes to extended-mode-p local 71 | (*extended-mode-p* *extended-mode-p*)) 72 | (declare (type fixnum open-paren-pos)) 73 | (cond (number 74 | ;; condition is a number (i.e. refers to a 75 | ;; back-reference) 76 | (let* ((inner-close-token (get-token lexer)) 77 | (reg-expr (reg-expr lexer)) 78 | (close-token (get-token lexer))) 79 | (unless (eq inner-close-token :close-paren) 80 | (signal-ppcre-syntax-error* 81 | (+ open-paren-pos 2) 82 | "Opening paren has no matching closing paren")) 83 | (unless (eq close-token :close-paren) 84 | (signal-ppcre-syntax-error* 85 | open-paren-pos 86 | "Opening paren has no matching closing paren")) 87 | (list :branch number reg-expr))) 88 | (t 89 | ;; condition must be a full regex (actually a 90 | ;; look-behind or look-ahead); and here comes a 91 | ;; terrible kludge: instead of being cleanly 92 | ;; separated from the lexer, the parser pushes 93 | ;; back the lexer by one position, thereby 94 | ;; landing in the middle of the 'token' "(?(" - 95 | ;; yuck!! 96 | (decf (lexer-pos lexer)) 97 | (let* ((inner-reg-expr (group lexer)) 98 | (reg-expr (reg-expr lexer)) 99 | (close-token (get-token lexer))) 100 | (unless (eq close-token :close-paren) 101 | (signal-ppcre-syntax-error* 102 | open-paren-pos 103 | "Opening paren has no matching closing paren")) 104 | (list :branch inner-reg-expr reg-expr)))))) 105 | ((member open-token '(:open-paren 106 | :open-paren-colon 107 | :open-paren-greater 108 | :open-paren-equal 109 | :open-paren-exclamation 110 | :open-paren-less-equal 111 | :open-paren-less-exclamation) 112 | :test #'eq) 113 | ;; make changes to extended-mode-p local 114 | (let ((*extended-mode-p* *extended-mode-p*)) 115 | ;; we saw one of the six token representing opening 116 | ;; parentheses 117 | (let* ((open-paren-pos (car (lexer-last-pos lexer))) 118 | (reg-expr (reg-expr lexer)) 119 | (close-token (get-token lexer))) 120 | (when (eq open-token :open-paren) 121 | ;; if this is the "("")" production we have to 122 | ;; increment the register counter of the lexer 123 | (incf (lexer-reg lexer))) 124 | (unless (eq close-token :close-paren) 125 | ;; the token following must be the closing 126 | ;; parenthesis or this is a syntax error 127 | (signal-ppcre-syntax-error* 128 | open-paren-pos 129 | "Opening paren has no matching closing paren")) 130 | (if flags 131 | ;; if the lexer has returned a list of flags this must 132 | ;; have been the "(?:"")" production 133 | (cons :group (nconc flags (list reg-expr))) 134 | (list (case open-token 135 | ((:open-paren) 136 | :register) 137 | ((:open-paren-colon) 138 | :group) 139 | ((:open-paren-greater) 140 | :standalone) 141 | ((:open-paren-equal) 142 | :positive-lookahead) 143 | ((:open-paren-exclamation) 144 | :negative-lookahead) 145 | ((:open-paren-less-equal) 146 | :positive-lookbehind) 147 | ((:open-paren-less-exclamation) 148 | :negative-lookbehind)) 149 | reg-expr))))) 150 | (t 151 | ;; this is the production; is 152 | ;; any token which passes START-OF-SUBEXPR-P (otherwise 153 | ;; parsing had already stopped in the SEQ method) 154 | open-token)))) 155 | 156 | (defun greedy-quant (lexer) 157 | (declare (optimize speed 158 | (safety 0) 159 | (space 0) 160 | (debug 0) 161 | (compilation-speed 0) 162 | #+:lispworks (hcl:fixnum-safety 0))) 163 | "Parses and consumes a . 164 | The productions are: -> | 165 | where is parsed by the lexer function GET-QUANTIFIER. 166 | Will return or (:GREEDY-REPETITION )." 167 | (let* ((group (group lexer)) 168 | (token (get-quantifier lexer))) 169 | (if token 170 | ;; if GET-QUANTIFIER returned a non-NIL value it's the 171 | ;; two-element list ( ) 172 | (list :greedy-repetition (first token) (second token) group) 173 | group))) 174 | 175 | (defun quant (lexer) 176 | (declare (optimize speed 177 | (safety 0) 178 | (space 0) 179 | (debug 0) 180 | (compilation-speed 0) 181 | #+:lispworks (hcl:fixnum-safety 0))) 182 | "Parses and consumes a . 183 | The productions are: -> | \"?\". 184 | Will return the returned by GREEDY-QUANT and optionally 185 | change :GREEDY-REPETITION to :NON-GREEDY-REPETITION." 186 | (let* ((greedy-quant (greedy-quant lexer)) 187 | (pos (lexer-pos lexer)) 188 | (next-char (next-char lexer))) 189 | (when next-char 190 | (if (char= next-char #\?) 191 | (setf (car greedy-quant) :non-greedy-repetition) 192 | (setf (lexer-pos lexer) pos))) 193 | greedy-quant)) 194 | 195 | (defun seq (lexer) 196 | (declare (optimize speed 197 | (safety 0) 198 | (space 0) 199 | (debug 0) 200 | (compilation-speed 0) 201 | #+:lispworks (hcl:fixnum-safety 0))) 202 | "Parses and consumes a . 203 | The productions are: -> | . 204 | Will return or (:SEQUENCE )." 205 | (flet ((make-array-from-two-chars (char1 char2) 206 | (let ((string (make-array 2 207 | :element-type 'character 208 | :fill-pointer t 209 | :adjustable t))) 210 | (setf (aref string 0) char1) 211 | (setf (aref string 1) char2) 212 | string))) 213 | ;; Note that we're calling START-OF-SUBEXPR-P before we actually try 214 | ;; to parse a or in order to catch empty regular 215 | ;; expressions 216 | (if (start-of-subexpr-p lexer) 217 | (let ((quant (quant lexer))) 218 | (if (start-of-subexpr-p lexer) 219 | (let* ((seq (seq lexer)) 220 | (quant-is-char-p (characterp quant)) 221 | (seq-is-sequence-p (and (consp seq) 222 | (eq (first seq) :sequence)))) 223 | (cond ((and quant-is-char-p 224 | (characterp seq)) 225 | (make-array-from-two-chars seq quant)) 226 | ((and quant-is-char-p 227 | (stringp seq)) 228 | (vector-push-extend quant seq) 229 | seq) 230 | ((and quant-is-char-p 231 | seq-is-sequence-p 232 | (characterp (second seq))) 233 | (cond ((cddr seq) 234 | (setf (cdr seq) 235 | (cons 236 | (make-array-from-two-chars (second seq) 237 | quant) 238 | (cddr seq))) 239 | seq) 240 | (t (make-array-from-two-chars (second seq) quant)))) 241 | ((and quant-is-char-p 242 | seq-is-sequence-p 243 | (stringp (second seq))) 244 | (cond ((cddr seq) 245 | (setf (cdr seq) 246 | (cons 247 | (progn 248 | (vector-push-extend quant (second seq)) 249 | (second seq)) 250 | (cddr seq))) 251 | seq) 252 | (t 253 | (vector-push-extend quant (second seq)) 254 | (second seq)))) 255 | (seq-is-sequence-p 256 | ;; if is also a :SEQUENCE parse tree we merge 257 | ;; both lists into one to avoid unnecessary consing 258 | (setf (cdr seq) 259 | (cons quant (cdr seq))) 260 | seq) 261 | (t (list :sequence quant seq)))) 262 | quant)) 263 | :void))) 264 | 265 | (defun reg-expr (lexer) 266 | (declare (optimize speed 267 | (safety 0) 268 | (space 0) 269 | (debug 0) 270 | (compilation-speed 0) 271 | #+:lispworks (hcl:fixnum-safety 0))) 272 | "Parses and consumes a , a complete regular expression. 273 | The productions are: -> | \"|\". 274 | Will return or (:ALTERNATION )." 275 | (let ((pos (lexer-pos lexer))) 276 | (case (next-char lexer) 277 | ((nil) 278 | ;; if we didn't get any token we return :VOID which stands for 279 | ;; "empty regular expression" 280 | :void) 281 | ((#\|) 282 | ;; now check whether the expression started with a vertical 283 | ;; bar, i.e. - the left alternation - is empty 284 | (list :alternation :void (reg-expr lexer))) 285 | (otherwise 286 | ;; otherwise un-read the character we just saw and parse a 287 | ;; plus the character following it 288 | (setf (lexer-pos lexer) pos) 289 | (let* ((seq (seq lexer)) 290 | (pos (lexer-pos lexer))) 291 | (case (next-char lexer) 292 | ((nil) 293 | ;; no further character, just a 294 | seq) 295 | ((#\|) 296 | ;; if the character was a vertical bar, this is an 297 | ;; alternation and we have the second production 298 | (let ((reg-expr (reg-expr lexer))) 299 | (cond ((and (consp reg-expr) 300 | (eq (first reg-expr) :alternation)) 301 | ;; again we try to merge as above in SEQ 302 | (setf (cdr reg-expr) 303 | (cons seq (cdr reg-expr))) 304 | reg-expr) 305 | (t (list :alternation seq reg-expr))))) 306 | (otherwise 307 | ;; a character which is not a vertical bar - this is 308 | ;; either a syntax error or we're inside of a group and 309 | ;; the next character is a closing parenthesis; so we 310 | ;; just un-read the character and let another function 311 | ;; take care of it 312 | (setf (lexer-pos lexer) pos) 313 | seq))))))) 314 | 315 | (defun reverse-strings (parse-tree) 316 | (declare (optimize speed 317 | (safety 0) 318 | (space 0) 319 | (debug 0) 320 | (compilation-speed 0) 321 | #+:lispworks (hcl:fixnum-safety 0))) 322 | (cond ((stringp parse-tree) 323 | (nreverse parse-tree)) 324 | ((consp parse-tree) 325 | (loop for parse-tree-rest on parse-tree 326 | while parse-tree-rest 327 | do (setf (car parse-tree-rest) 328 | (reverse-strings (car parse-tree-rest)))) 329 | parse-tree) 330 | (t parse-tree))) 331 | 332 | (defun parse-string (string) 333 | (declare (optimize speed 334 | (safety 0) 335 | (space 0) 336 | (debug 0) 337 | (compilation-speed 0) 338 | #+:lispworks (hcl:fixnum-safety 0))) 339 | "Translate the regex string STRING into a parse tree." 340 | (let* ((lexer (make-lexer string)) 341 | (parse-tree (reverse-strings (reg-expr lexer)))) 342 | ;; check whether we've consumed the whole regex string 343 | (if (end-of-string-p lexer) 344 | parse-tree 345 | (signal-ppcre-syntax-error* 346 | (lexer-pos lexer) 347 | "Expected end of string")))) -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/perltest.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # This is a heavily modified version of the file 'perltest' which 4 | # comes with the PCRE library package, which is open source software, 5 | # written by Philip Hazel, and copyright by the University of 6 | # Cambridge, England. 7 | 8 | # The PCRE library package is available from 9 | # 10 | 11 | use Time::HiRes qw(time); 12 | 13 | sub string_for_lisp { 14 | my(@a, $t, $in_string, $switch); 15 | 16 | my $string = shift; 17 | $string =~ s/\\/\\\\/g; 18 | $string =~ s/"/\\"/g; 19 | 20 | return "\"$string\"" 21 | if $string =~ /^[\n\x20-\x7f]*$/; 22 | 23 | $in_string = 1; 24 | foreach $c (split(//, $string)) { 25 | if (ord $c >= 32 and ord $c < 127) { 26 | if ($in_string) { 27 | $t .= $c; 28 | } else { 29 | $in_string = 1; 30 | $t = $c; 31 | } 32 | } else { 33 | if ($in_string) { 34 | push @a, "\"$t\""; 35 | $in_string = 0; 36 | $switch = 1; 37 | } 38 | push @a, ord $c; 39 | } 40 | } 41 | if ($switch) { 42 | if ($in_string) { 43 | push @a, "\"$t\""; 44 | } 45 | '(' . (join ' ', @a) . ')'; 46 | } else { 47 | "\"$t\""; 48 | } 49 | } 50 | 51 | $min_time = shift; 52 | 53 | NEXT_RE: while (1) { 54 | last 55 | if !($_ = <>); 56 | next 57 | if $_ eq ""; 58 | 59 | $pattern = $_; 60 | 61 | while ($pattern !~ /^\s*(.).*\1/s) { 62 | last 63 | if !($_ = <>); 64 | $pattern .= $_; 65 | } 66 | 67 | chomp($pattern); 68 | $pattern =~ s/\s+$//; 69 | $pattern =~ s/\+(?=[a-z]*$)//; 70 | 71 | $multi_line_mode = ($pattern =~ /m[a-z]*$/) ? 't' : 'nil'; 72 | $single_line_mode = ($pattern =~ /s[a-z]*$/) ? 't' : 'nil'; 73 | $extended_mode = ($pattern =~ /x[a-z]*$/) ? 't' : 'nil'; 74 | $case_insensitive_mode = ($pattern =~ /i[a-z]*$/) ? 't' : 'nil'; 75 | $pattern =~ s/^(.*)g([a-z]*)$/\1\2/; 76 | 77 | $pattern_for_lisp = $pattern; 78 | $pattern_for_lisp =~ s/[a-z]*$//; 79 | $pattern_for_lisp =~ s/^\s*(.)(.*)\1/$2/s; 80 | $pattern_for_lisp =~ s/\\/\\\\/g; 81 | $pattern_for_lisp =~ s/"/\\"/g; 82 | 83 | $pattern = "/(?#)/$2" 84 | if ($pattern =~ /^(.)\1(.*)$/); 85 | 86 | while (1) { 87 | last NEXT_RE 88 | if !($_ = <>); 89 | 90 | chomp; 91 | 92 | s/\s+$//; 93 | s/^\s+//; 94 | 95 | last 96 | if ($_ eq ""); 97 | 98 | $info_string = string_for_lisp "\"$_\" =~ $pattern"; 99 | $x = eval "\"$_\""; 100 | 101 | @subs = (); 102 | 103 | eval <<"END"; 104 | if (\$x =~ ${pattern}) { 105 | push \@subs,\$&; 106 | push \@subs,\$1; 107 | push \@subs,\$2; 108 | push \@subs,\$3; 109 | push \@subs,\$4; 110 | push \@subs,\$5; 111 | push \@subs,\$6; 112 | push \@subs,\$7; 113 | push \@subs,\$8; 114 | push \@subs,\$9; 115 | push \@subs,\$10; 116 | push \@subs,\$11; 117 | push \@subs,\$12; 118 | push \@subs,\$13; 119 | push \@subs,\$14; 120 | push \@subs,\$15; 121 | push \@subs,\$16; 122 | } 123 | 124 | \$test = sub { 125 | my \$times = shift; 126 | 127 | my \$start = time; 128 | for (my \$i = 0; \$i < \$times; \$i++) { 129 | \$x =~ ${pattern}; 130 | } 131 | return time - \$start; 132 | }; 133 | END 134 | 135 | $times = 1; 136 | $used = 0; 137 | $counter++; 138 | print STDERR "$counter\n"; 139 | 140 | if ($@) { 141 | $error = 't'; 142 | } else { 143 | $error = 'nil'; 144 | if ($min_time) { 145 | $times = 10; 146 | while (1) { 147 | $used = &$test($times); 148 | last 149 | if $used > $min_time; 150 | $times *= 10; 151 | } 152 | } 153 | } 154 | 155 | print "($counter $info_string \"$pattern_for_lisp\" $case_insensitive_mode $multi_line_mode $single_line_mode $extended_mode " . string_for_lisp($x) . " $error $times $used "; 156 | if (!@subs) { 157 | print 'nil nil'; 158 | } else { 159 | print string_for_lisp($subs[0]) . ' ('; 160 | undef $not_first; 161 | for ($i = 1; $i <= 16; $i++) { 162 | print ' ' 163 | unless $i == 1; 164 | if (defined $subs[$i]) { 165 | print string_for_lisp $subs[$i]; 166 | } else { 167 | print 'nil'; 168 | } 169 | } 170 | print ')'; 171 | } 172 | print ")\n"; 173 | } 174 | } 175 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/ppcre-tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/ppcre-tests.lisp,v 1.26 2004/09/30 09:58:42 edi Exp $ 3 | 4 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package #:cl-ppcre-test) 31 | 32 | (defparameter *cl-ppcre-test-base-directory* 33 | (make-pathname :name nil :type nil :version nil 34 | :defaults (parse-namestring *load-truename*))) 35 | 36 | (defun full-gc () 37 | "Start a full garbage collection." 38 | ;; what are the corresponding values for MCL and OpenMCL? 39 | #+:allegro (excl:gc t) 40 | #+(or :cmu :scl) (ext:gc :full t) 41 | #+:ecl (si:gc t) 42 | #+:clisp (ext:gc) 43 | #+:cormanlisp (loop for i from 0 to 3 do (cormanlisp:gc i)) 44 | #+:lispworks (hcl:mark-and-sweep 3) 45 | #+:sbcl (sb-ext:gc :full t)) 46 | 47 | ;; warning: ugly code ahead!! 48 | ;; this is just a quick hack for testing purposes 49 | 50 | (defun time-regex (factor regex string 51 | &key case-insensitive-mode 52 | multi-line-mode 53 | single-line-mode 54 | extended-mode) 55 | (declare (optimize speed 56 | (safety 0) 57 | (space 0) 58 | (debug 0) 59 | (compilation-speed 0) 60 | #+:lispworks (hcl:fixnum-safety 0))) 61 | "Auxiliary function used by TEST to benchmark a regex scanner 62 | against Perl timings." 63 | (declare (type string string)) 64 | (let* ((scanner (create-scanner regex 65 | :case-insensitive-mode case-insensitive-mode 66 | :multi-line-mode multi-line-mode 67 | :single-line-mode single-line-mode 68 | :extended-mode extended-mode)) 69 | ;; make sure GC doesn't invalidate our benchmarking 70 | (dummy (full-gc)) 71 | (start (get-internal-real-time))) 72 | (declare (ignore dummy)) 73 | (dotimes (i factor) 74 | (funcall scanner string 0 (length string))) 75 | (float (/ (- (get-internal-real-time) start) internal-time-units-per-second)))) 76 | 77 | #+(or scl 78 | lispworks 79 | (and sbcl sb-thread)) 80 | (defun threaded-scan (scanner target-string &key (threads 10) (repetitions 5000)) 81 | (declare (optimize speed 82 | (safety 0) 83 | (space 0) 84 | (debug 0) 85 | (compilation-speed 0) 86 | #+:lispworks (hcl:fixnum-safety 0))) 87 | "Auxiliary function used by TEST to check whether SCANNER is thread-safe." 88 | (full-gc) 89 | (let ((collector (make-array threads)) 90 | (counter 0)) 91 | (loop for i below threads 92 | do (let* ((j i) 93 | (fn 94 | (lambda () 95 | (let ((r (random repetitions))) 96 | (loop for k below repetitions 97 | if (= k r) 98 | do (setf (aref collector j) 99 | (let ((result 100 | (multiple-value-list 101 | (cl-ppcre:scan scanner target-string)))) 102 | (unless (cdr result) 103 | (setq result '(nil nil #() #()))) 104 | result)) 105 | else 106 | do (cl-ppcre:scan scanner target-string)) 107 | (incf counter))))) 108 | #+scl (thread:thread-create fn) 109 | #+lispworks (mp:process-run-function "" nil fn) 110 | #+(and sbcl sb-thread) (sb-thread:make-thread fn))) 111 | (loop while (< counter threads) 112 | do (sleep .1)) 113 | (destructuring-bind (first-start first-end first-reg-starts first-reg-ends) 114 | (aref collector 0) 115 | (loop for (start end reg-starts reg-ends) across collector 116 | if (or (not (eql first-start start)) 117 | (not (eql first-end end)) 118 | (/= (length first-reg-starts) (length reg-starts)) 119 | (/= (length first-reg-ends) (length reg-ends)) 120 | (loop for first-reg-start across first-reg-starts 121 | for reg-start across reg-starts 122 | thereis (not (eql first-reg-start reg-start))) 123 | (loop for first-reg-end across first-reg-ends 124 | for reg-end across reg-ends 125 | thereis (not (eql first-reg-end reg-end)))) 126 | do (return (format nil "~&Inconsistent results during multi-threading")))))) 127 | 128 | (defun create-string-from-input (input) 129 | (cond ((or (null input) 130 | (stringp input)) 131 | input) 132 | (t 133 | (cl-ppcre::string-list-to-simple-string 134 | (loop for element in input 135 | if (stringp element) 136 | collect element 137 | else 138 | collect (string (code-char element))))))) 139 | 140 | (defun test (&key (file-name 141 | (make-pathname :name "testdata" 142 | :type nil :version nil 143 | :defaults *cl-ppcre-test-base-directory*) 144 | file-name-provided-p) 145 | threaded) 146 | (declare (optimize speed 147 | (safety 0) 148 | (space 0) 149 | (debug 0) 150 | (compilation-speed 0) 151 | #+:lispworks (hcl:fixnum-safety 0))) 152 | (declare (ignorable threaded)) 153 | "Loop through all test cases in FILE-NAME and print report. Only in 154 | LispWorks and SCL: If THREADED is true, also test whether the scanners 155 | work multi-threaded." 156 | (with-open-file (stream file-name 157 | #+(or :allegro :clisp :scl) 158 | :external-format 159 | #+(or :allegro :clisp :scl) 160 | (if file-name-provided-p 161 | :default 162 | #+:allegro :iso-8859-1 163 | #+:clisp charset:iso-8859-1 164 | #+:scl :iso-8859-1)) 165 | (loop with testcount of-type fixnum = 0 166 | with *regex-char-code-limit* = (if file-name-provided-p 167 | *regex-char-code-limit* 168 | ;; the standard test suite 169 | ;; doesn't need full 170 | ;; Unicode support 171 | 255) 172 | with *allow-quoting* = (if file-name-provided-p 173 | *allow-quoting* 174 | t) 175 | for input-line = (read stream nil nil) 176 | for (counter info-string regex 177 | case-insensitive-mode multi-line-mode 178 | single-line-mode extended-mode 179 | string perl-error factor 180 | perl-time ex-result ex-subs) = input-line 181 | while input-line 182 | do (let ((info-string (create-string-from-input info-string)) 183 | (regex (create-string-from-input regex)) 184 | (string (create-string-from-input string)) 185 | (ex-result (create-string-from-input ex-result)) 186 | (ex-subs (mapcar #'create-string-from-input ex-subs)) 187 | (errors '())) 188 | ;; provide some visual feedback for slow CL 189 | ;; implementations; suggested by JP Massar 190 | (incf testcount) 191 | #+(or scl 192 | lispworks 193 | (and sbcl sb-thread)) 194 | (when threaded 195 | (format t "Test #~A (ID ~A)~%" testcount counter) 196 | (force-output)) 197 | (unless #-(or scl 198 | lispworks 199 | (and sbcl sb-thread)) 200 | nil 201 | #+(or scl 202 | lispworks 203 | (and sbcl sb-thread)) 204 | threaded 205 | (when (zerop (mod testcount 10)) 206 | (format t ".") 207 | (force-output)) 208 | (when (zerop (mod testcount 100)) 209 | (terpri))) 210 | (handler-case 211 | (let* ((*use-bmh-matchers* (if (and (> factor 1) (plusp perl-time)) 212 | *use-bmh-matchers* 213 | ;; if we only check for 214 | ;; correctness we don't 215 | ;; care about speed that 216 | ;; match (but rather 217 | ;; about space 218 | ;; constraints of the 219 | ;; trial versions) 220 | nil)) 221 | (scanner (create-scanner regex 222 | :case-insensitive-mode case-insensitive-mode 223 | :multi-line-mode multi-line-mode 224 | :single-line-mode single-line-mode 225 | :extended-mode extended-mode))) 226 | (multiple-value-bind (result1 result2 sub-starts sub-ends) 227 | (scan scanner string) 228 | (cond (perl-error 229 | (push (format nil 230 | "~&expected an error but got a result") 231 | errors)) 232 | (t 233 | (when (not (eq result1 ex-result)) 234 | (if result1 235 | (let ((result (subseq string result1 result2))) 236 | (unless (string= result ex-result) 237 | (push (format nil 238 | "~&expected ~S but got ~S" 239 | ex-result result) 240 | errors)) 241 | (setq sub-starts (coerce sub-starts 'list) 242 | sub-ends (coerce sub-ends 'list)) 243 | (loop for i from 0 244 | for ex-sub in ex-subs 245 | for sub-start = (nth i sub-starts) 246 | for sub-end = (nth i sub-ends) 247 | for sub = (if (and sub-start sub-end) 248 | (subseq string sub-start sub-end) 249 | nil) 250 | unless (string= ex-sub sub) 251 | do (push (format nil 252 | "~&\\~A: expected ~S but got ~S" 253 | (1+ i) ex-sub sub) errors))) 254 | (push (format nil 255 | "~&expected ~S but got ~S" 256 | ex-result result1) 257 | errors))))) 258 | #+(or scl 259 | lispworks 260 | (and sbcl sb-thread)) 261 | (when threaded 262 | (let ((thread-result (threaded-scan scanner string))) 263 | (when thread-result 264 | (push thread-result errors)))))) 265 | (condition (msg) 266 | (unless perl-error 267 | (push (format nil "~&got an unexpected error: '~A'" msg) 268 | errors)))) 269 | (setq errors (nreverse errors)) 270 | (cond (errors 271 | (when (or (<= factor 1) (zerop perl-time)) 272 | (format t "~&~4@A (~A):~{~& ~A~}~%" 273 | counter info-string errors))) 274 | ((and (> factor 1) (plusp perl-time)) 275 | (let ((result (time-regex factor regex string 276 | :case-insensitive-mode case-insensitive-mode 277 | :multi-line-mode multi-line-mode 278 | :single-line-mode single-line-mode 279 | :extended-mode extended-mode))) 280 | (format t "~&~4@A: ~,4F (~A repetitions, Perl: ~,4F seconds, CL-PPCRE: ~,4F seconds)" counter 281 | (float (/ result perl-time)) factor perl-time result) 282 | #+:cormanlisp (force-output *standard-output*))) 283 | (t nil)))) 284 | (values))) 285 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/specials.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/specials.lisp,v 1.19 2004/04/22 18:50:16 edi Exp $ 3 | 4 | ;;; globally declared special variables 5 | 6 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 7 | 8 | ;;; Redistribution and use in source and binary forms, with or without 9 | ;;; modification, are permitted provided that the following conditions 10 | ;;; are met: 11 | 12 | ;;; * Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | 15 | ;;; * Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials 18 | ;;; provided with the distribution. 19 | 20 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 21 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 24 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 26 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | (in-package #:cl-ppcre) 33 | 34 | ;;; special variables used by the lexer/parser combo 35 | 36 | (defvar *extended-mode-p* nil 37 | "Whether the parser will start in extended mode.") 38 | (declaim (type boolean *extended-mode-p*)) 39 | 40 | ;;; special variables used by the SCAN function and the matchers 41 | 42 | (defvar *string* "" 43 | "The string which is currently scanned by SCAN. 44 | Will always be coerced to a SIMPLE-STRING.") 45 | (declaim (type simple-string *string*)) 46 | 47 | (defvar *start-pos* 0 48 | "Where to start scanning within *STRING*.") 49 | (declaim (type fixnum *start-pos*)) 50 | 51 | (defvar *real-start-pos* nil 52 | "The real start of *STRING*. This is for repeated scans and is only used internally.") 53 | (declaim (type (or null fixnum) *real-start-pos*)) 54 | 55 | (defvar *end-pos* 0 56 | "Where to stop scanning within *STRING*.") 57 | (declaim (type fixnum *end-pos*)) 58 | 59 | (defvar *reg-starts* (make-array 0) 60 | "An array which holds the start positions 61 | of the current register candidates.") 62 | (declaim (type simple-vector *reg-starts*)) 63 | 64 | (defvar *regs-maybe-start* (make-array 0) 65 | "An array which holds the next start positions 66 | of the current register candidates.") 67 | (declaim (type simple-vector *regs-maybe-start*)) 68 | 69 | (defvar *reg-ends* (make-array 0) 70 | "An array which holds the end positions 71 | of the current register candidates.") 72 | (declaim (type simple-vector *reg-ends*)) 73 | 74 | (defvar *end-string-pos* nil 75 | "Start of the next possible end-string candidate.") 76 | 77 | (defvar *rep-num* 0 78 | "Counts the number of \"complicated\" repetitions while the matchers 79 | are built.") 80 | (declaim (type fixnum *rep-num*)) 81 | 82 | (defvar *zero-length-num* 0 83 | "Counts the number of repetitions the inner regexes of which may 84 | have zero-length while the matchers are built.") 85 | (declaim (type fixnum *zero-length-num*)) 86 | 87 | (defvar *repeat-counters* (make-array 0 88 | :initial-element 0 89 | :element-type 'fixnum) 90 | "An array to keep track of how often 91 | repetitive patterns have been tested already.") 92 | (declaim (type (array fixnum (*)) *repeat-counters*)) 93 | 94 | (defvar *last-pos-stores* (make-array 0) 95 | "An array to keep track of the last positions 96 | where we saw repetitive patterns. 97 | Only used for patterns which might have zero length.") 98 | (declaim (type simple-vector *last-pos-stores*)) 99 | 100 | (defvar *use-bmh-matchers* t 101 | "Whether the scanners created by CREATE-SCANNER should use the \(fast 102 | but large) Boyer-Moore-Horspool matchers.") 103 | 104 | (defvar *allow-quoting* nil 105 | "Whether the parser should support Perl's \\Q and \\E.") 106 | 107 | (pushnew :cl-ppcre *features*) 108 | 109 | ;; stuff for Nikodemus Siivola's HYPERDOC 110 | ;; see 111 | ;; and 112 | 113 | (defvar *hyperdoc-base-uri* "http://weitz.de/cl-ppcre/") 114 | 115 | (let ((exported-symbols-alist 116 | (loop for symbol being the external-symbols of :cl-ppcre 117 | collect (cons symbol 118 | (concatenate 'string 119 | "#" 120 | (string-downcase symbol)))))) 121 | (defun hyperdoc-lookup (symbol type) 122 | (declare (ignore type)) 123 | (cdr (assoc symbol 124 | exported-symbols-alist 125 | :test #'eq)))) 126 | -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/testdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/practicals/libraries/cl-ppcre-1.2.3/testdata -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/testinput: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-common-lisp/339dbf0224db6b3b23fd69b336c21625ca9142be/practicals/libraries/cl-ppcre-1.2.3/testinput -------------------------------------------------------------------------------- /practicals/libraries/cl-ppcre-1.2.3/util.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/cl-ppcre/util.lisp,v 1.27 2005/01/24 14:06:38 edi Exp $ 3 | 4 | ;;; Utility functions and constants dealing with the hash-tables 5 | ;;; we use to encode character classes 6 | 7 | ;;; Hash-tables are treated like sets, i.e. a character C is a member of the 8 | ;;; hash-table H iff (GETHASH C H) is true. 9 | 10 | ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved. 11 | 12 | ;;; Redistribution and use in source and binary forms, with or without 13 | ;;; modification, are permitted provided that the following conditions 14 | ;;; are met: 15 | 16 | ;;; * Redistributions of source code must retain the above copyright 17 | ;;; notice, this list of conditions and the following disclaimer. 18 | 19 | ;;; * Redistributions in binary form must reproduce the above 20 | ;;; copyright notice, this list of conditions and the following 21 | ;;; disclaimer in the documentation and/or other materials 22 | ;;; provided with the distribution. 23 | 24 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 25 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 26 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 27 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 28 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 30 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 31 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 32 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 33 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 34 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package #:cl-ppcre) 37 | 38 | (defmacro with-unique-names ((&rest bindings) &body body) 39 | "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* 40 | 41 | Executes a series of forms with each VAR bound to a fresh, 42 | uninterned symbol. The uninterned symbol is as if returned by a call 43 | to GENSYM with the string denoted by X - or, if X is not supplied, the 44 | string denoted by VAR - as argument. 45 | 46 | The variable bindings created are lexical unless special declarations 47 | are specified. The scopes of the name bindings and declarations do not 48 | include the Xs. 49 | 50 | The forms are evaluated in order, and the values of all but the last 51 | are discarded \(that is, the body is an implicit PROGN)." 52 | ;; reference implementation posted to comp.lang.lisp as 53 | ;; by Vebjorn Ljosa - see also 54 | ;; 55 | `(let ,(mapcar #'(lambda (binding) 56 | (check-type binding (or cons symbol)) 57 | (if (consp binding) 58 | (destructuring-bind (var x) binding 59 | (check-type var symbol) 60 | `(,var (gensym ,(etypecase x 61 | (symbol (symbol-name x)) 62 | (character (string x)) 63 | (string x))))) 64 | `(,binding (gensym ,(symbol-name binding))))) 65 | bindings) 66 | ,@body)) 67 | 68 | (defmacro with-rebinding (bindings &body body) 69 | "WITH-REBINDING ( { var | (var prefix) }* ) form* 70 | 71 | Evaluates a series of forms in the lexical environment that is 72 | formed by adding the binding of each VAR to a fresh, uninterned 73 | symbol, and the binding of that fresh, uninterned symbol to VAR's 74 | original value, i.e., its value in the current lexical environment. 75 | 76 | The uninterned symbol is created as if by a call to GENSYM with the 77 | string denoted by PREFIX - or, if PREFIX is not supplied, the string 78 | denoted by VAR - as argument. 79 | 80 | The forms are evaluated in order, and the values of all but the last 81 | are discarded \(that is, the body is an implicit PROGN)." 82 | ;; reference implementation posted to comp.lang.lisp as 83 | ;; by Vebjorn Ljosa - see also 84 | ;; 85 | (loop for binding in bindings 86 | for var = (if (consp binding) (car binding) binding) 87 | for name = (gensym) 88 | collect `(,name ,var) into renames 89 | collect ``(,,var ,,name) into temps 90 | finally (return `(let ,renames 91 | (with-unique-names ,bindings 92 | `(let (,,@temps) 93 | ,,@body)))))) 94 | 95 | (eval-when (:compile-toplevel :execute :load-toplevel) 96 | (defvar *regex-char-code-limit* char-code-limit 97 | "The upper exclusive bound on the char-codes of characters 98 | which can occur in character classes. 99 | Change this value BEFORE creating scanners if you don't need 100 | the full Unicode support of LW, ACL, or CLISP.") 101 | (declaim (type fixnum *regex-char-code-limit*)) 102 | 103 | (defun make-char-hash (test) 104 | (declare (optimize speed space)) 105 | "Returns a hash-table of all characters satisfying test." 106 | (loop with hash = (make-hash-table) 107 | for c of-type fixnum from 0 below char-code-limit 108 | for chr = (code-char c) 109 | if (and chr (funcall test chr)) 110 | do (setf (gethash chr hash) t) 111 | finally (return hash))) 112 | 113 | (declaim (inline word-char-p)) 114 | 115 | (defun word-char-p (chr) 116 | (declare (optimize speed 117 | (safety 0) 118 | (space 0) 119 | (debug 0) 120 | (compilation-speed 0) 121 | #+:lispworks (hcl:fixnum-safety 0))) 122 | "Tests whether a character is a \"word\" character. 123 | In the ASCII charset this is equivalent to a-z, A-Z, 0-9, or _, 124 | i.e. the same as Perl's [\\w]." 125 | (or (alphanumericp chr) 126 | (char= chr #\_))) 127 | 128 | (unless (boundp '+whitespace-char-string+) 129 | (defconstant +whitespace-char-string+ 130 | (coerce 131 | '(#\Space #\Tab #\Linefeed #\Return #\Page) 132 | 'string) 133 | "A string of all characters which are considered to be whitespace. 134 | Same as Perl's [\\s].")) 135 | 136 | (defun whitespacep (chr) 137 | (declare (optimize speed space)) 138 | "Tests whether a character is whitespace, 139 | i.e. whether it would match [\\s] in Perl." 140 | (find chr +whitespace-char-string+ :test #'char=))) 141 | 142 | ;; the following DEFCONSTANT statements are wrapped with 143 | ;; (UNLESS (BOUNDP ...) ...) to make SBCL happy 144 | 145 | (unless (boundp '+digit-hash+) 146 | (defconstant +digit-hash+ 147 | (make-char-hash (lambda (chr) (char<= #\0 chr #\9))) 148 | "Hash-table containing the digits from 0 to 9.")) 149 | 150 | (unless (boundp '+word-char-hash+) 151 | (defconstant +word-char-hash+ 152 | (make-char-hash #'word-char-p) 153 | "Hash-table containing all \"word\" characters.")) 154 | 155 | (unless (boundp '+whitespace-char-hash+) 156 | (defconstant +whitespace-char-hash+ 157 | (make-char-hash #'whitespacep) 158 | "Hash-table containing all whitespace characters.")) 159 | 160 | (defun merge-hash (hash1 hash2) 161 | (declare (optimize speed 162 | (safety 0) 163 | (space 0) 164 | (debug 0) 165 | (compilation-speed 0) 166 | #+:lispworks (hcl:fixnum-safety 0))) 167 | "Returns the \"sum\" of two hashes. This is a destructive operation 168 | on HASH1." 169 | (cond ((> (hash-table-count hash2) 170 | *regex-char-code-limit*) 171 | ;; don't walk through, e.g., the whole +WORD-CHAR-HASH+ if 172 | ;; the user has set *REGEX-CHAR-CODE-LIMIT* to a lower value 173 | (loop for c of-type fixnum from 0 below *regex-char-code-limit* 174 | for chr = (code-char c) 175 | if (and chr (gethash chr hash2)) 176 | do (setf (gethash chr hash1) t))) 177 | (t 178 | (loop for chr being the hash-keys of hash2 179 | do (setf (gethash chr hash1) t)))) 180 | hash1) 181 | 182 | (defun merge-inverted-hash (hash1 hash2) 183 | (declare (optimize speed 184 | (safety 0) 185 | (space 0) 186 | (debug 0) 187 | (compilation-speed 0) 188 | #+:lispworks (hcl:fixnum-safety 0))) 189 | "Returns the \"sum\" of HASH1 and the \"inverse\" of HASH2. This is 190 | a destructive operation on HASH1." 191 | (loop for c of-type fixnum from 0 below *regex-char-code-limit* 192 | for chr = (code-char c) 193 | if (and chr (not (gethash chr hash2))) 194 | do (setf (gethash chr hash1) t)) 195 | hash1) 196 | 197 | (defun create-ranges-from-hash (hash &key downcasep) 198 | (declare (optimize speed 199 | (safety 0) 200 | (space 0) 201 | (debug 0) 202 | (compilation-speed 0) 203 | #+:lispworks (hcl:fixnum-safety 0))) 204 | "Tries to identify up to three intervals (with respect to CHAR<) 205 | which together comprise HASH. Returns NIL if this is not possible. 206 | If DOWNCASEP is true it will treat the hash-table as if it represents 207 | both the lower-case and the upper-case variants of its members and 208 | will only return the respective lower-case intervals." 209 | ;; discard empty hash-tables 210 | (unless (and hash (plusp (hash-table-count hash))) 211 | (return-from create-ranges-from-hash nil)) 212 | (loop with min1 and min2 and min3 213 | and max1 and max2 and max3 214 | ;; loop through all characters in HASH, sorted by CHAR< 215 | for chr in (sort (the list 216 | (loop for chr being the hash-keys of hash 217 | collect (if downcasep 218 | (char-downcase chr) 219 | chr))) 220 | #'char<) 221 | for code = (char-code chr) 222 | ;; MIN1, MAX1, etc. are _exclusive_ 223 | ;; bounds of the intervals identified so far 224 | do (cond 225 | ((not min1) 226 | ;; this will only happen once, for the first character 227 | (setq min1 (1- code) 228 | max1 (1+ code))) 229 | ((<= (the fixnum min1) code (the fixnum max1)) 230 | ;; we're here as long as CHR fits into the first interval 231 | (setq min1 (min (the fixnum min1) (1- code)) 232 | max1 (max (the fixnum max1) (1+ code)))) 233 | ((not min2) 234 | ;; we need to open a second interval 235 | ;; this'll also happen only once 236 | (setq min2 (1- code) 237 | max2 (1+ code))) 238 | ((<= (the fixnum min2) code (the fixnum max2)) 239 | ;; CHR fits into the second interval 240 | (setq min2 (min (the fixnum min2) (1- code)) 241 | max2 (max (the fixnum max2) (1+ code)))) 242 | ((not min3) 243 | ;; we need to open the third interval 244 | ;; happens only once 245 | (setq min3 (1- code) 246 | max3 (1+ code))) 247 | ((<= (the fixnum min3) code (the fixnum max3)) 248 | ;; CHR fits into the third interval 249 | (setq min3 (min (the fixnum min3) (1- code)) 250 | max3 (max (the fixnum max3) (1+ code)))) 251 | (t 252 | ;; we're out of luck, CHR doesn't fit 253 | ;; into one of the three intervals 254 | (return nil))) 255 | ;; on success return all bounds 256 | ;; make them inclusive bounds before returning 257 | finally (return (values (code-char (1+ min1)) 258 | (code-char (1- max1)) 259 | (and min2 (code-char (1+ min2))) 260 | (and max2 (code-char (1- max2))) 261 | (and min3 (code-char (1+ min3))) 262 | (and max3 (code-char (1- max3))))))) 263 | 264 | (defmacro maybe-coerce-to-simple-string (string) 265 | (with-unique-names (=string=) 266 | `(let ((,=string= ,string)) 267 | (cond ((simple-string-p ,=string=) 268 | ,=string=) 269 | (t 270 | (coerce ,=string= 'simple-string)))))) 271 | 272 | (declaim (inline nsubseq)) 273 | (defun nsubseq (sequence start &optional (end (length sequence))) 274 | "Return a subsequence by pointing to location in original sequence." 275 | (make-array (- end start) 276 | :element-type (array-element-type sequence) 277 | :displaced-to sequence 278 | :displaced-index-offset start)) 279 | 280 | (defun normalize-var-list (var-list) 281 | "Utility function for REGISTER-GROUPS-BIND and 282 | DO-REGISTER-GROUPS. Creates the long form \(a list of \(FUNCTION VAR) 283 | entries) out of the short form of VAR-LIST." 284 | (loop for element in var-list 285 | if (consp element) 286 | nconc (loop for var in (rest element) 287 | collect (list (first element) var)) 288 | else 289 | collect (list '(function identity) element))) 290 | 291 | (defun string-list-to-simple-string (string-list) 292 | (declare (optimize speed 293 | (safety 0) 294 | (space 0) 295 | (debug 0) 296 | (compilation-speed 0) 297 | #+:lispworks (hcl:fixnum-safety 0))) 298 | "Concatenates a list of strings to one simple-string." 299 | ;; this function provided by JP Massar; note that we can't use APPLY 300 | ;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT 301 | (let ((total-size 0)) 302 | (declare (type fixnum total-size)) 303 | (dolist (string string-list) 304 | #-genera (declare (type string string)) 305 | (incf total-size (length string))) 306 | (let ((result-string (make-sequence 'simple-string total-size)) 307 | (curr-pos 0)) 308 | (declare (type fixnum curr-pos)) 309 | (dolist (string string-list) 310 | #-genera (declare (type string string)) 311 | (replace result-string string :start1 curr-pos) 312 | (incf curr-pos (length string))) 313 | result-string))) 314 | -------------------------------------------------------------------------------- /practicals/practicals.asd: -------------------------------------------------------------------------------- 1 | (defpackage :com.gigamonkeys.practicals-system (:use :asdf :cl)) 2 | (in-package :com.gigamonkeys.practicals-system) 3 | 4 | (require :aserve) 5 | 6 | (defsystem practicals 7 | :name "practicals" 8 | :author "Peter Seibel " 9 | :version "1.0" 10 | :maintainer "Peter Seibel " 11 | :licence "BSD" 12 | :description "All code from Practical Common Lisp." 13 | :depends-on 14 | (:binary-data 15 | :html 16 | :id3v2 17 | :macro-utilities 18 | :mp3-browser 19 | :mp3-database 20 | :pathnames 21 | :shoutcast 22 | :simple-database 23 | :spam 24 | :test-framework 25 | :url-function)) 26 | 27 | 28 | --------------------------------------------------------------------------------