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

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

11 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Fix minor HTML bogosity Date: Fri Jun 11 10:35:33 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.55 lisppaste2/web-server.lisp:1.56 --- lisppaste2/web-server.lisp:1.55 Fri Jun 11 08:00:41 2004 +++ lisppaste2/web-server.lisp Fri Jun 11 10:35:33 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.55 2004/06/11 15:00:41 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.56 2004/06/11 17:35:33 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -512,7 +512,7 @@ `((tr (th "Select a channel:") (td ((select :name "channel") - (option :value "") + ((option :value "")) ,@(mapcar #'(lambda (e) `((option :value ,e ,@(if (string-equal e default-channel) '(:selected "SELECTED")))

1 0

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

11 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Allow selected colorization to override default Date: Fri Jun 11 08:00:41 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.54 lisppaste2/web-server.lisp:1.55 --- lisppaste2/web-server.lisp:1.54 Fri Jun 11 06:02:38 2004 +++ lisppaste2/web-server.lisp Fri Jun 11 08:00:41 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.54 2004/06/11 13:02:38 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.55 2004/06/11 15:00:41 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -529,7 +529,7 @@ `((tr (th (i "(Optional) Colorize as: ")) (td ((select :name "colorize") - ((option :value "" :selected "SELECTED") "") + ((option :value "" :selected "SELECTED") "Default for this channel") ((option :value "None") "None") ,@(mapcar #'(lambda (pair) `((option :value ,(cdr pair)) @@ -656,7 +656,9 @@ ,@(if (not annotation) `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* " | " "")))) - ,@(if *meme-links* + ,@(if (and *meme-links* + (not (and *no-channel-pastes* + (string-equal (paste-channel paste) "None")))) `(((a :href ,(irc-log-link (paste-universal-time paste) (paste-channel paste))) "Context in IRC logs"))))))) (tr ((td :align "left" :valign "top" :nowrap "nowrap") "Paste contents:") ,@(if this-url @@ -685,10 +687,12 @@ element)) *pastes*)) (linenumbers (equalp (araneida:body-param "linenumbers" (araneida:request-body request)) "true")) - (colorize-string (or (and paste - (> (length (paste-colorization-mode paste)) 0) - (paste-colorization-mode paste)) - (araneida:body-param "colorize" (araneida:request-body request)))) + (colorize-string (or + (araneida:body-param "colorize" (araneida:request-body request)) + (and paste + (> (length (paste-colorization-mode paste)) 0) + (paste-colorization-mode paste)) + )) (colorize-as (or (car (rassoc colorize-string (colorize:coloring-types) :test #'string-equal)) (if (and paste

1 0

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

11 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: C/C++/Java support Date: Fri Jun 11 07:34:34 2004 Author: bmastenbrook Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.2 lisppaste2/colorize.lisp:1.3 --- lisppaste2/colorize.lisp:1.2 Thu Jun 3 07:17:04 2004 +++ lisppaste2/colorize.lisp Fri Jun 11 07:34:34 2004 @@ -16,7 +16,9 @@ (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function :initform (constantly nil)) (parent-type :initarg :parent-type :accessor coloring-type-parent-type - :initform nil))) + :initform nil) + (visible :initarg :visible :accessor coloring-type-visible + :initform t))) (defun find-coloring-type (type) (if (typep type 'coloring-type) @@ -28,13 +30,14 @@ (find name *coloring-types* :key #'cdr :test #'(lambda (name type) - (funcall (coloring-type-autodetect-function type) name))))) + (and (coloring-type-visible type) + (funcall (coloring-type-autodetect-function type) name)))))) (defun coloring-types () - (mapcar #'(lambda (type-pair) - (cons (car type-pair) - (coloring-type-fancy-name (cdr type-pair)))) - *coloring-types*)) + (loop for type-pair in *coloring-types* + if (coloring-type-visible (cdr type-pair)) + collect (cons (car type-pair) + (coloring-type-fancy-name (cdr type-pair))))) (defun (setf find-coloring-type) (new-value type) (if new-value @@ -115,7 +118,8 @@ (defvar *formatter-local-variables*) (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters - autodetect parent formatter-variables (formatter-after-hook '(constantly ""))) + autodetect parent formatter-variables (formatter-after-hook '(constantly "")) + invisible) (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 @@ -129,6 +133,7 @@ ,@(if autodetect `(:autodetect-function ,autodetect)) :parent-type ,parent-type + :visible (not ,invisible) :formatter-initial-values (lambda nil (list* ,@(mapcar #'(lambda (e) `(cons ',(car e) ,(second e))) @@ -183,16 +188,17 @@ (values ,position-foobage ,advance))))) ))))))))))) +(defun full-transition-table (coloring-type-object) + (let ((parent (coloring-type-parent-type coloring-type-object))) + (if parent + (append (coloring-type-transition-functions coloring-type-object) + (full-transition-table parent)) + (coloring-type-transition-functions coloring-type-object)))) + (defun scan-string (coloring-type string) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) - (parent (coloring-type-parent-type coloring-type-object)) - (transitions (append - (coloring-type-transition-functions - coloring-type-object) - (if parent - (coloring-type-transition-functions - parent)))) + (transitions (full-transition-table coloring-type-object)) (result nil) (low-bound 0) (current-mode (coloring-type-default-mode coloring-type-object)) Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.5 lisppaste2/coloring-types.lisp:1.6 --- lisppaste2/coloring-types.lisp:1.5 Fri Jun 4 07:09:51 2004 +++ lisppaste2/coloring-types.lisp Fri Jun 11 07:34:34 2004 @@ -230,3 +230,171 @@ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" result (call-parent-formatter)) (call-parent-formatter))))))) + +(defvar *c-open-parens* "([{") +(defvar *c-close-parens* ")]}") + +(defvar *c-reserved-words* + '("auto" "break" "case" "char" "const" + "continue" "default" "do" "double" "else" + "enum" "extern" "float" "for" "goto" + "if" "int" "long" "register" "return" + "short" "signed" "sizeof" "static" "struct" + "switch" "typedef" "union" "unsigned" "void" + "volatile" "while" "__restrict" "_Bool")) + +(define-coloring-type :basic-c "Basic C" + :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) + :default-mode :normal + :invisible t + :transitions + ((:normal + ((scan-any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") + (set-mode :word-ish + :until (scan-any '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #$ #$ #\' #\" #\[ #\] #\< #\> #\#)) + :advancing nil)) + ((scan "/*") + (set-mode :comment + :until (scan "*/"))) + + ((or + (scan-any *c-open-parens*) + (scan-any *c-close-parens*)) + (set-mode :paren-ish + :until (advance 1) + :advancing nil)) + ((scan #\") + (set-mode :string + :until (scan #\"))) + ((or (scan "'\\") + (scan #\')) + (set-mode :character + :until (advance 2)))) + (:string + ((scan #\\) + (set-mode :single-escape + :until (advance 1))))) + :formatter-variables + ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect ""))) + :formatters + ((:normal + (lambda (type s) + (declare (ignore type)) + s)) + (:comment + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:string + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:character + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:single-escape + (lambda (type s) + (call-formatter (cdr type) s))) + (:paren-ish + (lambda (type s) + (declare (ignore type)) + (let ((open nil) + (count 0)) + (if (eql (length s) 1) + (progn + (when (member (elt s 0) (coerce *c-open-parens* 'list)) + (setf open t) + (setf count (mod paren-counter 6)) + (incf paren-counter)) + (when (member (elt s 0) (coerce *c-close-parens* 'list)) + (setf open nil) + (decf paren-counter) + (setf count (mod paren-counter 6))) + (if open + (format nil "~A" + (1+ count) s *css-background-class*) + (format nil "~A" + s))) + s)))) + (:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c-reserved-words* :test #'string=) + (format nil "~A" s) + s))) + )) + +(define-coloring-type :c "C" + :parent :basic-c + :transitions + ((:normal + ((scan #\#) + (set-mode :preprocessor + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:preprocessor + (lambda (type s) + (declare (ignore type)) + (format nil "~A" s))))) + +(defvar *c++-reserved-words* + '("asm" "auto" "bool" "break" "case" + "catch" "char" /*class*/ "const" "const_cast" + "continue" "default" "delete" "do" "double" + "dynamic_cast" "else" "enum" "explicit" "export" + "extern" "false" "float" "for" "friend" + "goto" "if" "inline" "int" "long" + "mutable" "namespace" "new" "operator" "private" + "protected" "public" "register" "reinterpret_cast" "return" + "short" "signed" "sizeof" "static" "static_cast" + "struct" "switch" "template" "this" "throw" + "true" "try" "typedef" "typeid" "typename" + "union" "unsigned" "using" "virtual" "void" + "volatile" "wchar_t" "while")) + +(define-coloring-type :c++ "C++" + :parent :c + :transitions + ((:normal + ((scan "//") + (set-mode :comment + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c++-reserved-words* :test #'string=) + (format nil "~A" + s) + s))))) + +(defvar *java-reserved-words* + '("abstract" "boolean" "break" "byte" "case" + "catch" "char" "class" "const" "continue" + "default" "do" "double" "else" "extends" + "final" "finally" "float" "for" "goto" + "if" "implements" "import" "instanceof" "int" + "interface" "long" "native" "new" "package" + "private" "protected" "public" "return" "short" + "static" "strictfp" "super" "switch" "synchronized" + "this" "throw" "throws" "transient" "try" + "void" "volatile" "while")) + +(define-coloring-type :java "Java" + :parent :c++ + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *java-reserved-words* :test #'string=) + (format nil "~A" + s) + s)))))

1 0

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

11 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: < antifuchs> MORE DISCLAIMERS (this line is provided without any warranty) Date: Fri Jun 11 06:02:38 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.53 lisppaste2/web-server.lisp:1.54 --- lisppaste2/web-server.lisp:1.53 Wed Jun 9 12:46:35 2004 +++ lisppaste2/web-server.lisp Fri Jun 11 06:02:38 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.53 2004/06/09 19:46:35 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.54 2004/06/11 13:02:38 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -123,7 +123,9 @@ " | " ((a :href ,(araneida:urlstring *stats-url*)) "Stats") " | " - ((a :href "http://common-lisp.net/project/lisppaste") "lisppaste home page"))) + ((a :href "http://common-lisp.net/project/lisppaste") "lisppaste home page") + (br) + (i "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively."))) (defun time-delta (time &key (level 2) (ago-p t) (origin (get-universal-time))) (let ((delta (- origin time)))

1 0

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

09 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv3420 Modified Files: lisppaste.lisp Log Message: Small fix for no-channel pasting. Date: Wed Jun 9 13:05:31 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.20 lisppaste2/lisppaste.lisp:1.21 --- lisppaste2/lisppaste.lisp:1.20 Wed Jun 9 12:46:35 2004 +++ lisppaste2/lisppaste.lisp Wed Jun 9 13:05:31 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.20 2004/06/09 19:46:35 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.21 2004/06/09 20:05:31 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -53,6 +53,8 @@ :port port))) (setf *connection* connection) (setf *channels* channels) + (if *no-channel-pastes* + (pushnew "None" *channels* :test #'string-equal)) (read-pastes-from-file *paste-file*) (format t "Populating lookup table...~%") (clhs-lookup:populate-table)

1 0

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

09 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv7901 Modified Files: variable.lisp Log Message: Event logging Date: Wed Jun 9 12:48:46 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.20 lisppaste2/variable.lisp:1.21 --- lisppaste2/variable.lisp:1.20 Tue Jun 8 08:22:39 2004 +++ lisppaste2/variable.lisp Wed Jun 9 12:48:46 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.20 2004/06/08 15:22:39 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.21 2004/06/09 19:48:46 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -38,7 +38,10 @@ (defparameter *ban-log-file* "ban-log") -(defparameter *no-channel-pastes* t) +(defparameter *event-log-file* + "event-log") + +(defparameter *no-channel-pastes* nil) ;; You shouldn't need to edit below this line. ;; LINE

1 0

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

09 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv6729 Modified Files: elisp-lookup.lisp clhs-lookup.lisp r5rs-lookup.lisp Log Message: Conditional populating Date: Wed Jun 9 12:47:13 2004 Author: bmastenbrook Index: lisppaste2/elisp-lookup.lisp diff -u lisppaste2/elisp-lookup.lisp:1.1 lisppaste2/elisp-lookup.lisp:1.2 --- lisppaste2/elisp-lookup.lisp:1.1 Thu Jun 3 13:20:19 2004 +++ lisppaste2/elisp-lookup.lisp Wed Jun 9 12:47:13 2004 @@ -1,21 +1,27 @@ (defpackage :elisp-lookup (:use :cl) - (:export :symbol-lookup :populate-table)) + (:export :populate-table :symbol-lookup)) (in-package :elisp-lookup) (defparameter *elisp-root* "http://www.gnu.org/software/emacs/elisp-manual/html_node/") (defparameter *elisp-file* "elisp-symbols.lisp-expr") -(defparameter *table* nil) +(defvar *table* nil) + +(defvar *populated-p* nil) (defun populate-table () - (with-open-file (r *elisp-file* :direction :input) - (setf *table* (make-hash-table :test #'equalp)) - (let ((s (read r))) - (loop for i in s do (setf (gethash (car i) *table*) (cdr i)))) - 'done)) + (unless *populated-p* + (with-open-file (r *elisp-file* :direction :input) + (setf *table* (make-hash-table :test #'equalp)) + (let ((s (read r))) + (loop for i in s do (setf (gethash (car i) *table*) (cdr i)))) + 'done) + (setf *populated-p* t))) (defun symbol-lookup (symbol) + (unless *populated-p* + (populate-table)) (multiple-value-bind (val found) (gethash symbol *table*) (if found Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.3 lisppaste2/clhs-lookup.lisp:1.4 --- lisppaste2/clhs-lookup.lisp:1.3 Fri Jun 4 17:14:31 2004 +++ lisppaste2/clhs-lookup.lisp Wed Jun 9 12:47:13 2004 @@ -19,6 +19,8 @@ (defvar *section-table* (make-hash-table :test 'equalp)) (defvar *format-table* (make-hash-table :test 'equalp)) + +(defvar *populated-p* nil) (defun add-clhs-section-to-table (&rest numbers) (let ((key (format nil "~{~d~^.~}" numbers)) @@ -29,93 +31,97 @@ (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*) - ;; populate the table with the symbols from the Map file - ;; this bit is easy and portable. - (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 *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) + (unless *populated-p* + ;; Hyperspec + (with-open-file (s *hyperspec-map-file*) + ;; populate the table with the symbols from the Map file + ;; this bit is easy and portable. + (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 *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 (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 (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 (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 (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 (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*) - (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))))) + ;; 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*) + (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)))) + (setf *populated-p* t))) (defun spec-lookup (term &key (type :all)) + (unless *populated-p* + (populate-table)) (ecase type (:all (or (gethash term *symbol-table*) Index: lisppaste2/r5rs-lookup.lisp diff -u lisppaste2/r5rs-lookup.lisp:1.1 lisppaste2/r5rs-lookup.lisp:1.2 --- lisppaste2/r5rs-lookup.lisp:1.1 Thu Jun 3 07:14:45 2004 +++ lisppaste2/r5rs-lookup.lisp Wed Jun 9 12:47:13 2004 @@ -6,16 +6,22 @@ (defparameter *r5rs-file* "r5rs-symbols.lisp-expr") -(defparameter *table* nil) +(defvar *table* nil) + +(defvar *populated-p* nil) (defun populate-table () - (with-open-file (r *r5rs-file* :direction :input) - (setf *table* (make-hash-table :test #'equalp)) - (let ((s (read r))) - (loop for i in s do (setf (gethash (car i) *table*) (cdr i)))) - 'done)) + (unless *populated-p* + (with-open-file (r *r5rs-file* :direction :input) + (setf *table* (make-hash-table :test #'equalp)) + (let ((s (read r))) + (loop for i in s do (setf (gethash (car i) *table*) (cdr i)))) + 'done) + (setf *populated-p* t))) (defun symbol-lookup (symbol) + (unless *populated-p* + (populate-table)) (multiple-value-bind (val found) (gethash symbol *table*) (if found

1 0

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

09 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv6177 Modified Files: lisppaste.lisp web-server.lisp persistent-pastes.lisp Log Message: Event log, update read-pastes-from-file Date: Wed Jun 9 12:46:35 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.19 lisppaste2/lisppaste.lisp:1.20 --- lisppaste2/lisppaste.lisp:1.19 Tue Jun 8 08:21:30 2004 +++ lisppaste2/lisppaste.lisp Wed Jun 9 12:46:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.19 2004/06/08 15:21:30 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.20 2004/06/09 19:46:35 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -54,14 +54,16 @@ (setf *connection* connection) (setf *channels* channels) (read-pastes-from-file *paste-file*) - (mapcar #'(lambda (channel) (irc:join connection channel)) channels) + (format t "Populating lookup table...~%") (clhs-lookup:populate-table) (r5rs-lookup:populate-table) (elisp-lookup:populate-table) - (araneida:start-listening *paste-listener*) + (format t "Done!~%") + (mapcar #'(lambda (channel) (irc:join connection channel)) channels) (add-hook nickname) (setf *boot-time* (get-universal-time)) - (irc:start-background-message-handler connection))) + (irc:start-background-message-handler connection) + (araneida:start-listening *paste-listener*))) (defun join-new-channel (channel) (setf *channels* (nconc *channels* (list channel))) @@ -114,3 +116,10 @@ (setf (paste-annotations paste) (remove ann (paste-annotations paste) :key #'paste-number)) (serialize-to-file *paste-file* `(kill-paste-annotation ,number ,ann)))) + +(defun log-event (text) + (with-open-file (s *event-log-file* :direction :output :if-exists :append + :if-does-not-exist :create) + (write-string text *trace-output*) + (write-string text s) + (finish-output s))) \ No newline at end of file Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.52 lisppaste2/web-server.lisp:1.53 --- lisppaste2/web-server.lisp:1.52 Tue Jun 8 08:20:40 2004 +++ lisppaste2/web-server.lisp Wed Jun 9 12:46:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.52 2004/06/08 15:20:40 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.53 2004/06/09 19:46:35 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -43,7 +43,7 @@ (member forwarded-for *banned-ips* :test #'string-equal)) (progn - (with-open-file (s "ban-log" :direction :output :if-exists :append + (with-open-file (s *ban-log-file* :direction :output :if-exists :append :if-does-not-exist :create) (format s "Logged attempt by ~S to submit a paste.~%" forwarded-for) @@ -585,6 +585,12 @@ "#" (prin1-to-string annotation-number)) (prin1-to-string paste-number)))))) + (log-event + (format nil "New paste from IP ~A: number ~A, annotation of ~A, title ~S.~%" + (car (araneida:request-header request :x-forwarded-for)) + paste-number + annotation-number + title)) (make-new-paste *pastes* (annotate paste-number (paste-annotations paste-to-annotate)) @@ -688,9 +694,10 @@ (colorize:autodetect-coloring-type (paste-channel paste))))) (colorize:*css-background-class* "paste")) (and paste - (format t "Serving paste number ~S to ~S.~%" - (paste-number paste) - (car (araneida:request-header request :x-forwarded-for)))) + (log-event + (format nil "Serving paste number ~S to ~S.~%" + (paste-number paste) + (car (araneida:request-header request :x-forwarded-for))))) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.10 lisppaste2/persistent-pastes.lisp:1.11 --- lisppaste2/persistent-pastes.lisp:1.10 Tue Jun 8 08:21:30 2004 +++ lisppaste2/persistent-pastes.lisp Wed Jun 9 12:46:35 2004 @@ -51,7 +51,7 @@ ,@body)) (defun make-paste-from-alist (e &optional annotate) - (with-assoc-vals (number user title contents universal-time channel) e + (with-assoc-vals (number user title contents universal-time channel colorization-mode) e (if annotate (setf (paste-annotation-counter annotate) (max (paste-annotation-counter annotate) number)) (setf *paste-counter* (max *paste-counter* number))) @@ -61,6 +61,7 @@ :contents (remove #\return contents) :universal-time universal-time :channel channel + :colorization-mode colorization-mode :annotations nil))) (defun deserialize (expr) @@ -75,6 +76,7 @@ (defun read-pastes-from-file (file-name) (let ((*in-operation* t)) (setf *pastes* nil) + (setf *paste-counter* 0) (let ((*package* (find-package :lisppaste))) (with-open-file (file file-name :direction :input :if-does-not-exist nil) (if file

1 0

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

08 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-css.lisp package.lisp Log Message: Minor changes Date: Tue Jun 8 08:23:04 2004 Author: bmastenbrook Index: lisppaste2/coloring-css.lisp diff -u lisppaste2/coloring-css.lisp:1.1 lisppaste2/coloring-css.lisp:1.2 --- lisppaste2/coloring-css.lisp:1.1 Fri Jun 4 14:23:23 2004 +++ lisppaste2/coloring-css.lisp Tue Jun 8 08:23:04 2004 @@ -25,6 +25,6 @@ (defvar *css-background-class* "") (defun make-background-css (color &key (class *css-background-class*)) - (format nil ".~A { background-color: ~A; color : inherit; }~:*~:* -.~A:hover { background-color: ~A; color : inherit; }~%" + (format nil ".~A { background-color: ~A; color: WindowText; }~:*~:* +.~A:hover { background-color: ~A; color: WindowText; }~%" class color)) Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.6 lisppaste2/package.lisp:1.7 --- lisppaste2/package.lisp:1.6 Thu Jun 3 07:17:58 2004 +++ lisppaste2/package.lisp Tue Jun 8 08:23:04 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.6 2004/06/03 14:17:58 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.7 2004/06/08 15:23:04 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,6 +8,7 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste (:use :cl #+sbcl :sb-bsd-sockets :html-encode) - (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help + :kill-paste :kill-paste-annotations :kill-paste-annotation)))

1 0

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

08 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/foo/lisppaste2 Modified Files: variable.lisp Log Message: No-channel pastes Date: Tue Jun 8 08:22:39 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.19 lisppaste2/variable.lisp:1.20 --- lisppaste2/variable.lisp:1.19 Fri Jun 4 17:16:54 2004 +++ lisppaste2/variable.lisp Tue Jun 8 08:22:39 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.19 2004/06/05 00:16:54 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.20 2004/06/08 15:22:39 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -37,6 +37,8 @@ (defparameter *ban-log-file* "ban-log") + +(defparameter *no-channel-pastes* t) ;; You shouldn't need to edit below this line. ;; LINE

1 0