bknr-cvs February 2008

bknr-cvs@common-lisp.net

3 participants
128 discussions

[bknr-cvs] r2442 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 05 Feb '08

05 Feb '08

Author: hhubner Date: Tue Feb 5 15:59:12 2008 New Revision: 2442 Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Log: Dummy commit to check whether update mechanics work. Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Tue Feb 5 15:59:12 2008 @@ -14,7 +14,7 @@ <html xmlns="http://www.w3.org/1999/xhtml"> <head> - <title>LISP-ECOOP07 - $(title)</title> + <title>European Lisp Workshop 2008 - $(title)</title> <link rel="stylesheet" type="text/css" href="../static/styles.css" /> <script src="../static/javascript.js" language="javascript" type="text/javascript"> </script> </head> @@ -62,4 +62,4 @@ </div> </xsl:template> -</xsl:stylesheet> \ No newline at end of file +</xsl:stylesheet>

1 0

[bknr-cvs] r2441 - branches/trunk-reorg/projects/bos
by hhubner＠common-lisp.net 02 Feb '08

02 Feb '08

Author: hhubner Date: Sat Feb 2 18:43:53 2008 New Revision: 2441 Added: branches/trunk-reorg/projects/bos/ - copied from r2440, branches/bos/projects/bos/ Log: copied over bos project from bos branch

1 0

[bknr-cvs] r2440 - branches/trunk-reorg/projects/bos
by hhubner＠common-lisp.net 02 Feb '08

02 Feb '08

Author: hhubner Date: Sat Feb 2 18:40:28 2008 New Revision: 2440 Removed: branches/trunk-reorg/projects/bos/ Log: remove bos projects to do a full fetch from the branch

1 0

[bknr-cvs] r2439 - in branches/trunk-reorg: bknr/web/src projects/quickhoney/src
by hhubner＠common-lisp.net 02 Feb '08

02 Feb '08

Author: hhubner Date: Sat Feb 2 18:30:00 2008 New Revision: 2439 Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/projects/quickhoney/src/handlers.lisp Log: Commit smaller fixes before trying a merge from the bos branch Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Sat Feb 2 18:30:00 2008 @@ -22,7 +22,6 @@ :depends-on (:cl-interpol :cl-ppcre :cl-gd - :kmrcl :alexandria :md5 :cxml Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp Sat Feb 2 18:30:00 2008 @@ -39,7 +39,7 @@ (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) #'< :key #'blob-timestamp)) -(defmethod image-to-javascript ((image quickhoney-image) &optional stream) +(defmethod image-to-javascript ((image quickhoney-image)) (format nil " new parent.ServerImage(~S, ~D, ~S, ~D, ~D, ~S)" (store-image-name image) (store-object-id image)

1 0

[bknr-cvs] r2438 - in branches/trunk-reorg: bknr/datastore/src bknr/datastore/src/utils bknr/datastore/src/xml-impex bknr/web/src bknr/web/src/web projects/bos/worldpay-test projects/eboy/src projects/gpn projects/lisp-ecoop/src projects/quickhoney/src projects/quickhoney/website/templates projects/saugnapf/src thirdparty/cl+ssl
by hhubner＠common-lisp.net 02 Feb '08

02 Feb '08

Author: hhubner Date: Sat Feb 2 17:54:13 2008 New Revision: 2438 Added: branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp - copied, changed from r2434, branches/trunk-reorg/bknr/web/src/web/templates.lisp Removed: branches/trunk-reorg/bknr/web/src/web/templates.lisp Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp branches/trunk-reorg/projects/eboy/src/item-handlers.lisp branches/trunk-reorg/projects/gpn/gpn-tags.lisp branches/trunk-reorg/projects/gpn/import-handler.lisp branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp branches/trunk-reorg/projects/quickhoney/src/tags.lisp branches/trunk-reorg/projects/quickhoney/src/webserver.lisp branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml branches/trunk-reorg/projects/quickhoney/website/templates/index.xml branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp Log: Fix templater to work with current CXML. Began porting lisp-ecoop over to the new framework. Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd Sat Feb 2 17:54:13 2008 @@ -35,5 +35,6 @@ (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) (:file "date-calc") + (:file "parse-time") (:file "acl-mp-compat" :depends-on ("package")))))) Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Sat Feb 2 17:54:13 2008 @@ -30,6 +30,7 @@ #:month-num-days #:hostname + #:parse-time ;; filesystem functions #:copy-stream Added: branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp Sat Feb 2 17:54:13 2008 @@ -0,0 +1,635 @@ +(in-package :bknr.utils) + +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; + +;;; It was subsequently borrowed and modified slightly by Daniel +;;; Barlow <dan(a)telent.net> to become part of the net-telent-date +;;; package. Daniel, Tue May 22 05:45:27 BST 2001 + +;;; ********************************************************************** + +;;; Parsing routines for time and date strings. PARSE-TIME returns the +;;; universal time integer for the time and/or date given in the string. + +;;; Written by Jim Healy, June 1987. + +;;; ********************************************************************** + +(defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`)) +(defvar time-dividers '(#\: #\.)) +(defvar date-dividers '(#\\ #\/ #\-)) + +(defvar *error-on-mismatch* nil + "If t, an error will be signalled if parse-time is unable + to determine the time/date format of the string.") + +;;; Set up hash tables for month, weekday, zone, and special strings. +;;; Provides quick, easy access to associated information for these items. + +;;; Hashlist takes an association list and hashes each pair into the +;;; specified tables using the car of the pair as the key and the cdr as +;;; the data object. + +(defmacro hashlist (list table) + `(dolist (item ,list) + (setf (gethash (car item) ,table) (cdr item)))) + +(defparameter weekday-table-size 23) +(defparameter month-table-size 31) +(defparameter zone-table-size 11) +(defparameter special-table-size 11) + +(defvar *weekday-strings* (make-hash-table :test #'equal + :size weekday-table-size)) + +(defvar *month-strings* (make-hash-table :test #'equal + :size month-table-size)) + +(defvar *zone-strings* (make-hash-table :test #'equal + :size zone-table-size)) + +(defvar *special-strings* (make-hash-table :test #'equal + :size special-table-size)) + +;;; Load-time creation of the hash tables. + +(hashlist '(("monday" . 0) ("mon" . 0) + ("tuesday" . 1) ("tues" . 1) ("tue" . 1) + ("wednesday" . 2) ("wednes" . 2) ("wed" . 2) + ("thursday" . 3) ("thurs" . 3) ("thu" . 3) + ("friday" . 4) ("fri" . 4) + ("saturday" . 5) ("sat" . 5) + ("sunday" . 6) ("sun" . 6)) + *weekday-strings*) + +(hashlist '(("january" . 1) ("jan" . 1) + ("february" . 2) ("feb" . 2) + ("march" . 3) ("mar" . 3) + ("april" . 4) ("apr" . 4) + ("may" . 5) ("june" . 6) + ("jun" . 6) ("july" . 7) + ("jul" . 7) ("august" . 8) + ("aug" . 8) ("september" . 9) + ("sept" . 9) ("sep" . 9) + ("october" . 10) ("oct" . 10) + ("november" . 11) ("nov" . 11) + ("december" . 12) ("dec" . 12)) + *month-strings*) + +(hashlist '(("gmt" . 0) ("est" . 5) + ("edt" . 4) ("cst" . 6) + ("cdt" . 5) ("mst" . 7) + ("mdt" . 6) ("pst" . 8) + ("pdt" . 7)) + *zone-strings*) + +(hashlist '(("yesterday" . yesterday) ("today" . today) + ("tomorrow" . tomorrow) ("now" . now)) + *special-strings*) + +;;; Time/date format patterns are specified as lists of symbols repre- +;;; senting the elements. Optional elements can be specified by +;;; enclosing them in parentheses. Note that the order in which the +;;; patterns are specified below determines the order of search. + +;;; Choices of pattern symbols are: second, minute, hour, day, month, +;;; year, time-divider, date-divider, am-pm, zone, izone, weekday, +;;; noon-midn, and any special symbol. + +(defparameter *default-date-time-patterns* + '( + ;; Date formats. + ((weekday) month (date-divider) day (date-divider) year (noon-midn)) + ((weekday) day (date-divider) month (date-divider) year (noon-midn)) + ((weekday) month (date-divider) day (noon-midn)) + (year (date-divider) month (date-divider) day (noon-midn)) + (month (date-divider) year (noon-midn)) + (year (date-divider) month (noon-midn)) + + ((noon-midn) (weekday) month (date-divider) day (date-divider) year) + ((noon-midn) (weekday) day (date-divider) month (date-divider) year) + ((noon-midn) (weekday) month (date-divider) day) + ((noon-midn) year (date-divider) month (date-divider) day) + ((noon-midn) month (date-divider) year) + ((noon-midn) year (date-divider) month) + + ;; Time formats. + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + (noon-midn) + (hour (noon-midn)) + + ;; Time/date combined formats. + ((weekday) month (date-divider) day (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + ((weekday) day (date-divider) month (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + ((weekday) month (date-divider) day + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (year (date-divider) month (date-divider) day + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (month (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (year (date-divider) month + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) month (date-divider) + day (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) day (date-divider) + month (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) month (date-divider) + day) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) year (date-divider) month + (date-divider) day) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) month (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) year (date-divider) month) + + ;; Weird, non-standard formats. + (weekday month day hour (time-divider) minute (time-divider) + secondp (am-pm) + (zone) year) + ((weekday) day (date-divider) month (date-divider) year hour + (time-divider) minute (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + ((weekday) month (date-divider) day (date-divider) year hour + (time-divider) minute (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + + ;; Special-string formats. + (now (yesterday)) + ((yesterday) now) + (now (today)) + ((today) now) + (now (tomorrow)) + ((tomorrow) now) + (yesterday (noon-midn)) + ((noon-midn) yesterday) + (today (noon-midn)) + ((noon-midn) today) + (tomorrow (noon-midn)) + ((noon-midn) tomorrow) +)) + +;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C. +(defparameter *http-date-time-patterns* + '( + ;; RFC1123/RFC822 and RFC850. + ((weekday) day (date-divider) month (date-divider) year + hour time-divider minute (time-divider) (secondp) izone) + ((weekday) day (date-divider) month (date-divider) year + hour time-divider minute (time-divider) (secondp) (zone)) + + ;; ANSI-C. + ((weekday) month day + hour time-divider minute (time-divider) (secondp) year))) + + +;;; The decoded-time structure holds the time/date values which are +;;; eventually passed to 'encode-universal-time' after parsing. + +;;; Note: Currently nothing is done with the day of the week. It might +;;; be appropriate to add a function to see if it matches the date. + +(defstruct decoded-time + (second 0 :type integer) ; Value between 0 and 59. + (minute 0 :type integer) ; Value between 0 and 59. + (hour 0 :type integer) ; Value between 0 and 23. + (day 1 :type integer) ; Value between 1 and 31. + (month 1 :type integer) ; Value between 1 and 12. + (year 1900 :type integer) ; Value above 1899 or between 0 and 99. + (zone 0 :type rational) ; Value between -24 and 24 inclusive. + (dotw 0 :type integer)) ; Value between 0 and 6. + +;;; Make-default-time returns a decoded-time structure with the default +;;; time values already set. The default time is currently 00:00 on +;;; the current day, current month, current year, and current time-zone. + +(defun make-default-time (def-sec def-min def-hour def-day + def-mon def-year def-zone def-dotw) + (let ((default-time (make-decoded-time))) + (multiple-value-bind (sec min hour day mon year dotw dst zone) + (get-decoded-time) + (declare (ignore dst)) + (if def-sec + (if (eq def-sec :current) + (setf (decoded-time-second default-time) sec) + (setf (decoded-time-second default-time) def-sec)) + (setf (decoded-time-second default-time) 0)) + (if def-min + (if (eq def-min :current) + (setf (decoded-time-minute default-time) min) + (setf (decoded-time-minute default-time) def-min)) + (setf (decoded-time-minute default-time) 0)) + (if def-hour + (if (eq def-hour :current) + (setf (decoded-time-hour default-time) hour) + (setf (decoded-time-hour default-time) def-hour)) + (setf (decoded-time-hour default-time) 0)) + (if def-day + (if (eq def-day :current) + (setf (decoded-time-day default-time) day) + (setf (decoded-time-day default-time) def-day)) + (setf (decoded-time-day default-time) day)) + (if def-mon + (if (eq def-mon :current) + (setf (decoded-time-month default-time) mon) + (setf (decoded-time-month default-time) def-mon)) + (setf (decoded-time-month default-time) mon)) + (if def-year + (if (eq def-year :current) + (setf (decoded-time-year default-time) year) + (setf (decoded-time-year default-time) def-year)) + (setf (decoded-time-year default-time) year)) + (if def-zone + (if (eq def-zone :current) + (setf (decoded-time-zone default-time) zone) + (setf (decoded-time-zone default-time) def-zone)) + (setf (decoded-time-zone default-time) zone)) + (if def-dotw + (if (eq def-dotw :current) + (setf (decoded-time-dotw default-time) dotw) + (setf (decoded-time-dotw default-time) def-dotw)) + (setf (decoded-time-dotw default-time) dotw)) + default-time))) + +;;; Converts the values in the decoded-time structure to universal time +;;; by calling encode-universal-time. +;;; If zone is in numerical form, tweeks it appropriately. + +(defun convert-to-unitime (parsed-values) + (let ((zone (decoded-time-zone parsed-values))) + (encode-universal-time (decoded-time-second parsed-values) + (decoded-time-minute parsed-values) + (decoded-time-hour parsed-values) + (decoded-time-day parsed-values) + (decoded-time-month parsed-values) + (decoded-time-year parsed-values) + (if (or (> zone 24) (< zone -24)) + (let ((new-zone (/ zone 100))) + (cond ((minusp new-zone) (- new-zone)) + ((plusp new-zone) (- 24 new-zone)) + ;; must be zero (GMT) + (t new-zone))) + zone)))) + +;;; Sets the current values for the time and/or date parts of the +;;; decoded time structure. + +(defun set-current-value (values-structure &key (time nil) (date nil) + (zone nil)) + (multiple-value-bind (sec min hour day mon year dotw dst tz) + (get-decoded-time) + (declare (ignore dst)) + (when time + (setf (decoded-time-second values-structure) sec) + (setf (decoded-time-minute values-structure) min) + (setf (decoded-time-hour values-structure) hour)) + (when date + (setf (decoded-time-day values-structure) day) + (setf (decoded-time-month values-structure) mon) + (setf (decoded-time-year values-structure) year) + (setf (decoded-time-dotw values-structure) dotw)) + (when zone + (setf (decoded-time-zone values-structure) tz)))) + +;;; Special function definitions. To define a special substring, add +;;; a dotted pair consisting of the substring and a symbol in the +;;; *special-strings* hashlist statement above. Then define a function +;;; here which takes one argument- the decoded time structure- and +;;; sets the values of the structure to whatever is necessary. Also, +;;; add a some patterns to the patterns list using whatever combinations +;;; of special and pre-existing symbols desired. + +(defun yesterday (parsed-values) + (set-current-value parsed-values :date t :zone t) + (setf (decoded-time-day parsed-values) + (1- (decoded-time-day parsed-values)))) + +(defun today (parsed-values) + (set-current-value parsed-values :date t :zone t)) + +(defun tomorrow (parsed-values) + (set-current-value parsed-values :date t :zone t) + (setf (decoded-time-day parsed-values) + (1+ (decoded-time-day parsed-values)))) + +(defun now (parsed-values) + (set-current-value parsed-values :time t)) + +;;; Predicates for symbols. Each symbol has a corresponding function +;;; defined here which is applied to a part of the datum to see if +;;; it matches the qualifications. + +(defun am-pm (string) + (and (simple-string-p string) + (cond ((string= string "am") 'am) + ((string= string "pm") 'pm) + (t nil)))) + +(defun noon-midn (string) + (and (simple-string-p string) + (cond ((string= string "noon") 'noon) + ((string= string "midnight") 'midn) + (t nil)))) + +(defun weekday (string) + (and (simple-string-p string) (gethash string *weekday-strings*))) + +(defun month (thing) + (or (and (simple-string-p thing) (gethash thing *month-strings*)) + (and (integerp thing) (<= 1 thing 12)))) + +(defun zone (thing) + (or (and (simple-string-p thing) (gethash thing *zone-strings*)) + (if (integerp thing) + (let ((zone (/ thing 100))) + (and (integerp zone) (<= -24 zone 24)))))) + +;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. +(defun izone (thing) + (if (integerp thing) + (multiple-value-bind (hours mins) + (truncate thing 100) + (and (<= -24 hours 24) (<= -59 mins 59))))) + +(defun special-string-p (string) + (and (simple-string-p string) (gethash string *special-strings*))) + +(defun secondp (number) + (and (integerp number) (<= 0 number 59))) + +(defun minute (number) + (and (integerp number) (<= 0 number 59))) + +(defun hour (number) + (and (integerp number) (<= 0 number 23))) + +(defun day (number) + (and (integerp number) (<= 1 number 31))) + +(defun year (number) + (and (integerp number) + (or (<= 0 number 99) + (<= 1900 number)))) + +(defun time-divider (character) + (and (characterp character) + (member character time-dividers :test #'char=))) + +(defun date-divider (character) + (and (characterp character) + (member character date-dividers :test #'char=))) + +;;; Match-substring takes a string argument and tries to match it with +;;; the strings in one of the four hash tables: *weekday-strings*, *month- +;;; strings*, *zone-strings*, *special-strings*. It returns a specific +;;; keyword and/or the object it finds in the hash table. If no match +;;; is made then it immediately signals an error. + +(defun match-substring (substring) + (let ((substring (nstring-downcase substring))) + (or (let ((test-value (month substring))) + (if test-value (cons 'month test-value))) + (let ((test-value (weekday substring))) + (if test-value (cons 'weekday test-value))) + (let ((test-value (am-pm substring))) + (if test-value (cons 'am-pm test-value))) + (let ((test-value (noon-midn substring))) + (if test-value (cons 'noon-midn test-value))) + (let ((test-value (zone substring))) + (if test-value (cons 'zone test-value))) + (let ((test-value (special-string-p substring))) + (if test-value (cons 'special test-value))) + (if *error-on-mismatch* + (error "\"~A\" is not a recognized word or abbreviation." + substring) + (return-from match-substring nil))))) + +;;; Decompose-string takes the time/date string and decomposes it into a +;;; list of alphabetic substrings, numbers, and special divider characters. +;;; It matches whatever strings it can and replaces them with a dotted pair +;;; containing a symbol and value. + +(defun decompose-string (string &key (start 0) (end (length string)) (radix 10)) + (do ((string-index start) + (next-negative nil) + (parts-list nil)) + ((eq string-index end) (nreverse parts-list)) + (let ((next-char (char string string-index)) + (prev-char (if (= string-index start) + nil + (char string (1- string-index))))) + (cond ((alpha-char-p next-char) + ;; Alphabetic character - scan to the end of the substring. + (do ((scan-index (1+ string-index) (1+ scan-index))) + ((or (eq scan-index end) + (not (alpha-char-p (char string scan-index)))) + (let ((match-symbol (match-substring + (subseq string string-index scan-index)))) + (if match-symbol + (push match-symbol parts-list) + (return-from decompose-string nil))) + (setf string-index scan-index)))) + ((digit-char-p next-char radix) + ;; Numeric digit - convert digit-string to a decimal value. + (do ((scan-index string-index (1+ scan-index)) + (numeric-value 0 (+ (* numeric-value radix) + (digit-char-p (char string scan-index) radix)))) + ((or (eq scan-index end) + (not (digit-char-p (char string scan-index) radix))) + ;; If next-negative is t, set the numeric value to it's + ;; opposite and reset next-negative to nil. + (when next-negative + (setf next-negative nil) + (setf numeric-value (- numeric-value))) + (push numeric-value parts-list) + (setf string-index scan-index)))) + ((and (char= next-char #\-) + (or (not prev-char) + (member prev-char whitespace-chars :test #'char=))) + ;; If we see a minus sign before a number, but not after one, + ;; it is not a date divider, but a negative offset from GMT, so + ;; set next-negative to t and continue. + (setf next-negative t) + (incf string-index)) + ((member next-char time-dividers :test #'char=) + ;; Time-divider - add it to the parts-list with symbol. + (push (cons 'time-divider next-char) parts-list) + (incf string-index)) + ((member next-char date-dividers :test #'char=) + ;; Date-divider - add it to the parts-list with symbol. + (push (cons 'date-divider next-char) parts-list) + (incf string-index)) + ((member next-char whitespace-chars :test #'char=) + ;; Whitespace character - ignore it completely. + (incf string-index)) + ((char= next-char #$) + ;; Parenthesized string - scan to the end and ignore it. + (do ((scan-index string-index (1+ scan-index))) + ((or (eq scan-index end) + (char= (char string scan-index) #$)) + (setf string-index (1+ scan-index))))) + (t + ;; Unrecognized character - barf voraciously. + (if *error-on-mismatch* + (error + 'simple-error + :format-control "Can't parse time/date string.~%>>> ~A~ + ~%~VT^-- Bogus character encountered here." + :format-arguments (list string (+ string-index 4))) + (return-from decompose-string nil))))))) + +;;; Match-pattern-element tries to match a pattern element with a datum +;;; element and returns the symbol associated with the datum element if +;;; successful. Otherwise nil is returned. + +(defun match-pattern-element (pattern-element datum-element) + (cond ((listp datum-element) + (let ((datum-type (if (eq (car datum-element) 'special) + (cdr datum-element) + (car datum-element)))) + (if (eq datum-type pattern-element) datum-element))) + ((funcall pattern-element datum-element) + (cons pattern-element datum-element)) + (t nil))) + +;;; Match-pattern matches a pattern against a datum, returning the +;;; pattern if successful and nil otherwise. + +(defun match-pattern (pattern datum datum-length) + (if (>= (length pattern) datum-length) + (let ((form-list nil)) + (do ((pattern pattern (cdr pattern)) + (datum datum (cdr datum))) + ((or (null pattern) (null datum)) + (cond ((and (null pattern) (null datum)) + (nreverse form-list)) + ((null pattern) nil) + ((null datum) (dolist (element pattern + (nreverse form-list)) + (if (not (listp element)) + (return nil)))))) + (let* ((pattern-element (car pattern)) + (datum-element (car datum)) + (optional (listp pattern-element)) + (matching (match-pattern-element (if optional + (car pattern-element) + pattern-element) + datum-element))) + (cond (matching (let ((form-type (car matching))) + (unless (or (eq form-type 'time-divider) + (eq form-type 'date-divider)) + (push matching form-list)))) + (optional (push datum-element datum)) + (t (return-from match-pattern nil)))))))) + +;;; Deal-with-noon-midn sets the decoded-time values to either noon +;;; or midnight depending on the argument form-value. Form-value +;;; can be either 'noon or 'midn. + +(defun deal-with-noon-midn (form-value parsed-values) + (cond ((eq form-value 'noon) + (setf (decoded-time-hour parsed-values) 12)) + ((eq form-value 'midn) + (setf (decoded-time-hour parsed-values) 0)) + (t (error "Unrecognized symbol: ~A" form-value))) + (setf (decoded-time-minute parsed-values) 0) + (setf (decoded-time-second parsed-values) 0)) + +;;; Deal-with-am-pm sets the decoded-time values to be in the am +;;; or pm depending on the argument form-value. Form-value can +;;; be either 'am or 'pm. + +(defun deal-with-am-pm (form-value parsed-values) + (let ((hour (decoded-time-hour parsed-values))) + (cond ((eq form-value 'am) + (cond ((eq hour 12) + (setf (decoded-time-hour parsed-values) 0)) + ((not (<= 0 hour 12)) + (if *error-on-mismatch* + (error "~D is not an AM hour, dummy." hour))))) + ((eq form-value 'pm) + (if (<= 0 hour 11) + (setf (decoded-time-hour parsed-values) + (mod (+ hour 12) 24)))) + (t (error "~A isn't AM/PM - this shouldn't happen." form-value))))) + +;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. +(defun deal-with-izone (form-value parsed-values) + (multiple-value-bind (hours mins) + (truncate form-value 100) + (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60)))))) + +;;; Set-time-values uses the association list of symbols and values +;;; to set the time in the decoded-time structure. + +(defun set-time-values (string-form parsed-values) + (dolist (form-part string-form t) + (let ((form-type (car form-part)) + (form-value (cdr form-part))) + (case form-type + (secondp (setf (decoded-time-second parsed-values) form-value)) + (minute (setf (decoded-time-minute parsed-values) form-value)) + (hour (setf (decoded-time-hour parsed-values) form-value)) + (day (setf (decoded-time-day parsed-values) form-value)) + (month (setf (decoded-time-month parsed-values) form-value)) + (year (setf (decoded-time-year parsed-values) form-value)) + (zone (setf (decoded-time-zone parsed-values) form-value)) + (izone (deal-with-izone form-value parsed-values)) + (weekday (setf (decoded-time-dotw parsed-values) form-value)) + (am-pm (deal-with-am-pm form-value parsed-values)) + (noon-midn (deal-with-noon-midn form-value parsed-values)) + (special (funcall form-value parsed-values)) + (t (error "Unrecognized symbol in form list: ~A." form-type)))))) + +(defun parse-time (time-string &key (start 0) (end (length time-string)) + (error-on-mismatch nil) + (patterns *default-date-time-patterns*) + (default-seconds nil) (default-minutes nil) + (default-hours nil) (default-day nil) + (default-month nil) (default-year nil) + (default-zone nil) (default-weekday nil)) + "Tries very hard to make sense out of the argument time-string and + returns a single integer representing the universal time if + successful. If not, it returns nil. If the :error-on-mismatch + keyword is true, parse-time will signal an error instead of + returning nil. Default values for each part of the time/date + can be specified by the appropriate :default- keyword. These + keywords can be given a numeric value or the keyword :current + to set them to the current value. The default-default values + are 00:00:00 on the current date, current time-zone." + (setq *error-on-mismatch* error-on-mismatch) + (let* ((string-parts (decompose-string time-string :start start :end end)) + (parts-length (length string-parts)) + (string-form (dolist (pattern patterns) + (let ((match-result (match-pattern pattern + string-parts + parts-length))) + (if match-result (return match-result)))))) + (if string-form + (let ((parsed-values (make-default-time default-seconds default-minutes + default-hours default-day + default-month default-year + default-zone default-weekday))) + (set-time-values string-form parsed-values) + (convert-to-unitime parsed-values)) + (if *error-on-mismatch* + (error "\"~A\" is not a recognized time/date format." time-string) + nil)))) + + Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp Sat Feb 2 17:54:13 2008 @@ -158,6 +158,8 @@ direct-slots)) (xml-direct (first xml-directs))) + ;; Commented out this check because I could not determine what it does and it warned me. + #+(or) (when (> (length xml-directs) 1) (dolist (slot-def (class-slots (class-of (first xml-directs)))) (unless (apply #'equal (mapcar #'(lambda (slot) (slot-value slot (slot-definition-name slot-def))) xml-directs)) Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Sat Feb 2 17:54:13 2008 @@ -94,7 +94,7 @@ "sessions" "site")) - (:file "templates" + (:file "template-handler" :depends-on ("handlers")) (:file "rss-handlers" :depends-on ("handlers")) @@ -106,7 +106,7 @@ (:file "tags" :depends-on ("handlers" - "templates" + "template-handler" "site" "web-utils"))) :depends-on ("sysclasses" "packages" "rss")) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Sat Feb 2 17:54:13 2008 @@ -270,6 +270,7 @@ #:find-template-pathname #:initial-template-environment #:with-tag-expanders + #:emit-tag-children #:*html-variables* #:*template-dtd-catalog* Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Sat Feb 2 17:54:13 2008 @@ -18,7 +18,8 @@ (emit-template-node toplevel))) (define-bknr-tag tag-body () - (mapc #'emit-template-node *toplevel-children*)) + (let ((*tag-children* *toplevel-children*)) + (emit-tag-children))) (define-bknr-tag redirect-request (&key target) (redirect target)) Copied: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (from r2434, branches/trunk-reorg/bknr/web/src/web/templates.lisp) ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Sat Feb 2 17:54:13 2008 @@ -6,16 +6,19 @@ (defvar *template-expander*) (defvar *template-env*) -(defvar *template-dtd-catalog* `(;; libxml standard - "/etc/xml/catalog" - ;; FreeBSD - "/usr/local/share/xml/catalog.ports")) +(defparameter *template-dtd-catalog* `(;; libxml standard + "/etc/xml/catalog" + ;; FreeBSD + "/usr/local/share/xml/catalog.ports" + "/usr/local/share/xml/catalog")) -#+cmu (eval-when (:load-toplevel :execute) (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG"))) (when env-catalog - (pushnew env-catalog *template-dtd-catalog* :test #'equal)))) + (pushnew env-catalog *template-dtd-catalog* :test #'equal))) + (setf cxml:*catalog* (cxml:make-catalog (remove-if-not #'probe-file *template-dtd-catalog*)) + cxml:*dtd-cache* (cxml:make-dtd-cache) + cxml:*cache-all-dtds* t)) ;; user-error is supposed to be raised when an error is provoked by ;; the user (i.e. by supplying invalid form data). @@ -37,10 +40,15 @@ (defclass template-expander () ((command-packages :initarg :command-packages :initform nil - :reader template-expander-command-packages))) + :reader template-expander-command-packages) + (destination :initarg :destination + :reader template-expander-destination) + (cached-templates :initform (make-hash-table :test 'equal) + :accessor template-expander-cached-templates))) (defmethod find-tag-function ((expander template-expander) name ns) - (let ((package-name (cdr (assoc (make-keyword-from-string ns) (template-expander-command-packages expander)))) + (let ((package-name (cdr (find ns (template-expander-command-packages expander) + :test #'equal :key #'car))) (function-name (string-upcase name))) (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*) (error "can't find package ~A in tag function registry" package-name))) @@ -100,23 +108,6 @@ (t (format nil "~A" val)))))) string)) -(defun emit-template (expander stream node env) - (let* ((*template-expander* expander) - (*template-env* env) - (sink (cxml:make-character-stream-sink stream :canonical nil)) - (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod))) - (if (node-attribute node "suppress-xml-headers") - (emit-template-node node) - (progn - (sax:start-document *html-sink*) - (sax:start-dtd *html-sink* - "html" - "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") - (sax:end-dtd *html-sink*) - (emit-template-node node))) - (sax:end-document *html-sink*))) - (defun xmls-attributes-to-sax (fn attrs) (mapcar (lambda (a) (destructuring-bind (name value) a @@ -131,55 +122,109 @@ :specified-p t)))) attrs)) -(defun emit-template-node (node) +(defun parse-template (template-pathname) + (let ((sax:*include-xmlns-attributes* t)) + (cxml:parse-file (namestring (probe-file template-pathname)) + (cxml-xmls:make-xmls-builder) + :validate nil))) + +(defvar *tag-children*) + +(defun emit-tag-children () + "Function to be called by application defined tags to emit their children." + (mapc (curry #'emit-template-node *template-expander*) *tag-children*)) + +(defun emit-template-node (expander node) (if (stringp node) (sax:characters *html-sink* (expand-variables node)) (let* ((name (node-name node)) (ns (node-ns node)) (children (node-children node)) (attrs (cxml-xmls:node-attrs node))) - ;; XML-technisch waere es korrekter, nicht auf das Praefix zu gucken, - ;; sondern auf die Namespace-URI. (cond - ((and ns - (not (find #\: ns))) - (apply (find-tag-function *template-expander* name ns) - (append (loop for (key name) in (remove-if #'(lambda (attr) (scan "^xmlns" (car attr))) attrs) - collect (make-keyword-from-string key) - collect (expand-variables name)) - (when children - (list :children children))))) + ((find ns (template-expander-command-packages expander) + :test #'equal :key #'car) + (let ((*tag-children* children)) + (apply (find-tag-function expander name ns) + (append (loop for (key name) in attrs + collect (make-keyword-from-string key) + collect (expand-variables name)))))) (t (sax:start-element *html-sink* nil nil name (xmls-attributes-to-sax #'expand-variables attrs)) (dolist (child children) - (emit-template-node child)) + (emit-template-node expander child)) (sax:end-element *html-sink* nil nil name)))))) +(defun emit-parsed-template (expander toplevel) + "Emit the given XMLS compatible structure as XML to *HTML-SINK*." + ;; In order to generate xmlns attributes, we use the internal + ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function. This may need to + ;; be revised with newer cxml releases. + (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel) + (cxml-xmls::compute-attributes/lnames toplevel t)) + (let ((*template-expander* expander)) + (mapc (curry #'emit-template-node expander) (node-children toplevel))) + (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel))) + +(defun find-template (dir components) + (if (null components) + nil + (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components))) + dir))) + (when (probe-file next-dir) + (let ((result (multiple-value-list (find-template next-dir (cdr components))))) + (when (car result) + (return-from find-template (values-list result))))) + (let ((file (merge-pathnames (make-pathname :type "xml" + :name (first components)) + dir))) + (when (probe-file file) + (values file (cdr components))))))) + +(defmethod find-template-pathname ((expander template-expander) template-name) + (let ((components (remove "" (split "/" template-name) :test #'equal))) + (multiple-value-bind (pathname ret-components) + (find-template (template-expander-destination expander) components) + (unless pathname + (template-not-found template-name)) + (values pathname + ret-components + (with-output-to-string (s) + (dolist (component (subseq components 0 (- (length components) + (length ret-components)))) + (write-char #\/ s) + (write-string component s))))))) + +(defun get-cached-template (pathname expander) + (let* ((table (template-expander-cached-templates expander)) + (namestring (namestring pathname)) + (cache-entry (gethash namestring table)) + (current-write-date (file-write-date namestring))) + (unless (and cache-entry (eql (car cache-entry) current-write-date)) + (setf cache-entry + (cons current-write-date (parse-template pathname))) + (setf (gethash namestring table) cache-entry)) + (cdr cache-entry))) + +(defun emit-template (expander stream node env) + (let* ((*template-env* env) + (*html-sink* (cxml:make-character-stream-sink stream :canonical nil))) + (if (node-attribute node "suppress-xml-headers") + (emit-parsed-template expander node) + (progn + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd *html-sink*) + (emit-parsed-template expander node))) + (sax:end-document *html-sink*))) ;; template handler (defclass template-handler (prefix-handler template-expander) - ((destination :initarg :destination - :reader template-handler-destination) - (cached-templates :initform (make-hash-table :test 'equal) - :accessor template-handler-cached-templates) - (dtd-cache :initform (cxml:make-dtd-cache) - :reader template-handler-dtd-cache) - (catalog :initform (cxml:make-catalog *template-dtd-catalog*) - :reader template-handler-catalog))) - -(defconstant +max-template-expansions-per-request+ 100 - "Maximum number of template expansions in one template request (circular dependency safeguard") - -(defun parse-template (handler template-pathname) - (let ((cxml:*dtd-cache* (template-handler-dtd-cache handler)) - (cxml:*cache-all-dtds* t) - (cxml:*catalog* (template-handler-catalog handler)) - (sax:*include-xmlns-attributes* t)) - (cxml:parse-file (namestring (probe-file template-pathname)) - (cxml:make-recoder (cxml-xmls:make-xmls-builder) - #'cxml::rod-to-utf8-string) - :validate nil))) + ()) (defmethod expand-template ((handler template-handler) template-name &key env) @@ -216,46 +261,6 @@ env))) (template-not-found template-pathname)))) -(defun find-template (dir components) - (if (null components) - nil - (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components))) - dir))) - (when (probe-file next-dir) - (let ((result (multiple-value-list (find-template next-dir (cdr components))))) - (when (car result) - (return-from find-template (values-list result))))) - (let ((file (merge-pathnames (make-pathname :type "xml" - :name (first components)) - dir))) - (when (probe-file file) - (values file (cdr components))))))) - -(defmethod find-template-pathname ((handler template-handler) template-name) - (let ((components (remove "" (split "/" template-name) :test #'equal))) - (multiple-value-bind (pathname ret-components) - (find-template (template-handler-destination handler) components) - (unless pathname - (template-not-found template-name)) - (values pathname - ret-components - (with-output-to-string (s) - (dolist (component (subseq components 0 (- (length components) - (length ret-components)))) - (write-char #\/ s) - (write-string component s))))))) - -(defun get-cached-template (pathname handler) - (let* ((table (template-handler-cached-templates handler)) - (namestring (namestring pathname)) - (cache-entry (gethash namestring table)) - (current-write-date (file-write-date namestring))) - (unless (and cache-entry (eql (car cache-entry) current-write-date)) - (setf cache-entry - (cons current-write-date (parse-template handler pathname))) - (setf (gethash namestring table) cache-entry)) - (cdr cache-entry))) - (defun send-error-response (handler message &key (response-code +http-internal-server-error+)) (with-http-response (:content-type "text/html; charset=UTF-8" :response response-code) Modified: branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp Sat Feb 2 17:54:13 2008 @@ -31,7 +31,7 @@ ()) (defmethod authorized-p ((handler boi-handler)) - (let ((user (bknr-request-user))) + (let ((user (bknr-session-user))) (or (admin-p user) (user-has-flag user :boi)))) @@ -91,7 +91,7 @@ (with-transaction (:contract-paid) (contract-set-paidp contract (format nil "~A: manually set paid by ~A" (format-date-time) - (user-login (bknr-request-user)))) + (user-login (bknr-session-user)))) (when name (setf (user-full-name (contract-sponsor contract)) name)))) (with-xml-response () Modified: branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp Sat Feb 2 17:54:13 2008 @@ -96,7 +96,7 @@ (contract (make-contract sponsor (parse-integer numsqm) :paidp (format nil "~A: manually created by ~A" (format-date-time (get-universal-time)) - (user-login (bknr-request-user))) + (user-login (bknr-session-user))) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) (mail-backoffice-sponsor-data contract) @@ -223,7 +223,7 @@ (html (:h2 "Completing square meter sale")) (sponsor-set-country (contract-sponsor contract) country) (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A" - (format-date-time) (user-login (bknr-request-user)))) + (format-date-time) (user-login (bknr-session-user)))) (when email (html (:p "Sending instruction email to " (:princ-safe email))) (mail-instructions-to-sponsor contract email)))) @@ -243,8 +243,8 @@ (sponsor-id-or-x (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor)) (t - (when (eq (find-class 'sponsor) (class-of (bknr-request-user))) - (bknr-request-user)))))) + (when (eq (find-class 'sponsor) (class-of (bknr-session-user))) + (bknr-session-user)))))) (with-http-response (:content-type "text/html; charset=UTF-8") (with-http-body () (let ((*standard-output* *html-stream*)) @@ -265,7 +265,7 @@ (with-http-body () (format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%" (cond - ((eq (find-class 'sponsor) (class-of (bknr-request-user))) + ((eq (find-class 'sponsor) (class-of (bknr-session-user))) "logged-in") (__sponsorid "login-failed") Modified: branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp Sat Feb 2 17:54:13 2008 @@ -24,7 +24,7 @@ (define-bknr-tag worldpay-receipt () (emit-without-quoting "<WPDISPLAY ITEM=banner>")) -(define-bknr-tag process-payment (&key children) +(define-bknr-tag process-payment () (with-template-vars (cartId transId email country) (let* ((contract (get-contract (parse-integer cartId))) (sponsor (contract-sponsor contract))) @@ -34,7 +34,7 @@ (contract-set-paidp contract (format nil "~A: paid via worldpay" (format-date-time))) (setf (get-template-var :master-code) (sponsor-master-code sponsor)) (setf (get-template-var :sponsor-id) (sponsor-id sponsor)))) - (mapc #'emit-template-node children)) + (emit-tag-children)) (define-bknr-tag generate-cert () (with-template-vars (gift email name address) @@ -106,7 +106,7 @@ (if donationcert-yearly "1" "0") (if gift "1" "0") (when *worldpay-test-mode* "&testMode=100")))))) - (mapc #'emit-template-node children))) + (emit-tag-children))) (define-bknr-tag mail-transfer () (with-query-params ((get-template-var :request) @@ -126,16 +126,16 @@ :language (session-variable :language)) (mail-manual-sponsor-data (get-template-var :request))))) -(define-bknr-tag when-certificate (&key children) +(define-bknr-tag when-certificate () (let ((sponsor (bknr-request-user (get-template-var :request)))) (when (some #'contract-pdf-pathname (sponsor-contracts sponsor)) - (mapc #'emit-template-node children)))) + (emit-tag-children)))) -(define-bknr-tag send-info-request (&key children email) +(define-bknr-tag send-info-request (&key email) (mail-info-request email) - (mapc #'emit-template-node children)) + (emit-tag-children)) -(define-bknr-tag save-profile (&key children) +(define-bknr-tag save-profile () (let ((sponsor (bknr-request-user (get-template-var :request)))) (with-template-vars (email name password infotext anonymize) (when anonymize @@ -144,7 +144,7 @@ 'info-text nil 'email nil)) (when name - (change-slot-values sponsor 'full-name name)) + (change-sLot-values sponsor 'full-name name)) (when email (change-slot-values sponsor 'bknr.web::email email)) (when password @@ -160,9 +160,9 @@ (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor)))))) - (mapc #'emit-template-node children)) + (emit-tag-children)) -(define-bknr-tag admin-login-page (&key children) +(define-bknr-tag admin-login-page () (if (admin-p (bknr-request-user (get-template-var :request))) (html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin")))) - (mapc #'emit-template-node children))) \ No newline at end of file + (emit-tag-children))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp Sat Feb 2 17:54:13 2008 @@ -27,8 +27,8 @@ ((:p :class "footer") "local time is " (:princ-safe (format-date-time)) " - " - (if (bknr-request-user) - (html "logged in as " (html-link (bknr-request-user))) + (if (bknr-session-user) + (html "logged in as " (html-link (bknr-session-user))) (html "not logged in")) " - current content language is " (cmslink "change-language" Modified: branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp Sat Feb 2 17:54:13 2008 @@ -112,7 +112,7 @@ (defmethod handle-object ((handler certificate-handler) contract) (unless contract - (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user))))) + (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-session-user))))) (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)))) (defclass statistics-handler (admin-only-handler prefix-handler) Modified: branches/trunk-reorg/projects/eboy/src/item-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/item-handlers.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/item-handlers.lisp Sat Feb 2 17:54:13 2008 @@ -77,7 +77,7 @@ :confirm "Really delete item?"))))))) (defmethod authorized-p ((handler edit-item-handler)) - (admin-p (bknr-request-user))) + (admin-p (bknr-session-user))) (defmethod handle-object-form ((handler edit-item-handler) action item) Modified: branches/trunk-reorg/projects/gpn/gpn-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/gpn-tags.lisp (original) +++ branches/trunk-reorg/projects/gpn/gpn-tags.lisp Sat Feb 2 17:54:13 2008 @@ -32,14 +32,14 @@ ((:a :class "headlink" :href (second button)) (:princ-safe (first button)))))) (html (:td)))) - (if (eql (find-user "anonymous") (bknr-request-user)) + (if (eql (find-user "anonymous") (bknr-session-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/login") "LOGIN"))) (html ((:td :class "headbar") ((:a :class "headlogin" :href (format nil "/gpn-user/~a" - (user-login (bknr-request-user)))) + (user-login (bknr-session-user)))) "HOME")) - (when (admin-p (bknr-request-user)) + (when (admin-p (bknr-session-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/admin") "ADMIN")))) ((:td :class "headbar") @@ -71,7 +71,7 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time item) :show-weekday t)) - (when (equal (article-author item) (bknr-request-user)) + (when (equal (article-author item) (bknr-session-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id item))) " (edit)"))) )))) (html ((:a :class "rss" :href (format nil "~a/~a" (handler-url :blog-rss) @@ -154,7 +154,7 @@ (when email (html ((:div :class "email") "EMAIL: " (:princ-safe (string-upcase (user-email user)))))))) - (when (string-equal (user-login user) (user-login (bknr-request-user))) + (when (string-equal (user-login user) (user-login (bknr-session-user))) (html ((:div :class "user-edit") ((:p :class "news") "Zum Importieren von Bildern zuerst die Bilder auf ftp://fiep/ hochladen, @@ -278,11 +278,11 @@ (define-bknr-tag logged-in () (html ((:div :class "logged-in") "logged in as " - (if (string-equal (user-login (bknr-request-user)) "anonymous") + (if (string-equal (user-login (bknr-session-user)) "anonymous") (html "anonymous") (html ((:a :style "color:#cc3333;" - :href (format nil "/gpn-user/~a" (user-login (bknr-request-user)))) - (:princ-safe (user-login (bknr-request-user))))))))) + :href (format nil "/gpn-user/~a" (user-login (bknr-session-user)))) + (:princ-safe (user-login (bknr-session-user))))))))) (define-bknr-tag gpn-fahrplan (&key location) (let ((events (sort (remove-if #'(lambda (event) (< (zeitplan-event-end-time event) (get-universal-time))) @@ -414,5 +414,5 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time article) :show-weekday t)) - (when (equal (article-author article) (bknr-request-user)) + (when (equal (article-author article) (bknr-session-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id article))) " (edit)")))))))))) Modified: branches/trunk-reorg/projects/gpn/import-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/import-handler.lisp (original) +++ branches/trunk-reorg/projects/gpn/import-handler.lisp Sat Feb 2 17:54:13 2008 @@ -6,7 +6,7 @@ ()) (defmethod import-handler-import-pathname ((handler gpn-import-handler)) - (let* ((user (bknr-request-user)) + (let* ((user (bknr-session-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user) "images")) @@ -34,7 +34,7 @@ (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (spool-dir (import-handler-import-pathname handler))) (import-directory spool-dir - :user (bknr-request-user) + :user (bknr-session-user) :keywords (when (admin-p *user*) keywords) :spool (import-handler-spool-dir handler) :keywords-from-dir (if (admin-p *user*) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp Sat Feb 2 17:54:13 2008 @@ -7,7 +7,7 @@ (when (probe-file "site.lisp") (load "site.lisp"))) -(defparameter *root-directory* #p"home:bknr-svn/projects/lisp-ecoop/") +(defparameter *root-directory* (merge-pathnames #P"../" *load-pathname*)) (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp Sat Feb 2 17:54:13 2008 @@ -5,8 +5,8 @@ (defun format-object-id (format object &rest args) (apply #'format nil format (store-object-id object) args)) -(defmacro with-lisp-ecoop-page ((req title) &body body) - `(with-bknr-page (,req :title ,title) +(defmacro with-lisp-ecoop-page ((title) &body body) + `(with-bknr-page (:title ,title) ,@body)) (defclass edit-participant-handler (edit-object-handler) @@ -14,7 +14,7 @@ (:default-initargs :class 'participant :query-function #'find-user)) (defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant)) - (with-lisp-ecoop-page (req #?"Edit participant $((user-login participant))") + (with-lisp-ecoop-page (#?"Edit participant $((user-login participant))") ((:form :method "post" :enctype "multipart/form-data") ((:table :border "1") (:tr (:th "Login") @@ -29,7 +29,7 @@ (defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant)) (participant-reset-password participant) - (with-lisp-ecoop-page (req "Password reset") + (with-lisp-ecoop-page ("Password reset") "The participant's password has been reset and sent by mail")) (defclass pdf-handler (object-handler) @@ -39,7 +39,7 @@ (defmethod handle-object ((handler pdf-handler) (document document)) (let ((pdf (file-contents (blob-pathname document)))) (with-http-response (:content-type "application/pdf") - (setf (request-reply-content-length) (length pdf)) + (setf (content-length) (length pdf)) (with-http-body (:external-format '(unsigned-byte 8)) (write-sequence pdf *html-stream*))))) @@ -49,7 +49,7 @@ (defmethod handle ((handler make-submission-handler)) (with-query-params (type title abstract) (let ((submission (make-object (if (string-equal type "paper") 'paper 'breakout-group-proposal) :title title :abstract abstract))) - (with-lisp-ecoop-page (req #?"Submission created") + (with-lisp-ecoop-page (#?"Submission created") (html ((:script :type "text/javascript") (:princ-safe #?" if (window.opener) { @@ -80,7 +80,9 @@ (let ((document (make-object 'document :info info :submission submission))) (blob-from-file document file-name) (redirect (format-object-id "/upload/~A?success=1" submission))) - (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file"))))))))) + (redirect (format-object-id "/upload/~A?failure=~A" + submission + (url-encode "Uploaded file does not appear to be a PDF file"))))))))) (:get (redirect (format-object-id "/upload/~A" submission))))) @@ -97,7 +99,7 @@ ()) (defmethod handle ((handler page-handler)) - (with-lisp-ecoop-page (req "LISP-ECOOP Administration") + (with-lisp-ecoop-page ("LISP-ECOOP Administration") "Please choose an administrative task from the menu")) (define-bknr-webserver-module participants Modified: branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp Sat Feb 2 17:54:13 2008 @@ -13,6 +13,9 @@ (make-user "admin" :password "wispleb" :full-name "Administrator" :flags '(:admin)) (import-image "bknr-logo.png" :keywords '(:banner :bknr))) + #+(or) (bknr.cron:start-cron) - (publish-lisp-ecoop)) + (publish-lisp-ecoop) + + (start-webserver)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd Sat Feb 2 17:54:13 2008 @@ -18,20 +18,17 @@ :depends-on (:bknr-datastore :bknr-web + :closer-mop + :cl-smtp :cxml) :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "macros" :depends-on ("config")) - #+(or) (:file "schedule" :depends-on ("macros")) - #+(or) (:file "participant" :depends-on ("macros" "schedule")) - #+(or) (:file "mail" :depends-on ("participant")) - #+(or) (:file "tags" :depends-on ("participant")) - #+(or) (:file "handlers" :depends-on ("participant")) - (:file "webserver" :depends-on (#+(or) "handlers")) + (:file "webserver" :depends-on ("handlers")) (:file "init" :depends-on ("webserver")))) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp Sat Feb 2 17:54:13 2008 @@ -3,7 +3,8 @@ (asdf:oos 'asdf:load-op :lisp-ecoop) (asdf:oos 'asdf:load-op :swank) -(swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t) +(swank::create-server :port 4005) (lisp-ecoop::startup) +#+cmu (mp::startup-idle-and-top-level-loops) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp Sat Feb 2 17:54:13 2008 @@ -29,13 +29,13 @@ access slot class))) (cons name rest)))) -(defmacro define-lisp-ecoop-class (class (&rest superclasses) slots &rest class-options) +(defmacro define-lisp-ecoop-class (class-name (&rest superclasses) slots &rest class-options) (let ((superclasses (or superclasses '(store-object))) - (slots (mapcar #'(lambda (slot) (compute-slot class slot)) + (slots (mapcar #'(lambda (slot) (compute-slot class-name slot)) slots))) ;; the eval-when is there to create the index access functions at compile time `(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ,class ,superclasses + (defclass ,class-name ,superclasses ((bknr.datastore::id :attribute t) ,@slots) (:metaclass persistent-xml-class) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp Sat Feb 2 17:54:13 2008 @@ -77,5 +77,4 @@ :xhtml-generator :lisp-ecoop.config :lisp-ecoop) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:export #:hello)) \ No newline at end of file + (:shadowing-import-from :cl-interpol #:quote-meta-chars)) \ No newline at end of file Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp Sat Feb 2 17:54:13 2008 @@ -16,7 +16,7 @@ (with-slots (documents) submission (setf documents (remove document documents))))) -(define-lisp-ecoop-class submission () +y(define-lisp-ecoop-class submission () ((title :update :documentation "Title of the submission" :initform nil :attribute t) (abstract :update :documentation "Abstract or short description" :initform nil :element t) (submitters :update :documentation "List of participants who submitted this" :initform nil :element t :containment :+) @@ -38,8 +38,8 @@ "Generic submission") (defun submission-edit-permitted-p (submission) - (or (admin-p (bknr-request-user)) - (find (bknr-request-user) (submission-submitters submission)))) + (or (admin-p (bknr-session-user)) + (find (bknr-session-user) (submission-submitters submission)))) (defmethod submission-add-submitter ((submission submission) submitter) (pushnew submitter (submission-submitters submission)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp Sat Feb 2 17:54:13 2008 @@ -83,7 +83,7 @@ ("/schedule" schedule-handler) ("/edit-timeslot" edit-timeslot-handler)) -(defun show-day-schedule (&key day children) +(defun show-day-schedule (&key day) (let* ((begin (parse-time-spec day)) (end (+ begin (* 24 60 60)))) (labels ((timeslot-wanted (timeslot) @@ -93,15 +93,15 @@ #'< :key #'timeslot-begin-time)) (with-tag-expanders ((time () - (if (admin-p (bknr-request-user)) + (if (admin-p (bknr-session-user)) (html ((:a :href #?"/edit-timeslot/$((store-object-id timeslot))") (:princ-safe (timeslot-time-string timeslot)))) (html (:princ-safe (timeslot-time-string timeslot))))) (content () (print-object-as-html (timeslot-content timeslot)))) - (mapc #'emit-template-node children)))))) + (emit-tag-children)))))) (in-package :lisp-ecoop.tags) -(define-bknr-tag show-day-schedule (&key day children) - (lisp-ecoop::show-day-schedule :day day :children children)) +(define-bknr-tag show-day-schedule (&key day) + (lisp-ecoop::show-day-schedule :day day)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp Sat Feb 2 17:54:13 2008 @@ -3,7 +3,7 @@ (enable-interpol-syntax) (defun object-to-template-vars (object) - (dolist (slot-name (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object)))) + (dolist (slot-name (mapcar #'closer-mop:slot-definition-name (closer-mop:class-slots (class-of object)))) (when (and (slot-boundp object slot-name) (slot-value object slot-name)) (setf (get-template-var (make-keyword-from-string (symbol-name slot-name))) @@ -20,16 +20,16 @@ (if (parse-integer key :junk-allowed t) (find-store-object (parse-integer key :junk-allowed t)) (find-user key)) - (bknr-request-user)))) + (bknr-session-user)))) -(define-bknr-tag profile-editor (&key children) - (when (anonymous-p (bknr-request-user)) +(define-bknr-tag profile-editor () + (when (anonymous-p (bknr-session-user)) (warn "User not logged in") (html (:h2 "Please log in to edit the profile")) (return-from profile-editor)) (let ((participant (participant-from-request))) - (unless (or (admin-p (bknr-request-user)) - (eq participant (bknr-request-user))) + (unless (or (admin-p (bknr-session-user)) + (eq participant (bknr-session-user))) (html (:h2 "can't edit this profile")) (return-from profile-editor)) (when (eq :post (request-method)) @@ -91,7 +91,7 @@ (setf (participant-text participant) text))))) (object-to-template-vars participant) (let ((*participant* participant)) - (mapc #'emit-template-node children)))) + (emit-tag-children)))) (defun document-file-info (document) (with-open-file (document-file (blob-pathname document)) @@ -104,7 +104,7 @@ (defun submission-from-request () (find-store-object (parse-integer (get-template-var :*path-arg*)))) -(define-bknr-tag submission-editor (&key children) +(define-bknr-tag submission-editor () (let ((submission (submission-from-request))) (unless submission (html (:h2 "Invalid submission ID")) @@ -143,10 +143,10 @@ (setf (submission-abstract submission) abstract))))) (object-to-template-vars submission) (let ((*submission* submission)) - (mapc #'emit-template-node children)))) + (emit-tag-children)))) -(define-bknr-tag add-participant (&key children) - (unless (admin-p (bknr-request-user)) +(define-bknr-tag add-participant () + (unless (admin-p (bknr-session-user)) (html "You must be logged in as adminstrator to create new participants") (return-from add-participant)) (with-query-params (action) @@ -159,7 +159,7 @@ (make-participant login :full-name full-name :email email :text text :submission submission) (html (:princ-safe #?"The participant $(login) has been created in the database and a welcome mail has been sent."))))) - (mapc #'emit-template-node children)) + (emit-tag-children)) (define-bknr-tag submission-option-list () (dolist (submission (sort (copy-list (class-instances 'submission)) @@ -193,14 +193,14 @@ (:ul (dolist (participant (set-difference (class-instances 'participant) submitters)) (html (:li ((:a :href (format nil "~A?add-submitter-id=~A" - (puri:uri-path (request-uri)) + (script-name) (store-object-id participant))) (:princ-safe (user-full-name participant))))))))) (remove-submitter (html (:strong "Remove Submitter") (:ul (dolist (participant submitters) - (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri)) (store-object-id participant))) + (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (script-name) (store-object-id participant))) (:princ-safe (user-full-name participant)))))))))))))) (define-bknr-tag submission-uploader () @@ -252,27 +252,27 @@ (html ((:img :src (format-object-id "/image/~A/cell" image))))) (:span ((:a :href (format-object-id "/profile/~A" participant)) (:princ-safe (user-full-name participant))) - (when (or (eq participant (bknr-request-user)) - (admin-p (bknr-request-user))) + (when (or (eq participant (bknr-session-user)) + (admin-p (bknr-session-user))) (html " " ((:a :href (format-object-id "/edit-profile/~A" participant)) "[Edit]"))))))))) -(define-bknr-tag participants-only (&key children error) - (if (participant-p (bknr-request-user)) - (mapc #'emit-template-node children) +(define-bknr-tag participants-only (&key error) + (if (participant-p (bknr-session-user)) + (emit-tag-children) (when error (html (:princ-safe error))))) -(define-bknr-tag admin-only (&key children error) - (if (admin-p (bknr-request-user)) - (mapc #'emit-template-node children) +(define-bknr-tag admin-only (&key error) + (if (admin-p (bknr-session-user)) + (emit-tag-children) (when error (html (:princ-safe error))))) -(define-bknr-tag profile (&key children) +(define-bknr-tag profile () (let* ((participant (participant-from-request))) (object-to-template-vars participant) (let ((*participant* participant)) - (mapc #'emit-template-node children)))) + (emit-tag-children)))) (define-bknr-tag participant-picture-image (&key (width 20) (height 20)) (when (participant-picture *participant*) @@ -287,7 +287,7 @@ (html "[no submission]"))) (define-bknr-tag login-widget () - (let ((user (bknr-request-user))) + (let ((user (bknr-session-user))) (cond ((anonymous-p user) (html ((:form :method "post") @@ -300,15 +300,15 @@ ((:button :type "submit" :name "action" :value "login") "login")))) (t (html ((:form :method "post" :action (website-make-path *website* "logout")) - ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri)))) + ((:input :type "hidden" :name "url" :value (script-name))) (:div "Logged in as " :br ((:a :href (format-object-id "/edit-profile/~A" user)) (:princ-safe (user-full-name user)))) (:div ((:button :type "submit" :name "action" :value "logout") "logout")))))))) -(define-bknr-tag admin-only (&key children) - (when (admin-p (bknr-request-user)) - (mapc #'emit-template-node children))) +(define-bknr-tag admin-only () + (when (admin-p (bknr-session-user)) + (emit-tag-children))) (defun parse-duration (string) (ignore-errors @@ -318,7 +318,7 @@ (define-bknr-tag schedule-submission () (when (eq :post (request-method)) (with-query-params (date time duration submission freetext) - (let ((start (ext:parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone + (let ((start (parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone (duration (parse-duration duration)) (submission (ignore-errors (store-object-with-id (parse-integer submission :junk-allowed t))))) (cond @@ -380,17 +380,17 @@ (html (:li ((:a :href (format-object-id "/pdf/~A" document) :target "_new") (:princ-safe (document-info document)) " " (:princ-safe (document-file-info document))))))))) -(define-bknr-tag load-argument-object (&key children) +(define-bknr-tag load-argument-object () (let* ((object (object-from-request))) (object-to-template-vars object) (setf (get-template-var :object-id) (store-object-id object)) - (mapc #'emit-template-node children))) + (emit-tag-children))) -(define-bknr-tag page (&key children name) +(define-bknr-tag page (&key name) (setf (get-template-var :title) name) (setf (get-template-var :base) (website-base-href *website*)) (let* ((expander bknr.web::*template-expander*) (pathname (find-template-pathname expander "toplevel")) (toplevel (bknr.web::get-cached-template pathname expander)) - (bknr.web::*toplevel-children* children)) + (bknr.web::*toplevel-children* bknr.web::*tag-children*)) (emit-template-node toplevel))) \ No newline at end of file Modified: branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp Sat Feb 2 17:54:13 2008 @@ -9,8 +9,7 @@ (defun make-daily-statistics () (bknr.stats::make-yesterdays-stats :delete-events t :remove-referer-hosts '("lisp-ecoop.bknr.net"))) -#+(or) -(defun publish-lisp-ecoop (&key (port *webserver-port*) (listeners 20) (base-href *base-path*)) +(defun publish-lisp-ecoop (&key (base-href *base-path*)) (unless (bknr.cron:cron-job-with-name "daily webserver statistics") (bknr.cron:make-cron-job "daily webserver statistics" 'make-daily-statistics @@ -23,24 +22,23 @@ :template-command-packages '((:lisp-ecoop . :lisp-ecoop.tags) (:bknr . :bknr.web) (:menu . :bknr.site-menu)) - :handler-definitions `(("/" redirect-handler + :handler-definitions `(user images + #+(or) stats + #+(or) mailinglist + #+(or) mailinglist-registration + participants schedule + ("/" redirect-handler :to "home") ("/static" directory-handler - :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*)))) - :modules '(user images stats mailinglist mailinglist-registration participants schedule) - + :destination ,(probe-file (merge-pathnames #p"static/" *website-directory*)))) :admin-navigation nil :authorizer (make-instance 'bknr-authorizer) :style-sheet-urls (list (format nil "~Astatic/styles.css" base-href)) - :javascript-urls (list (format nil "~Astatic/javascript.js" base-href))) - - (start :port port :listeners listeners)) + :javascript-urls (list (format nil "~Astatic/javascript.js" base-href)))) (defun start-webserver (&key (port 9000)) (when (and (boundp '*server*) *server*) (stop-server *server*)) - (setq *dispatch-table* - (list 'dispatch-easy-handlers - (create-folder-dispatcher-and-handler "/" *website-directory*))) + (publish-lisp-ecoop) (setq *server* (start-server :port port))) \ No newline at end of file Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp Sat Feb 2 17:54:13 2008 @@ -1,4 +1,7 @@ (in-package :quickhoney.tags) -(define-bknr-tag version-and-last-change () - (html "v1.0 | updated " (:princ-safe (string-downcase (substitute #\Space #\- (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) \ No newline at end of file +(define-bknr-tag version-and-last-change (&rest args) + (format *debug-io* "hello world: ~A~%" args) + (html "v1.1 | updated " (:princ-safe (string-downcase + (substitute #\Space #\- + (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) \ No newline at end of file Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Sat Feb 2 17:54:13 2008 @@ -42,8 +42,8 @@ :content-type "application/x-icon") ("/" template-handler :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) - :command-packages ((:quickhoney . :quickhoney.tags) - (:bknr . :bknr.web)))) + :command-packages (("http://quickhoney.com/" . :quickhoney.tags) + ("http://bknr.net/" . :bknr.web)))) :admin-navigation '(("user" . "/user/") ("images" . "/edit-images") ("import" . "/import") Modified: branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml (original) +++ branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml Sat Feb 2 17:54:13 2008 @@ -8,8 +8,7 @@ > <head> <link rel="stylesheet" href="/static/styles.css" /> - <link rel="alternate" type="application/rss+xml" title="RSS Feed" - href="http://quickhoney.com/rss/quickhoney" /> + <link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/quickhoney" /> <script src="/static/javascript.js" type="text/javascript"> </script> <title>QuickHoney - Nana Rausch + Peter Stemmler</title> Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml (original) +++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Sat Feb 2 17:54:13 2008 @@ -3,8 +3,8 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" - xmlns:bknr="http://bknr.net" - xmlns:quickhoney="http://quickhoney.com" + xmlns:bknr="http://bknr.net/" + xmlns:quickhoney="http://quickhoney.com/" > <head> <link rel="stylesheet" href="/static/styles.css" /> @@ -35,7 +35,7 @@ </a> <p id="path" class="text"> </p> - <p id="version" class="text"><quickhoney:version-and-last-change /></p> + <p id="version" class="text"><quickhoney:version-and-last-change foo="1" bar="2" /></p> <div id="elements"> <div id="quickhoney"> Modified: branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp ============================================================================== --- branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp (original) +++ branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp Sat Feb 2 17:54:13 2008 @@ -35,7 +35,7 @@ (defmethod authorized-p ((handler saugnapf-track-handler)) (let* ((track (object-handler-get-object handler)) - (user (bknr-request-user)) + (user (bknr-session-user)) (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p user) nil) @@ -82,7 +82,7 @@ :artist artist :description description :url url - :submitter (bknr-request-user) + :submitter (bknr-session-user) :date (get-universal-time)))) (redirect (edit-object-url track))))) Modified: branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp (original) +++ branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp Sat Feb 2 17:54:13 2008 @@ -244,5 +244,6 @@ (defun reload () (cffi:load-foreign-library 'libssl) (cffi:load-foreign-library 'libeay32) + (cffi:load-foreign-library 'libcrypto) (setf *ssl-global-context* nil) (setf *ssl-global-method* nil)) Modified: branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp (original) +++ branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp Sat Feb 2 17:54:13 2008 @@ -27,3 +27,8 @@ (:windows "libeay32.dll")) (cffi:use-foreign-library libeay32) + +(cffi:define-foreign-library libcrypto + #+freebsd (:unix "libcrypto.so")) + +(cffi:use-foreign-library libcrypto) \ No newline at end of file

1 0

[bknr-cvs] r2437 - in branches/trunk-reorg/projects/quickhoney/website: static templates
by hhubner＠common-lisp.net 01 Feb '08

01 Feb '08

Author: hhubner Date: Fri Feb 1 07:01:51 2008 New Revision: 2437 Modified: branches/trunk-reorg/projects/quickhoney/website/static/javascript.js branches/trunk-reorg/projects/quickhoney/website/static/styles.css branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Log: Fix navigation - This was very simple, and I really regret that using achors to store navigation information had not occured to me two years ago. One can now deep link into the Quickhoney site, a feature that is used by the RSS feed. Also, inner-site navigation updates the anchor now, making it possible to store links to anything. Modified: branches/trunk-reorg/projects/quickhoney/website/static/javascript.js ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/static/javascript.js (original) +++ branches/trunk-reorg/projects/quickhoney/website/static/javascript.js Fri Feb 1 07:01:51 2008 @@ -531,14 +531,14 @@ if (current_directory) { if (current_subdirectory) { - path_links[0] = '<a href="#" onclick="show_page(' + "'" + current_directory + "'" + ');">' + current_directory + '</a>'; + path_links[0] = '<a href="#' + current_directory + '" onclick="show_page(' + "'" + current_directory + "'" + ');">' + current_directory + '</a>'; } else { path_links[0] = current_directory; } } if (current_subdirectory) { if (current_image) { - path_links[1] = '<a href="#" onclick="subdirectory(' + "'" + current_subdirectory + "'" + ');">' + current_subdirectory + '</a>'; + path_links[1] = '<a href="#' + current_directory + "/" + current_subdirectory + '" onclick="subdirectory(' + "'" + current_subdirectory + "'" + ');">' + current_subdirectory + '</a>'; } else { path_links[1] = current_subdirectory; } @@ -646,6 +646,7 @@ } else { buttons[i].style.visibility = 'hidden'; buttons[i].src = new_image; + buttons[i].parentNode.href = '#' + current_directory + '/' + subdirectory_name; eval("button_links[i].onclick = function onclick(event) { subdirectory('" + subdirectory_name + "'); }"); } } @@ -734,13 +735,16 @@ if (query_result_pages.length > 1) { if (current_page > 0) { - push(result_links, '<a href="#" onclick="goto_page(' + (current_page - 1) + ');"><<</a>'); + push(result_links, + '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page - 1) + + '" onclick="goto_page(' + (current_page - 1) + ');"><<</a>'); } else { push(result_links, '<<'); } var last_page = position_to_page(query_result.length - 1); if (current_page < last_page) { - push(result_links, '<a href="#" onclick="goto_page(' + (current_page + 1).toString() + ');">>></a>'); + push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() + + '" onclick="goto_page(' + (current_page + 1).toString() + ');">>></a>'); } else { push(result_links, '>>'); } @@ -764,7 +768,8 @@ if (page_number == current_page) { push(result_links, (page_number + 1).toString()); } else { - push(result_links, '<a href="#" onclick="goto_page(' + page_number + ');">' + (page_number + 1) + '</a>'); + push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() + + '" onclick="goto_page(' + page_number + ');">' + (page_number + 1) + '</a>'); } } @@ -795,7 +800,9 @@ for (var image_index = 2; image_index < row.length; image_index++) { var image = row[image_index]; thumbnail_html - += '<a href="#" onclick="display_image(' + "'" + image.position + "'" + ');">' + += '<a href="#' + + current_directory + '/' + current_subdirectory + '/' + image.name + + '" onclick="display_image(' + "'" + image.position + "'" + ');">' + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" ' + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + ',8" ' + ' onload="reveal_image(this);" />' @@ -813,15 +820,20 @@ var result_links = []; if (query_position > 0) { - push(result_links, '<a href="#" onclick="display_image(' + (query_position - 1) + ');"><<</a>'); + push(result_links, '<a href="#' + + current_directory + '/' + current_subdirectory + '/' + query_result[query_position - 1].name + + '" onclick="display_image(' + (query_position - 1) + ');"><<</a>'); } else { push(result_links, '<<'); } if (query_position < (query_result.length - 1)) { - push(result_links, '<a href="#" onclick="display_image(' + (query_position + 1) + ');">>></a>'); + push(result_links, '<a href="#' + + current_directory + '/' + current_subdirectory + '/' + query_result[query_position + 1].name + + '" onclick="display_image(' + (query_position + 1) + ');">>></a>'); } else { push(result_links, '>>'); } + document.getElementById('back_to_results_link').href = '#' + current_directory + '/' + current_subdirectory + '/' + position_to_page(query_position); document.getElementById("image_navbar").innerHTML = result_links.join(" "); document.getElementById("result_image_count").innerHTML = "result " + (query_position + 1) + " of " + query_result.length; @@ -1012,37 +1024,35 @@ } function init() { - if (document.location.href.indexOf("#debug") != -1) { - want_debugger = true; + var path = (document.location.href + "#").split("#")[1]; + + if (path) { + if (path == "debug") { + + want_debugger = true; - document.getElementById("debugger").style.visibility = 'visible'; - document.getElementById("debugger").style.left = '730px'; - document.getElementById("debugger").style.width = '400px'; - document.getElementById("debugger").style.heigth = '640px'; - } else { - document.getElementById("debugger").style.left = "1px"; - document.getElementById("debugger").style.right = "1px"; - document.getElementById("debugger").style.width = "1px"; - document.getElementById("debugger").style.height = "1px"; - } + document.getElementById("debugger").style.visibility = 'visible'; + document.getElementById("debugger").style.left = '730px'; + document.getElementById("debugger").style.width = '400px'; + document.getElementById("debugger").style.heigth = '640px'; - debug('init - path is ', document.location.href); + } else if (path == "update") { - if (document.location.href.indexOf("#update") != -1) { - if ((navigator.platform == "MacPPC") && (navigator.userAgent.indexOf("MSIE 5.") != -1)) { - alert("CMS functionality not supported on IE5/Mac"); + if ((navigator.platform == "MacPPC") && (navigator.userAgent.indexOf("MSIE 5.") != -1)) { + alert("CMS functionality not supported on IE5/Mac"); + } else { + wants_cms = true; + document.getElementById("login_form").style.visibility = 'visible'; + } + show_cms_window("login_form"); } else { - wants_cms = true; - document.getElementById("login_form").style.visibility = 'visible'; + var jump_to = path; + jump_to = jump_to.replace(/[&#].*/, ""); + document.jump_to = jump_to; } - show_cms_window("login_form"); } - if (document.location.href.indexOf("jumpto=") != -1) { - var jump_to = document.location.href.replace(/.*jumpto=/, ""); - jump_to = jump_to.replace(/[&#].*/, ""); - document.jump_to = jump_to; - } + debug('init - path is ', path); buttons = document.getElementById("directory").getElementsByTagName('img'); button_links = document.getElementById("directory").getElementsByTagName('a'); Modified: branches/trunk-reorg/projects/quickhoney/website/static/styles.css ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/static/styles.css (original) +++ branches/trunk-reorg/projects/quickhoney/website/static/styles.css Fri Feb 1 07:01:51 2008 @@ -69,10 +69,10 @@ #debugger { visibility: hidden; position: absolute; - left: 0px; - top: 36px; - width: 0px; - height: 0px; + left: 1px; + top: 1px; + width: 1px; + height: 1px; } .debugger { Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml (original) +++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Fri Feb 1 07:01:51 2008 @@ -15,22 +15,22 @@ <body id="quickhoney"> - <a onclick="show_page('quickhoney')" href="#"> + <a onclick="show_page('quickhoney')" href="#quickhoney"> <img alt="quickhoney" class="menu" id="m_quickhoney" src="/image/quickhoney" /> </a> - <a onclick="show_page('pixel')" href="#"> + <a onclick="show_page('pixel')" href="#pixel"> <img alt="pixel" class="menu" id="m_pixel" src="/image/pixel" /> </a> - <a onclick="show_page('vector')" href="#"> + <a onclick="show_page('vector')" href="#vector"> <img alt="vector" class="menu" id="m_vector" src="/image/vector" /> </a> - <a onclick="show_page('photo')" href="#"> + <a onclick="show_page('photo')" href="#photo"> <img alt="photo" class="menu" id="m_photo" src="/image/photo" /> </a> - <a onclick="show_page('clients')" href="#"> + <a onclick="show_page('clients')" href="#clients"> <img alt="clients" class="menu" id="m_clients" src="/image/clients" /> </a> - <a onclick="show_page('contact')" href="#"> + <a onclick="show_page('contact')" href="#contact"> <img alt="contact" class="menu" id="m_contact" src="/image/contact" /> </a> @@ -81,7 +81,7 @@ </span> <span id="results_navbar" class="text"> - <span id="back_to_results"><a onclick="back_to_results()" href="#">back to results</a></span> + <span id="back_to_results"><a id="back_to_results_link" onclick="back_to_results()" href="#">back to results</a></span> <span id="result_image_count">  </span> </span> @@ -95,7 +95,7 @@ </div> <div id="clients"> - <a href="#" onclick="return nice_jobs();"> + <a href="#clients/nicejobs" onclick="return nice_jobs();"> <img id="jobs-banner" src="/random-image/button/jobs" border="0" /> </a> <img id="clients-type" src="/image/type-niceclients" />

1 0

[bknr-cvs] r2436 - in branches/trunk-reorg: bknr/datastore/src projects/quickhoney/src
by hhubner＠common-lisp.net 01 Feb '08

01 Feb '08

Author: hhubner Date: Fri Feb 1 05:56:52 2008 New Revision: 2436 Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd branches/trunk-reorg/projects/quickhoney/src/load.lisp Log: Quickhoney startup fixes. Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd Fri Feb 1 05:56:52 2008 @@ -29,7 +29,7 @@ (:file "class" :depends-on ("package" "utils")) #+(or cmu allegro openmcl sbcl) (:file "smbpasswd" :depends-on ("utils")) - (:file "actor" :depends-on ("utils")) + #-sbcl (:file "actor" :depends-on ("utils")) (:file "reader" :depends-on ("utils")) (:file "crypt-md5" :depends-on ("utils")) (:file "capability" :depends-on ("utils")) Modified: branches/trunk-reorg/projects/quickhoney/src/load.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/load.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/load.lisp Fri Feb 1 05:56:52 2008 @@ -3,6 +3,7 @@ (asdf:oos 'asdf:load-op :quickhoney) (asdf:oos 'asdf:load-op :swank) -(swank::create-swank-server 4085 :spawn #'swank::simple-announce-function t) +(swank::create-server :port 4085) +#+cmu (mp::startup-idle-and-top-level-loops)

1 0

[bknr-cvs] r2435 - branches/trunk-reorg/projects/quickhoney/src
by hhubner＠common-lisp.net 01 Feb '08

01 Feb '08

Author: hhubner Date: Fri Feb 1 05:22:06 2008 New Revision: 2435 Modified: branches/trunk-reorg/projects/quickhoney/src/image.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp Log: Fix default external format, we're using UTF-8. Display image in encoded content of RSS feed. Modified: branches/trunk-reorg/projects/quickhoney/src/image.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/image.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/image.lisp Fri Feb 1 05:22:06 2008 @@ -6,6 +6,13 @@ :index-reader images-for-client :index-keys all-clients))) +(defmethod rss-item-pub-date ((item quickhoney-image)) + (blob-timestamp item)) + +(defmethod rss-item-encoded-content ((item quickhoney-image)) + (with-output-to-string (s) + (html-stream s ((:img :src (format nil "http://~A/image/~A" (header-in :host) (store-object-id item))))))) + (defvar *last-image-upload-timestamp* 0) (defmethod initialize-transient-instance :after ((image quickhoney-image)) Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Fri Feb 1 05:22:06 2008 @@ -8,6 +8,7 @@ "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so")) + (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (when *store* (close-store)) (make-instance 'store

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs February 2008