lisppaste-cvs

lisppaste-cvs@common-lisp.net

192 discussions

[Lisppaste-cvs] CVS lisppaste2
by bmastenbrook 14 Aug '06

14 Aug '06

Update of /project/lisppaste/cvsroot/lisppaste2 In directory clnet:/tmp/cvs-serv16331 Modified Files: coloring-css.lisp coloring-types.lisp Log Message: Erlang syntax highlighting (thanks to Peter Kazmier) --- /project/lisppaste/cvsroot/lisppaste2/coloring-css.lisp 2004/09/25 20:20:27 1.6 +++ /project/lisppaste/cvsroot/lisppaste2/coloring-css.lisp 2006/08/14 21:33:00 1.7 @@ -12,6 +12,11 @@ .keyword { color : #770000; background-color : inherit; } .comment { color : #007777; background-color : inherit; } .string { color : #777777; background-color : inherit; } +.atom { color : #314F4F; background-color : inherit; } +.macro { color : #FF6347; background-color : inherit; } +.variable { color : #458B74; background-color : inherit; } +.function { color : #B03060; background-color : inherit; } +.attribute { color : #FF6347; background-color : inherit; } .character { color : #0055AA; background-color : inherit; } .syntaxerror { color : #FF0000; background-color : inherit; } span.paren1:hover { color : inherit; background-color : #BAFFFF; } --- /project/lisppaste/cvsroot/lisppaste2/coloring-types.lisp 2006/08/11 18:56:37 1.18 +++ /project/lisppaste/cvsroot/lisppaste2/coloring-types.lisp 2006/08/14 21:33:00 1.19 @@ -495,6 +495,180 @@ (setf is-keyword (not is-keyword)))))))) +(defvar *erlang-open-parens* "([{") +(defvar *erlang-close-parens* ")]}") + +(defvar *erlang-reserved-words* + '("after" "andalso" "begin" "catch" "case" "end" "fun" "if" "of" "orelse" + "receive" "try" "when" "query" "is_atom" "is_binary" "is_constant" + "is_float" "is_function" "is_integer" "is_list" "is_number" "is_pid" + "is_port" "is_reference" "is_tuple" "is_record" "abs" "element" "float" + "hd" "tl" "length" "node" "round" "self" "size" "trunc" "alive" "apply" + "atom_to_list" "binary_to_list" "binary_to_term" "concat_binary" + "date" "disconnect_node" "erase" "exit" "float_to_list" "garbage_collect" + "get" "get_keys" "group_leader" "halt" "integer_to_list" "internal_bif" + "link" "list_to_atom" "list_to_binary" "list_to_float" "list_to_integer" + "make_ref" "node_link" "node_unlink" "notalive" "open_port" "pid_to_list" + "process_flag" "process_info" "processes" "put" "register" "registered" + "setelement" "spawn" "spawn_link" "split_binary" "statistics" + "term_to_binary" "time" "throw" "trace" "trunc" "tuple_to_list" + "unlink" "unregister" "whereis")) + +(defparameter *erlang-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") +(defparameter *erlang-begin-fun* "abcdefghijklmnopqrstuvwxyz") +(defparameter *erlang-begin-var* "ABCDEFGHIJKLMNOPQRSTUVWXYZ_") +(defparameter *erlang-terminators* '(#\space #\return #\tab #\newline #\. #\; #\, #\/ #\- #\* #\+ #$ #$ #\' #\" #\[ #\] #\< #\> #\{ #\})) + +(define-coloring-type :erlang "Erlang" + :modes (:first-char-on-line :normal :char :comment :word-ish :variable :atom :paren-ish :string :single-escape :attribute :function :macro) + :default-mode :first-char-on-line + :transitions + (((:normal :paren-ish) + ((scan "%") + (set-mode :comment + :until (scan #\newline))) + ((scan-any *erlang-begin-var*) + (set-mode :variable + :until (scan-any *erlang-terminators*) + :advancing nil)) + ((scan-any *erlang-begin-word*) + (set-mode :word-ish + :until (scan-any *erlang-terminators*) + :advancing nil)) + ((or + (scan-any *erlang-open-parens*) + (scan-any *erlang-close-parens*)) + (set-mode :paren-ish + :until (advance 1) + :advancing nil)) + ((scan #\") + (set-mode :string + :until (scan #\"))) + ((scan #\') + (set-mode :atom + :until (scan #\'))) + ((scan #\?) + (set-mode :macro + :until (scan-any *erlang-terminators*))) + ((scan #\$) + (set-mode :char + :until (scan-any *erlang-terminators*))) + ((scan #\newline) + (set-mode :first-char-on-line))) + + ((:function :attribute) + ((or + (scan-any *erlang-open-parens*) + (scan-any *erlang-close-parens*)) + (set-mode :paren-ish + :until (advance 1) + :advancing nil)) + ((scan-any *erlang-terminators*) + (set-mode :normal + :until (scan #\newline)))) + + (:first-char-on-line + ((scan "%") + (set-mode :comment + :until (scan #\newline))) + ((scan-any *erlang-begin-fun*) + (set-mode :function + :until (scan #\newline) + :advancing nil)) + ((scan "-") + (set-mode :attribute + :until (scan #\newline) + :advancing nil)) + ((advance 1) + (set-mode :normal + :until (scan #\newline)))) + (: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 :first-char-on-line) + (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))) + (:variable + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:function + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:attribute + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:macro + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:atom + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:char + (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 *erlang-open-parens* 'list)) + (setf open t) + (setf count (mod paren-counter 6)) + (incf paren-counter)) + (when (member (elt s 0) (coerce *erlang-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 *erlang-reserved-words* :test #'string=) + (format nil "~A" s) + s))) + )) + (defvar *python-reserved-words* '("and" "assert" "break" "class" "continue" "def" "del" "elif" "else" "except"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/site-lisp/panacea.lisp lisppaste2/site-lisp/start-critters.lisp
by bmastenbrook＠common-lisp.net 23 Jan '05

23 Jan '05

Update of /project/lisppaste/cvsroot/lisppaste2/site-lisp In directory common-lisp.net:/home/bmastenbrook/lisppaste2/site-lisp Added Files: panacea.lisp start-critters.lisp Log Message: Add site start-lisppaste files to CVS Date: Sun Jan 23 07:41:15 2005 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: Directory change: lisppaste2/site-lisp
by bmastenbrook＠common-lisp.net 23 Jan '05

23 Jan '05

Update of /project/lisppaste/cvsroot/lisppaste2/site-lisp In directory common-lisp.net:/home/bmastenbrook/lisppaste2/site-lisp Log Message: Directory /project/lisppaste/cvsroot/lisppaste2/site-lisp added to the repository Date: Sun Jan 23 07:40:46 2005 Author: bmastenbrook New directory lisppaste2/site-lisp added

1 0

[Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/variable.lisp lisppaste2/web-server.lisp
by bmastenbrook＠common-lisp.net 23 Jan '05

23 Jan '05

1 0

[Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/web-server.lisp
by bmastenbrook＠common-lisp.net 10 Dec '04

10 Dec '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: README.lisp web-server.lisp Log Message: Partially roll back changes to help prevent misppastes to channels Date: Fri Dec 10 16:34:26 2004 Author: bmastenbrook Index: lisppaste2/README.lisp diff -u lisppaste2/README.lisp:1.17 lisppaste2/README.lisp:1.18 --- lisppaste2/README.lisp:1.17 Mon Nov 29 16:47:52 2004 +++ lisppaste2/README.lisp Fri Dec 10 16:34:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: README.lisp,v 1.17 2004/11/29 15:47:52 bmastenbrook Exp $ +;;;; $Id: README.lisp,v 1.18 2004/12/10 15:34:25 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/README.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -45,5 +45,5 @@ :server "niven.freenode.net" :port 6667) (lisppaste:start-irc-notification - :channels '("#lisppaste" "#pearpc" "#fpc" "#hprog" "#concatenative" "#slate-users") + :channels '("#lisppaste" "#pearpc" "#fpc" "#hprog" "#concatenative" "#slate-users" "#swhack" "#ud")) :nickname "lisppaste2")) Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.72 lisppaste2/web-server.lisp:1.73 --- lisppaste2/web-server.lisp:1.72 Mon Nov 29 21:45:31 2004 +++ lisppaste2/web-server.lisp Fri Dec 10 16:34:26 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.72 2004/11/29 20:45:31 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.73 2004/12/10 15:34:26 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -276,6 +276,7 @@ (araneida:body-param "channel" (araneida:request-body request))) (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) + (concatenate 'string "#" (araneida:request-cookie request "CHANNEL")) (and *no-channel-pastes* "None") ))))) @@ -840,9 +841,12 @@ ((th :align left :width "0%" :nowrap "nowrap") "Select a channel:") (td ,@(if (or (string= default-channel "") (string= default-channel "None")) - `(,(format nil "To paste to an IRC channel on the network ~A, select a channel from the " - *irc-network-name*) - ((input :type "hidden" :name "channel" :value ,default-channel))) + `(((select :name "channel") + ,@(mapcar #'(lambda (e) + `((option :value ,e ,@(if (string-equal e default-channel) + '(:selected "SELECTED"))) + ,(encode-for-pre e))) + *channels*))) `(((select :name "channel") ,@(mapcar #'(lambda (e) `((option :value ,e ,@(if (string-equal e default-channel) @@ -851,9 +855,11 @@ (list* default-channel (if *no-channel-pastes* '("None"))))) (br) ,(format nil "To paste to a different IRC channel on the network ~A, select a channel from the " - *irc-network-name*))) - ((a :href ,(araneida:urlstring *channel-select-url*)) "channel list") - ".")))) + *irc-network-name*) + ((a :href ,(araneida:urlstring *channel-select-url*)) "channel list") + ".")) + + )))) (tr ((th :align left :width "0%" :nowrap "nowrap") "Enter your username:") (td ((input :type text :name "username"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp lisppaste2/cocoa-lookup.lisp lisppaste2/elisp-lookup.lisp lisppaste2/r5rs-lookup.lisp
by bmastenbrook＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: clhs-lookup.lisp cocoa-lookup.lisp elisp-lookup.lisp r5rs-lookup.lisp Log Message: MORE ROBUSTNESS Date: Tue Nov 30 20:16:13 2004 Author: bmastenbrook Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.9 lisppaste2/clhs-lookup.lisp:1.10 --- lisppaste2/clhs-lookup.lisp:1.9 Fri Nov 12 15:47:00 2004 +++ lisppaste2/clhs-lookup.lisp Tue Nov 30 20:16:11 2004 @@ -15,7 +15,8 @@ ;;; AMOP. (defparameter *mop-map-file* - (merge-pathnames "Mop_Sym.txt" #.*compile-file-pathname*)) + (merge-pathnames "Mop_Sym.txt" + (or #.*compile-file-truename* *default-pathname-defaults*))) (defparameter *mop-root* "http://www.alu.org/mop/") Index: lisppaste2/cocoa-lookup.lisp diff -u lisppaste2/cocoa-lookup.lisp:1.1 lisppaste2/cocoa-lookup.lisp:1.2 --- lisppaste2/cocoa-lookup.lisp:1.1 Tue Nov 16 22:58:02 2004 +++ lisppaste2/cocoa-lookup.lisp Tue Nov 30 20:16:12 2004 @@ -7,11 +7,11 @@ (defparameter *appkit-file* (merge-pathnames "appkit.lisp-expr" - (or #.*compile-file-pathname* *default-pathname-defaults*))) + (or #.*compile-file-truename* *default-pathname-defaults*))) (defparameter *foundation-file* (merge-pathnames "foundation.lisp-expr" - (or #.*compile-file-pathname* *default-pathname-defaults*))) + (or #.*compile-file-truename* *default-pathname-defaults*))) (defvar *table* nil) Index: lisppaste2/elisp-lookup.lisp diff -u lisppaste2/elisp-lookup.lisp:1.2 lisppaste2/elisp-lookup.lisp:1.3 --- lisppaste2/elisp-lookup.lisp:1.2 Wed Jun 9 21:47:13 2004 +++ lisppaste2/elisp-lookup.lisp Tue Nov 30 20:16:12 2004 @@ -4,7 +4,9 @@ (defparameter *elisp-root* "http://www.gnu.org/software/emacs/elisp-manual/html_node/") -(defparameter *elisp-file* "elisp-symbols.lisp-expr") +(defparameter *elisp-file* + (merge-pathnames "elisp-symbols.lisp-expr" + (or #.*compile-file-truename* *default-pathname-defaults*))) (defvar *table* nil) Index: lisppaste2/r5rs-lookup.lisp diff -u lisppaste2/r5rs-lookup.lisp:1.2 lisppaste2/r5rs-lookup.lisp:1.3 --- lisppaste2/r5rs-lookup.lisp:1.2 Wed Jun 9 21:47:13 2004 +++ lisppaste2/r5rs-lookup.lisp Tue Nov 30 20:16:12 2004 @@ -4,7 +4,9 @@ (defparameter *r5rs-root* "http://www.schemers.org/Documents/Standards/R5RS/HTML/") -(defparameter *r5rs-file* "r5rs-symbols.lisp-expr") +(defparameter *r5rs-file* + (merge-pathnames "r5rs-symbols.lisp-expr" + (or #.*compile-file-truename* *default-pathname-defaults*))) (defvar *table* nil)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by bmastenbrook＠common-lisp.net 29 Nov '04

29 Nov '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Oops: format t! Date: Mon Nov 29 21:45:32 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.71 lisppaste2/web-server.lisp:1.72 --- lisppaste2/web-server.lisp:1.71 Mon Nov 29 21:41:55 2004 +++ lisppaste2/web-server.lisp Mon Nov 29 21:45:31 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.71 2004/11/29 20:41:55 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.72 2004/11/29 20:45:31 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -360,7 +360,6 @@ (weeks (* hours 487/16)) (months (* weeks 12)) (years (* hours (+ 365 1/4)))) - (format t "weeks is ~S, delta is ~S, floor w/weeks is ~S~%" weeks delta (floor delta weeks)) (let ((primitive (cond ((< delta seconds) (format nil "~D second~:P" delta))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by bmastenbrook＠common-lisp.net 29 Nov '04

29 Nov '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv11415 Modified Files: web-server.lisp Log Message: Bug fix to time-delta-primitive Date: Mon Nov 29 21:41:56 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.70 lisppaste2/web-server.lisp:1.71 --- lisppaste2/web-server.lisp:1.70 Mon Nov 29 16:47:52 2004 +++ lisppaste2/web-server.lisp Mon Nov 29 21:41:55 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.70 2004/11/29 15:47:52 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.71 2004/11/29 20:41:55 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -357,9 +357,10 @@ (minutes (* seconds 60)) (hours (* minutes 24)) (days (* hours 7)) - (weeks (* days 487/16)) + (weeks (* hours 487/16)) (months (* weeks 12)) (years (* hours (+ 365 1/4)))) + (format t "weeks is ~S, delta is ~S, floor w/weeks is ~S~%" weeks delta (floor delta weeks)) (let ((primitive (cond ((< delta seconds) (format nil "~D second~:P" delta)) @@ -368,7 +369,7 @@ ((< delta days) (format nil "~D day~:P" (floor delta hours))) ((< delta weeks) (format nil "~D week~:P" (floor delta days))) ((< delta months) (format nil "~D month~:P" (floor delta weeks))) - (t (format nil "~D years" (floor delta years)))))) + (t (format nil "~D years" (floor delta months)))))) (if (eql level 1) primitive (format nil "~A, ~A" primitive (time-delta-primitive

1 0

[Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/variable.lisp lisppaste2/web-server.lisp
by bmastenbrook＠common-lisp.net 29 Nov '04

29 Nov '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: README.lisp variable.lisp web-server.lisp Log Message: Random bug fixes Date: Mon Nov 29 16:47:53 2004 Author: bmastenbrook Index: lisppaste2/README.lisp diff -u lisppaste2/README.lisp:1.16 lisppaste2/README.lisp:1.17 --- lisppaste2/README.lisp:1.16 Sun Nov 7 22:01:43 2004 +++ lisppaste2/README.lisp Mon Nov 29 16:47:52 2004 @@ -1,4 +1,4 @@ -;;;; $Id: README.lisp,v 1.16 2004/11/07 21:01:43 bmastenbrook Exp $ +;;;; $Id: README.lisp,v 1.17 2004/11/29 15:47:52 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/README.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -42,8 +42,8 @@ "#growl" "#chicken" "#quicksilver" "#svn" "#slate" "#squeak" "#wiki" "#nebula" "#imgames") :nickname "lisppaste" - :server "orwell.freenode.net" + :server "niven.freenode.net" :port 6667) (lisppaste:start-irc-notification - :channels '("#lisppaste" "#pearpc" "#fpc" "#hprog") + :channels '("#lisppaste" "#pearpc" "#fpc" "#hprog" "#concatenative" "#slate-users") :nickname "lisppaste2")) Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.36 lisppaste2/variable.lisp:1.37 --- lisppaste2/variable.lisp:1.36 Sun Nov 7 22:01:43 2004 +++ lisppaste2/variable.lisp Mon Nov 29 16:47:52 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.36 2004/11/07 21:01:43 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.37 2004/11/29 15:47:52 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -127,6 +127,9 @@ (defparameter *email-redirect-url* (araneida:merge-url *paste-external-url* "email")) + +(defparameter *channel-select-url* + (araneida:merge-url *paste-external-url* "channels")) (defparameter *main-system-server-url* (araneida:merge-url *paste-external-url* "system-server/")) Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.69 lisppaste2/web-server.lisp:1.70 --- lisppaste2/web-server.lisp:1.69 Sun Nov 7 22:01:43 2004 +++ lisppaste2/web-server.lisp Mon Nov 29 16:47:52 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.69 2004/11/07 21:01:43 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.70 2004/11/29 15:47:52 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -52,6 +52,8 @@ (defclass email-redirect-handler (lisppaste-basic-handler) ()) +(defclass channel-select-handler (lisppaste-basic-handler) ()) + (defvar *referer-hash* (make-hash-table :test #'equalp)) (defvar *referer-example-hash* (make-hash-table :test #'equalp)) @@ -83,33 +85,35 @@ (incf (gethash "Google" *referer-hash* 0) count))))) (defmethod araneida:handle-request-response :around ((handler lisppaste-basic-handler) method request) - (progn #+nil with-open-file #+nil (*trace-output* (times-file-for-class handler) + (with-open-file (*trace-output* (times-file-for-class handler) :direction :output :if-exists :append :if-does-not-exist :create) - (time - (progn - (let ((referer (car (araneida:request-header request :referer))) - (araneida::*default-url-defaults* (araneida:request-url request))) - (when (stringp referer) - (let ((url (araneida:parse-urlstring referer nil))) - (when url - (let ((real-host (araneida:url-host url)) - (split-host (split-sequence:split-sequence #\. (araneida:url-host url)))) - (if (or - (and (eql (length split-host) 3) - (string-equal (first split-host) "www") - (string-equal (second split-host) "google")) - (and (eql (length split-host) 4) - (string-equal (first split-host) "www") - (string-equal (second split-host) "google") - (or - (string-equal (third split-host) "co") - (string-equal (third split-host) "com")) - (eql (length (fourth split-host)) 2))) - (setf real-host "Google")) - (incf (gethash real-host *referer-hash* 0)) - (setf (gethash real-host *referer-example-hash*) url)))))) - (call-next-method))))) + (unwind-protect + (time + (progn + (let ((referer (car (araneida:request-header request :referer))) + (araneida::*default-url-defaults* (araneida:request-url request))) + (when (stringp referer) + (let ((url (araneida:parse-urlstring referer nil))) + (when url + (let ((real-host (araneida:url-host url)) + (split-host (split-sequence:split-sequence #\. (araneida:url-host url)))) + (if (or + (and (eql (length split-host) 3) + (string-equal (first split-host) "www") + (string-equal (second split-host) "google")) + (and (eql (length split-host) 4) + (string-equal (first split-host) "www") + (string-equal (second split-host) "google") + (or + (string-equal (third split-host) "co") + (string-equal (third split-host) "com")) + (eql (length (fourth split-host)) 2))) + (setf real-host "Google")) + (incf (gethash real-host *referer-hash* 0)) + (setf (gethash real-host *referer-example-hash*) url)))))) + (call-next-method))) + (force-output *trace-output*)))) (defun make-css () (let ((colorize:*css-background-class* "paste")) @@ -196,7 +200,7 @@ (araneida:html-stream (araneida:request-stream request) (lisppaste-wrap-page - *paste-site-name* + (format nil "~A pastebin" *paste-site-name*) `((table :width "100%" :border 0 :cellpadding 2) (tr (td ((div :class "small-header") "Recent pastes")) ((td :align right) ((div :class "small-header") "Make a new paste"))) @@ -271,14 +275,9 @@ (and (eql method :post) (araneida:body-param "channel" (araneida:request-body request))) + (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) (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")) ))))) (cond ((and default-channel (or (and *no-channel-pastes* @@ -414,6 +413,36 @@ append)) "Full"))))) *channels*))))) +(defmethod araneida:handle-request-response ((handler channel-select-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) + (lisppaste-wrap-page + "Select a channel" + `((table :width "100%" :border 0 :cellpadding 2) + ((tr :valign top :align left) + ((td :style "width: 5em;") " ") + (td + ((table :class "info-table") + ,@(mapcar #'(lambda (channel) + `(tr + ((th :align left) + ((a :href ,(concatenate 'string + (araneida:urlstring *new-paste-url*) + "/" + (subseq channel 1))) ,channel) + ))) + (sort (copy-list (remove "None" *channels* :test #'string=)) #'string<)))) + ((td :style "width: 5em;") " ") + (td + ((div :class "info-text") + ,(format nil "Lisppaste is available in a number of channels on the IRC network ~A. Select a channel from the list below and bookmark its URL to paste with direct notification to your channel." *irc-network-name*) + (p) + "Questions? Comments? Want lisppaste in your channel? " ((a :href ,(araneida:urlstring *email-redirect-url*)) "Email me") ".")) + + ((td :style "width: 5em;") " ")))))) + (defun encode-beginning-of-month (month year &key next-month) (if next-month (encode-beginning-of-month (if (eql month 12) 1 (1+ month)) @@ -809,13 +838,22 @@ ,@(if (not annotate) `((tr ((th :align left :width "0%" :nowrap "nowrap") "Select a channel:") - (td ((select :name "channel") - ,@(if (not *no-channel-pastes*) - `(((option :value "")))) - ,@(mapcar #'(lambda (e) - `((option :value ,e ,@(if (string-equal e default-channel) - '(:selected "SELECTED"))) - ,(encode-for-pre e))) *channels*)))))) + (td ,@(if (or (string= default-channel "") + (string= default-channel "None")) + `(,(format nil "To paste to an IRC channel on the network ~A, select a channel from the " + *irc-network-name*) + ((input :type "hidden" :name "channel" :value ,default-channel))) + `(((select :name "channel") + ,@(mapcar #'(lambda (e) + `((option :value ,e ,@(if (string-equal e default-channel) + '(:selected "SELECTED"))) + ,(encode-for-pre e))) + (list* default-channel (if *no-channel-pastes* '("None"))))) + (br) + ,(format nil "To paste to a different IRC channel on the network ~A, select a channel from the " + *irc-network-name*))) + ((a :href ,(araneida:urlstring *channel-select-url*)) "channel list") + ".")))) (tr ((th :align left :width "0%" :nowrap "nowrap") "Enter your username:") (td ((input :type text :name "username" @@ -1042,9 +1080,10 @@ (colorize-string (or (araneida:body-param "colorize" (araneida:request-body request)) (and paste - (when (eql (paste-colorization-mode paste) :none) - (setf (paste-colorization-mode paste) "") - nil) + (if (eql (paste-colorization-mode paste) :none) + (progn (setf (paste-colorization-mode paste) "") + nil) + t) (> (length (paste-colorization-mode paste)) 0) (paste-colorization-mode paste)) )) @@ -1103,7 +1142,7 @@ (araneida:html-stream (araneida:request-stream request) (lisppaste-wrap-page - (format nil "Paste number ~A" paste-number) + (format nil "Paste number ~A: ~A" paste-number (encode-for-pre (paste-title paste))) `(div ((form :method post :action ,(araneida:urlstring *new-paste-url*)) (center @@ -1236,3 +1275,8 @@ (araneida:http-listener-handler *paste-listener*) (make-instance 'email-redirect-handler) (araneida:urlstring *email-redirect-url*) t) + +(araneida:install-handler + (araneida:http-listener-handler *paste-listener*) + (make-instance 'channel-select-handler) + (araneida:urlstring *channel-select-url*) t)

1 0

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

16 Nov '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv2665 Modified Files: coloring-types.lisp colorize.lisp Log Message: Smarter ObjC colorization Date: Tue Nov 16 23:27:31 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.11 lisppaste2/coloring-types.lisp:1.12 --- lisppaste2/coloring-types.lisp:1.11 Tue Nov 16 22:55:51 2004 +++ lisppaste2/coloring-types.lisp Tue Nov 16 23:27:31 2004 @@ -268,7 +268,8 @@ "switch" "typedef" "union" "unsigned" "void" "volatile" "while" "__restrict" "_Bool")) -(defvar *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #$ #$ #\' #\" #\[ #\] #\< #\> #\#)) +(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") +(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #$ #$ #\' #\" #\[ #\] #\< #\> #\#)) (define-coloring-type :basic-c "Basic C" :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) @@ -276,7 +277,7 @@ :invisible t :transitions ((:normal - ((scan-any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") + ((scan-any *c-begin-word*) (set-mode :word-ish :until (scan-any *c-terminators*) :advancing nil)) @@ -426,19 +427,64 @@ s) s))))) -(define-coloring-type :objective-c "Objective C" - :autodetect (lambda (text) (search "mac" text :test #'char=)) +(let ((terminate-next nil)) + (define-coloring-type :objective-c "Objective C" + :autodetect (lambda (text) (search "mac" text :test #'char=)) + :modes (:begin-message-send :end-message-send) + :transitions + ((:normal + ((scan #\[) + (set-mode :begin-message-send + :until (advance 1) + :advancing nil)) + ((scan #\]) + (set-mode :end-message-send + :until (advance 1) + :advancing nil)) + ((scan-any *c-begin-word*) + (set-mode :word-ish + :until (or + (and (peek-any '(#\:)) + (setf terminate-next t)) + (and terminate-next (progn + (setf terminate-next nil) + (advance 1))) + (scan-any *c-terminators*)) + :advancing nil))) + (:word-ish + #+nil + ((scan #\:) + (format t "hi~%") + (set-mode :word-ish :until (advance 1) :advancing nil) + (setf terminate-next t)))) :parent :c++ + :formatter-variables ((is-keyword nil) (in-message-send nil)) :formatters - ((:word-ish + ((:begin-message-send + (lambda (type s) + (setf is-keyword nil) + (setf in-message-send t) + (call-formatter (cons :paren-ish type) s))) + (:end-message-send + (lambda (type s) + (setf is-keyword nil) + (setf in-message-send nil) + (call-formatter (cons :paren-ish type) s))) + (:word-ish (lambda (type s) (declare (ignore type)) - (let ((result (if (find-package :cocoa-lookup) - (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup)) - s)))) - (if result - (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" - result (call-parent-formatter)) - (if (member s *c-reserved-words* :test #'string=) - (format nil "~A" s) - s))))))) + (prog1 + (let ((result (if (find-package :cocoa-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup)) + s)))) + (if result + (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" + result s) + (if (member s *c-reserved-words* :test #'string=) + (format nil "~A" s) + (if in-message-send + (if is-keyword + (format nil "~A" s) + s) + s)))) + (setf is-keyword (not is-keyword)))))))) \ No newline at end of file Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.5 lisppaste2/colorize.lisp:1.6 --- lisppaste2/colorize.lisp:1.5 Thu Jul 15 14:36:49 2004 +++ lisppaste2/colorize.lisp Tue Nov 16 23:27:31 2004 @@ -64,7 +64,7 @@ `(labels ((advance (,num) (setf ,position-place (+ ,position-place ,num)) t) - (scan-any (,items &key ,not-preceded-by) + (peek-any (,items &key ,not-preceded-by) (incf *scan-calls*) (let* ((,items (if (stringp ,items) (coerce ,items 'list) ,items)) @@ -98,13 +98,16 @@ t) t) nil) - (progn - (advance (length ,item)) - t) + ,item (progn (and *reset-position* (setf ,position-place *reset-position*)) nil))))) + (scan-any (,items &key ,not-preceded-by) + (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by))) + (and ,item (advance (length ,item))))) + (peek (,item &key ,not-preceded-by) + (peek-any (list ,item) :not-preceded-by ,not-preceded-by)) (scan (,item &key ,not-preceded-by) (scan-any (list ,item) :not-preceded-by ,not-preceded-by))) (macrolet ((set-mode (,new-mode &key ,until (,advancing t))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

lisppaste-cvs