[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp lisppaste2/encode-for-pre.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Jun 8 15:20:40 UTC 2004
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 "<span class=\"paste\">~A</span>"
+ (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 "<br>" out)
+ (if with-line-numbers
+ (write-string (funcall with-line-numbers) out))
(go escape-spaces))
((#\&)
(write-string "&" out))
More information about the Lisppaste-cvs
mailing list