June 2004 - lisppaste-cvs@common-lisp.net

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

24 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/test/lisppaste2 Modified Files: variable.lisp Log Message: The variable part of CSS, I think Date: Thu Jun 24 12:52:25 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.23 lisppaste2/variable.lisp:1.24 --- lisppaste2/variable.lisp:1.23 Thu Jun 17 06:42:32 2004 +++ lisppaste2/variable.lisp Thu Jun 24 12:52:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.23 2004/06/17 13:42:32 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.24 2004/06/24 19:52:25 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -31,12 +31,6 @@ (defparameter *paste-site-name* "localhost" "Website we are running on (used for creating links).") -(defparameter *paste-url* - (araneida:merge-url - (araneida:make-url :scheme "http" - :host *paste-site-name* - :port *internal-http-port*) "/paste/")) - (defparameter *paste-external-url* (araneida:merge-url (araneida:make-url :scheme "http" @@ -95,6 +89,9 @@ (defparameter *stats-url* (araneida:merge-url *paste-external-url* "stats")) +(defparameter *css-url* + (araneida:merge-url *paste-external-url* "lisppaste.css")) + (defvar *paste-listener* (let ((fwd-url (araneida:copy-url *paste-external-url*))) (setf (araneida:url-port fwd-url) *internal-http-port*) @@ -110,7 +107,7 @@ #+sbcl #-sb-thread 'araneida:serve-event-http-listener #-sbcl 'threaded-http-listener :address #(127 0 0 1) - :port (araneida:url-port *paste-url*))) + :port *internal-http-port*)) (defvar *default-nickname* "devpaste") (defvar *default-irc-server* "irc.freenode.net")

1 0

[Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.lisp
by Brian Mastenbrook 24 Jun '04

24 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: encode-for-pre.lisp Log Message: more beginning-of-line damage Date: Thu Jun 24 12:48:04 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.17 lisppaste2/encode-for-pre.lisp:1.18 --- lisppaste2/encode-for-pre.lisp:1.17 Tue Jun 8 08:20:40 2004 +++ lisppaste2/encode-for-pre.lisp Thu Jun 24 12:48:04 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.17 2004/06/08 15:20:40 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.18 2004/06/24 19:48:04 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,13 +10,16 @@ (defun encode-for-tt (string &key with-line-numbers first-char-nbsp) (let ((pos 0) (end (length string)) - (char nil)) + (char nil) (last-was-newline nil)) (flet ((next-char () - (setf char (when (> end pos) - (prog1 - (schar string pos) - (incf pos)))))) - (with-output-to-string (out) + (prog1 + (setf char (when (> end pos) + (prog1 + (schar string pos) + (incf pos)))) + (when char (setf last-was-newline (eql char #\newline)))))) + (values + (with-output-to-string (out) (block nil (tagbody (unless first-char-nbsp @@ -32,9 +35,9 @@ ((nil) (return)) ((#\Newline) (write-string " " out) - (if with-line-numbers - (write-string (funcall with-line-numbers) out)) - (go escape-spaces)) + (when with-line-numbers + (write-string (funcall with-line-numbers) out)) + (go escape-spaces)) ((#\&) (write-string "&" out)) ((#\<) @@ -50,7 +53,8 @@ (t (write-char char out))) (next-char) - (go process-char))))))) + (go process-char)))) + last-was-newline)))) (defun encode-for-pre (string)

1 0

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

24 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp coloring-css.lisp Log Message: super-neato CSS, part 1 Date: Thu Jun 24 12:47:39 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.58 lisppaste2/web-server.lisp:1.59 --- lisppaste2/web-server.lisp:1.58 Thu Jun 24 08:02:58 2004 +++ lisppaste2/web-server.lisp Thu Jun 24 12:47:39 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.58 2004/06/24 15:02:58 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.59 2004/06/24 19:47:39 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,6 +23,8 @@ (defclass main-handler (araneida:handler) ()) +(defclass css-handler (araneida:handler) ()) + (defclass new-paste-handler (araneida:handler) ()) (defclass list-paste-handler (araneida:handler) ()) @@ -39,19 +41,50 @@ (defclass stats-handler (araneida:handler) ()) -(defun lisppaste-wrap-page (title &rest forms) +(defmethod araneida:handle-request-response ((handler css-handler) method request) (let ((colorize:*css-background-class* "paste")) - `(html - (head (title ,title) - ((style :type "text/css") - ,(format nil "~A~%~A~%" - (colorize:make-background-css "#F4F4F4") - colorize:*coloring-css*)) - ,(rss-link-header)) - (body - (h2 ,title) - ,@forms - ,@(bottom-links))))) + (araneida:request-send-headers request :expires 0 :content-type "text/css") + (araneida:html-stream + (araneida:request-stream request) + (format nil "a { margin:1px; border-collapse: collapse; } +a:link { color:#335570; text-decoration: none; background-color: transparent;} +a:visited { color:#705533; text-decoration: none; background-color: transparent;} +a:hover { color:#000000; text-decoration: none; background-color: #BBCCEE; border: 1px solid #335577; margin: 0px;} +a:active { color:#000000; text-decoration: none; background-color: #CCBBFF; border: 1px solid #335577; margin: 0px;} +.simple-paste-list { background-color : #E9FFE9 ; border: 2px solid #9D9; padding : 4px; font-size: small; } +.simple-paste-list td { border-bottom: 1px dotted #9D9; font-size: small; } +table.detailed-paste-list { border-collapse: collapse; border : 1px solid #AAA ; } +table.detailed-paste-list td { border : 1px dotted #AAA; } +table.info-table { border-collapse: collapse; border : 1px solid #AAA ; background-color: #F9E9F9; empty-cells: hide; } +table.info-table td { border : 1px dotted #AAA; background-color: transparent; padding-left: 2em; padding-right: 2em; } +table.info-table th { border : 1px dotted #AAA; background-color: transparent; text-align: left; padding-right: 1em; } +.new-paste-form { background-color : #FFE9E9 ; border: 2px solid #D99; padding : 4px; } +.paste-header { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-bottom : 4px; } +.info-text { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-top : 4px; text-align: justify; } +.controls { background-color : #E9E9FF ; border: 2px solid #99D; padding : 4px; } +.small-header { font-weight: bold; font-size: large; } +.top-header { text-align : center; font-style: italic; font-weight: bold; font-size: x-large; } +.big-warning { text-align : center; font-weight: bold; font-size: x-large; } +.paste-area { background-color : #F4F4F4 ; border : 2px solid #AAA ; } +.bottom-links { background-color : #F9F9E9; border: 2px solid #DD9; padding : 4px; margin-bottom : 4px;} +#main-link { text-align : left; font-weight: bold; } +#other-links { text-align : right; } +hr { border: 1px solid #999; } +~A~&~A~&" + (colorize:make-background-css "#F4F4F4") + colorize:*coloring-css*)))) + +(defun lisppaste-wrap-page (title &rest forms) + `(html + (head (title ,title) + ((link :type "text/css" :rel "stylesheet" :href ,(araneida:url-path *css-url*))) + ,(rss-link-header)) + (body + ((div :class "top-header") + ,title) + (p) + ,@forms + ,@(bottom-links)))) (defun paste-display-url (paste) (araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) @@ -61,20 +94,49 @@ (araneida:html-stream (araneida:request-stream request) (lisppaste-wrap-page - "Lisppaste" + *paste-site-name* `((table :width "100%" :border 0 :cellpadding 2) - (tr (td (b "Recent pastes")) - (td (center (b "Make a new paste")))) + (tr (td ((div :class "small-header") "Recent pastes")) + ((td :align right) ((div :class "small-header") "Make a new paste"))) (tr - ((td :valign top) - ,@(loop for i from 1 to 10 - for j in *pastes* - appending `( - ((a :href ,(paste-display-url j)) - ,(encode-for-pre (paste-title j))) - " by " ,(encode-for-pre (paste-user j)) (br)))) - ((td :valign top) - ,(generate-new-paste-form :width 40))))))) + ((td :valign top :width "40%") + ((div :class "simple-paste-list") + (table + ,@(loop for i from 1 to 10 + for j in *pastes* + collect `(tr + ((td :valign center) ((a :href ,(paste-display-url j)) + ,(encode-for-pre (paste-title j)))) + ((td :valign bottom) " by " ,(encode-for-pre (paste-user j))) + ((td :valign bottom) ,(encode-for-pre (paste-channel j))))))) + (p) + ((div :class "small-header") "About lisppaste") + ((div :class "info-text") + "Many times when working via IRC, people want to share a +snippet of code with somebody else. However, just pasting the code +into IRC creates a flood of text which is hard to read and scrolls by +as discussion progresses." + (p) + "Thus, the pastebot was invented, which has a web form where +users can paste code, and the URL of the paste is announced on the +desired channel. Lisppaste is an advanced pastebot running on the IRC +server " + ,(encode-for-pre (irc:server-name *connection*)) + " which has many unique features." + ,@(if *no-channel-pastes* + '((p) " It also allows pastes which are not announced on any channel, which +is useful for sections of code which need to be sent to a mailing list +or are discussed in ways other than IRC.")) + (p) + "Lisppaste is graciously hosted by " + (b ((a :href "http://www.common-lisp.net/") "common-lisp.net")) + " - a hosting service for projects written in Common Lisp +(like this one).")) + ((td :valign top :align right) + ((form :method post :action ,(araneida:urlstring *submit-paste-url*)) + ,(generate-new-paste-form :width 60)))) + + )))) (defmethod araneida:handle-request-response :around ((handler submit-paste-handler) method request) @@ -137,29 +199,36 @@ (lisppaste-wrap-page "Select a channel" `((form :method post :action ,(araneida:urlstring *new-paste-url*)) - ((input :type "hidden" :name "annotate" :value ,annotate-string)) - "Please select a channel to lisppaste to: " - ((select :name "channel") - ((option :value "")) - ,@(mapcar #'(lambda (e) - `((option :value ,e) - ,(encode-for-pre e))) *channels*)) - ((input :type submit :value "Submit"))))))))) - + ((div :class "controls") + ((input :type "hidden" :name "annotate" :value ,annotate-string)) + "Please select a channel to lisppaste to: " + ((select :name "channel") + ((option :value "")) + ,@(mapcar #'(lambda (e) + `((option :value ,e) + ,(encode-for-pre e))) *channels*)) + ((input :type submit :value "Submit")))))))))) + (defun bottom-links () - `((hr) - ((a :href ,(araneida:urlstring *new-paste-url*)) "New paste") - " | " - ((a :href ,(araneida:urlstring *list-paste-url*)) "List all pastes") - " | " - ((a :href ,(araneida:urlstring *syndication-url*)) "Syndication") - " | " - ((a :href "http://common-lisp.net/project/lisppaste/xml-rpc.html") "XML-RPC") - " | " - ((a :href ,(araneida:urlstring *stats-url*)) "Stats") - " | " - ((a :href "http://common-lisp.net/project/lisppaste") "lisppaste home page") - (br) + `((p) + ((div :class "bottom-links") + ((table :width "100%") + (tr + ((td :id "main-link") + ((a :href ,(araneida:urlstring *paste-external-url*)) + "Main page")) + ((td :id "other-links") + ((a :href ,(araneida:urlstring *new-paste-url*)) "New paste") + " | " + ((a :href ,(araneida:urlstring *list-paste-url*)) "List all pastes") + " | " + ((a :href ,(araneida:urlstring *syndication-url*)) "Syndication") + " | " + ((a :href "http://common-lisp.net/project/lisppaste/xml-rpc.html") "XML-RPC") + " | " + ((a :href ,(araneida:urlstring *stats-url*)) "Stats") + " | " + ((a :href "http://common-lisp.net/project/lisppaste") "Project home"))))) (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))) @@ -219,35 +288,24 @@ "Lisppaste can be syndicated in a variety of RSS formats for use with your favorite RSS reader." `(p) - `(table + `((table :class "info-table") (tr ((th :align left) "All channels") - ((td :width 30)) (td ((a :href ,(araneida:urlstring *rss-url*)) "Basic")) - ((td :width 10)) (td ((a :href ,(araneida:urlstring *rss-full-url*)) "Full"))) - ,@(if *no-channel-pastes* - `((tr - ((th :align left) "None") - ((td :width 30)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-url*) - "?none")) "Basic")) - ((td :width 10)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-full-url*) - "?none")) "Full"))))) ,@(mapcar #'(lambda (channel) + (let ((append (if (and *no-channel-pastes* + (string-equal channel "None")) + "?none" + (substitute #\? #\# channel)))) `(tr ((th :align left) ,channel) - ((td :width 30)) (td ((a :href ,(concatenate 'string (araneida:urlstring *rss-url*) - (substitute #\? #\# channel))) "Basic")) - ((td :width 10)) + append)) "Basic")) (td ((a :href ,(concatenate 'string (araneida:urlstring *rss-full-url*) - (substitute #\? #\# channel))) "Full")))) + append)) "Full"))))) *channels*))))) (defmethod araneida:handle-request-response ((handler stats-handler) method request) @@ -258,18 +316,16 @@ (lisppaste-wrap-page "Statistics" `(div - (b "Uptime: ") + ((span :class "small-header") "Uptime: ") ,(time-delta *boot-time* :ago-p nil :level 3) (p) - (b "Most popular channels:") - (br) - ((table :border 0) + ((span :class "small-header") "Most popular channels:") + (p) + ((table :border 0 :class "info-table") ,@(mapcar #'(lambda (pair) `(tr - ((td :valign top) + ((th :valign top) ,(car pair)) - ((td) - " ") ((td :valign top) ,(cdr pair)))) (sort @@ -279,14 +335,13 @@ :test #'string=))) #'> :key #'cdr))) (p) - (b "Average rates of pasting:") (br) - ((table :border 0) + ((span :class "small-header") "Average rates of pasting:") (p) + ((table :border 0 :class "info-table") ,@(mapcar #'(lambda (pair) `(tr #+(or) (td ,(length (second pair))) - ((td :valign top) + ((th :valign top) ,(first pair)) - (td " ") ((td :valign top) ,(time-delta 0 :origin @@ -401,7 +456,7 @@ discriminate-channel))))))) `(center ((form :method post :action ,(araneida:urlstring *list-paste-url*)) - (table + ((table :class "controls") (tr ((td :align left) "View only: ") ((td :valign top :align center) ((select :name "channel") @@ -439,10 +494,11 @@ ,@page-links)) ))) `(p) - `((table :width "100%" :cellpadding 2) + `((table :width "100%" :cellpadding 2 :class "detailed-paste-list") (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann.")) ,@(mapcar #'(lambda (paste) - `(tr ((td :nowrap "nowrap") ((a :href ,(paste-display-url paste)) + `(tr + ((td :nowrap "nowrap") ((a :href ,(paste-display-url paste)) ,(concatenate 'string "#" (prin1-to-string (paste-number paste))))) ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12))) ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste))) @@ -454,8 +510,9 @@ for j in discriminated-pastes if (>= i (* page *pastes-per-page*)) collect j))) + `(p) `(center - "Page: " ,@page-links) + ((table :class "controls") (tr (td "Page: " ,@page-links)))) )))))) (defun handle-rss-request (request &key full) @@ -515,41 +572,43 @@ (handle-rss-request request :full t)) (defun generate-new-paste-form (&key annotate (default-channel "None") (default-user "") (default-title "") (default-contents "") (width 80)) - `(table - ,@(if (not annotate) - `((tr - ((th :align left) "Select a channel:") - (td ((select :name "channel") - ((option :value "")) - ,@(mapcar #'(lambda (e) - `((option :value ,e ,@(if (string-equal e default-channel) - '(:selected "SELECTED"))) - ,(encode-for-pre e))) *channels*)))))) - (tr - ((th :align left) "Enter your username:") - (td ((input :type text :name "username" - :value ,(encode-for-pre default-user))))) - (tr - ((th :align left) "Enter a title:") - (td ((input :type text :name "title" - :value ,(encode-for-pre default-title))))) - ,@(if (not annotate) - `((tr - ((th :align left) (i "(Optional) Colorize as: ")) - (td ((select :name "colorize") - ((option :value "" :selected "SELECTED") "Default for this channel") - ((option :value "None") "None") - ,@(mapcar #'(lambda (pair) - `((option :value ,(cdr pair)) - ,(cdr pair))) - (colorize:coloring-types))))))) - (tr - ((th :align left :valign top) "Enter your paste:") - (td ((textarea :rows 24 :cols ,width :name "text") - ,(encode-for-pre default-contents)))) - (tr - ((th :align left) "Submit your paste:") - ((td) ((input :type submit :value "Submit paste")) " " ((input :type reset :value "Clear paste")))))) + `((table :class "new-paste-form") + ,@(if (not annotate) + `((tr + ((th :align left :width "0%" :nowrap "nowrap") "Select a channel:") + (td ((select :name "channel") + ((option :value "")) + ,@(mapcar #'(lambda (e) + `((option :value ,e ,@(if (string-equal e default-channel) + '(:selected "SELECTED"))) + ,(encode-for-pre e))) *channels*)))))) + (tr + ((th :align left :width "0%" :nowrap "nowrap") "Enter your username:") + (td ((input :type text :name "username" + :value ,(encode-for-pre default-user))))) + (tr + ((th :align left :width "0%" :nowrap "nowrap") "Enter a title:") + (td ((input :type text :name "title" + :value ,(encode-for-pre default-title))))) + ,@(if (not annotate) + `((tr + ((th :align left :width "0%" :nowrap "nowrap") (i "(Optional) Colorize as: ")) + (td ((select :name "colorize") + ((option :value "" :selected "SELECTED") "Default for this channel") + ((option :value "None") "None") + ,@(mapcar #'(lambda (pair) + `((option :value ,(cdr pair)) + ,(cdr pair))) + (colorize:coloring-types))))))) + (tr + ((th :align left :valign top :width "0%" :nowrap "nowrap") "Enter your paste:") + ((td #|:width "100%"|#))) + (tr + ((td :colspan 2) ((textarea :rows 24 :cols ,width :name "text") + ,(encode-for-pre default-contents)))) + (tr + ((th :align left :width "0%" :nowrap "nowrap") "Submit your paste:") + ((td) ((input :type submit :value "Submit paste")) " " ((input :type reset :value "Clear paste")))))) (defun new-paste-form (request &key (message "") (annotate nil) (default-channel "") (default-user "") (default-title "") (default-contents "")) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") @@ -557,19 +616,22 @@ (araneida:request-stream request) (lisppaste-wrap-page (if annotate "Enter your annotation" "Enter your paste") - `((font :color red) (h2 ,message)) + (if (length message) + `((div :class "big-warning") ,message) + "") `((form :method post :action ,(araneida:urlstring *submit-paste-url*)) - (p "Enter a username, title, and paste contents into the fields below." - ,@(unless (and annotate - *no-channel-pastes* - (string-equal (paste-channel annotate) "None")) - `("The paste will be announced on the selected channel @ " ,(irc:server-name *connection*) "."))) - ,@(if annotate - `((p "This paste will be used to annotate " - ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) "."))) - ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number annotate)))) - ((input :type hidden :name "channel" :value ,(paste-channel annotate))))) - (hr) + ((div :class "info-text") + "Enter a username, title, and paste contents into the fields below. " + ,@(unless (and annotate + *no-channel-pastes* + (string-equal (paste-channel annotate) "None")) + `("The paste will be announced on the selected channel on " ,(irc:server-name *connection*) ". ")) + ,@(if annotate + `("This paste will be used to annotate " + ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) ".")) + ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number annotate)))) + ((input :type hidden :name "channel" :value ,(paste-channel annotate)))))) + (p) ,(generate-new-paste-form :annotate annotate :default-channel default-channel :default-user default-user :default-title default-title :default-contents default-contents))))) (defmethod araneida:handle-request-response ((handler submit-paste-handler) method request) @@ -637,14 +699,15 @@ (araneida:request-stream request) (lisppaste-wrap-page (format nil "Paste number ~A pasted!" paste-number) - `(p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) + `(p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") (b ((a :href ,url) ,url)) ,@(unless (and *no-channel-pastes* (string-equal channel "none")) - `(", and was also sent to " ,channel " @ " ,(irc:server-name *connection*))) ".") - `(h3 "Don't paste more junk; annotate!") + `(", and was also sent to " ,channel " at " ,(irc:server-name *connection*))) ".") + `((span :class "small-header") "Don't paste more junk; annotate!") `((form :method post :action ,(araneida:urlstring *new-paste-url*)) ((input :type hidden :name "annotate" :value ,(prin1-to-string paste-number))) - (center ((input :type submit :value "Annotate this paste")))) + (center ((span :class "controls") + ((input :type submit :value "Annotate this paste"))))) )))))))) (defun ends-with (str end) @@ -654,7 +717,7 @@ (string= (subseq str (- l1 l2) l1) end)))) (defun format-paste (paste this-url paste-number &optional annotation colorize-as line-numbers) - (let ((n 0) (next-first-char-nbsp nil)) + (let ((n 0) (next-first-char-nbsp t)) (labels ((line-number () (format nil "~A" @@ -669,40 +732,41 @@ :first-char-nbsp next-first-char-nbsp) (prog1 encoded (setf next-first-char-nbsp last))))) - `((table :width "100%" :cellpadding 2) - (tr ((td :align "left" :width "0%" :nowrap "nowrap") - ,(if annotation - `((a :name ,(prin1-to-string paste-number)) "Annotation number ") - "Paste number ") ,paste-number ": ") - ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) - (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") - ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) - (tr (td) - ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) - ,@(if (or (not annotation) *meme-links*) - `((tr (td) - ((td :align "left" :width "100%") - ,@(if (not annotation) - `((,(encode-for-pre (paste-channel paste))))) - ,@(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 - `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) - (tr (td (p))) - (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") - (tt - ,@(if line-numbers - (list (line-number))) - ,(if colorize-as - (colorize:format-scan colorize-as - (mapcar #'(lambda (e) - (cons (car e) - (encode (cdr e)))) - (colorize:scan-string colorize-as (paste-contents paste)))) - (encode (paste-contents paste)))))))))) + `(div + ((table :class "paste-header") + (tr ((td :align "left" :width "0%" :nowrap "nowrap") + ,(if annotation + `((a :name ,(prin1-to-string paste-number)) "Annotation number ") + "Paste number ") ,paste-number ": ") + ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) + (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") + ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) + (tr (td) + ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) + ,@(if (or (not annotation) *meme-links*) + `((tr (td) + ((td :align "left" :width "100%") + ,@(if (not annotation) + `((,(encode-for-pre (paste-channel paste))))) + ,@(if (and *meme-links* + (not (and *no-channel-pastes* + (string-equal (paste-channel paste) "None")))) + `(,@(and (not annotation) '(" | ")) ((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 + `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)")))))) + ((table :width "100%" :class "paste-area") + (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") + (tt + ,@(if line-numbers + (list (line-number))) + ,(if colorize-as + (colorize:format-scan colorize-as + (mapcar #'(lambda (e) + (cons (car e) + (encode (cdr e)))) + (colorize:scan-string colorize-as (paste-contents paste)))) + (encode (paste-contents paste))))))))))) (defmethod araneida:handle-request-response ((handler display-paste-handler) method request) ; XXX request-unhandled-part will be exported in 0.81 @@ -749,7 +813,22 @@ (write-string (remove #\return (paste-contents paste) :test #'char=)(araneida:request-stream request))))) - (progn + (let ((annotate-html + `((table :class "controls") + (tr (td + ,@(if (paste-annotations paste) + `("Index of paste annotations: " + ,@(loop for ann in (reverse (paste-annotations paste)) + for test from (length (paste-annotations paste)) downto 1 + appending + `(((a :href ,(format nil "#~A" + (paste-number ann))) + ,(prin1-to-string (paste-number ann)))) + if (not (eql test 1)) + appending '(" | ")) + (p))) + ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number paste)))) + (center ((input :type submit :value "Annotate this paste")))))))) (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream @@ -757,57 +836,56 @@ (lisppaste-wrap-page (format nil "Paste number ~A" paste-number) `(div - ,@(if (paste-annotations paste) - `("Index of paste annotations: " - ,@(loop for ann in (reverse (paste-annotations paste)) - for test from (length (paste-annotations paste)) downto 1 - appending - `(((a :href ,(format nil "#~A" - (paste-number ann))) - ,(prin1-to-string (paste-number ann)))) - if (not (eql test 1)) - appending '(" | ")) - (p))) + ((form :method post :action ,(araneida:urlstring *new-paste-url*)) + (center + ,annotate-html)) + (p) ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as linenumbers) ,@(if (paste-annotations paste) `((p) - "Annotations for this paste: " + ((span :class "small-header") "Annotations for this paste: ") ,@(reduce #'append (mapcar #'(lambda (a) - `((hr) + `((p) ,(format-paste a (format nil "~A,~A" (araneida:urlstring (araneida:request-url request)) (paste-number a)) (paste-number a) t colorize-as linenumbers))) (reverse (paste-annotations paste))))) - `((p) "This paste has no annotations.")) + `((p) ((span :class "small-header") "This paste has no annotations."))) (p) - ((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 "SELECTED"))) - ,(cdr pair))) - (colorize:coloring-types))) - (br) - ((input :type "checkbox" :name "linenumbers" :value "true" - ,@(if linenumbers '(:checked "checked")))) " Show Line Numbers" - (br) - ((input :type submit :value "Format"))) - (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")))) - ))))) + ((table :width "100%") + (tr + ((td :align "left") + ((form :method post :action ,(araneida:urlstring + (araneida:merge-url + *display-paste-url* + (araneida:request-unhandled-part request)))) + ((table :class "controls") + (tr + (td + "Colorize as: " + ((select :name "colorize") + ((option :value "None") "None") + ,@(mapcar #'(lambda (pair) + `((option :value ,(cdr pair) + ,@(if (eq + (car pair) + colorize-as) + '(:selected "SELECTED"))) + ,(cdr pair))) + (colorize:coloring-types))) + (br) + ((input :type "checkbox" :name "linenumbers" :value "true" + ,@(if linenumbers '(:checked "checked")))) + " Show Line Numbers" + (br) + (center ((input :type submit :value "Format")))))))) + ((td :align "right") + ((form :method post :action ,(araneida:urlstring *new-paste-url*)) + ,annotate-html)))) + ))))) (progn (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") @@ -861,3 +939,8 @@ (araneida:http-listener-handler *paste-listener*) (make-instance 'main-handler) (araneida:urlstring *paste-external-url*) t) + +(araneida:install-handler + (araneida:http-listener-handler *paste-listener*) + (make-instance 'css-handler) + (araneida:urlstring *css-url*) t) Index: lisppaste2/coloring-css.lisp diff -u lisppaste2/coloring-css.lisp:1.3 lisppaste2/coloring-css.lisp:1.4 --- lisppaste2/coloring-css.lisp:1.3 Thu Jun 17 05:46:59 2004 +++ lisppaste2/coloring-css.lisp Thu Jun 24 12:47:39 2004 @@ -3,28 +3,37 @@ (in-package :colorize) (defparameter *coloring-css* - ".symbol { color : #770055; background-color : inherit; } -a.symbol:link { color : #229955; background-color : inherit; text-decoration: none; } -a.symbol:active { color : #229955; background-color : inherit; text-decoration: none; } -a.symbol:visited { color : #229955; background-color : inherit; text-decoration: none; } -a.symbol:hover { color : #229955; background-color : inherit; text-decoration: none; } + ".symbol { color : #770055; background-color : transparent; border: 0px; margin: 0px;} +a.symbol:link { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } .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; } -.paren1:hover { color : inherit; background-color : #CAFFFF; } +.paren1:hover { color : inherit; background-color : #BAFFFF; } .paren2:hover { color : inherit; background-color : #FFCACA; } -.paren3:hover { color : inherit; background-color : #FFFFCA; } +.paren3:hover { color : inherit; background-color : #FFFFBA; } .paren4:hover { color : inherit; background-color : #CACAFF; } .paren5:hover { color : inherit; background-color : #CAFFCA; } -.paren6:hover { color : inherit; background-color : #FFCAFF; } +.paren6:hover { color : inherit; background-color : #FFBAFF; } ") (defvar *css-background-class* "") -(defun make-background-css (color &key (class *css-background-class*)) - (format nil ".~A { background-color: ~A; color: WindowText; }~:*~:* -.~A:hover { background-color: ~A; color: WindowText; }~%" - class color)) +(defun for-css (thing) + (if (symbolp thing) (string-downcase (symbol-name thing)) + thing)) + +(defun make-background-css (color &key (class *css-background-class*) (extra nil)) + (format nil ".~A { background-color: ~A; color: WindowText; ~{~A; ~}}~:*~:*~:* +.~A:hover { background-color: ~A; color: WindowText; ~{~A; ~}}~%" + class color + (mapcar #'(lambda (extra) + (format nil "~A : ~{~A ~}" + (for-css (first extra)) + (mapcar #'for-css (cdr extra)))) + extra)))

1 0

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

24 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.lisp Log Message: Small error in make-paste Date: Thu Jun 24 08:03:22 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.21 lisppaste2/lisppaste.lisp:1.22 --- lisppaste2/lisppaste.lisp:1.21 Wed Jun 9 13:05:31 2004 +++ lisppaste2/lisppaste.lisp Thu Jun 24 08:03:22 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.21 2004/06/09 20:05:31 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.22 2004/06/24 15:03:22 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -85,7 +85,7 @@ &key channel user title &allow-other-keys) (let ((paste-name (gensym))) `(let ((,paste-name (make-paste ,@keys))) - (if (not (string-equal channel "None")) + (if (not (string-equal ,channel "None")) (irc:privmsg *connection* ,channel (if ,annotate (format nil "~A annotated #~A with \"~A\" at ~A" ,user ,real-number ,title ,url) @@ -124,4 +124,4 @@ :if-does-not-exist :create) (write-string text *trace-output*) (write-string text s) - (finish-output s))) \ No newline at end of file + (finish-output s)))

1 0

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

24 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Bit-o-refactoring, "main page" Date: Thu Jun 24 08:02:58 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.57 lisppaste2/web-server.lisp:1.58 --- lisppaste2/web-server.lisp:1.57 Thu Jun 17 05:46:59 2004 +++ lisppaste2/web-server.lisp Thu Jun 24 08:02:58 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.57 2004/06/17 12:46:59 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.58 2004/06/24 15:02:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -21,6 +21,8 @@ `(progn (funcall 'make-instance 'paste ,@arguments))) +(defclass main-handler (araneida:handler) ()) + (defclass new-paste-handler (araneida:handler) ()) (defclass list-paste-handler (araneida:handler) ()) @@ -37,6 +39,43 @@ (defclass stats-handler (araneida:handler) ()) +(defun lisppaste-wrap-page (title &rest forms) + (let ((colorize:*css-background-class* "paste")) + `(html + (head (title ,title) + ((style :type "text/css") + ,(format nil "~A~%~A~%" + (colorize:make-background-css "#F4F4F4") + colorize:*coloring-css*)) + ,(rss-link-header)) + (body + (h2 ,title) + ,@forms + ,@(bottom-links))))) + +(defun paste-display-url (paste) + (araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) + +(defmethod araneida:handle-request-response ((handler main-handler) method request) + (araneida:request-send-headers request :expires 0) + (araneida:html-stream + (araneida:request-stream request) + (lisppaste-wrap-page + "Lisppaste" + `((table :width "100%" :border 0 :cellpadding 2) + (tr (td (b "Recent pastes")) + (td (center (b "Make a new paste")))) + (tr + ((td :valign top) + ,@(loop for i from 1 to 10 + for j in *pastes* + appending `( + ((a :href ,(paste-display-url j)) + ,(encode-for-pre (paste-title j))) + " by " ,(encode-for-pre (paste-user j)) (br)))) + ((td :valign top) + ,(generate-new-paste-form :width 40))))))) + (defmethod araneida:handle-request-response :around ((handler submit-paste-handler) method request) (let ((forwarded-for (car (araneida:request-header request :x-forwarded-for)))) @@ -95,22 +134,17 @@ (t (araneida:request-send-headers request :expires 0) (araneida:html-stream (araneida:request-stream request) - `(html - (head - (title "Select a channel") - ,(rss-link-header)) - (body - (h2 "Select a channel") - ((form :method post :action ,(araneida:urlstring *new-paste-url*)) - ((input :type "hidden" :name "annotate" :value ,annotate-string)) - "Please select a channel to lisppaste to: " - ((select :name "channel") - ((option :value "")) - ,@(mapcar #'(lambda (e) - `((option :value ,e) - ,(encode-for-pre e))) *channels*)) - ((input :type submit :value "Submit"))) - ,@(bottom-links)))))))) + (lisppaste-wrap-page + "Select a channel" + `((form :method post :action ,(araneida:urlstring *new-paste-url*)) + ((input :type "hidden" :name "annotate" :value ,annotate-string)) + "Please select a channel to lisppaste to: " + ((select :name "channel") + ((option :value "")) + ,@(mapcar #'(lambda (e) + `((option :value ,e) + ,(encode-for-pre e))) *channels*)) + ((input :type submit :value "Submit"))))))))) (defun bottom-links () `((hr) @@ -180,74 +214,70 @@ (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) - `(html - (head (title "Syndication options") - ,(rss-link-header)) - (body - (h2 "Syndication options") - "Lisppaste can be syndicated in a variety of RSS formats for use + (lisppaste-wrap-page + "Syndication options" + "Lisppaste can be syndicated in a variety of RSS formats for use with your favorite RSS reader." - (p) - (table - (tr - ((th :align left) "All channels") - ((td :width 30)) - (td ((a :href ,(araneida:urlstring *rss-url*)) "Basic")) - ((td :width 10)) - (td ((a :href ,(araneida:urlstring *rss-full-url*)) "Full"))) - ,@(if *no-channel-pastes* - `((tr - ((th :align left) "None") - ((td :width 30)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-url*) - "?none")) "Basic")) - ((td :width 10)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-full-url*) - "?none")) "Full"))))) - ,@(mapcar #'(lambda (channel) - `(tr - ((th :align left) ,channel) - ((td :width 30)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-url*) - (substitute #\? #\# channel))) "Basic")) - ((td :width 10)) - (td ((a :href ,(concatenate 'string - (araneida:urlstring *rss-full-url*) - (substitute #\? #\# channel))) "Full")))) - *channels*)) - ,@(bottom-links))))) + `(p) + `(table + (tr + ((th :align left) "All channels") + ((td :width 30)) + (td ((a :href ,(araneida:urlstring *rss-url*)) "Basic")) + ((td :width 10)) + (td ((a :href ,(araneida:urlstring *rss-full-url*)) "Full"))) + ,@(if *no-channel-pastes* + `((tr + ((th :align left) "None") + ((td :width 30)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + "?none")) "Basic")) + ((td :width 10)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + "?none")) "Full"))))) + ,@(mapcar #'(lambda (channel) + `(tr + ((th :align left) ,channel) + ((td :width 30)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + (substitute #\? #\# channel))) "Basic")) + ((td :width 10)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + (substitute #\? #\# channel))) "Full")))) + *channels*))))) (defmethod araneida:handle-request-response ((handler stats-handler) method request) (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) - `(html - (head (title "Statistics") - ,(rss-link-header)) - (body - (h2 "Statistics") - (b "Uptime: ") ,(time-delta *boot-time* :ago-p nil :level 3) + (lisppaste-wrap-page + "Statistics" + `(div + (b "Uptime: ") + ,(time-delta *boot-time* :ago-p nil :level 3) (p) - (b "Most popular channels:") (br) + (b "Most popular channels:") + (br) ((table :border 0) ,@(mapcar #'(lambda (pair) - `(tr - ((td :valign top) - ,(car pair)) + `(tr + ((td :valign top) + ,(car pair)) ((td) " ") ((td :valign top) - ,(cdr pair)))) + ,(cdr pair)))) (sort - (loop for i in *channels* - collect (cons i (count i *pastes* - :key #'paste-channel - :test #'string=))) - #'> :key #'cdr))) + (loop for i in *channels* + collect (cons i (count i *pastes* + :key #'paste-channel + :test #'string=))) + #'> :key #'cdr))) (p) (b "Average rates of pasting:") (br) ((table :border 0) @@ -300,7 +330,7 @@ (- (paste-universal-time (first p)) (paste-universal-time (car (last p))))))) #'> :key #'(lambda (e) (length (second e))))))) - ,@(bottom-links))))) + )))) (defmethod araneida:handle-request-response ((handler list-paste-handler) method request) (araneida:request-send-headers request :expires 0) @@ -360,75 +390,73 @@ "> Older")))))) (araneida:html-stream (araneida:request-stream request) - `(html - (head (title "All pastes") - ,(rss-link-header)) - (body - (center (h2 ,(if discriminate-channel - (format nil "All pastes in channel ~A" discriminate-channel) - "All pastes in system"))) + (lisppaste-wrap-page + (if discriminate-channel + (format nil "All pastes in channel ~A" discriminate-channel) + "All pastes in system") + `(div ,@(if discriminate-channel (if (not (member discriminate-channel *channels* :test #'string-equal)) `(((h2) ((font :color "red") ,(format nil "Warning: no channel named ~A found!" - discriminate-channel)))))) - (center - ((form :method post :action ,(araneida:urlstring *list-paste-url*)) - (table - (tr ((td :align left) "View only: ") - ((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*)) - ((input :type submit :value "Submit"))) - ) - (tr ((td :align left) - ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: ")) - ((td :align center) - ((a :href ,(concatenate 'string - (araneida:urlstring *rss-url*) - (if discriminate-channel - (or (and *no-channel-pastes* - (string-equal discriminate-channel "none") - "?none") - (substitute #\? #\# discriminate-channel)) ""))) "Basic") - " | " - ((a :href ,(concatenate 'string - (araneida:urlstring *rss-full-url*) - (if discriminate-channel - (or (and *no-channel-pastes* - (string-equal discriminate-channel "none") - "?none") - (substitute #\? #\# discriminate-channel)) - ""))) "Full")) - ) - (tr ((td :align left) - "Page: ") - ((td :align center) - ,@page-links)) - ))) - (p) - ((table :width "100%" :cellpadding 2) - (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann.")) - ,@(mapcar #'(lambda (paste) - `(tr ((td :nowrap "nowrap") ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) - ,(concatenate 'string "#" (prin1-to-string (paste-number paste))))) - ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12))) - ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste))) - ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil)) - ((td :width "100%" :bgcolor "#F6F6F6" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50))) - ((td :nowrap "nowrap") ,(length (paste-annotations paste))))) - (loop for i from 0 - to (- (* (1+ page) *pastes-per-page*) 1) - for j in discriminated-pastes - if (>= i (* page *pastes-per-page*)) - collect j))) - (center - "Page: " ,@page-links) - ,@(bottom-links)))))))) + discriminate-channel))))))) + `(center + ((form :method post :action ,(araneida:urlstring *list-paste-url*)) + (table + (tr ((td :align left) "View only: ") + ((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*)) + ((input :type submit :value "Submit"))) + ) + (tr ((td :align left) + ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: ")) + ((td :align center) + ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + (if discriminate-channel + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) ""))) "Basic") + " | " + ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + (if discriminate-channel + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) + ""))) "Full")) + ) + (tr ((td :align left) + "Page: ") + ((td :align center) + ,@page-links)) + ))) + `(p) + `((table :width "100%" :cellpadding 2) + (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann.")) + ,@(mapcar #'(lambda (paste) + `(tr ((td :nowrap "nowrap") ((a :href ,(paste-display-url paste)) + ,(concatenate 'string "#" (prin1-to-string (paste-number paste))))) + ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12))) + ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste))) + ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil)) + ((td :width "100%" :bgcolor "#F6F6F6" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50))) + ((td :nowrap "nowrap") ,(length (paste-annotations paste))))) + (loop for i from 0 + to (- (* (1+ page) *pastes-per-page*) 1) + for j in discriminated-pastes + if (>= i (* page *pastes-per-page*)) + collect j))) + `(center + "Page: " ,@page-links) + )))))) (defun handle-rss-request (request &key full) (araneida:request-send-headers request :expires 0 :content-type "application/rss+xml") @@ -486,32 +514,11 @@ (defmethod araneida:handle-request-response ((handler rss-full-handler) method request) (handle-rss-request request :full t)) -(defun new-paste-form (request &key (message "") (annotate nil) (default-channel "") (default-user "") (default-title "") (default-contents "")) - (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") - (araneida:html-stream - (araneida:request-stream request) - `(html - (head (title ,(if annotate "Annotate" "Paste")) - ,(rss-link-header)) - (body - (h2 ,(if annotate "Enter your annotation" "Enter your paste")) - ((font :color red) (h2 ,message)) - ((form :method post :action ,(araneida:urlstring *submit-paste-url*)) - (p "Enter a username, title, and paste contents into the fields below." - ,@(unless (and annotate - *no-channel-pastes* - (string-equal (paste-channel annotate) "None")) - `("The paste will be announced on the selected channel @ " ,(irc:server-name *connection*) "."))) - ,@(if annotate - `((p "This paste will be used to annotate " - ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) "."))) - ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number annotate)))) - ((input :type hidden :name "channel" :value ,(paste-channel annotate))))) - (hr) - (table +(defun generate-new-paste-form (&key annotate (default-channel "None") (default-user "") (default-title "") (default-contents "") (width 80)) + `(table ,@(if (not annotate) `((tr - (th "Select a channel:") + ((th :align left) "Select a channel:") (td ((select :name "channel") ((option :value "")) ,@(mapcar #'(lambda (e) @@ -519,16 +526,16 @@ '(:selected "SELECTED"))) ,(encode-for-pre e))) *channels*)))))) (tr - (th "Enter your username:") + ((th :align left) "Enter your username:") (td ((input :type text :name "username" :value ,(encode-for-pre default-user))))) (tr - (th "Enter a title:") + ((th :align left) "Enter a title:") (td ((input :type text :name "title" :value ,(encode-for-pre default-title))))) ,@(if (not annotate) `((tr - (th (i "(Optional) Colorize as: ")) + ((th :align left) (i "(Optional) Colorize as: ")) (td ((select :name "colorize") ((option :value "" :selected "SELECTED") "Default for this channel") ((option :value "None") "None") @@ -537,13 +544,33 @@ ,(cdr pair))) (colorize:coloring-types))))))) (tr - ((th :valign top) "Enter your paste:") - (td ((textarea :rows 24 :cols 80 :name "text") + ((th :align left :valign top) "Enter your paste:") + (td ((textarea :rows 24 :cols ,width :name "text") ,(encode-for-pre default-contents)))) (tr - ((th) "Submit your paste:") + ((th :align left) "Submit your paste:") ((td) ((input :type submit :value "Submit paste")) " " ((input :type reset :value "Clear paste")))))) - ,@(bottom-links))))) + +(defun new-paste-form (request &key (message "") (annotate nil) (default-channel "") (default-user "") (default-title "") (default-contents "")) + (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") + (araneida:html-stream + (araneida:request-stream request) + (lisppaste-wrap-page + (if annotate "Enter your annotation" "Enter your paste") + `((font :color red) (h2 ,message)) + `((form :method post :action ,(araneida:urlstring *submit-paste-url*)) + (p "Enter a username, title, and paste contents into the fields below." + ,@(unless (and annotate + *no-channel-pastes* + (string-equal (paste-channel annotate) "None")) + `("The paste will be announced on the selected channel @ " ,(irc:server-name *connection*) "."))) + ,@(if annotate + `((p "This paste will be used to annotate " + ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) "."))) + ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number annotate)))) + ((input :type hidden :name "channel" :value ,(paste-channel annotate))))) + (hr) + ,(generate-new-paste-form :annotate annotate :default-channel default-channel :default-user default-user :default-title default-title :default-contents default-contents))))) (defmethod araneida:handle-request-response ((handler submit-paste-handler) method request) (let* ((username (araneida:body-param "username" (araneida:request-body request))) @@ -608,20 +635,17 @@ (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) - `(html - (head (title "Paste number " ,paste-number) - ,(rss-link-header)) - (body - (h2 "Pasted!") - (p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) - ,@(unless (and *no-channel-pastes* - (string-equal channel "none")) - `(", and was also sent to " ,channel " @ " ,(irc:server-name *connection*))) ".") - (h3 "Don't paste more junk; annotate!") - ((form :method post :action ,(araneida:urlstring *new-paste-url*)) - ((input :type hidden :name "annotate" :value ,(prin1-to-string paste-number))) - (center ((input :type submit :value "Annotate this paste")))) - ,@(bottom-links)))))))))) + (lisppaste-wrap-page + (format nil "Paste number ~A pasted!" paste-number) + `(p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) + ,@(unless (and *no-channel-pastes* + (string-equal channel "none")) + `(", and was also sent to " ,channel " @ " ,(irc:server-name *connection*))) ".") + `(h3 "Don't paste more junk; annotate!") + `((form :method post :action ,(araneida:urlstring *new-paste-url*)) + ((input :type hidden :name "annotate" :value ,(prin1-to-string paste-number))) + (center ((input :type submit :value "Annotate this paste")))) + )))))))) (defun ends-with (str end) (let ((l1 (length str)) @@ -630,17 +654,21 @@ (string= (subseq str (- l1 l2) l1) end)))) (defun format-paste (paste this-url paste-number &optional annotation colorize-as line-numbers) - (let ((n 0)) + (let ((n 0) (next-first-char-nbsp nil)) (labels ((line-number () (format nil "~A" (encode-for-tt (format nil "~4D: " (incf n)) :first-char-nbsp t))) (encode (str) - (encode-for-tt str - :with-line-numbers - (if line-numbers - #'line-number)))) + (multiple-value-bind (encoded last) + (encode-for-tt str + :with-line-numbers + (if line-numbers + #'line-number) + :first-char-nbsp next-first-char-nbsp) + (prog1 encoded + (setf next-first-char-nbsp last))))) `((table :width "100%" :cellpadding 2) (tr ((td :align "left" :width "0%" :nowrap "nowrap") ,(if annotation @@ -701,9 +729,10 @@ (colorize:*css-background-class* "paste")) (and paste (log-event - (format nil "Serving paste number ~S to ~S.~%" + (format nil "Serving paste number ~S to ~S (referred by ~S).~%" (paste-number paste) - (car (araneida:request-header request :x-forwarded-for))))) + (car (araneida:request-header request :x-forwarded-for)) + (car (araneida:request-header request :referer))))) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -725,16 +754,9 @@ (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) - `(html - (head - (title "Paste number " ,paste-number) - ((style :type "text/css") - ,(format nil "~A~%~A~%" - (colorize:make-background-css "#F4F4F4") - colorize:*coloring-css*)) - ,(rss-link-header)) - (body - + (lisppaste-wrap-page + (format nil "Paste number ~A" paste-number) + `(div ,@(if (paste-annotations paste) `("Index of paste annotations: " ,@(loop for ann in (reverse (paste-annotations paste)) @@ -749,17 +771,17 @@ ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as linenumbers) ,@(if (paste-annotations paste) - `((p) - "Annotations for this paste: " - ,@(reduce #'append - (mapcar #'(lambda (a) - `((hr) - ,(format-paste a - (format nil "~A,~A" - (araneida:urlstring (araneida:request-url request)) - (paste-number a)) (paste-number a) t colorize-as linenumbers))) - (reverse (paste-annotations paste))))) - `((p) "This paste has no annotations.")) + `((p) + "Annotations for this paste: " + ,@(reduce #'append + (mapcar #'(lambda (a) + `((hr) + ,(format-paste a + (format nil "~A,~A" + (araneida:urlstring (araneida:request-url request)) + (paste-number a)) (paste-number a) t colorize-as linenumbers))) + (reverse (paste-annotations paste))))) + `((p) "This paste has no annotations.")) (p) ((form :method post :action ,(araneida:urlstring (araneida:merge-url @@ -785,19 +807,15 @@ ((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")))) - ,@(bottom-links)))))) - (progn - (araneida:request-send-headers request :expires 0) - (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") - (araneida:html-stream - (araneida:request-stream request) - `(html - (head - (title "Invalid paste number" ,paste-number) - ,(rss-link-header)) - (body - (h3 "No paste numbered " ,paste-number " could be found.") - ,@(bottom-links)))))))) + ))))) + (progn + (araneida:request-send-headers request :expires 0) + (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") + (araneida:html-stream + (araneida:request-stream request) + (lisppaste-wrap-page + (format nil "Invalid paste number ~A!" paste-number) + )))))) (araneida:install-handler (araneida:http-listener-handler *paste-listener*) @@ -838,3 +856,8 @@ (araneida:http-listener-handler *paste-listener*) (make-instance 'stats-handler) (araneida:urlstring *stats-url*) nil) + +(araneida:install-handler + (araneida:http-listener-handler *paste-listener*) + (make-instance 'main-handler) + (araneida:urlstring *paste-external-url*) t)

1 0

[Lisppaste-cvs] CVS update: public_html/index.html
by Brian Mastenbrook 17 Jun '04

17 Jun '04

Update of /project/lisppaste/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv8105 Modified Files: index.html Log Message: release 2.3 Date: Thu Jun 17 07:15:35 2004 Author: bmastenbrook Index: public_html/index.html diff -u public_html/index.html:1.8 public_html/index.html:1.9 --- public_html/index.html:1.8 Mon Mar 8 22:48:14 2004 +++ public_html/index.html Thu Jun 17 07:15:35 2004 @@ -28,8 +28,13 @@ as that sounds. Lisppaste 2 can be downloaded from here: <a - href="ftp://common-lisp.net/pub/project/lisppaste/lisppaste2-latest.tar.gz">lisppaste2-latest.tar.gz</a>. The - latest version is 2.2, released March 9, 2004. + href="ftp://common-lisp.net/pub/project/lisppaste/lisppaste2.3.tar.gz">lisppaste2.3.tar.gz</a>. The + latest version is 2.3, released June 17, 2004. + + New in lisppaste 2.3 is a whole slew of improvements, including + pagination for the paste list page, colorization for many + languages, portability to other lisps (when run with CVS araneida) + and support for pastes without a channel announcement. New in lisppaste 2.2 is greater RSS flexibility, channel-specific URLs for new pastes and paste listing, much @@ -39,10 +44,11 @@ context at <a href="http://meme.b9.com/">meme.b9.com</a>. The code in CVS (<a href="/faq.shtml">checkout - instructions</a>) is also considered fairly usable. You'll also - need <a href="http://araneida.telent.net">araneida</a> and <a - href="http://www.sbcl.org"> SBCL</a>. If you do install it, read - the <a + instructions</a>) mirrors what is currently running on freenode + and should be fairly usable. You'll also need <a + href="http://www.cliki.net/araneida">araneida</a> and + href="http://www.cliki.net/cl-irc">CL-IRC</a>. If you do install + it, read the <a href="/cgi-bin/viewcvs.cgi/lisppaste2/README.lisp?rev=HEAD&cvsroot=lisppaste&content-type=text/vnd.viewcvs-markup">README.lisp</a> file which contains all the information you need to run a lisppaste on your own. @@ -64,7 +70,7 @@ <address><a href="http://www.cs.indiana.edu/~bmastenb/">Brian Mastenbrook</a></address>   -Last modified: Tue Mar 9 01:48:05 2004 EST +Last modified: Thu Jun 17 09:15:17 2004 CDT  </body> </html>

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv16551 Modified Files: variable.lisp Log Message: MORE DOCUMENTATION Date: Thu Jun 17 06:42:32 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.22 lisppaste2/variable.lisp:1.23 --- lisppaste2/variable.lisp:1.22 Thu Jun 17 06:26:12 2004 +++ lisppaste2/variable.lisp Thu Jun 17 06:42:32 2004 @@ -1,8 +1,26 @@ -;;;; $Id: variable.lisp,v 1.22 2004/06/17 13:26:12 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.23 2004/06/17 13:42:32 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. +;;; This is the main file to edit to customize lisppaste to your +;;; site. In particular, the main variables are at the top, which +;;; define how lisppaste knows which site it is running on, and how to +;;; generate links to itself. There are two ways to run lisppaste: +;;; naked, and behind a proxying apache. When running naked, you can +;;; leave much of this file as-is, and change *internal-http-port* and +;;; *external-http-port* to the port you want it to run on, and +;;; *paste-site-name* to the hostname it is running on. + +;;; When running behind a proxy, set *internal-http-port* to the port +;;; it will listen for requests from Apache, but set +;;; *external-http-port* to 80. Set *paste-site-name* to a hostname +;;; that lisppaste is running on, and comment out the line in +;;; *paste-external-url* as indicated. + +;;; There are a few other options below, but the defaults should work +;;; well. + (in-package :lisppaste) (defparameter *internal-http-port* 8000 @@ -23,25 +41,32 @@ (araneida:merge-url (araneida:make-url :scheme "http" :host *paste-site-name* + ;;; comment out this next line when running + ;;; behind a proxying apache :port *external-http-port* ) "/paste/")) -(defvar *meme-links* nil) ; whether to link to meme IRC logs +(defvar *meme-links* nil) ; whether to link to meme IRC logs, probably + ; only useful for freenode's lisppaste -(defvar *paste-maximum-size* 51200) +(defvar *paste-maximum-size* 51200) ; in bytes -(defvar *pastes-per-page* 50) +(defvar *pastes-per-page* 50) ; for the paste list (defparameter *banned-ips* - '("69.11.238.252" "168.143.113.138")) + '("69.11.238.252" "168.143.113.138")) ; two examples of + ; troublemakers affecting + ; freenode's lisppaste (defparameter *ban-log-file* - "ban-log") + "ban-log") ; where logs of attempts by banned users to paste go (defparameter *event-log-file* - "event-log") + "event-log") ; where normal events are logged -(defparameter *no-channel-pastes* nil) +(defparameter *no-channel-pastes* nil) ; whether to allow pastes that + ; don't get announced on a + ; channel ;; You shouldn't need to edit below this line. ;; LINE

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv23892 Modified Files: variable.lisp Log Message: A somewhat sane starting configuration Date: Thu Jun 17 06:26:12 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.21 lisppaste2/variable.lisp:1.22 --- lisppaste2/variable.lisp:1.21 Wed Jun 9 12:48:46 2004 +++ lisppaste2/variable.lisp Thu Jun 17 06:26:12 2004 @@ -1,13 +1,13 @@ -;;;; $Id: variable.lisp,v 1.21 2004/06/09 19:48:46 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.22 2004/06/17 13:26:12 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) -(defparameter *internal-http-port* 8081 +(defparameter *internal-http-port* 8000 "Port lisppaste's araneida will listen on for requests from Apache.") -(defparameter *external-http-port* 80 +(defparameter *external-http-port* 8000 "Port lisppaste's araneida will listen on for requests from remote clients.") (defparameter *paste-site-name* "localhost" @@ -23,7 +23,7 @@ (araneida:merge-url (araneida:make-url :scheme "http" :host *paste-site-name* - #|:port *external-http-port*|# + :port *external-http-port* ) "/paste/")) (defvar *meme-links* nil) ; whether to link to meme IRC logs

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv1487 Modified Files: lisppaste.asd Log Message: Oops. forgot the colorize-package dependency in web-server Date: Thu Jun 17 06:10:04 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.12 lisppaste2/lisppaste.asd:1.13 --- lisppaste2/lisppaste.asd:1.12 Fri Jun 4 17:14:31 2004 +++ lisppaste2/lisppaste.asd Thu Jun 17 06:10:04 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.12 2004/06/05 00:14:31 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.13 2004/06/17 13:10:04 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -39,6 +39,6 @@ (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server" - :depends-on ("encode-for-pre" "lisppaste")) + :depends-on ("encode-for-pre" "lisppaste" "colorize-package")) (:file "persistent-pastes" :depends-on ("web-server"))))

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv13571 Modified Files: clhs-lookup.lisp Log Message: Slightly less aggressive warning behavior Date: Thu Jun 17 05:59:17 2004 Author: bmastenbrook Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.5 lisppaste2/clhs-lookup.lisp:1.6 --- lisppaste2/clhs-lookup.lisp:1.5 Thu Jun 17 05:53:17 2004 +++ lisppaste2/clhs-lookup.lisp Thu Jun 17 05:59:17 2004 @@ -30,6 +30,8 @@ (defun valid-target (&rest numbers) (probe-file (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers))))) +(defvar *last-warn-time* 0) + (defun populate-table () (unless *populated-p* ;; Hyperspec @@ -37,7 +39,9 @@ ;; populate the table with the symbols from the Map file ;; this bit is easy and portable. (unless s - (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%") + (when (> (- (get-universal-time) *last-warn-time*) 10) + (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%") + (setf *last-warn-time* (get-universal-time))) (return-from populate-table nil)) (do ((symbol-name (read-line s nil s) (read-line s nil s)) (url (read-line s nil s) (read-line s nil s)))

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv6048 Modified Files: clhs-lookup.lisp Log Message: Warn when the hyperspec map isn't found Date: Thu Jun 17 05:53:17 2004 Author: bmastenbrook Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.4 lisppaste2/clhs-lookup.lisp:1.5 --- lisppaste2/clhs-lookup.lisp:1.4 Wed Jun 9 12:47:13 2004 +++ lisppaste2/clhs-lookup.lisp Thu Jun 17 05:53:17 2004 @@ -33,9 +33,12 @@ (defun populate-table () (unless *populated-p* ;; Hyperspec - (with-open-file (s *hyperspec-map-file*) + (with-open-file (s *hyperspec-map-file* :if-does-not-exist nil) ;; populate the table with the symbols from the Map file ;; this bit is easy and portable. + (unless s + (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%") + (return-from populate-table nil)) (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)

1 0

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

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp coloring-css.lisp web-server.lisp Log Message: Index of paste annotations; adjust Lisp coloring to find less english and MORE CODE; tweak to CSS to not underline links to specifications. Date: Thu Jun 17 05:46:59 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.7 lisppaste2/coloring-types.lisp:1.8 --- lisppaste2/coloring-types.lisp:1.7 Tue Jun 15 06:52:52 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 17 05:46:59 2004 @@ -22,10 +22,10 @@ (defparameter *close-parens* '(#\))) (define-coloring-type :lisp "Basic Lisp" - :modes (:normal :symbol :escaped-symbol :keyword :string :comment + :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment :multiline :character :single-escaped :in-list :syntax-error) - :default-mode :normal + :default-mode :first-char-on-line :transitions (((:in-list) ((or @@ -59,10 +59,20 @@ ((scan #$) (set-mode :in-list :until (scan #$)))) - (:normal + ((:normal :first-char-on-line) ((scan #$) (set-mode :in-list :until (scan #$)))) + (:first-char-on-line + ((scan #\;) + (set-mode :comment + :until (scan #\newline))) + ((scan "#|") + (set-mode :multiline + :until (scan "|#"))) + ((advance 1) + (set-mode :normal + :until (scan #\newline)))) (:multiline ((scan "#|") (set-mode :multiline @@ -81,9 +91,10 @@ (loop for i from paren-counter downto 1 collect ""))) :formatters - ((:normal (lambda (type s) - (declare (ignore type)) - s)) + (((:normal :first-char-on-line) + (lambda (type s) + (declare (ignore type)) + s)) ((:in-list) (lambda (type s) (declare (ignore type)) Index: lisppaste2/coloring-css.lisp diff -u lisppaste2/coloring-css.lisp:1.2 lisppaste2/coloring-css.lisp:1.3 --- lisppaste2/coloring-css.lisp:1.2 Tue Jun 8 08:23:04 2004 +++ lisppaste2/coloring-css.lisp Thu Jun 17 05:46:59 2004 @@ -4,10 +4,10 @@ (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; } +a.symbol:link { color : #229955; background-color : inherit; text-decoration: none; } +a.symbol:active { color : #229955; background-color : inherit; text-decoration: none; } +a.symbol:visited { color : #229955; background-color : inherit; text-decoration: none; } +a.symbol:hover { color : #229955; background-color : inherit; text-decoration: none; } .special { color : #FF5000; background-color : inherit; } .keyword { color : #770000; background-color : inherit; } .comment { color : #007777; background-color : inherit; } Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.56 lisppaste2/web-server.lisp:1.57 --- lisppaste2/web-server.lisp:1.56 Fri Jun 11 10:35:33 2004 +++ lisppaste2/web-server.lisp Thu Jun 17 05:46:59 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.56 2004/06/11 17:35:33 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.57 2004/06/17 12:46:59 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -18,7 +18,8 @@ (colorization-mode :initarg :colorization-mode :initform "" :accessor paste-colorization-mode))) (defmacro make-paste (&rest arguments) - `(make-instance 'paste ,@arguments)) + `(progn + (funcall 'make-instance 'paste ,@arguments))) (defclass new-paste-handler (araneida:handler) ()) @@ -135,7 +136,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.html?utime=~A&channel=~A" utime (string-left-trim "#" channel))) @@ -654,12 +655,11 @@ `((tr (td) ((td :align "left" :width "100%") ,@(if (not annotation) - `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* - " | " "")))) + `((,(encode-for-pre (paste-channel paste))))) ,@(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"))))))) + `(" | " ((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 `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) @@ -734,6 +734,18 @@ colorize:*coloring-css*)) ,(rss-link-header)) (body + + ,@(if (paste-annotations paste) + `("Index of paste annotations: " + ,@(loop for ann in (reverse (paste-annotations paste)) + for test from (length (paste-annotations paste)) downto 1 + appending + `(((a :href ,(format nil "#~A" + (paste-number ann))) + ,(prin1-to-string (paste-number ann)))) + if (not (eql test 1)) + appending '(" | ")) + (p))) ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as linenumbers) ,@(if (paste-annotations paste)

1 0

[Lisppaste-cvs] CVS update: lisppaste/READ-ME-WHERE-IS-THE-SOURCE lisppaste/README.lisp lisppaste/apache.conf.include lisppaste/encode-for-pre.lisp lisppaste/irc-protocol.lisp lisppaste/web-server.lisp
by Brian Mastenbrook 17 Jun '04

17 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste In directory common-lisp.net:/home/bmastenbrook/lisppaste Added Files: READ-ME-WHERE-IS-THE-SOURCE Removed Files: README.lisp apache.conf.include encode-for-pre.lisp irc-protocol.lisp web-server.lisp Log Message: Avoid confusion - remove old source, add readme Date: Thu Jun 17 05:45:52 2004 Author: bmastenbrook

1 0

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

15 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp Log Message: Only colorize in parens in lisp mode Date: Tue Jun 15 06:52:52 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.6 lisppaste2/coloring-types.lisp:1.7 --- lisppaste2/coloring-types.lisp:1.6 Fri Jun 11 07:34:34 2004 +++ lisppaste2/coloring-types.lisp Tue Jun 15 06:52:52 2004 @@ -27,7 +27,7 @@ :single-escaped :in-list :syntax-error) :default-mode :normal :transitions - (((:normal :in-list) + (((:in-list) ((or (scan-any *symbol-characters*) (and (scan #\.) (scan-any *symbol-characters*)) @@ -56,6 +56,10 @@ ((scan "#|") (set-mode :multiline :until (scan "|#"))) + ((scan #$) + (set-mode :in-list + :until (scan #$)))) + (:normal ((scan #$) (set-mode :in-list :until (scan #$))))

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: 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

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.lisp lisppaste2/persistent-pastes.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: lisppaste.lisp persistent-pastes.lisp Log Message: no-channel pastes; kill-paste command Date: Tue Jun 8 08:21:30 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.18 lisppaste2/lisppaste.lisp:1.19 --- lisppaste2/lisppaste.lisp:1.18 Fri Jun 4 17:14:31 2004 +++ lisppaste2/lisppaste.lisp Tue Jun 8 08:21:30 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.18 2004/06/05 00:14:31 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.19 2004/06/08 15:21:30 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -81,19 +81,36 @@ &key channel user title &allow-other-keys) (let ((paste-name (gensym))) `(let ((,paste-name (make-paste ,@keys))) - (irc:privmsg *connection* ,channel - (if ,annotate - (format nil "~A annotated #~A with \"~A\" at ~A" ,user ,real-number ,title ,url) - (format nil "~A pasted \"~A\" at ~A" ,user ,title ,url))) - ,(if annotate - `(if ,annotate - (push ,paste-name ,annotate-list) - (push ,paste-name ,paste-list)) - `(push ,paste-name ,paste-list)) - (serialize-transaction "pastes.lisp-expr" ,paste-name (if ,annotate ,real-number))))) + (if (not (string-equal channel "None")) + (irc:privmsg *connection* ,channel + (if ,annotate + (format nil "~A annotated #~A with \"~A\" at ~A" ,user ,real-number ,title ,url) + (format nil "~A pasted \"~A\" at ~A" ,user ,title ,url)))) + ,(if annotate + `(if ,annotate + (push ,paste-name ,annotate-list) + (push ,paste-name ,paste-list)) + `(push ,paste-name ,paste-list)) + (serialize-transaction *paste-file* ,paste-name (if ,annotate ,real-number))))) (defun shut-up () (setf (irc:client-stream *connection*) (make-broadcast-stream))) (defun un-shut-up () (setf (irc:client-stream *connection*) *trace-output*)) + +(defun kill-paste (number) + (setf *pastes* + (remove number *pastes* :key #'paste-number)) + (serialize-to-file *paste-file* `(kill-paste ,number))) + +(defun kill-paste-annotations (number) + (setf (paste-annotations (find number *pastes* :key #'paste-number)) + nil) + (serialize-to-file *paste-file* `(kill-paste-annotations ,number))) + +(defun kill-paste-annotation (number ann) + (let ((paste (find number *pastes* :key #'paste-number))) + (setf (paste-annotations paste) + (remove ann (paste-annotations paste) :key #'paste-number)) + (serialize-to-file *paste-file* `(kill-paste-annotation ,number ,ann)))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.9 lisppaste2/persistent-pastes.lisp:1.10 --- lisppaste2/persistent-pastes.lisp:1.9 Fri May 21 12:30:45 2004 +++ lisppaste2/persistent-pastes.lisp Tue Jun 8 08:21:30 2004 @@ -1,5 +1,7 @@ (in-package :lisppaste) +(defvar *in-operation* nil) + (defun paste-alist (paste) (list (cons 'number (paste-number paste)) @@ -7,7 +9,8 @@ (cons 'title (paste-title paste)) (cons 'contents (paste-contents paste)) (cons 'universal-time (paste-universal-time paste)) - (cons 'channel (paste-channel paste)))) + (cons 'channel (paste-channel paste)) + (cons 'colorization-mode (paste-colorization-mode paste)))) (defun serialized-initial-paste (paste) (cons 'make-paste (paste-alist paste))) @@ -29,14 +32,19 @@ (let ((*print-readably* t)) (format file "~{~S~%~}" (mapcan #'paste-list-alist (reverse *pastes*))))))) +(defun serialize-to-file (file-name operation) + (unless *in-operation* + (let ((*package* (find-package :lisppaste))) + (with-open-file (file file-name :direction :output :if-exists :append + :if-does-not-exist :create) + (let ((*print-readably* t)) + (format file "~S~%" operation)))))) + (defun serialize-transaction (file-name paste &optional annotate-number) - (let ((*package* (find-package :lisppaste))) - (with-open-file (file file-name :direction :output :if-exists :append - :if-does-not-exist :create) - (let ((*print-readably* t)) - (if annotate-number - (format file "~S~%" (serialized-annotation annotate-number paste)) - (format file "~S~%" (serialized-initial-paste paste))))))) + (serialize-to-file file-name + (if annotate-number + (serialized-annotation annotate-number paste) + (serialized-initial-paste paste)))) (defmacro with-assoc-vals (entry-list alist &body body) `(let ,(mapcar #'(lambda (e) (list e `(cdr (assoc ',e ,alist)))) entry-list) @@ -59,14 +67,18 @@ (ecase (car expr) (make-paste (push (make-paste-from-alist (cdr expr)) *pastes*)) (annotate-paste (let ((paste (find (second expr) *pastes* :key #'paste-number))) - (push (make-paste-from-alist (cddr expr) paste) (paste-annotations paste)))))) + (push (make-paste-from-alist (cddr expr) paste) (paste-annotations paste)))) + (kill-paste (kill-paste (second expr))) + (kill-paste-annotations (kill-paste-annotations (second expr))) + (kill-paste-annotation (kill-paste-annotation (second expr) (third expr))))) (defun read-pastes-from-file (file-name) - (setf *pastes* nil) - (let ((*package* (find-package :lisppaste))) - (with-open-file (file file-name :direction :input :if-does-not-exist nil) - (if file - (loop (let ((paste (read file nil))) - (if paste - (deserialize paste) - (return-from read-pastes-from-file t)))))))) + (let ((*in-operation* t)) + (setf *pastes* nil) + (let ((*package* (find-package :lisppaste))) + (with-open-file (file file-name :direction :input :if-does-not-exist nil) + (if file + (loop (let ((paste (read file nil))) + (if paste + (deserialize paste) + (return-from read-pastes-from-file t)))))))))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp lisppaste2/encode-for-pre.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: web-server.lisp encode-for-pre.lisp Log Message: Fix line numbering, spacing. Add support for pastes with no channel. Date: Tue Jun 8 08:20:40 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.51 lisppaste2/web-server.lisp:1.52 --- lisppaste2/web-server.lisp:1.51 Fri Jun 4 14:23:23 2004 +++ lisppaste2/web-server.lisp Tue Jun 8 08:20:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.51 2004/06/04 21:23:23 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.52 2004/06/08 15:20:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -60,7 +60,6 @@ (body (h1 ((font :color "red") "Naughty boy!")))))) (call-next-method)))) - (defmethod araneida:handle-request-response ((handler new-paste-handler) method request) (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request))) (annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t))) @@ -69,15 +68,28 @@ (or (and annotate (paste-channel annotate)) (find-if #'(lambda (e) (> (length e) 1)) (list + (and (eql method :post) + (araneida:body-param "channel" + (araneida:request-body request))) + (and *no-channel-pastes* + (or + (string-equal (araneida::request-unhandled-part request) "/none") + (string-equal (araneida:request-cookie request "CHANNEL") "None")) + "None") (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) (concatenate 'string "#" (araneida:request-cookie request "CHANNEL")) - (and (eql method :post) - (araneida:body-param "channel" - (araneida:request-body request)))))))) + ))))) (cond - ((and default-channel (find default-channel *channels* :test #'string=)) - (araneida:request-send-headers request :expires 0 :set-cookie (format nil "CHANNEL=~A; path=/" (subseq default-channel 1))) + ((and default-channel (or (and *no-channel-pastes* + (string-equal default-channel "None")) + (find default-channel *channels* :test #'string=))) + (araneida:request-send-headers request :expires 0 :set-cookie + (format nil "CHANNEL=~A; path=/" + (or (and *no-channel-pastes* + (string-equal default-channel "none") + "None") + (subseq default-channel 1)))) (new-paste-form request :annotate annotate :default-channel default-channel)) (t (araneida:request-send-headers request :expires 0) (araneida:html-stream @@ -180,6 +192,17 @@ (td ((a :href ,(araneida:urlstring *rss-url*)) "Basic")) ((td :width 10)) (td ((a :href ,(araneida:urlstring *rss-full-url*)) "Full"))) + ,@(if *no-channel-pastes* + `((tr + ((th :align left) "None") + ((td :width 30)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + "?none")) "Basic")) + ((td :width 10)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + "?none")) "Full"))))) ,@(mapcar #'(lambda (channel) `(tr ((th :align left) ,channel) @@ -300,8 +323,11 @@ (let* ((discriminate-channel (or (araneida:body-param "channel" (araneida:request-body request)) (if (not (string= channel "")) - (substitute #\# #\/ channel - :test #'char=)))) + (or (and *no-channel-pastes* + (string-equal channel "/none") + "None") + (substitute #\# #\/ channel + :test #'char=))))) (discriminate-channel (if (string-equal discriminate-channel "allchannels") nil discriminate-channel)) @@ -362,12 +388,19 @@ ((a :href ,(concatenate 'string (araneida:urlstring *rss-url*) (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Basic") + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) ""))) "Basic") " | " ((a :href ,(concatenate 'string (araneida:urlstring *rss-full-url*) (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Full")) + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) + ""))) "Full")) ) (tr ((td :align left) "Page: ") @@ -398,8 +431,11 @@ (araneida:request-send-headers request :expires 0 :content-type "application/rss+xml") (format (araneida:request-stream request) "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>~C~C" #\Return #\Linefeed) (let ((discriminate-channel (if (not (string= (araneida::request-unhandled-part request) "")) - (substitute #\# #\? (araneida::request-unhandled-part request) - :test #'char=)))) + (or (and *no-channel-pastes* + (string-equal (araneida::request-unhandled-part request) "?none") + "None") + (substitute #\# #\? (araneida::request-unhandled-part request) + :test #'char=))))) (araneida:html-stream (araneida:request-stream request) `((|rss| :|version| "2.0") @@ -458,8 +494,11 @@ (h2 ,(if annotate "Enter your annotation" "Enter your paste")) ((font :color red) (h2 ,message)) ((form :method post :action ,(araneida:urlstring *submit-paste-url*)) - (p "Enter a username, title, and paste contents into the fields below. The -paste will be announced on the selected channel @ " ,(irc:server-name *connection*) ".") + (p "Enter a username, title, and paste contents into the fields below." + ,@(unless (and annotate + *no-channel-pastes* + (string-equal (paste-channel annotate) "None")) + `("The paste will be announced on the selected channel @ " ,(irc:server-name *connection*) "."))) ,@(if annotate `((p "This paste will be used to annotate " ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) "."))) @@ -474,7 +513,7 @@ (option :value "") ,@(mapcar #'(lambda (e) `((option :value ,e ,@(if (string-equal e default-channel) - '(:selected))) + '(:selected "SELECTED"))) ,(encode-for-pre e))) *channels*)))))) (tr (th "Enter your username:") @@ -484,6 +523,16 @@ (th "Enter a title:") (td ((input :type text :name "title" :value ,(encode-for-pre default-title))))) + ,@(if (not annotate) + `((tr + (th (i "(Optional) Colorize as: ")) + (td ((select :name "colorize") + ((option :value "" :selected "SELECTED") "") + ((option :value "None") "None") + ,@(mapcar #'(lambda (pair) + `((option :value ,(cdr pair)) + ,(cdr pair))) + (colorize:coloring-types))))))) (tr ((th :valign top) "Enter your paste:") (td ((textarea :rows 24 :cols 80 :name "text") @@ -497,13 +546,18 @@ (let* ((username (araneida:body-param "username" (araneida:request-body request))) (title (araneida:body-param "title" (araneida:request-body request))) (text (araneida:body-param "text" (araneida:request-body request))) + (colorize-as (araneida:body-param "colorize" (araneida:request-body request))) (annotate (araneida:body-param "annotate" (araneida:request-body request))) (annotate-number (if annotate (parse-integer annotate :junk-allowed t))) (annotate-paste (if annotate-number (find annotate-number *pastes* :key #'paste-number))) (channel (araneida:body-param "channel" (araneida:request-body request)))) (if (> (length channel) 1) (araneida:request-send-headers request :expires 0 - :set-cookie (format nil "CHANNEL=~A; path=/" (subseq channel 1))) + :set-cookie (format nil "CHANNEL=~A; path=/" + (or (and *no-channel-pastes* + (string-equal channel "none") + "None") + (subseq channel 1)))) (araneida:request-send-headers request :expires 0)) (cond ((> (length text) *paste-maximum-size*) @@ -540,7 +594,8 @@ :title title :contents text :universal-time (get-universal-time) - :channel channel) + :channel channel + :colorization-mode (coerce colorize-as 'string)) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) @@ -549,7 +604,10 @@ ,(rss-link-header)) (body (h2 "Pasted!") - (p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) ", and was also sent to " ,channel " @ " ,(irc:server-name *connection*)) + (p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) + ,@(unless (and *no-channel-pastes* + (string-equal channel "none")) + `(", and was also sent to " ,channel " @ " ,(irc:server-name *connection*))) ".") (h3 "Don't paste more junk; annotate!") ((form :method post :action ,(araneida:urlstring *new-paste-url*)) ((input :type hidden :name "annotate" :value ,(prin1-to-string paste-number))) @@ -562,38 +620,51 @@ (if (< l1 l2) nil (string= (subseq str (- l1 l2) l1) end)))) -(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 - `((a :name ,(prin1-to-string paste-number)) "Annotation number ") - "Paste number ") ,paste-number ": ") - ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) - (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") - ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) - (tr (td) - ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) - ,@(if (or (not annotation) *meme-links*) - `((tr (td) - ((td :align "left" :width "100%") - ,@(if (not annotation) - `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* - " | " "")))) - ,@(if *meme-links* - `(((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 - `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) - (tr (td (p))) - (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)))))))) +(defun format-paste (paste this-url paste-number &optional annotation colorize-as line-numbers) + (let ((n 0)) + (labels + ((line-number () + (format nil "~A" + (encode-for-tt (format nil "~4D: " (incf n)) + :first-char-nbsp t))) + (encode (str) + (encode-for-tt str + :with-line-numbers + (if line-numbers + #'line-number)))) + `((table :width "100%" :cellpadding 2) + (tr ((td :align "left" :width "0%" :nowrap "nowrap") + ,(if annotation + `((a :name ,(prin1-to-string paste-number)) "Annotation number ") + "Paste number ") ,paste-number ": ") + ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) + (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") + ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) + (tr (td) + ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) + ,@(if (or (not annotation) *meme-links*) + `((tr (td) + ((td :align "left" :width "100%") + ,@(if (not annotation) + `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* + " | " "")))) + ,@(if *meme-links* + `(((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 + `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) + (tr (td (p))) + (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") + (tt + ,@(if line-numbers + (list (line-number))) + ,(if colorize-as + (colorize:format-scan colorize-as + (mapcar #'(lambda (e) + (cons (car e) + (encode (cdr e)))) + (colorize:scan-string colorize-as (paste-contents paste)))) + (encode (paste-contents paste)))))))))) (defmethod araneida:handle-request-response ((handler display-paste-handler) method request) ; XXX request-unhandled-part will be exported in 0.81 @@ -604,13 +675,22 @@ (paste (some #'(lambda (element) (and (eql paste-number (paste-number element)) element)) *pastes*)) - (colorize-string (araneida:body-param "colorize" (araneida:request-body request))) + (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-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))))) (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)))) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -641,7 +721,8 @@ colorize:*coloring-css*)) ,(rss-link-header)) (body - ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as) + ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as + linenumbers) ,@(if (paste-annotations paste) `((p) "Annotations for this paste: " @@ -651,7 +732,7 @@ ,(format-paste a (format nil "~A,~A" (araneida:urlstring (araneida:request-url request)) - (paste-number a)) (paste-number a) t colorize-as))) + (paste-number a)) (paste-number a) t colorize-as linenumbers))) (reverse (paste-annotations paste))))) `((p) "This paste has no annotations.")) (p) @@ -670,7 +751,11 @@ '(:selected "SELECTED"))) ,(cdr pair))) (colorize:coloring-types))) - ((input :type submit :value "Colorize"))) + (br) + ((input :type "checkbox" :name "linenumbers" :value "true" + ,@(if linenumbers '(:checked "checked")))) " Show Line Numbers" + (br) + ((input :type submit :value "Format"))) (p) ((form :method post :action ,(araneida:urlstring *new-paste-url*)) ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number paste)))) Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.16 lisppaste2/encode-for-pre.lisp:1.17 --- lisppaste2/encode-for-pre.lisp:1.16 Thu Jun 3 13:19:40 2004 +++ lisppaste2/encode-for-pre.lisp Tue Jun 8 08:20:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.16 2004/06/03 20:19:40 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.17 2004/06/08 15:20:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,7 +8,7 @@ (:export :encode-for-pre :encode-for-tt :encode-for-http)) (in-package :html-encode) -(defun encode-for-tt (string) +(defun encode-for-tt (string &key with-line-numbers first-char-nbsp) (let ((pos 0) (end (length string)) (char nil)) (flet ((next-char () @@ -19,6 +19,9 @@ (with-output-to-string (out) (block nil (tagbody + (unless first-char-nbsp + (next-char) + (go process-char)) escape-spaces (next-char) (when (eql char #\Space) @@ -29,6 +32,8 @@ ((nil) (return)) ((#\Newline) (write-string " " out) + (if with-line-numbers + (write-string (funcall with-line-numbers) out)) (go escape-spaces)) ((#\&) (write-string "&" out))

1 0

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

04 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp Log Message: Make the scanner treat numbers as symbols; simplify the scanner Date: Fri Jun 4 07:09:51 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.4 lisppaste2/coloring-types.lisp:1.5 --- lisppaste2/coloring-types.lisp:1.4 Thu Jun 3 13:20:46 2004 +++ lisppaste2/coloring-types.lisp Fri Jun 4 07:09:51 2004 @@ -3,7 +3,7 @@ (in-package :colorize) (defparameter *symbol-characters* - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&") + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890") (defparameter *non-constituent* '(#\space #\tab #\newline #\linefeed #\page #\return @@ -30,10 +30,7 @@ (((:normal :in-list) ((or (scan-any *symbol-characters*) - (and (scan "+") (scan-any *symbol-characters*)) - (and (scan "-") (scan-any *symbol-characters*)) - (scan "1+") - (scan "1-") + (and (scan #\.) (scan-any *symbol-characters*)) (and (scan #\\) (advance 1))) (set-mode :symbol :until (scan-any *non-constituent*)

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: IP banning (web-server.lisp part) Date: Thu Jun 3 15:12:14 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.49 lisppaste2/web-server.lisp:1.50 --- lisppaste2/web-server.lisp:1.49 Thu Jun 3 07:16:35 2004 +++ lisppaste2/web-server.lisp Thu Jun 3 15:12:14 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.49 2004/06/03 14:16:35 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.50 2004/06/03 22:12:14 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -35,6 +35,31 @@ (defclass syndication-handler (araneida:handler) ()) (defclass stats-handler (araneida:handler) ()) + +(defmethod araneida:handle-request-response :around + ((handler submit-paste-handler) method request) + (let ((forwarded-for (car (araneida:request-header request :x-forwarded-for)))) + (if (and forwarded-for + (member forwarded-for + *banned-ips* :test #'string-equal)) + (progn + (with-open-file (s "ban-log" :direction :output :if-exists :append + :if-does-not-exist :create) + (format s "Logged attempt by ~S to submit a paste.~%" + forwarded-for) + (format s "Request headers are: ~S.~%" + (araneida:request-headers request)) + (format s "Request body is: ~S.~%" + (araneida:request-body request))) + (araneida:request-send-headers request :expires 0) + (araneida:html-stream + (araneida:request-stream request) + `(html + (head + (title "No cookie for you!")) + (body (h1 ((font :color "red") "Naughty boy!")))))) + (call-next-method)))) + (defmethod araneida:handle-request-response ((handler new-paste-handler) method request) (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request)))

1 0

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

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/test/lisppaste2 Modified Files: variable.lisp Log Message: IP banning (variable.lisp part) Date: Thu Jun 3 15:12:03 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.15 lisppaste2/variable.lisp:1.16 --- lisppaste2/variable.lisp:1.15 Tue Jun 1 06:21:19 2004 +++ lisppaste2/variable.lisp Thu Jun 3 15:12:03 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.15 2004/06/01 13:21:19 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.16 2004/06/03 22:12:03 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -30,6 +30,12 @@ (defvar *paste-maximum-size* 51200) (defvar *pastes-per-page* 50) + +(defparameter *banned-ips* + '("69.11.238.252" "168.143.113.138")) + +(defparameter *ban-log-file* + "ban-log") ;; You shouldn't need to edit below this line. ;; LINE

1 0

[Lisppaste-cvs] CVS update: lisppaste2/elisp-symbols.lisp-expr
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: elisp-symbols.lisp-expr Log Message: Take out "foo" Date: Thu Jun 3 13:29:17 2004 Author: bmastenbrook Index: lisppaste2/elisp-symbols.lisp-expr diff -u lisppaste2/elisp-symbols.lisp-expr:1.1 lisppaste2/elisp-symbols.lisp-expr:1.2 --- lisppaste2/elisp-symbols.lisp-expr:1.1 Thu Jun 3 13:20:19 2004 +++ lisppaste2/elisp-symbols.lisp-expr Thu Jun 3 13:29:17 2004 @@ -766,7 +766,7 @@ ("font-lock-warning-face" . "elisp_370.html#IDX1128") ("fontification-functions" . "elisp_639.html#IDX2424") ("fontified (text property)" . "elisp_527.html#IDX1903") - ("foo" . "elisp_12.html#IDX7") ("for" . "elisp_182.html#IDX511") + ("for" . "elisp_182.html#IDX511") ("force-mode-line-update" . "elisp_358.html#IDX1087") ("format" . "elisp_75.html#IDX176") ("format-alist" . "elisp_404.html#IDX1284") @@ -1909,4 +1909,4 @@ ("y-or-n-p" . "elisp_281.html#IDX778") ("y-or-n-p-with-timeout" . "elisp_281.html#IDX779") ("yank" . "elisp_504.html#IDX1788") ("yank-pop" . "elisp_504.html#IDX1790") - ("yes-or-no-p" . "elisp_281.html#IDX780") ("zerop" . "elisp_60.html#IDX87")) \ No newline at end of file + ("yes-or-no-p" . "elisp_281.html#IDX780") ("zerop" . "elisp_60.html#IDX87"))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/coloring-types.lisp lisppaste2/lisppaste.asd
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: coloring-types.lisp lisppaste.asd Log Message: elisp colorization Date: Thu Jun 3 13:20:46 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.3 lisppaste2/coloring-types.lisp:1.4 --- lisppaste2/coloring-types.lisp:1.3 Thu Jun 3 07:17:04 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 3 13:20:46 2004 @@ -22,10 +22,6 @@ (defparameter *close-parens* '(#\))) (define-coloring-type :lisp "Basic Lisp" - :autodetect (lambda (name) - (member name '("emacs") - :test #'(lambda (name ext) - (search ext name :test #'char-equal)))) :modes (:normal :symbol :escaped-symbol :keyword :string :comment :multiline :character :single-escaped :in-list :syntax-error) @@ -191,6 +187,24 @@ (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 :elisp "Emacs Lisp" + :autodetect (lambda (name) + (member name '("emacs") + :test #'(lambda (name ext) + (search ext name :test #'char-equal)))) + :parent :lisp + :formatters + (((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :elisp-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) s)))) (if result (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.10 lisppaste2/lisppaste.asd:1.11 --- lisppaste2/lisppaste.asd:1.10 Thu Jun 3 07:17:58 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 13:20:46 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.11 2004/06/03 20:20:46 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -33,6 +33,7 @@ (:file "colorize" :depends-on ("colorize-package" "coloring-css")) (:file "clhs-lookup" :depends-on ("encode-for-pre")) (:file "r5rs-lookup" :depends-on ("encode-for-pre")) + (:file "elisp-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/r5rs-symbols.lisp-expr lisppaste2/elisp-symbols.lisp-expr lisppaste2/elisp-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-symbols.lisp-expr elisp-symbols.lisp-expr elisp-lookup.lisp Log Message: Symbols for R5RS and Elisp; lookup for elisp Date: Thu Jun 3 13:20:19 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.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: encode-for-pre.lisp Log Message: eight spaces instead of four for tabs Date: Thu Jun 3 13:19:40 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.15 lisppaste2/encode-for-pre.lisp:1.16 --- lisppaste2/encode-for-pre.lisp:1.15 Tue Jun 1 06:17:50 2004 +++ lisppaste2/encode-for-pre.lisp Thu Jun 3 13:19:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.15 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.16 2004/06/03 20:19:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -37,7 +37,7 @@ ((#\>) (write-string ">" out)) ((#\Tab) - (write-string "    " out)) + (write-string "        " out)) ((#\Space) (write-char #\Space out) (go escape-spaces))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/package.lisp lisppaste2/lisppaste.lisp lisppaste2/lisppaste.asd
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: package.lisp lisppaste.lisp lisppaste.asd Log Message: package: export shut-up; lisppaste: better response for help; lisppaste.asd: add r5rs-lookup Date: Thu Jun 3 07:17:58 2004 Author: bmastenbrook Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.5 lisppaste2/package.lisp:1.6 --- lisppaste2/package.lisp:1.5 Tue Jun 1 06:18:35 2004 +++ lisppaste2/package.lisp Thu Jun 3 07:17:58 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.5 2004/06/01 13:18:35 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.6 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,6 +8,6 @@ (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))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help))) Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.16 lisppaste2/lisppaste.lisp:1.17 --- lisppaste2/lisppaste.lisp:1.16 Tue Jun 1 06:17:50 2004 +++ lisppaste2/lisppaste.lisp Thu Jun 3 07:17:58 2004 @@ -1,10 +1,29 @@ -;;;; $Id: lisppaste.lisp,v 1.16 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.17 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) +(defun say-help (channel) + (when (and *connection* + (find channel *channels* :test #'string=)) + (irc:privmsg *connection* + channel + (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq channel 1))) + t)) + +(defun help-request-p (nick help text) + (and (> (length text) + (length nick)) + (search nick text :start2 0 :end2 (length nick) :test #'char-equal) + (let ((url-position (search help text :start2 (length nick) + :test #'char-equal))) + (and + url-position + (notany #'alphanumericp (subseq text (length nick) (1- url-position))) + (notany #'alphanumericp (subseq text (+ url-position (length help)))))))) + (defun make-msg-hook (nick) (lambda (message) (let ((text (irc:trailing-argument message))) @@ -12,18 +31,10 @@ (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)))))))))) + ((some #'(lambda (e) + (help-request-p nick e text)) + '("url" "help" "hello")) + (say-help (first (irc:arguments message)))))))) (defun add-hook (nick) @@ -44,6 +55,7 @@ (setf *channels* channels) (read-pastes-from-file *paste-file*) (mapcar #'(lambda (channel) (irc:join connection channel)) channels) + (clhs-lookup:populate-table) (araneida:start-listening *paste-listener*) (add-hook nickname) (setf *boot-time* (get-universal-time)) Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.9 lisppaste2/lisppaste.asd:1.10 --- lisppaste2/lisppaste.asd:1.9 Tue Jun 1 06:19:22 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 07:17:58 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.9 2004/06/01 13:19:22 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -22,15 +22,17 @@ pre-configured IRC channel about the paste and where it can be located." :depends-on (:araneida :cl-irc) - :components ((:file "package") + :components ((:file "encode-for-pre") + (:file "package" :depends-on ("encode-for-pre")) (:file "variable" :depends-on ("package")) - (:file "encode-for-pre" - :depends-on ("variable")) (:file "lisppaste" :depends-on ("variable")) - (:file "colorize") - (:file "clhs-lookup") + (:file "colorize-package") + (:file "coloring-css" :depends-on ("colorize-package")) + (:file "colorize" :depends-on ("colorize-package" "coloring-css")) + (:file "clhs-lookup" :depends-on ("encode-for-pre")) + (:file "r5rs-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0

[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 ""))) :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~C~A" + before-paren + (1+ count) + paren *css-background-class* + (color-parens after-paren)) + (format nil "~A~C~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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

lisppaste-cvs June 2004