- lisppaste-cvs@common-lisp.net - mailman3.common-lisp.net

[Lisppaste-cvs] CVS update: lisppaste2/colorize.lisp lisppaste2/coloring-types.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: colorize.lisp coloring-types.lisp Log Message: MORE ANGRY FRUITS! (paren colorization with CSS :hover) Date: Thu Jun 3 07:17:04 2004 Author: bmastenbrook Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.1 lisppaste2/colorize.lisp:1.2 --- lisppaste2/colorize.lisp:1.1 Tue Jun 1 06:17:50 2004 +++ lisppaste2/colorize.lisp Thu Jun 3 07:17:04 2004 @@ -1,10 +1,5 @@ ;;;; colorize.lisp -(defpackage :colorize (:use :common-lisp) - (:export :scan-string :format-scan - :find-coloring-type :autodetect-coloring-type - :coloring-types :scan :scan-any :advance :call-parent-formatter :colorize-file - :*coloring-css*)) (in-package :colorize) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -16,6 +11,8 @@ (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions) (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter) + (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil) + (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly "")) (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function :initform (constantly nil)) (parent-type :initarg :parent-type :accessor coloring-type-parent-type @@ -61,9 +58,8 @@ (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body) (with-gensyms (num items position not-preceded-by string item new-mode until advancing) `(labels ((advance (,num) - (when (> (length ,string-param) (+ ,position-place ,num)) - (setf ,position-place (+ ,position-place ,num)) - t)) + (setf ,position-place (+ ,position-place ,num)) + t) (scan-any (,items &key ,not-preceded-by) (incf *scan-calls*) (let* ((,items (if (stringp ,items) @@ -116,38 +112,59 @@ (list 'values ,until ,advancing))))))) ,@body)))) +(defvar *formatter-local-variables*) + (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters - autodetect parent) + autodetect parent formatter-variables (formatter-after-hook '(constantly ""))) (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) `(let ((,parent-type (or (find-coloring-type ,parent) (and ,parent (error "No such coloring type: ~S" ,parent))))) (setf (find-coloring-type ,name) (make-instance 'coloring-type - :fancy-name ',fancy-name - :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) - :default-mode (or ',default-mode - (if ,parent-type (coloring-type-default-mode ,parent-type))) - ,@(if autodetect - `(:autodetect-function ,autodetect)) - :parent-type ,parent-type - :term-formatter - (lambda (,term) - (labels ((call-parent-formatter (&optional (,type (car ,term)) - (,string (cdr ,term))) - (if ,parent-type - (funcall (coloring-type-term-formatter ,parent-type) - (cons ,type ,string)))) - (call-formatter (&optional (,type (car ,term)) - (,string (cdr ,term))) - (funcall - (case (first ,type) - ,@formatters - (t (lambda (,type text) - (call-parent-formatter ,type text)))) - ,type ,string))) - (call-formatter))) - :transition-functions + :fancy-name ',fancy-name + :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) + :default-mode (or ',default-mode + (if ,parent-type (coloring-type-default-mode ,parent-type))) + ,@(if autodetect + `(:autodetect-function ,autodetect)) + :parent-type ,parent-type + :formatter-initial-values (lambda nil + (list* ,@(mapcar #'(lambda (e) + `(cons ',(car e) ,(second e))) + formatter-variables) + (if ,parent-type + (funcall (coloring-type-formatter-initial-values ,parent-type)) + nil))) + :formatter-after-hook (lambda nil + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (concatenate 'string + (funcall ,formatter-after-hook) + (if ,parent-type + (funcall (coloring-type-formatter-after-hook ,parent-type)) + "")))) + :term-formatter + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (lambda (,term) + (labels ((call-parent-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (if ,parent-type + (funcall (coloring-type-term-formatter ,parent-type) + (cons ,type ,string)))) + (call-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (funcall + (case (first ,type) + ,@formatters + (t (lambda (,type text) + (call-parent-formatter ,type text)))) + ,type ,string))) + (call-formatter)))) + :transition-functions (list ,@(loop for transition in transitions collect (destructuring-bind (mode &rest table) transition @@ -202,7 +219,7 @@ current-position new-position current-wait new-wait)))) (loop - (if (>= current-position (length string)) + (if (> current-position (length string)) (return-from scan-string (progn (format t "Scan was called ~S times.~%" @@ -230,6 +247,8 @@ (multiple-value-bind (pos advance) (funcall current-wait current-position) + #+nil + (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) (and pos (when (> pos current-position) (finish-current (if advance @@ -247,9 +266,11 @@ (defun format-scan (coloring-type scan) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) - (color-formatter (coloring-type-term-formatter coloring-type-object))) - (format nil "~{~A~}" - (mapcar color-formatter scan)))) + (color-formatter (coloring-type-term-formatter coloring-type-object)) + (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object)))) + (format nil "~{~A~}~A" + (mapcar color-formatter scan) + (funcall (coloring-type-formatter-after-hook coloring-type-object))))) (defun colorize-file (coloring-type input-file-name &optional output-file-name) (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) @@ -258,7 +279,8 @@ :defaults (merge-pathnames input-file-name)))) (output-file (or output-file-name (make-pathname :type "html" - :defaults input-file)))) + :defaults input-file))) + (*css-background-class* "default")) (with-open-file (s input-file :direction :input) (let ((lines nil) (string nil)) @@ -271,11 +293,21 @@ (nreverse lines))) (with-open-file (s2 output-file :direction :output :if-exists :supersede) (format s2 - "<html><head><style type=\"text/css\">~A</style><body><tt>~A</tt></body></html>" + "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\"> +<html><head><style type=\"text/css\">~A~%~A</style><body> +<table width=\"100%\"><tr><td class=\"~A\"> +<tt>~A</tt> +</tr></td></table></body></html>" *coloring-css* + (make-background-css "white") + *css-background-class* (format-scan coloring-type (mapcar #'(lambda (p) (cons (car p) - (html-encode:encode-for-tt (cdr p)))) + (let ((tt + (html-encode:encode-for-tt (cdr p)))) + (if (and (> (length tt) 0) + (char= (elt tt (1- (length tt))) #\>)) + (format nil "~A~%" tt) tt)))) (scan-string coloring-type - string))))))))) \ No newline at end of file + string))))))))) Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.2 lisppaste2/coloring-types.lisp:1.3 --- lisppaste2/coloring-types.lisp:1.2 Tue Jun 1 06:41:27 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 3 07:17:04 2004 @@ -2,26 +2,12 @@ (in-package :colorize) -(defparameter *coloring-css* - ".symbol { color : #770055; background-color : inherit; } -a.symbol:link { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:active { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:visited { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:hover { color : #229955; background-color : inherit; text-decoration: underline; } -.special { color : #FF5000; background-color : inherit; } -.keyword { color : #770000; background-color : inherit; } -.comment { color : #007777; background-color : inherit; } -.string { color : #777777; background-color : inherit; } -.character { color : #0055AA; background-color : inherit; } -.syntaxerror { color : #FF0000; background-color : inherit; } -") - (defparameter *symbol-characters* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&") (defparameter *non-constituent* '(#\space #\tab #\newline #\linefeed #\page #\return - #\" #\' #$ #$ #\, #\; #\`)) + #\" #\' #$ #$ #\, #\; #\` #\[ #\])) (defparameter *special-forms* '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the" @@ -32,6 +18,9 @@ (defparameter *common-macros* '("loop" "cond" "lambda")) +(defparameter *open-parens* '(#$)) +(defparameter *close-parens* '(#$)) + (define-coloring-type :lisp "Basic Lisp" :autodetect (lambda (name) (member name '("emacs") @@ -39,21 +28,10 @@ (search ext name :test #'char-equal)))) :modes (:normal :symbol :escaped-symbol :keyword :string :comment :multiline :character - :single-escaped :in-list :dotted-list-tail :syntax-error) + :single-escaped :in-list :syntax-error) :default-mode :normal :transitions - (#| - ((:in-list) - ((scan #\.) - (set-mode :dotted-list-tail - :until (scan #\)) - :advancing nil))) - ((:dotted-list-tail) - ((scan #\.) - (set-mode :syntax-error - :until (scan #\)) - :advancing nil)))|# - ((:normal :in-list :dotted-list-tail) + (((:normal :in-list) ((or (scan-any *symbol-characters*) (and (scan "+") (scan-any *symbol-characters*)) @@ -68,9 +46,6 @@ (set-mode :keyword :until (scan-any *non-constituent*) :advancing nil)) - ((scan #\|) - (set-mode :escaped-symbol - :until (scan #\|))) ((scan "#\\") (let ((count 0)) (set-mode :character @@ -103,14 +78,47 @@ (incf count) (if (< count 2) (advance 1)))))))) + :formatter-variables ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect "</span></span>"))) :formatters ((:normal (lambda (type s) (declare (ignore type)) s)) - ((:in-list :dotted-list-tail) + ((:in-list) (lambda (type s) (declare (ignore type)) - s)) + (labels ((color-parens (s) + (let ((paren-pos (find-if-not #'null + (mapcar #'(lambda (c) + (position c s)) + (append *open-parens* + *close-parens*))))) + (if paren-pos + (let ((before-paren (subseq s 0 paren-pos)) + (after-paren (subseq s (1+ paren-pos))) + (paren (elt s paren-pos)) + (open nil) + (count 0)) + (when (member paren *open-parens* :test #'char=) + (setf count (mod paren-counter 6)) + (incf paren-counter) + (setf open t)) + (when (member paren *close-parens* :test #'char=) + (decf paren-counter)) + (if open + (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A" + before-paren + (1+ count) + paren *css-background-class* + (color-parens after-paren)) + (format nil "~A</span>~C</span>~A" + before-paren + paren (color-parens after-paren)))) + s)))) + (color-parens s)))) ((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) @@ -163,16 +171,41 @@ (search "scheme" text :test #'char-equal)) :parent :lisp :transitions - (((:normal :in-list :dotted-list-tail) + (((:normal :in-list) ((scan "...") (set-mode :symbol :until (scan-any *non-constituent*) - :advancing nil))))) + :advancing nil)) + ((scan #\[) + (set-mode :in-list + :until (scan #\]))))) + :formatters + (((:in-list) + (lambda (type s) + (declare (ignore type s)) + (let ((*open-parens* (cons #\[ *open-parens*)) + (*close-parens* (cons #\] *close-parens*))) + (call-parent-formatter)))) + ((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :r5rs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) + s)))) + (if result + (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" + result (call-parent-formatter)) + (call-parent-formatter))))))) (define-coloring-type :common-lisp "Common Lisp" :autodetect (lambda (text) (search "lisp" text :test #'char-equal)) :parent :lisp + :transitions + (((:normal :in-list) + ((scan #\|) + (set-mode :escaped-symbol + :until (scan #\|))))) :formatters (((:symbol :escaped-symbol) (lambda (type s)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Adventures in compliant HTML and class-ification Date: Thu Jun 3 07:16:35 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.48 lisppaste2/web-server.lisp:1.49 --- lisppaste2/web-server.lisp:1.48 Tue Jun 1 06:17:50 2004 +++ lisppaste2/web-server.lisp Thu Jun 3 07:16:35 2004 @@ -1,20 +1,24 @@ -;;;; $Id: web-server.lisp,v 1.48 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.49 2004/06/03 14:16:35 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) -(defstruct paste - (number nil :type integer) - (user nil :type string) - (title nil :type string) - (contents nil :type string) - (universal-time nil :type integer) - (is-annotation nil :type boolean) - (annotations nil :type list) - (annotation-counter 0 :type integer) - (channel "" :type string)) +(defclass paste () + ((number :initarg :number :initform 0 :accessor paste-number) + (user :initarg :user :initform "" :accessor paste-user) + (title :initarg :title :initform "" :accessor paste-title) + (contents :initarg :contents :initform "" :accessor paste-contents) + (universal-time :initarg :universal-time :initform 0 :accessor paste-universal-time) + (is-annotation :initarg :is-annotation :initform nil :accessor paste-is-annotation) + (annotations :initarg :annotations :initform nil :accessor paste-annotations) + (annotation-counter :initarg :annotation-counter :initform 0 :accessor paste-annotation-counter) + (channel :initarg :channel :initform "" :accessor paste-channel) + (colorization-mode :initarg :colorization-mode :initform "" :accessor paste-colorization-mode))) + +(defmacro make-paste (&rest arguments) + `(make-instance 'paste ,@arguments)) (defclass new-paste-handler (araneida:handler) ()) @@ -92,7 +96,7 @@ (t (format nil "~A~A" (time-delta-primitive delta level) (if ago-p " ago" "")))))) (defun irc-log-link (utime channel) - (format nil "http://meme.b9.com/now?utime=~A&channel=~A" + (format nil "http://meme.b9.com/now?utime=~A&channel=~A" utime (string-left-trim "#" channel))) @@ -580,7 +584,8 @@ (car (rassoc colorize-string (colorize:coloring-types) :test #'string-equal)) (if (and paste (not (string-equal colorize-string "None"))) - (colorize:autodetect-coloring-type (paste-channel paste)))))) + (colorize:autodetect-coloring-type (paste-channel paste))))) + (colorize:*css-background-class* "paste")) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -606,12 +611,14 @@ (head (title "Paste number " ,paste-number) ((style :type "text/css") - ,colorize:*coloring-css*) + ,(format nil "~A~%~A~%" + (colorize:make-background-css "#F4F4F4") + colorize:*coloring-css*)) ,(rss-link-header)) (body ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as) - ,(if (paste-annotations paste) - `(p + ,@(if (paste-annotations paste) + `((p) "Annotations for this paste: " ,@(reduce #'append (mapcar #'(lambda (a) @@ -621,7 +628,8 @@ (araneida:urlstring (araneida:request-url request)) (paste-number a)) (paste-number a) t colorize-as))) (reverse (paste-annotations paste))))) - `(p "This paste has no annotations.")) + `((p) "This paste has no annotations.")) + (p) ((form :method post :action ,(araneida:urlstring (araneida:merge-url *display-paste-url* @@ -634,7 +642,7 @@ ,@(if (eq (car pair) colorize-as) - '(:selected "true"))) + '(:selected "SELECTED"))) ,(cdr pair))) (colorize:coloring-types))) ((input :type submit :value "Colorize")))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: clhs-lookup.lisp Log Message: Add back MOP and format lookup Date: Thu Jun 3 07:16:16 2004 Author: bmastenbrook Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.1 lisppaste2/clhs-lookup.lisp:1.2 --- lisppaste2/clhs-lookup.lisp:1.1 Tue Jun 1 06:41:27 2004 +++ lisppaste2/clhs-lookup.lisp Thu Jun 3 07:16:16 2004 @@ -1,9 +1,9 @@ (defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup - :populate-table)) + :populate-table + :spec-lookup)) (in-package :clhs-lookup) -;;; CLHS. This will be the default lookup. -(defparameter *hyperspec-pathname* #p"/Users/chandler/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -14,8 +14,20 @@ (defparameter *mop-root* "http://www.alu.org/mop/") -(defvar *table* (make-hash-table :test 'equalp)) +(defvar *symbol-table* (make-hash-table :test 'equalp)) + +(defvar *section-table* (make-hash-table :test 'equalp)) + +(defvar *format-table* (make-hash-table :test 'equalp)) +(defun add-clhs-section-to-table (&rest numbers) + (let ((key (format nil "~{~d~^.~}" numbers)) + (target (concatenate 'string *hyperspec-root* (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers)))))) + (setf (gethash key *section-table*) target))) + +(defun valid-target (&rest numbers) + (probe-file (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers))))) + (defun populate-table () ;; Hyperspec (with-open-file (s *hyperspec-map-file*) @@ -24,24 +36,97 @@ (do ((symbol-name (read-line s nil s) (read-line s nil s)) (url (read-line s nil s) (read-line s nil s))) ((eq url s) 'done) - (setf (gethash symbol-name *table*) (concatenate 'string *hyperspec-root* (subseq url 3)))) + (setf (gethash symbol-name *symbol-table*) (concatenate 'string *hyperspec-root* (subseq url 3)))) + ;; add in section references. + (let ((*default-pathname-defaults* *hyperspec-pathname*)) + ;; Yuk. I know. Fixes welcome. + (loop for section from 0 to 27 + do (add-clhs-section-to-table section) + do (loop named s for s1 from 1 to 26 + unless (valid-target section s1) + do (return-from s nil) + do (add-clhs-section-to-table section s1) + do (loop named ss for s2 from 1 to 26 + unless (valid-target section s1 s2) + do (return-from ss nil) + do (add-clhs-section-to-table section s1 s2) + do (loop named sss for s3 from 1 to 26 + unless (valid-target section s1 s2 s3) + do (return-from sss nil) + do (add-clhs-section-to-table section s1 s2 s3) + do (loop named ssss for s4 from 1 to 26 + unless (valid-target section s1 s2 s3 s4) + do (return-from ssss nil) + do (add-clhs-section-to-table section s1 s2 s3 s4) + do (loop named sssss for s5 from 1 to 26 + unless (valid-target section s1 s2 s3 s4 s5) + do (return-from sssss nil) + do (add-clhs-section-to-table section s1 s2 s3 s4 s5)))))))) + ;; format directives + (loop for code from 32 to 127 + do (setf (gethash (format nil "~~~A" (code-char code)) *format-table*) + (concatenate 'string + *hyperspec-root* + (case (code-char code) + ((#\c #\C) "Body/22_caa.htm") + ((#\%) "Body/22_cab.htm") + ((#\&) "Body/22_cac.htm") + ((#\|) "Body/22_cad.htm") + ((#\~) "Body/22_cae.htm") + ((#\r #\R) "Body/22_cba.htm") + ((#\d #\D) "Body/22_cbb.htm") + ((#\b #\B) "Body/22_cbc.htm") + ((#\o #\O) "Body/22_cbd.htm") + ((#\x #\X) "Body/22_cbe.htm") + ((#\f #\F) "Body/22_cca.htm") + ((#\e #\E) "Body/22_ccb.htm") + ((#\g #\G) "Body/22_ccc.htm") + ((#\$) "Body/22_ccd.htm") + ((#\a #\A) "Body/22_cda.htm") + ((#\s #\S) "Body/22_cdb.htm") + ((#\w #\W) "Body/22_cdc.htm") + ((#\_) "Body/22_cea.htm") + ((#\<) "Body/22_ceb.htm") + ((#\i #\I) "Body/22_cec.htm") + ((#\/) "Body/22_ced.htm") + ((#\t #\T) "Body/22_cfa.htm") + ;; FIXME + ((#\<) "Body/22_cfb.htm") + ((#\>) "Body/22_cfc.htm") + ((#\*) "Body/22_cga.htm") + ((#\[) "Body/22_cgb.htm") + ((#\]) "Body/22_cgc.htm") + ((#\{) "Body/22_cgd.htm") + ((#\}) "Body/22_cge.htm") + ((#\?) "Body/22_cgf.htm") + ((#$) "Body/22_cha.htm") + ((#$) "Body/22_chb.htm") + ((#\p #\P) "Body/22_chc.htm") + ((#\;) "Body/22_cia.htm") + ((#\^) "Body/22_cib.htm") + ((#\Newline) "Body/22_cic.htm") + (t "Body/22_c.htm"))))) ;; glossary. ) ;; MOP - (with-open-file (s *mop-map-file* :if-does-not-exist nil) - (when s - (do ((symbol-name (read-line s nil s) (read-line s nil s)) - (url (read-line s nil s) (read-line s nil s))) - ((eq url s) 'done) - (setf (gethash (concatenate 'string "MOP:" symbol-name) *table*) (concatenate 'string *mop-root* url)))))) - -(defmacro aif (test conseq &optional (else nil)) - `(let ((it ,test)) - (if it ,conseq - (symbol-macrolet ((it ,test)) - ,else)))) - -(defun symbol-lookup (str) - (aif (gethash str *table*) - it - nil)) + (with-open-file (s *mop-map-file*) + (do ((symbol-name (read-line s nil s) (read-line s nil s)) + (url (read-line s nil s) (read-line s nil s))) + ((eq url s) 'done) + (setf (gethash (concatenate 'string "MOP:" symbol-name) *symbol-table*) (concatenate 'string *mop-root* url))))) + +(defun spec-lookup (term &key (type :all)) + (ecase type + (:all + (or (gethash term *symbol-table*) + (gethash term *section-table*) + (gethash term *format-table*))) + (:symbol + (gethash term *symbol-table*)) + (:section + (gethash term *section-table*)) + (:format + (gethash term *format-table*)))) + +(defun symbol-lookup (term) + (spec-lookup term :type :symbol))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/Mop_Sym.txt
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: Mop_Sym.txt Log Message: Add MOP index file Date: Thu Jun 3 07:15:31 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/r5rs-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: r5rs-lookup.lisp Log Message: R5RS symbol lookup Date: Thu Jun 3 07:14:45 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp lisppaste2/coloring-types.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv10256 Modified Files: coloring-types.lisp Added Files: clhs-lookup.lisp Log Message: Fix CLHS lookup Date: Tue Jun 1 06:41:27 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.1 lisppaste2/coloring-types.lisp:1.2 --- lisppaste2/coloring-types.lisp:1.1 Tue Jun 1 06:17:50 2004 +++ lisppaste2/coloring-types.lisp Tue Jun 1 06:41:27 2004 @@ -42,7 +42,8 @@ :single-escaped :in-list :dotted-list-tail :syntax-error) :default-mode :normal :transitions - (((:in-list) + (#| + ((:in-list) ((scan #\.) (set-mode :dotted-list-tail :until (scan #\)) @@ -51,7 +52,7 @@ ((scan #\.) (set-mode :syntax-error :until (scan #\)) - :advancing nil))) + :advancing nil)))|# ((:normal :in-list :dotted-list-tail) ((or (scan-any *symbol-characters*) @@ -178,8 +179,8 @@ (declare (ignore type)) (let* ((colon (position #\: s :from-end t :test #'char=)) (to-lookup (if colon (subseq s (1+ colon)) s)) - (result (if (find-package :clhs) - (funcall (symbol-function (intern "FUNCTION-LOOKUP" :clhs)) + (result (if (find-package :clhs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup)) to-lookup)))) (if result (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/variable.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory nittin.net:/tmp/cvs-serv2923 Modified Files: variable.lisp Log Message: Variables for pagination Date: Tue Jun 1 06:21:19 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.14 lisppaste2/variable.lisp:1.15 --- lisppaste2/variable.lisp:1.14 Fri May 21 12:30:45 2004 +++ lisppaste2/variable.lisp Tue Jun 1 06:21:19 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.14 2004/05/21 19:30:45 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.15 2004/06/01 13:21:19 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -26,6 +26,10 @@ :port *external-http-port*) "/paste/")) (defvar *meme-links* t) ; whether to link to meme IRC logs + +(defvar *paste-maximum-size* 51200) + +(defvar *pastes-per-page* 50) ;; You shouldn't need to edit below this line. ;; LINE

1 0

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.asd
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory nittin.net:/tmp/cvs-serv2238 Modified Files: lisppaste.asd Log Message: Add the colorizer to the .asd Date: Tue Jun 1 06:19:22 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.8 lisppaste2/lisppaste.asd:1.9 --- lisppaste2/lisppaste.asd:1.8 Tue Mar 9 06:16:21 2004 +++ lisppaste2/lisppaste.asd Tue Jun 1 06:19:22 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.8 2004/03/09 14:16:21 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.9 2004/06/01 13:19:22 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -29,6 +29,10 @@ :depends-on ("variable")) (:file "lisppaste" :depends-on ("variable")) + (:file "colorize") + (:file "clhs-lookup") + (:file "coloring-types" + :depends-on ("colorize" "clhs-lookup")) (:file "web-server" :depends-on ("encode-for-pre" "lisppaste")) (:file "persistent-pastes"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/package.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory nittin.net:/tmp/cvs-serv1247 Modified Files: package.lisp Log Message: Move encode-for-pre into its own html-encode package Date: Tue Jun 1 06:18:36 2004 Author: bmastenbrook Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.4 lisppaste2/package.lisp:1.5 --- lisppaste2/package.lisp:1.4 Fri May 21 12:30:45 2004 +++ lisppaste2/package.lisp Tue Jun 1 06:18:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.4 2004/05/21 19:30:45 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.5 2004/06/01 13:18:35 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -7,7 +7,7 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste - (:use :cl #+sbcl :sb-bsd-sockets) + (:use :cl #+sbcl :sb-bsd-sockets :html-encode) (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up)))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/colorize.lisp lisppaste2/coloring-types.lisp lisppaste2/encode-for-pre.lisp lisppaste2/web-server.lisp lisppaste2/lisppaste.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory nittin.net:/tmp/cvs-serv1010 Modified Files: encode-for-pre.lisp web-server.lisp lisppaste.lisp Added Files: colorize.lisp coloring-types.lisp Log Message: Major changes: new colorizer, URL via IRC, etc Date: Tue Jun 1 06:17:50 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.14 lisppaste2/encode-for-pre.lisp:1.15 --- lisppaste2/encode-for-pre.lisp:1.14 Fri May 21 15:11:09 2004 +++ lisppaste2/encode-for-pre.lisp Tue Jun 1 06:17:50 2004 @@ -1,9 +1,12 @@ -;;;; $Id: encode-for-pre.lisp,v 1.14 2004/05/21 22:11:09 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.15 2004/06/01 13:17:50 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. -(in-package :lisppaste) +(defpackage :html-encode + (:use :common-lisp) + (:export :encode-for-pre :encode-for-tt :encode-for-http)) +(in-package :html-encode) (defun encode-for-tt (string) (let ((pos 0) (end (length string)) Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.47 lisppaste2/web-server.lisp:1.48 --- lisppaste2/web-server.lisp:1.47 Fri May 21 14:29:11 2004 +++ lisppaste2/web-server.lisp Tue Jun 1 06:17:50 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.47 2004/05/21 21:29:11 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.48 2004/06/01 13:17:50 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -178,14 +178,16 @@ (b "Uptime: ") ,(time-delta *boot-time* :ago-p nil :level 3) (p) (b "Most popular channels:") (br) - ((table :border 2) + ((table :border 0) ,@(mapcar #'(lambda (pair) `(tr ((td :valign top) - (tt ,(car pair))) - ((td :valign top) - (tt ,(cdr pair))))) - (sort + ,(car pair)) + ((td) + " ") + ((td :valign top) + ,(cdr pair)))) + (sort (loop for i in *channels* collect (cons i (count i *pastes* :key #'paste-channel @@ -193,19 +195,20 @@ #'> :key #'cdr))) (p) (b "Average rates of pasting:") (br) - ((table :border 2) + ((table :border 0) ,@(mapcar #'(lambda (pair) `(tr #+(or) (td ,(length (second pair))) ((td :valign top) - (tt ,(first pair))) + ,(first pair)) + (td " ") ((td :valign top) - (tt ,(time-delta - 0 :origin - (truncate (/ - (third pair) - (length (second pair)))) :ago-p nil) - " between pastes")))) + ,(time-delta + 0 :origin + (truncate (/ + (third pair) + (length (second pair)))) :ago-p nil) + " between pastes"))) (list* (list "Overall" *pastes* (- (paste-universal-time (first *pastes*)) (paste-universal-time (car (last *pastes*))))) @@ -314,16 +317,16 @@ ((form :method post :action ,(araneida:urlstring *list-paste-url*)) (table (tr ((td :align left) "View only: ") - ((td :valign top) + ((td :valign top :align center) ((select :name "channel") ((option :value "allchannels") "All channels") ,@(mapcar #'(lambda (e) `((option :value ,e ,@(if (and discriminate-channel (string-equal e discriminate-channel)) '(:selected))) - ,(encode-for-pre e))) *channels*))) - ((td :valign top) - ((input :type submit :value "Submit")))) + ,(encode-for-pre e))) *channels*)) + ((input :type submit :value "Submit"))) + ) (tr ((td :align left) ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: ")) ((td :align center) @@ -336,7 +339,7 @@ (araneida:urlstring *rss-full-url*) (if discriminate-channel (substitute #\? #\# discriminate-channel) ""))) "Full")) - (td)) + ) (tr ((td :align left) "Page: ") ((td :align center) @@ -530,7 +533,7 @@ (if (< l1 l2) nil (string= (subseq str (- l1 l2) l1) end)))) -(defun format-paste (paste this-url paste-number &optional annotation) +(defun format-paste (paste this-url paste-number &optional annotation colorize-as) `((table :width "100%" :cellpadding 2) (tr ((td :align "left" :width "0%" :nowrap "nowrap") ,(if annotation @@ -553,7 +556,15 @@ ,@(if this-url `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) (tr (td (p))) - (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") (tt ,(encode-for-tt (paste-contents paste))))))) + (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") + (tt + ,(if colorize-as + (colorize:format-scan colorize-as + (mapcar #'(lambda (e) + (cons (car e) + (encode-for-tt (cdr e)))) + (colorize:scan-string colorize-as (paste-contents paste)))) + (encode-for-tt (paste-contents paste)))))))) (defmethod araneida:handle-request-response ((handler display-paste-handler) method request) ; XXX request-unhandled-part will be exported in 0.81 @@ -563,7 +574,13 @@ (raw (ends-with (araneida::request-unhandled-part request) "/raw")) (paste (some #'(lambda (element) (and (eql paste-number (paste-number element)) - element)) *pastes*))) + element)) *pastes*)) + (colorize-string (araneida:body-param "colorize" (araneida:request-body request))) + (colorize-as (or + (car (rassoc colorize-string (colorize:coloring-types) :test #'string-equal)) + (if (and paste + (not (string-equal colorize-string "None"))) + (colorize:autodetect-coloring-type (paste-channel paste)))))) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -588,9 +605,11 @@ `(html (head (title "Paste number " ,paste-number) + ((style :type "text/css") + ,colorize:*coloring-css*) ,(rss-link-header)) (body - ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number) + ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as) ,(if (paste-annotations paste) `(p "Annotations for this paste: " @@ -600,9 +619,26 @@ ,(format-paste a (format nil "~A,~A" (araneida:urlstring (araneida:request-url request)) - (paste-number a)) (paste-number a) t))) + (paste-number a)) (paste-number a) t colorize-as))) (reverse (paste-annotations paste))))) `(p "This paste has no annotations.")) + ((form :method post :action ,(araneida:urlstring + (araneida:merge-url + *display-paste-url* + (araneida:request-unhandled-part request)))) + "Colorize as: " + ((select :name "colorize") + ((option :value "None") "None") + ,@(mapcar #'(lambda (pair) + `((option :value ,(cdr pair) + ,@(if (eq + (car pair) + colorize-as) + '(:selected "true"))) + ,(cdr pair))) + (colorize:coloring-types))) + ((input :type submit :value "Colorize"))) + (p) ((form :method post :action ,(araneida:urlstring *new-paste-url*)) ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number paste)))) (center ((input :type submit :value "Annotate this paste")))) Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.15 lisppaste2/lisppaste.lisp:1.16 --- lisppaste2/lisppaste.lisp:1.15 Tue Apr 27 14:03:21 2004 +++ lisppaste2/lisppaste.lisp Tue Jun 1 06:17:50 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.15 2004/04/27 21:03:21 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.16 2004/06/01 13:17:50 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -7,11 +7,25 @@ (defun make-msg-hook (nick) (lambda (message) - (if (string= (first (irc:arguments message)) nick) - (irc:privmsg *connection* - (irc:source message) - (format nil "To use the lisppaste bot, visit ~A and enter your paste. Be sure to select the right channel!" (araneida:urlstring *new-paste-url*)))))) - + (let ((text (irc:trailing-argument message))) + (cond ((string= (first (irc:arguments message)) nick) + (irc:privmsg *connection* + (irc:source message) + (format nil "To use the lisppaste bot, visit ~A and enter your paste. Be sure to select the right channel!" (araneida:urlstring *new-paste-url*)))) + ((and (> (length text) + (length nick)) + (search nick text :start2 0 :end2 (length nick) :test #'char-equal)) + (let ((url-position (search "url" text :start2 (length nick) + :test #'char-equal))) + (if (and + url-position + (notany #'alphanumericp (subseq text (length nick) (1- url-position))) + (notany #'alphanumericp (subseq text (+ url-position 3)))) + (irc:privmsg *connection* + (first (irc:arguments message)) + (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq (first (irc:arguments message)) 1)))))))))) + + (defun add-hook (nick) (irc:remove-hooks *connection* 'irc:irc-privmsg-message) (irc:add-hook *connection* 'irc:irc-privmsg-message (make-msg-hook nick))) @@ -68,4 +82,4 @@ (setf (irc:client-stream *connection*) (make-broadcast-stream))) (defun un-shut-up () - (setf (irc:client-stream *connection*) *trace-output*)) \ No newline at end of file + (setf (irc:client-stream *connection*) *trace-output*))

1 0