[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
hhubner at common-lisp.net
hhubner at common-lisp.net
Sat Feb 2 22:54:17 UTC 2008
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 at 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)
, at 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)
, at 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"><!-- x -->
</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
More information about the Bknr-cvs
mailing list