- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2178 - in branches/bos: bknr/src bknr/src/indices bknr/src/utils bknr/src/xml bknr/src/xml-impex projects/bos/worldpay-test thirdparty/ironclad
by bknr＠bknr.net 03 Oct '07

03 Oct '07

Author: hhubner Date: 2007-10-02 21:20:42 -0400 (Tue, 02 Oct 2007) New Revision: 2178 Added: branches/bos/bknr/src/bknr-xml.asd branches/bos/bknr/src/xml/ branches/bos/bknr/src/xml/package.lisp branches/bos/bknr/src/xml/xml.lisp Removed: branches/bos/thirdparty/ironclad/digest.lisp.orig branches/bos/thirdparty/ironclad/package.lisp.orig Modified: branches/bos/bknr/src/bknr-impex.asd branches/bos/bknr/src/bknr-utils.asd branches/bos/bknr/src/bknr.asd branches/bos/bknr/src/indices/package.lisp branches/bos/bknr/src/packages.lisp branches/bos/bknr/src/utils/package.lisp branches/bos/bknr/src/utils/utils.lisp branches/bos/bknr/src/utils/xml.lisp branches/bos/bknr/src/xml-impex/package.lisp branches/bos/projects/bos/worldpay-test/utils.lisp Log: Patch from Kamen Tomov to isolate CXML from the datastore. In order to get this compiled, I moved FIND-ALL from the BOS project to bknr/src/utils. Modified: branches/bos/bknr/src/bknr-impex.asd =================================================================== --- branches/bos/bknr/src/bknr-impex.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-impex.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-indices) + :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: branches/bos/bknr/src/bknr-utils.asd =================================================================== --- branches/bos/bknr/src/bknr-utils.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-utils.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -17,7 +17,6 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cl-ppcre - :cxml :md5 #+(not allegro) :acl-compat @@ -37,7 +36,6 @@ (:file "base64" :depends-on ("utils")) (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) - (:file "xml" :depends-on ("utils")) (:file "date-calc") (:file "acl-mp-compat" :depends-on ("package")))))) Added: branches/bos/bknr/src/bknr-xml.asd =================================================================== --- branches/bos/bknr/src/bknr-xml.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-xml.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,42 @@ +;; -*-Lisp-*- + +(in-package :cl-user) + +(defpackage :bknr.xml.system + (:use :cl :asdf)) + +(in-package :bknr.xml.system) + +(defsystem :bknr-xml + :name "baikonour" + :author "Hans Huebner <hans(a)huebner.org>" + :author "Manuel Odendahl <manuel(a)bl0rg.net>" + :version "0" + :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" + :licence "BSD" + :description "baikonour - launchpad for lisp satellites" + :depends-on (:cl-interpol :cxml) + :components ((:module "xml" :components ((:file "package") + (:file "xml"))))) + +;; -*-Lisp-*- + +(in-package :cl-user) + +(defpackage :bknr.xml.system + (:use :cl :asdf)) + +(in-package :bknr.xml.system) + +(defsystem :bknr-xml + :name "baikonour" + :author "Hans Huebner <hans(a)huebner.org>" + :author "Manuel Odendahl <manuel(a)bl0rg.net>" + :version "0" + :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" + :licence "BSD" + :description "baikonour - launchpad for lisp satellites" + :depends-on (:cl-interpol :cxml) + :components ((:module "xml" :components ((:file "package") + (:file "xml"))))) + Modified: branches/bos/bknr/src/bknr.asd =================================================================== --- branches/bos/bknr/src/bknr.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -28,6 +28,7 @@ :cxml :unit-test :bknr-utils + :bknr-xml :puri ;:stem ;:mime Modified: branches/bos/bknr/src/indices/package.lisp =================================================================== --- branches/bos/bknr/src/indices/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/indices/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -6,7 +6,6 @@ #+cmu :ext #+sbcl :sb-ext :cl-user - :cxml :bknr.utils :bknr.skip-list #+allegro :aclmop Modified: branches/bos/bknr/src/packages.lisp =================================================================== --- branches/bos/bknr/src/packages.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/packages.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -26,7 +26,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) (:export #:xml-escape #:*img-src-scanner* #:*a-href-scanner* @@ -192,6 +192,7 @@ :bknr.indices :bknr.impex :bknr.utils + :bknr.xml :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) Modified: branches/bos/bknr/src/utils/package.lisp =================================================================== --- branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -4,7 +4,6 @@ (:use :cl :cl-ppcre :cl-interpol - :cxml-xmls :md5 #+cmu :extensions ; #+sbcl :sb-ext @@ -122,15 +121,6 @@ #:string-beginning-with-p #:string-delimited-by-p - ;; xml - #:node-children-nodes - #:find-child - #:find-children - #:node-string-body - #:node-attribute - #:node-child-string-body - #:node-to-html - ;; crypt-md5 #:crypt-md5 #:verify-md5-password @@ -150,4 +140,7 @@ #:mp-with-recursive-lock-held ;; class utils - #:class-subclasses)) + #:class-subclasses + + ;; norvig + #:find-all)) Modified: branches/bos/bknr/src/utils/utils.lisp =================================================================== --- branches/bos/bknr/src/utils/utils.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/utils.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -545,4 +545,15 @@ (format nil "~3,1F KB" (/ byte-count 1024))) (t (format nil "~A" byte-count)))) - \ No newline at end of file + +;;; from norvig +(defun find-all (item sequence &rest keyword-args + &key (test #'eql) test-not &allow-other-keys) + "Find all those elements of sequence that match item, + according to the keywords. Doesn't alter sequence." + (if test-not + (apply #'remove item sequence + :test-not (complement test-not) keyword-args) + (apply #'remove item sequence + :test (complement test) keyword-args))) + Modified: branches/bos/bknr/src/utils/xml.lisp =================================================================== --- branches/bos/bknr/src/utils/xml.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/xml.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,63 +0,0 @@ -(in-package :bknr.utils) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Added: branches/bos/bknr/src/xml/package.lisp =================================================================== --- branches/bos/bknr/src/xml/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,16 @@ +(in-package :cl-user) + +(defpackage :bknr.xml + (:use :cl + :cl-ppcre + :cl-interpol + :cxml-xmls) + (:shadowing-import-from :cl-interpol "QUOTE-META-CHARS") + (:export + #:node-children-nodes + #:find-child + #:find-children + #:node-string-body + #:node-attribute + #:node-child-string-body + #:node-to-html)) Added: branches/bos/bknr/src/xml/xml.lisp =================================================================== --- branches/bos/bknr/src/xml/xml.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml/xml.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,126 @@ +(in-package :bknr.xml) + +(defun node-children-nodes (xml) + (remove-if-not #'consp (node-children xml))) + +(defun find-child (xml node-name) + (let ((children (node-children-nodes xml))) + (find node-name children :test #'string-equal :key #'node-name))) + +(defun find-children (xml node-name) + (let ((children (node-children-nodes xml))) + (find-all node-name children :test #'string-equal :key #'node-name))) + +(defun node-string-body (xml) + (let ((children (remove-if #'consp (node-children xml)))) + (if (every #'stringp children) + (apply #'concatenate 'string children) + (error "Some children are not strings")))) + +(defun node-attribute (xml attribute-name) + (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + +(defun node-child-string-body (xml node-name) + (let ((child (find-child xml node-name))) + (if (and child (consp child)) + (node-string-body child) + nil))) + +(defun node-to-html (node &optional (stream *standard-output*)) + (when (stringp node) + (write-string node) + (return-from node-to-html)) + (write-char #\< stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (loop for (key value) in (node-attrs node) + do (write-char #\Space stream) + (write-string key stream) + (write-char #\= stream) + (write-char #\" stream) + (write-string value stream) + (write-char #\" stream)) + (if (node-children node) + (progn + (write-char #\> stream) + (write-char #\Newline stream) + (dolist (child (node-children node)) + (node-to-html child stream)) + (write-char #\< stream) + (write-char #\/ stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (write-char #\> stream) + (write-char #\Newline stream)) + (progn (write-char #\Space stream) + (write-char #\/ stream) + (write-char #\> stream) + (write-char #\Newline stream)))) + +(in-package :bknr.xml) + +(defun node-children-nodes (xml) + (remove-if-not #'consp (node-children xml))) + +(defun find-child (xml node-name) + (let ((children (node-children-nodes xml))) + (find node-name children :test #'string-equal :key #'node-name))) + +(defun find-children (xml node-name) + (let ((children (node-children-nodes xml))) + (find-all node-name children :test #'string-equal :key #'node-name))) + +(defun node-string-body (xml) + (let ((children (remove-if #'consp (node-children xml)))) + (if (every #'stringp children) + (apply #'concatenate 'string children) + (error "Some children are not strings")))) + +(defun node-attribute (xml attribute-name) + (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + +(defun node-child-string-body (xml node-name) + (let ((child (find-child xml node-name))) + (if (and child (consp child)) + (node-string-body child) + nil))) + +(defun node-to-html (node &optional (stream *standard-output*)) + (when (stringp node) + (write-string node) + (return-from node-to-html)) + (write-char #\< stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (loop for (key value) in (node-attrs node) + do (write-char #\Space stream) + (write-string key stream) + (write-char #\= stream) + (write-char #\" stream) + (write-string value stream) + (write-char #\" stream)) + (if (node-children node) + (progn + (write-char #\> stream) + (write-char #\Newline stream) + (dolist (child (node-children node)) + (node-to-html child stream)) + (write-char #\< stream) + (write-char #\/ stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (write-char #\> stream) + (write-char #\Newline stream)) + (progn (write-char #\Space stream) + (write-char #\/ stream) + (write-char #\> stream) + (write-char #\Newline stream)))) + Modified: branches/bos/bknr/src/xml-impex/package.lisp =================================================================== --- branches/bos/bknr/src/xml-impex/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml-impex/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -13,6 +13,7 @@ #+sbcl :sb-pcl :bknr.utils + :bknr.xml :bknr.indices) (:export #:xml-class Modified: branches/bos/projects/bos/worldpay-test/utils.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/utils.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/projects/bos/worldpay-test/utils.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -260,17 +260,6 @@ ((funcall test i num) (append l (nreverse smaller))))) -;;; from norvig -(defun find-all (item sequence &rest keyword-args - &key (test #'eql) test-not &allow-other-keys) - "Find all those elements of sequence that match item, - according to the keywords. Doesn't alter sequence." - (if test-not - (apply #'remove item sequence - :test-not (complement test-not) keyword-args) - (apply #'remove item sequence - :test (complement test) keyword-args))) - ;;; hash table (defun hash-to-list (hash &key (key #'cdr) (compare #'>) num) (let ((results (sort (loop for key being the hash-key of hash using (hash-value val) Deleted: branches/bos/thirdparty/ironclad/digest.lisp.orig =================================================================== --- branches/bos/thirdparty/ironclad/digest.lisp.orig 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/thirdparty/ironclad/digest.lisp.orig 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,196 +0,0 @@ -;;;; digest.lisp -- common functions for hashing - -(in-package :crypto) - - -;;; defining digest (hash) functions - -;;; general inlinable functions for implementing the higher-level functions - -(declaim (inline digest-sequence-body digest-stream-body digest-file-body)) - -(defun digest-sequence-body (sequence state-creation-fn - state-update-fn - state-finalize-fn - &key (start 0) end) - (declare (type (vector (unsigned-byte 8)) sequence) (type index start)) - (let ((state (funcall state-creation-fn))) - #+cmu - (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) - (funcall state-update-fn state data - :start real-start :end (or real-end (length sequence)))) - #+sbcl - (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) - (funcall state-update-fn state data - :start real-start :end (or real-end (length sequence)))) - #-(or cmu sbcl) - (let ((real-end (or end (length sequence)))) - (declare (type index real-end)) - (funcall state-update-fn state sequence - :start start :end (or real-end (length sequence)))) - (funcall state-finalize-fn state))) - -(eval-when (:compile-toplevel) -(defconstant +buffer-size+ (* 128 1024)) -) ; EVAL-WHEN - -(deftype buffer-index () `(integer 0 (,+buffer-size+))) - -(defun digest-stream-body (stream state-creation-fn - state-update-fn - state-finalize-fn) - (let ((state (funcall state-creation-fn))) - (cond - ((equal (stream-element-type stream) '(unsigned-byte 8)) - (let ((buffer (make-array +buffer-size+ - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) - buffer)) - (declare (dynamic-extent buffer)) - (loop for n-bytes of-type buffer-index = (read-sequence buffer stream) - do (funcall state-update-fn state buffer :end n-bytes) - until (< n-bytes +buffer-size+) - finally (return (funcall state-finalize-fn state))))) - (t - (error "Unsupported stream element-type ~S for stream ~S." - (stream-element-type stream) stream))))) - -(defun digest-file-body (pathname state-creation-fn - state-update-fn - state-finalize-fn) - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :direction :input - :if-does-not-exist :error) - (digest-stream-body stream state-creation-fn state-update-fn - state-finalize-fn))) - - -;;; high-level generic function drivers - -;;; These three functions are intended to be one-shot ways to digest -;;; an object of some kind. You could write these in terms of the more -;;; familiar digest interface below, but these are likely to be slightly -;;; more efficient, as well as more obvious about what you're trying to -;;; do. -(defgeneric digest-file (digest-name pathname) - (:documentation "Return the digest of PATHNAME using the algorithm DIGEST-NAME.")) - -(defgeneric digest-stream (digest-name stream) - (:documentation "Return the digest of STREAM using the algorithm DIGEST-NAME. -STREAM-ELEMENT-TYPE of STREAM should be (UNSIGNED-BYTE 8).")) - -(defgeneric digest-sequence (digest-name sequence &key start end) - (:documentation "Return the digest of the subsequence of SEQUENCE -specified by START and END using the algorithm DIGEST-NAME. For CMUCL -and SBCL, SEQUENCE can be any vector with an element-type of -(UNSIGNED-BYTE 8); for other implementations, SEQUENCE must be a -SIMPLE-ARRAY.")) - -;;; These four functions represent the common interface for digests in -;;; other crypto toolkits (OpenSSL, Botan, Python, etc.). You obtain -;;; some state object for a particular digest, you update it with some -;;; data, and then you get the actual digest. Flexibility is the name -;;; of the game with these functions. -(defgeneric make-digest (digest-name) - (:documentation "Return a digest object which uses the algorithm DIGEST-NAME.")) - -(defgeneric copy-digest (digest) - (:documentation "Return a copy of DIGEST. The copy is a deep copy, not a -shallow copy as might be returned by COPY-STRUCTURE.")) - -(defgeneric update-digest (digest sequence &key start end) - (:documentation "Update the internal state of DIGEST with the subsequence -of SEQUENCE specified by START and END. For CMUCL and SBCL, SEQUENCE -can be any vector with an element-type of (UNSIGNED-BYTE 8); for other -implementations, SEQUENCE must be a SIMPLE-ARRAY.")) - -(defgeneric produce-digest (digest) - (:documentation "Return the hash of the data processed by DIGEST so far. -This function does not modify the internal state of DIGEST.")) - - -;;; the digest-defining macro - -(defvar *supported-digests* nil) - -(defun list-all-digests () - (copy-seq *supported-digests*)) - -(defun digest-supported-p (name) - "Return T if the digest NAME is a valid digest name." - (member name *supported-digests*)) - -(defgeneric digest-length (digest) - (:documentation "Return the number of bytes in a digest generated by DIGEST.")) - -(defmacro defdigest (name &rest initargs) - (%defdigest name initargs)) - -(defun %defdigest (name initargs) - (let ((creation-function nil) - (copy-function nil) - (update-function nil) - (finalize-function nil) - (state-type nil) - (digest-length nil) - (digest-name (intern (string name) (find-package :keyword)))) - (loop for (arg value) in initargs - do - (case arg - (:creation-function - (if (not creation-function) - (setf creation-function value) - (error "Specified :CREATION-FUNCTION multiple times."))) - (:copy-function - (if (not copy-function) - (setf copy-function value) - (error "Specified :COPY-FUNCTION multiple times."))) - (:update-function - (if (not update-function) - (setf update-function value) - (error "Specified :UPDATE-FUNCTION multiple times."))) - (:finalize-function - (if (not finalize-function) - (setf finalize-function value) - (error "Specified :FINALIZE-FUNCTION multiple times."))) - (:state-type - (if (not state-type) - (setf state-type value) - (error "Specified :STATE-TYPE multiple times."))) - (:digest-length - (if (not digest-length) - (setf digest-length value) - (error "Specified :DIGEST-LENGTH multiple times.")))) - finally (if (and creation-function copy-function update-function - finalize-function state-type digest-length) - (return (generate-digest-forms digest-name state-type - digest-length - creation-function - copy-function update-function - finalize-function)) - (error "Didn't specify all required options for DEFDIGEST"))))) - -(defun generate-digest-forms (digest-name state-type digest-length - creation-function copy-function - update-function finalize-function) - `(progn - (push ,digest-name *supported-digests*) - (defmethod digest-length ((digest (eql ,digest-name))) - ,digest-length) - (defmethod digest-length ((digest ,state-type)) - ,digest-length) - (defmethod make-digest ((digest-name (eql ,digest-name))) - (,creation-function)) - (defmethod copy-digest ((digest ,state-type)) - (,copy-function digest)) - (defmethod update-digest ((digest ,state-type) sequence &key (start 0) end) - (,update-function digest sequence - :start start :end (or end (length sequence)))) - (defmethod produce-digest ((digest ,state-type)) - (,finalize-function (,copy-function digest))) - (defmethod digest-file ((digest-name (eql ,digest-name)) pathname) - (digest-file-body pathname #',creation-function #',update-function #',finalize-function)) - (defmethod digest-stream ((digest-name (eql ,digest-name)) stream) - (digest-stream-body stream #',creation-function #',update-function #',finalize-function)) - (defmethod digest-sequence ((digest-name (eql ,digest-name)) sequence &key (start 0) end) - (digest-sequence-body sequence #',creation-function #',update-function #',finalize-function :start start :end end)))) Deleted: branches/bos/thirdparty/ironclad/package.lisp.orig =================================================================== --- branches/bos/thirdparty/ironclad/package.lisp.orig 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/thirdparty/ironclad/package.lisp.orig 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,28 +0,0 @@ -(defpackage :ironclad - (:use :cl) - (:nicknames :crypto) - (:export - ;; hash functions - #:digest-sequence #:digest-stream #:digest-file - #:make-digest #:copy-digest #:update-digest #:produce-digest - - ;; HMACs - #:make-hmac #:update-hmac #:hmac-digest - - ;; introspection - #:cipher-supported-p #:list-all-ciphers - #:digest-supported-p #:list-all-digests - #:mode-supported-p #:list-all-modes - #:block-length #:digest-length - - ;; high-level operators - #:make-cipher #:encrypt #:decrypt - - ;; classes - #:aes-context #:square-context #:blowfish-context #:idea-context - #:twofish-context - #:des-context #:cast5-context #:tea-context #:xtea-context - - ;; conditions - #:ironclad-error #:initialization-vector-not-supplied - #:invalid-initialization-vector #:invalid-key-length)) \ No newline at end of file

1 0

[bknr-cvs] r2177 - in branches/bos/bknr/src: data utils
by bknr＠bknr.net 02 Oct '07

02 Oct '07

Author: hhubner Date: 2007-10-02 06:54:15 -0400 (Tue, 02 Oct 2007) New Revision: 2177 Modified: branches/bos/bknr/src/data/txn.lisp branches/bos/bknr/src/utils/acl-mp-compat.lisp branches/bos/bknr/src/utils/package.lisp Log: SBCL compatibility patch contributed by oudeis Modified: branches/bos/bknr/src/data/txn.lisp =================================================================== --- branches/bos/bknr/src/data/txn.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/data/txn.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -43,11 +43,11 @@ () (:default-initargs :guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk)))) :log-guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk))))) (:documentation "Store in which every transaction and operation is protected by a giant lock.")) Modified: branches/bos/bknr/src/utils/acl-mp-compat.lisp =================================================================== --- branches/bos/bknr/src/utils/acl-mp-compat.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/utils/acl-mp-compat.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -18,3 +18,14 @@ #+cmu `(mp:with-lock-held (,lock) ,@body)) + +(defmacro mp-with-recursive-lock-held ((lock) &rest body) + #+allegro + `(mp:with-process-lock (,lock) + ,@body) + #+sbcl + `(sb-thread:with-recursive-lock (,lock) + ,@body) + #+cmu + `(mp:with-lock-held (,lock) + ,@body)) Modified: branches/bos/bknr/src/utils/package.lisp =================================================================== --- branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -147,6 +147,7 @@ ;; mp compatibility #:mp-make-lock #:mp-with-lock-held + #:mp-with-recursive-lock-held ;; class utils #:class-subclasses))

1 0

[bknr-cvs] r2176 - branches/bos/bknr/src/data
by bknr＠bknr.net 02 Oct '07

02 Oct '07

Author: hhubner Date: 2007-10-02 06:53:43 -0400 (Tue, 02 Oct 2007) New Revision: 2176 Modified: branches/bos/bknr/src/data/object.lisp Log: Factor out partition function. Should be moved to utils eventually. Modified: branches/bos/bknr/src/data/object.lisp =================================================================== --- branches/bos/bknr/src/data/object.lisp 2007-09-28 17:16:21 UTC (rev 2175) +++ branches/bos/bknr/src/data/object.lisp 2007-10-02 10:53:43 UTC (rev 2176) @@ -613,16 +613,23 @@ (defmethod cascade-delete-p (object referencing-object) nil) +(defun partition-list (list predicate) + "Return two list values, the first containing all elements from LIST +that satisfy PREDICATE, the second those that don't" + (let (do dont) + (dolist (element list) + (if (funcall predicate element) + (push element do) + (push element dont))) + (values do dont))) + (defun cascading-delete-object (object) "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible to cascading deletes." - (let (cascading-delete-refs - remaining-refs) - (dolist (referencing-object (find-refs object)) - (if (cascade-delete-p object referencing-object) - (push referencing-object cascading-delete-refs) - (push referencing-object remaining-refs))) + (multiple-value-bind (cascading-delete-refs + remaining-refs) + (partition-list (find-refs object) #'cascade-delete-p) (when remaining-refs (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" object))

1 0

[bknr-cvs] r2175 - in branches/bos: bknr/src bknr/src/data bknr/src/sysclasses bknr/src/web projects/bos/m2 projects/bos/payment-website/templates/da projects/bos/payment-website/templates/de projects/bos/payment-website/templates/en projects/bos/worldpay-test thirdparty/iconv
by bknr＠bknr.net 28 Sep '07

28 Sep '07

Author: hhubner Date: 2007-09-28 13:16:21 -0400 (Fri, 28 Sep 2007) New Revision: 2175 Added: branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml Modified: branches/bos/bknr/src/data/object.lisp branches/bos/bknr/src/data/package.lisp branches/bos/bknr/src/packages.lisp branches/bos/bknr/src/sysclasses/user.lisp branches/bos/bknr/src/web/user-handlers.lisp branches/bos/bknr/src/web/user-tags.lisp branches/bos/bknr/src/web/web-visitor.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp branches/bos/projects/bos/worldpay-test/boi-handlers.lisp branches/bos/projects/bos/worldpay-test/contract-handlers.lisp branches/bos/projects/bos/worldpay-test/news-handlers.lisp branches/bos/projects/bos/worldpay-test/poi-handlers.lisp branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp branches/bos/projects/bos/worldpay-test/tags.lisp branches/bos/projects/bos/worldpay-test/worldpay-test.lisp branches/bos/thirdparty/iconv/iconv.lisp Log: Add better error message when the requested number of square meters cannot be allocated. Add :EDITOR user flag to control access to content editing functions. :ADMIN is now required to add or delete users, languages and allocation areas. The other CMS functions may be accessed by users having the :EDITOR flag. Change user flag handling so that an explicit list of legal flags is maintained within the source code, as opposed to generating the list on the fly from those flags that have been created using the user editor. Display all system users in the user maintenance CMS form, together with the most important attributes. Enhance user deletion: Implement confirmation dialog, cascading delete any existing event log entries that referenced the deleted users. The cascaded deletion is implemented by a general mechanism and an addition to the store API, CASCADING-DELETE-OBJECT. This function does a full traversal of the datastore to find any references to the object that is being deleted. For each object found, the generic function CASCADE-DELETE-P is called to determine whether the referencing object can be deleted, too. If any objects are found for that CASCADE-DELETE-P returns NIL, an error is generated. Modified: branches/bos/bknr/src/data/object.lisp =================================================================== --- branches/bos/bknr/src/data/object.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/data/object.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -607,6 +607,27 @@ :timestamp (get-universal-time) :args (mapcar #'store-object-id objects))))) +(defgeneric cascade-delete-p (object referencing-object) + (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted")) + +(defmethod cascade-delete-p (object referencing-object) + nil) + +(defun cascading-delete-object (object) + "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by +the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible +to cascading deletes." + (let (cascading-delete-refs + remaining-refs) + (dolist (referencing-object (find-refs object)) + (if (cascade-delete-p object referencing-object) + (push referencing-object cascading-delete-refs) + (push referencing-object remaining-refs))) + (when remaining-refs + (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" + object)) + (apply #'delete-objects object cascading-delete-refs))) + (deftransaction change-slot-values (object &rest slots-and-values) (when object (loop for (slot value) on slots-and-values by #'cddr @@ -655,4 +676,17 @@ (deftransaction store-object-set-keywords (object slot keywords) (setf (slot-value object slot) keywords)) +(defmethod find-refs ((object store-object)) + "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots." + (remove-if-not + (lambda (candidate) + (find-if (lambda (slotd) + (and (slot-boundp candidate (slot-definition-name slotd)) + (let ((slot-value (slot-value candidate (slot-definition-name slotd)))) + (or (eq object slot-value) + (and (listp slot-value) + (find object slot-value)))))) + (class-slots (class-of candidate)))) + (class-instances 'store-object))) + (pushnew :mop-store cl:*features*) Modified: branches/bos/bknr/src/data/package.lisp =================================================================== --- branches/bos/bknr/src/data/package.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/data/package.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -52,6 +52,8 @@ #:delete-object #:delete-objects + #:cascade-delete-p + #:cascading-delete-object #:initialize-persistent-instance #:initialize-transient-instance @@ -108,4 +110,6 @@ #:store-blob-root-tempdir #:store-object-subsystem - #:blob-subsystem)) + #:blob-subsystem + + #:find-refs)) Modified: branches/bos/bknr/src/packages.lisp =================================================================== --- branches/bos/bknr/src/packages.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/packages.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -130,6 +130,7 @@ #:user-flags #:user-preferences #:user-subscriptions + #:user-editable-p ;; Export slot names so that derived classes can overload ;; slots (e.g. to add XML impex attributes) @@ -152,6 +153,7 @@ #:user-add-flags #:user-remove-flags #:all-user-flags + #:define-user-flag #:user-reachable-by-mail-p #:user-mail-error-p @@ -163,6 +165,7 @@ #:all-users #:get-flag-users #:make-user + #:delete-user #:set-user-password #:set-user-last-login Modified: branches/bos/bknr/src/sysclasses/user.lisp =================================================================== --- branches/bos/bknr/src/sysclasses/user.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/sysclasses/user.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -13,8 +13,7 @@ :index-values all-users) (flags :update :initform nil :index-type hash-list-index - :index-reader get-flag-users - :index-keys all-user-flags) + :index-reader get-flag-users) (email :update :initform "" :documentation "Email Address, must be unique") @@ -30,6 +29,15 @@ (defconstant +salt-length+ 8) +(defgeneric user-editable-p (user) + (:documentation "Return non-nil if the given user can be edited through the administration interface. The USER class +is frequently subclassed to implement special user accounts that are self-registered and that cannot be edited through +the standard user administration interface. It would be better if the ``real'' system users would live in a seperate base +class that would be editable and have the USER class be non-editable.")) + +(defmethod user-editable-p ((user user)) + t) + (defun make-salt () (coerce (loop for i from 1 upto +salt-length+ @@ -91,6 +99,14 @@ (defmethod user-has-flag ((user user) flag) (find flag (user-flags user))) +(defvar *user-flags* '(:admin)) + +(defun define-user-flag (keyword) + (pushnew keyword *user-flags*)) + +(defun all-user-flags () + (copy-list *user-flags*)) + (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) @@ -149,6 +165,14 @@ (set-user-password user password)) user)) +(defmethod cascade-delete-p ((user user) (event event)) + t) + +(defmethod delete-user ((user user)) + (when (eq user (find-user "anonymous")) + (error "Can't delete system user ``anonymous''")) + (cascading-delete-object user)) + (deftransaction set-user-full-name (user full-name) (setf (user-full-name user) full-name)) Modified: branches/bos/bknr/src/web/user-handlers.lisp =================================================================== --- branches/bos/bknr/src/web/user-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/user-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -59,13 +59,21 @@ (defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) (with-bknr-page (req :title "Manage users") - #+(or) - (:ul (loop for user in (remove :registered (all-users) :key #'user-flags :test #'member) - do (html (:li ((:a :href (object-url user)) - (:princ-safe (user-login user))))))) - ((:form :method "POST") - (:h2 "Search for user") - "Login: " ((:input :type "text" :name "login" :size "20")) (submit-button "search" "search")) + ((:table :border "1") + (:tr (:th "Login") + (:th "Real name") + (:th "Privileges") + (:th "Last login")) + (dolist (user (sort (remove-if-not #'user-editable-p (all-users)) + #'string-lessp :key #'user-login)) + (html (:tr (:td ((:a :href (object-url user)) + (:princ-safe (user-login user)))) + (:td (:princ-safe (user-full-name user))) + (:td (:princ-safe (format nil "~{~A~^, ~}" (user-flags user)))) + (:td (:princ-safe (if (and (user-last-login user) + (plusp (user-last-login user))) + (format-date-time (user-last-login user)) + "<never logged in>"))))))) (:h2 "Create new user") (user-form))) @@ -90,25 +98,27 @@ (when password (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) + + (when (admin-p (bknr-request-user req)) + (let* ((all-flags (all-user-flags)) + (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (unset-flags (set-difference all-flags set-flags))) + (user-add-flags user set-flags) + (user-remove-flags user unset-flags))) + (call-next-method)) +(define-condition unauthorized-error (simple-error) + () + (:report "You are not authorized to perform this operation")) + (defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) + (unless (admin-p (bknr-request-user req)) + (error 'unauthorized-error)) (when user - (delete-object user)) + (delete-user user)) (redirect "/user" req)) -(defmethod handle-object-form ((handler user-handler) (action (eql :add-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-add-flags user flags))) - (call-next-method)) - -(defmethod handle-object-form ((handler user-handler) (action (eql :remove-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-remove-flags user flags))) - (call-next-method)) - (defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) (with-query-params (req login email full-name password password-repeat) (if (and password @@ -116,11 +126,11 @@ (error "please enter the same password twice") (if login (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) - (user (make-object 'user :login login - :email email - :full-name full-name - :password password - :flags flags))) + (user (make-user login + :email email + :full-name full-name + :password password + :flags flags))) (redirect (edit-object-url user) req)) (error "please enter a login"))))) Modified: branches/bos/bknr/src/web/user-tags.lisp =================================================================== --- branches/bos/bknr/src/web/user-tags.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/user-tags.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -2,20 +2,15 @@ (enable-interpol-syntax) -(define-bknr-tag user-flag-choose-dialog (&key (size "4") (name "keyword") (create nil)) - (let ((size (or (parse-integer size :junk-allowed t) 1))) - (loop for i from 1 to size - do (html ((:div :class "keyword-choose") - (when (> size 1) - (html (:princ-safe i) ". ")) - (select-box name - (loop for flag in - (sort (all-user-flags) #'string<) - collect (list (string-downcase flag) flag))) - (when create - (html ((:input :type "text" :length "20" :name name))))))))) +(define-bknr-tag user-flag-choose-dialog (&key enabled) + (dolist (flag (sort (all-user-flags) #'string<)) + (html + ((:div :class "user-flag-choose") + (if (find flag enabled) + (html ((:input :type "checkbox" :name "flags" :value flag :checked "checked"))) + (html ((:input :type "checkbox" :name "flags" :value flag)))) + (:princ-safe flag))))) - (define-bknr-tag user-form (&key user-id) (let ((user (when user-id (store-object-with-id (if (numberp user-id) @@ -36,11 +31,7 @@ (:td (html (text-field "email" :value (user-email user))))) (when (admin-p *user*) (html (:tr (:td "flags") - (:td (dolist (flag (user-flags user)) - (html (:princ-safe flag) " ")))) - (:tr (:td "new flags") - (:td (user-flag-choose-dialog :create t - :size "2"))))) + (:td (user-flag-choose-dialog :enabled (user-flags user)))))) (:tr (:td "new password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat new password") @@ -48,9 +39,7 @@ (:tr ((:td :colspan "2") (submit-button "save" "save") (when (admin-p *user*) - (submit-button "add-flags" "add flags") - (submit-button "remove-flags" "remove flags") - (submit-button "delete" "delete"))))))) + (submit-button "delete" "delete" :confirm "Really delete this user account? The operation cannot be undone."))))))) (html ((:form :method "post") (:table (:tr (:td "login") @@ -60,7 +49,7 @@ (:tr (:td "email") (:td ((:input :type "text" :name "email" :size "40")))) (:tr (:td "flags") - (:td (user-flag-choose-dialog :create t :size "2"))) + (:td (user-flag-choose-dialog))) (:tr (:td "password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat password") Modified: branches/bos/bknr/src/web/web-visitor.lisp =================================================================== --- branches/bos/bknr/src/web/web-visitor.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/web-visitor.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -16,12 +16,15 @@ (host-ip-address (web-visitor-event-host event)))) (defmethod print-object ((event web-visitor-event) stream) - (format stream "#<~a at ~a user ~a from ~a [~a]>" - (class-of event) (format-date-time (event-time event)) - (when (web-visitor-event-user event) - (user-login (web-visitor-event-user event))) - (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event))) + (print-unreadable-object (event stream :type t :identity t) + (format stream "at ~A user ~A" + (format-date-time (event-time event)) + (and (web-visitor-event-user event) + (user-login (web-visitor-event-user event)))) + (when (web-visitor-event-host event) + (format stream " from ~a [~a]" + (host-name (web-visitor-event-host event)) + (host-ip-address (web-visitor-event-host event)))))) event) #+(or) Modified: branches/bos/projects/bos/m2/m2.lisp =================================================================== --- branches/bos/projects/bos/m2/m2.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/m2/m2.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -123,6 +123,9 @@ (contracts :update :initform nil)) (:default-initargs :full-name nil :email nil)) +(defmethod user-editable-p ((sponsor sponsor)) + nil) + (defun sponsor-p (object) (equal (class-of object) (find-class 'sponsor))) @@ -146,6 +149,18 @@ (defmethod sponsor-id ((sponsor sponsor)) (store-object-id sponsor)) +(define-user-flag :editor) + +(defmethod editor-p ((user user)) + (or (admin-p user) + (user-has-flag user :editor))) + +(defclass editor-only-handler () + ()) + +(defmethod bknr.web:authorized-p ((handler editor-only-handler) req) + (editor-p (bknr-request-user req))) + ;;;; CONTRACT ;;; Exportierte Funktionen: @@ -308,6 +323,12 @@ contract) (warn "can't create contract, ~A square meters for ~A could not be allocated" m2-count sponsor)))) +(define-condition allocation-areas-exhausted (simple-error) + ((numsqm :initarg :numsqm :reader numsqm)) + (:report (lambda (condition stream) + (format stream "Could not satisfy your request for ~A sqms, please contact the BOS office" + (numsqm condition))))) + (defun make-contract (sponsor m2-count &key (date (get-universal-time)) paidp @@ -316,7 +337,11 @@ (unless (and (integerp m2-count) (plusp m2-count)) (error "number of square meters must be a positive integer")) - (let ((contract (do-make-contract sponsor m2-count :date date :paidp paidp :expires expires :download-only download-only))) + (let ((contract (do-make-contract sponsor m2-count + :date date + :paidp paidp + :expires expires + :download-only download-only))) (unless contract (send-system-mail :subject "Contact creation failed - Allocation areas exhaused" :text (format nil "A contract for ~A square meters could not be created, presumably because no @@ -326,7 +351,7 @@ Sponsor-ID: ~A " m2-count (store-object-id sponsor))) - (error "could not create contract, allocation areas exhausted?")) + (error 'allocation-areas-exhausted :numsqm m2-count)) contract)) (defvar *last-contracts-cache* nil) Modified: branches/bos/projects/bos/m2/packages.lisp =================================================================== --- branches/bos/projects/bos/m2/packages.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/m2/packages.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -91,6 +91,9 @@ #:country #:info-text + #:editor-only-handler + #:editor-p + #:contract #:make-contract #:contract-p Added: branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Großspende" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Anfrage zu groß für Online-Spende</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>Kontakt BOS Danmark med eventuelle spørgsmål.<br></br> + Vi modtager også gerne ideer til forbedringer at denne hjemmeside. + <br></br><br></br> + BOS Danmark.<br></br> + Økologihuset<br></br> + Blegdamsvej 4b<br></br> + 2200 København N + <br></br><br></br> + Telefon: 70 203 206<br></br> + Fax: 3537 3636<br></br><br></br> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img> + <a href="mailto:bos@orangutang.dk" class="more"> + bos(a)orangutang.dk + </a> + <br></br><br></br><br></br><br></br><br></br><br></br> + Vi besvarer alle henvendelser hurtigst muligt. + <br></br> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Added: branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,84 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Großspende" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Anfrage zu groß für Online-Spende</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>Leider konnten wir Ihre Spende nicht online verarbeiten, bitte nehmen Sie direkt + mit uns Kontakt auf:<br /> + <br /><br /> + BOS Deutschland e.V.<br /> + Böckhstr. 39<br /> + D - 10967 Berlin + <br /><br /> + Telefon: +49.30.26 36 78 33<br /> + Fax: +49.30.26 36 78 15<br /><br /> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="mailto:info@bos-deutschland.de" class="more"> + info(a)bos-deutschland.de + </a> + <br /><br /><br /><br /><br /><br /> + Wir werden Ihre Anfrage baldmöglichst beantworten. Bitte haben Sie etwas Geduld. + <br /> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Added: branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Large donation" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Your donation is too large to be processed online at this time!</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>We're sorry, but your donorship request is too large to be processed online at + this time. Please get in touch with us directly! Thank you! + <br /> + <br /><br /> + BOS Deutschland e.V.<br /> + Böckhstr. 39<br /> + D - 10967 Berlin + <br /><br /> + Telefon: +49.30.26 36 78 33<br /> + Fax: +49.30.26 36 78 15<br /><br /> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="mailto:info@bos-deutschland.de" class="more"> + info(a)bos-deutschland.de + </a> + <br /><br /><br /><br /><br /><br /> + Wir werden Ihre Anfrage baldmöglichst beantworten. Bitte haben Sie etwas Geduld. + <br /> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Modified: branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -80,7 +80,7 @@ (with-bos-cms-page (req :title "Allocation area has been deleted") (:h2 "The allocation area has been deleted"))) -(defclass allocation-area-gfx-handler (admin-only-handler object-handler) +(defclass allocation-area-gfx-handler (editor-only-handler object-handler) ()) (defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) Modified: branches/bos/projects/bos/worldpay-test/boi-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/boi-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/boi-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -31,9 +31,7 @@ ()) (defmethod authorized-p ((handler boi-handler) req) - (let ((user (bknr-request-user req))) - (or (admin-p user) - (user-has-flag user :boi)))) + (bos.m2:editor-p (bknr-request-user req))) (defclass create-contract-handler (boi-handler) ()) Modified: branches/bos/projects/bos/worldpay-test/contract-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/contract-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/contract-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -3,7 +3,7 @@ (enable-interpol-syntax) -(defclass contract-handler (admin-only-handler object-handler) +(defclass contract-handler (editor-only-handler object-handler) () (:default-initargs :class 'contract)) Modified: branches/bos/projects/bos/worldpay-test/news-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/news-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/news-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -6,7 +6,7 @@ (defmethod edit-object-url ((news-item news-item)) (format nil "/edit-news/~A" (store-object-id news-item))) -(defclass edit-news-handler (admin-only-handler edit-object-handler) +(defclass edit-news-handler (editor-only-handler edit-object-handler) ()) (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) Modified: branches/bos/projects/bos/worldpay-test/poi-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/poi-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/poi-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -20,7 +20,7 @@ (t (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) -(defclass edit-poi-handler (admin-only-handler edit-object-handler) +(defclass edit-poi-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -262,7 +262,7 @@ ;; edit-poi-image -(defclass edit-poi-image-handler (admin-only-handler edit-object-handler) +(defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi-image)) Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -3,13 +3,13 @@ (enable-interpol-syntax) -(defclass search-sponsors-handler (admin-only-handler form-handler) +(defclass search-sponsors-handler (editor-only-handler form-handler) ()) (defmethod handle-form ((handler search-sponsors-handler) action req) (with-bos-cms-page (req :title "Search for sponsor"))) -(defclass edit-sponsor-handler (admin-only-handler edit-object-handler) +(defclass edit-sponsor-handler (editor-only-handler edit-object-handler) ()) (defmethod object-handler-get-object ((handler edit-sponsor-handler) req) @@ -182,7 +182,7 @@ (delete-object sponsor) (html (:p "The sponsor has been deleted")))) -(defclass complete-transfer-handler (admin-only-handler edit-object-handler) +(defclass complete-transfer-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'contract)) @@ -276,7 +276,7 @@ (t "not-logged-in"))))))) -(defclass cert-regen-handler (admin-only-handler edit-object-handler) +(defclass cert-regen-handler (editor-only-handler edit-object-handler) () (:default-initargs :class 'contract)) Modified: branches/bos/projects/bos/worldpay-test/tags.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/tags.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/tags.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -57,56 +57,60 @@ (html ((:base "href" href))))) (define-bknr-tag buy-sqm (&key children) - (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) - (let* ((numsqm (parse-integer (or numsqm numsqm1))) - ;; Wer ueber dieses Formular bestellt, ist ein neuer - ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine - ;; Profil-ID wird automatisch zugewiesen, sonstige Daten - ;; haben wir zu diesem Zeitpunkt noch nicht. XXX - ;; Überweisung wird nur für die deutsche und dänische - ;; Website angeboten, was passenderweise durch die folgende - ;; Überprüfung auch sicher gestellt wurde. Sollte man aber - ;; eventuell noch mal prüfen und sicher stellen. - (manual-transfer (or (scan #?r"rweisen" action) - (scan #?r"rweisung" action) - (scan #?r"verf" action))) - (sponsor (make-sponsor)) - (contract (make-contract sponsor numsqm - :download-only download-only - :expires (+ (if manual-transfer - bos.m2::*manual-contract-expiry-time* - bos.m2::*online-contract-expiry-time*) - (get-universal-time)))) - (language (session-variable :language))) - (destructuring-bind (price currency) - (case (make-keyword-from-string language) - (:da (list (* numsqm 24) "DKK")) - (t (list (* numsqm 3) "EUR"))) - (setf (get-template-var :worldpay-url) - (if manual-transfer - (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" - (store-object-id contract) - price - numsqm - donationcert-yearly) - (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" - *worldpay-installation-id* - (store-object-id contract) - price - currency - language - (encode-urlencoded (format nil "~A ~A Samboja Lestari" - numsqm - (case (make-keyword-from-string language) - (:de "qm Regenwald in") - (:da "m2 Regnskov i") - (t "sqm rain forest in")))) - (store-object-id sponsor) - (sponsor-master-code sponsor) - (if donationcert-yearly "1" "0") - (if gift "1" "0") - (when *worldpay-test-mode* "&testMode=100")))))) - (mapc #'emit-template-node children))) + (handler-case + (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) + (let* ((numsqm (parse-integer (or numsqm numsqm1))) + ;; Wer ueber dieses Formular bestellt, ist ein neuer + ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine + ;; Profil-ID wird automatisch zugewiesen, sonstige Daten + ;; haben wir zu diesem Zeitpunkt noch nicht. + ;; Überweisung wird nur für die deutsche und dänische + ;; Website angeboten, was passenderweise durch die folgende + ;; Überprüfung auch sicher gestellt wurde. Sollte man aber + ;; eventuell noch mal prüfen und sicher stellen. + (manual-transfer (or (scan #?r"rweisen" action) + (scan #?r"rweisung" action) + (scan #?r"verf" action))) + (sponsor (make-sponsor)) + (contract (make-contract sponsor numsqm + :download-only download-only + :expires (+ (if manual-transfer + bos.m2::*manual-contract-expiry-time* + bos.m2::*online-contract-expiry-time*) + (get-universal-time)))) + (language (session-variable :language))) + (destructuring-bind (price currency) + (case (make-keyword-from-string language) + (:da (list (* numsqm 24) "DKK")) + (t (list (* numsqm 3) "EUR"))) + (setf (get-template-var :worldpay-url) + (if manual-transfer + (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" + (store-object-id contract) + price + numsqm + donationcert-yearly) + (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" + *worldpay-installation-id* + (store-object-id contract) + price + currency + language + (encode-urlencoded (format nil "~A ~A Samboja Lestari" + numsqm + (case (make-keyword-from-string language) + (:de "qm Regenwald in") + (:da "m2 Regnskov i") + (t "sqm rain forest in")))) + (store-object-id sponsor) + (sponsor-master-code sponsor) + (if donationcert-yearly "1" "0") + (if gift "1" "0") + (when *worldpay-test-mode* "&testMode=100")))))) + (mapc #'emit-template-node children)) + (bos.m2::allocation-areas-exhausted (e) + (declare (ignore e)) + (bknr.web::redirect-request :target "allocation-areas-exhausted")))) (define-bknr-tag mail-transfer () (with-query-params ((get-template-var :request) @@ -163,6 +167,6 @@ (mapc #'emit-template-node children)) (define-bknr-tag admin-login-page (&key children) - (if (admin-p (bknr-request-user (get-template-var :request))) + (if (editor-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 Modified: branches/bos/projects/bos/worldpay-test/worldpay-test.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/worldpay-test.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/worldpay-test.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -115,7 +115,7 @@ (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req))))) (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req)) -(defclass statistics-handler (admin-only-handler prefix-handler) +(defclass statistics-handler (editor-only-handler prefix-handler) ()) (defmethod handle ((handler statistics-handler) req) @@ -133,11 +133,11 @@ ((:p :id "stats")) ((:script :type "text/javascript") "statistic_selected()")))))) -(defclass admin-handler (admin-only-handler page-handler) +(defclass admin-handler (editor-only-handler page-handler) ()) (defmethod handle ((handler admin-handler) req) - (with-bos-cms-page (req :title "BOS CMS and Administration") + (with-bos-cms-page (req :title "CMS and Administration") "Please choose an administration activity from the menu above")) (defclass bos-authorizer (bknr-authorizer) @@ -183,7 +183,7 @@ (setf bknr.web:*upload-file-size-limit* 20000000) (make-instance 'bos-website - :name "BOS Website" + :name "create-rainforest.org CMS" :handler-definitions `(("/edit-poi" edit-poi-handler) ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) @@ -221,14 +221,14 @@ :command-packages ((:bos . :worldpay-test) (:bknr . :bknr.web)))) :modules '(user images stats) + :navigation '(("sponsor" . "edit-sponsor/") + ("statistics" . "statistics/") + ("news" . "edit-news/") + ("poi" . "edit-poi/") + ("logout" . "logout")) :admin-navigation '(("user" . "user/") - ("sponsor" . "edit-sponsor/") - ("statistics" . "statistics/") - ("news" . "edit-news/") - ("poi" . "edit-poi/") ("languages" . "languages") - ("allocation area" . "allocation-area/") - ("logout" . "logout")) + ("allocation area" . "allocation-area/")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css") Modified: branches/bos/thirdparty/iconv/iconv.lisp =================================================================== --- branches/bos/thirdparty/iconv/iconv.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/thirdparty/iconv/iconv.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -9,11 +9,11 @@ (in-package :iconv) -(cffi-uffi-compat:load-foreign-library "/usr/lib/libc.so") -(cffi-uffi-compat:load-foreign-library "/usr/local/lib/libiconv.so") +(load-foreign-library "/usr/lib/libc.so") +(load-foreign-library "/usr/local/lib/libiconv.so") #-sbcl -(cffi-uffi-compat:def-foreign-var ("errno" errno) :int "iconv") +(def-foreign-var ("errno" errno) :int "iconv") (defun get-errno () #-(or sbcl cmu19c) @@ -24,23 +24,23 @@ (sb-alien:get-errno) ) -(cffi-uffi-compat:def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte -(cffi-uffi-compat:def-constant EINVAL 22) ;imcomplete multibyte -(cffi-uffi-compat:def-constant E2BIG 7) ;not enough outbuf +(def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte +(def-constant EINVAL 22) ;imcomplete multibyte +(def-constant E2BIG 7) ;not enough outbuf -(cffi-uffi-compat:def-foreign-type uchar-ptr (* :unsigned-char)) -(cffi-uffi-compat:def-foreign-type iconv-t :pointer-void) +(def-foreign-type uchar-ptr (* :unsigned-char)) +(def-foreign-type iconv-t :pointer-void) -(cffi-uffi-compat:def-function ("iconv_open" iconv-open) +(def-function ("iconv_open" iconv-open) ((tocode :cstring) (fromcode :cstring)) :returning 'iconv-t) -(cffi-uffi-compat:def-function ("iconv_close" iconv-close) +(def-function ("iconv_close" iconv-close) ((cd 'iconv-t)) :returning :int) -(cffi-uffi-compat:def-function ("iconv" %iconv) +(def-function ("iconv" %iconv) ((cd 'iconv-t) (inbuf (* uchar-ptr)) (inbytesleft (* :unsigned-long)) @@ -49,7 +49,7 @@ :returning :unsigned-int) (defmacro with-iconv-cd ((cd from to) &body body) - `(cffi-uffi-compat:with-cstrings ((fromcode ,from) + `(with-cstrings ((fromcode ,from) (tocode ,to)) (let ((,cd (iconv-open tocode fromcode))) (unwind-protect @@ -63,21 +63,21 @@ (with-iconv-cd (cd from-code to-code) (let* ((from-len (length from-string)) (to-len (* from-len 2)) - (inbuffer (cffi-uffi-compat:convert-to-foreign-string from-string)) - (outbuffer (cffi-uffi-compat:allocate-foreign-string to-len :unsigned t)) - (in-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr)) - (out-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr)) - (inbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int)) - (outbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int))) + (inbuffer (convert-to-foreign-string from-string)) + (outbuffer (allocate-foreign-string to-len :unsigned t)) + (in-ptr (allocate-foreign-object 'uchar-ptr)) + (out-ptr (allocate-foreign-object 'uchar-ptr)) + (inbytesleft (allocate-foreign-object :unsigned-int)) + (outbytesleft (allocate-foreign-object :unsigned-int))) (unwind-protect (progn - (setf (cffi-uffi-compat:deref-pointer in-ptr 'uchar-ptr) inbuffer - (cffi-uffi-compat:deref-pointer out-ptr 'uchar-ptr) outbuffer - (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int) from-len - (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int) to-len) + (setf (deref-pointer in-ptr 'uchar-ptr) inbuffer + (deref-pointer out-ptr 'uchar-ptr) outbuffer + (deref-pointer inbytesleft :unsigned-int) from-len + (deref-pointer outbytesleft :unsigned-int) to-len) (labels ((current () - (- from-len (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int))) + (- from-len (deref-pointer inbytesleft :unsigned-int))) (self () (when (= (%iconv cd in-ptr inbytesleft @@ -91,10 +91,10 @@ (self))) (error "unexpected iconv error ~A" (get-errno)))))) (self)) - (cffi-uffi-compat:convert-from-foreign-string outbuffer :length (- to-len (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int)))) - (cffi-uffi-compat:free-foreign-object outbytesleft) - (cffi-uffi-compat:free-foreign-object inbytesleft) - (cffi-uffi-compat:free-foreign-object out-ptr) - (cffi-uffi-compat:free-foreign-object in-ptr) - (cffi-uffi-compat:free-foreign-object outbuffer) - (cffi-uffi-compat:free-foreign-object inbuffer)))))) + (convert-from-foreign-string outbuffer :length (- to-len (deref-pointer outbytesleft :unsigned-int)))) + (free-foreign-object outbytesleft) + (free-foreign-object inbytesleft) + (free-foreign-object out-ptr) + (free-foreign-object in-ptr) + (free-foreign-object outbuffer) + (free-foreign-object inbuffer))))))

1 0

[bknr-cvs] r2174 - branches/bos/projects/bos/worldpay-test
by bknr＠bknr.net 11 Sep '07

11 Sep '07

Author: hhubner Date: 2007-09-11 04:41:27 -0400 (Tue, 11 Sep 2007) New Revision: 2174 Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp Log: Add checkbox for donation cert. Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:40:55 UTC (rev 2173) +++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) @@ -83,8 +83,10 @@ do (html ((:option :value language-symbol) (:princ-safe language-name))))))) (:tr (:td "Name for certificate") (:td (text-field "name" :size 20))) - (:tr (:td "Postal address for certificate" - (:td (textarea-field "address" :rows 5 :cols 40)))) + (:tr (:td "Postal address for certificate") + (:td (textarea-field "address" :rows 5 :cols 40))) + (:tr (:td "Issue donation cert at the end of the year") + (:td (checkbox-field "donationcert-yearly" "" :checked nil))) (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))) (defun date-to-universal (date-string)

1 0

[bknr-cvs] r2173 - branches/bos/projects/bos/m2
by bknr＠bknr.net 11 Sep '07

11 Sep '07

Author: hhubner Date: 2007-09-11 04:40:55 -0400 (Tue, 11 Sep 2007) New Revision: 2173 Modified: branches/bos/projects/bos/m2/mail-generator.lisp Log: Properly destructure parameter list. Modified: branches/bos/projects/bos/m2/mail-generator.lisp =================================================================== --- branches/bos/projects/bos/m2/mail-generator.lisp 2007-08-30 09:43:19 UTC (rev 2172) +++ branches/bos/projects/bos/m2/mail-generator.lisp 2007-09-11 08:40:55 UTC (rev 2173) @@ -185,7 +185,7 @@ " (apply #'append (mapcar #'(lambda (cons) - (destructuring-bind (element-name content) cons + (destructuring-bind (element-name . content) cons (setf element-name (lookup-element-name element-name)) (list element-name (if (find #\Newline content)

1 0

[bknr-cvs] r2172 - in branches/bos/projects/bos: m2 payment-website/templates/da payment-website/templates/de
by bknr＠bknr.net 30 Aug '07

30 Aug '07

Author: hhubner Date: 2007-08-30 05:43:19 -0400 (Thu, 30 Aug 2007) New Revision: 2172 Modified: branches/bos/projects/bos/m2/mail-generator.lisp branches/bos/projects/bos/payment-website/templates/da/ueberweisung.xml branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml Log: copy previous commit to branch. Modified: branches/bos/projects/bos/m2/mail-generator.lisp =================================================================== --- branches/bos/projects/bos/m2/mail-generator.lisp 2007-08-30 09:29:34 UTC (rev 2171) +++ branches/bos/projects/bos/m2/mail-generator.lisp 2007-08-30 09:43:19 UTC (rev 2172) @@ -27,8 +27,8 @@ text))) (defun mail-info-request (email) - (send-system-mail :subject "Mailinglisten-Eintrag" - :text #?"Bitte in die Info-Mailingliste aufnehmen: + (send-system-mail :subject "Mailing list request" + :text #?"Please enter into the mailing list: $(email) @@ -158,6 +158,20 @@ :encoding :quoted-printable :content string)) +(defparameter *common-element-names* + '(("MC_donationcert-yearly" "donationcert-yearly") + ("MC_sponsorid" "sponsor-id") + ("countryString" "country") + ("postcode" "plz") + ("MC_gift" "gift") + ("cartId" "contract-id"))) + +(defun lookup-element-name (element-name) + "Given an ELEMENT-NAME (which may be either a form field name or a name of a post parameter from +worldpay), return the common XML element name" + (or (cdr (find element-name *common-element-names* :key #'car :test #'equal)) + element-name)) + (defun make-contract-xml-part (id params) (make-instance 'text-mime :type "text" @@ -169,13 +183,16 @@ ~{<~A>~A</~A>~} </sponsor> " - (apply #'append (mapcar #'(lambda (cons) - (list (car cons) - (if (find #\Newline (cdr cons)) - (format nil "<![CDATA[~A]]>" (cdr cons)) - (cdr cons)) - (car cons))) - params))))) + (apply #'append + (mapcar #'(lambda (cons) + (destructuring-bind (element-name content) cons + (setf element-name (lookup-element-name element-name)) + (list element-name + (if (find #\Newline content) + (format nil "<![CDATA[~A]]>" content) + content) + element-name))) + params))))) (defun make-vcard-part (id vcard) (make-instance 'text-mime @@ -194,7 +211,7 @@ :encoding :base64 :content (file-contents (contract-pdf-pathname contract :print t))))))) (send-system-mail :to (contract-office-email contract) - :subject (format nil "~A-Spenderdaten - Sponsor-ID ~D Contract-ID ~D" + :subject (format nil "~A-Sponsor data - Sponsor-ID ~D Contract-ID ~D" type (store-object-id (contract-sponsor contract)) (store-object-id contract)) @@ -214,12 +231,12 @@ (let ((parts (list (make-html-part (format nil " <html> <body> - <h1>Manuell erfasste Sponsordaten:</h1> + <h1>Manually entered sponsor data:</h1> <table border=\"1\"> <tr><td>Contract-ID</td><td>~@[~A~]</td></tr> - <tr><td>Anzahl sqm</td><td>~A</td></tr> + <tr><td>Number of sqm</td><td>~A</td></tr> <tr><td>Name</td><td>~@[~A~]</td></tr> - <tr><td>Adresse</td><td>~@[~A~]</td></tr> + <tr><td>Adress</td><td>~@[~A~]</td></tr> <tr><td>Email</td><td>~@[~A~]</td></tr> </table> </body> @@ -245,7 +262,7 @@ :name name :address address :email email))))) - (mail-contract-data contract "Manuell erfasster Sponsor" parts)))) + (mail-contract-data contract "Manually entered sponsor" parts)))) (defun mail-manual-sponsor-data (req) (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) @@ -254,26 +271,28 @@ (parts (list (make-html-part (format nil " <html> <body> - <h1>Ueberweisungsformulardaten:</h1> + <h1>Sponsor data as entered by the sponsor:</h1> <table border=\"1\"> <tr><td>Contract-ID</td><td>~@[~A~]</td></tr> - <tr><td>Anzahl sqm</td><td>~A</td></tr> - <tr><td>Vorname</td><td>~@[~A~]</td></tr> - <tr><td>Name</td><td>~@[~A~]</td></tr> - <tr><td>Strasse</td><td>~@[~A~]</td></tr> - <tr><td>PLZ</td><td>~@[~A~]</td></tr> - <tr><td>Ort</td><td>~@[~A~]</td></tr> + <tr><td>Number of sqm</td><td>~A</td></tr> + <tr><td>Amount</td><td>EUR~A</td></tr> + <tr><td>First name</td><td>~@[~A~]</td></tr> + <tr><td>Last name</td><td>~@[~A~]</td></tr> + <tr><td>Street</td><td>~@[~A~]</td></tr> + <tr><td>Postcode</td><td>~@[~A~]</td></tr> + <tr><td>City</td><td>~@[~A~]</td></tr> <tr><td>Email</td><td>~@[~A~]</td></tr> - <tr><td>Telefon</td><td>~@[~A~]</td></tr>~@[ + <tr><td>Phone</td><td>~@[~A~]</td></tr>~@[ <tr><td></td></tr> - <tr><td>Spendenbescheinigung am Jahresende</td><td>~A</td></tr>~] + <tr><td>Donation receipt at year's end</td><td>~A</td></tr>~] </table> - <p><a href=\"~A/complete-transfer/~A?email=~A\">Zahlungseingang bestätigen</a></p> + <p><a href=\"~A/complete-transfer/~A?email=~A\">Acknowledge receipt of payment</a></p> </body> </html> " contract-id (length (contract-m2s contract)) + (* 3.0 (length (contract-m2s contract))) vorname name strasse plz ort email telefon (if donationcert-yearly "ja" "nein") *website-url* contract-id email)) Modified: branches/bos/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/da/ueberweisung.xml 2007-08-30 09:29:34 UTC (rev 2171) +++ branches/bos/projects/bos/payment-website/templates/da/ueberweisung.xml 2007-08-30 09:43:19 UTC (rev 2172) @@ -43,6 +43,9 @@ onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Anuller venligst dette felt \'Fornavn\'.','name','#q','0','Anuller venligst dette felt \'Efternavn\'.','strasse','#q','0','Anuller venligst dette felt \'Gade/Nr.\'.','plz','#q','0','Anuller venligst dette felt \'Postnummer\'.','ort','#q','0','Anuller venligst dette felt \'Kommune\'.');return document.MM_returnValue"> <input type="hidden" name="country" value="DK" /> <input type="hidden" name="contract-id" value="$(contract-id)" /> + <input type="hidden" name="amount" value="$(amount)" /> + <input type="hidden" name="numsqm" value="$(numsqm)" /> + <input type="hidden" name="gift" value="$(gift)" /> <input type="hidden" name="donationcert-yearly" value="$(donationcert-yearly)" /> <table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0"> <tr> Modified: branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml 2007-08-30 09:29:34 UTC (rev 2171) +++ branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml 2007-08-30 09:43:19 UTC (rev 2172) @@ -42,6 +42,9 @@ id="mailtransfer" onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue"> <input type="hidden" name="contract-id" value="$(contract-id)" /> + <input type="hidden" name="amount" value="$(amount)" /> + <input type="hidden" name="numsqm" value="$(numsqm)" /> + <input type="hidden" name="gift" value="$(gift)" /> <input type="hidden" name="donationcert-yearly" value="$(donationcert-yearly)" /> <table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0"> <tr>

1 0

[bknr-cvs] r2171 - in trunk/projects/bos: m2 payment-website/templates/da payment-website/templates/de
by bknr＠bknr.net 30 Aug '07

30 Aug '07

Author: hhubner Date: 2007-08-30 05:29:34 -0400 (Thu, 30 Aug 2007) New Revision: 2171 Modified: trunk/projects/bos/m2/mail-generator.lisp trunk/projects/bos/payment-website/templates/da/ueberweisung.xml trunk/projects/bos/payment-website/templates/de/ueberweisung.xml Log: Unify XML formatted sponsor records. Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2007-08-30 06:08:39 UTC (rev 2170) +++ trunk/projects/bos/m2/mail-generator.lisp 2007-08-30 09:29:34 UTC (rev 2171) @@ -27,8 +27,8 @@ text))) (defun mail-info-request (email) - (send-system-mail :subject "Mailinglisten-Eintrag" - :text #?"Bitte in die Info-Mailingliste aufnehmen: + (send-system-mail :subject "Mailing list request" + :text #?"Please enter into the mailing list: $(email) @@ -158,6 +158,20 @@ :encoding :quoted-printable :content string)) +(defparameter *common-element-names* + '(("MC_donationcert-yearly" "donationcert-yearly") + ("MC_sponsorid" "sponsor-id") + ("countryString" "country") + ("postcode" "plz") + ("MC_gift" "gift") + ("cartId" "contract-id"))) + +(defun lookup-element-name (element-name) + "Given an ELEMENT-NAME (which may be either a form field name or a name of a post parameter from +worldpay), return the common XML element name" + (or (cdr (find element-name *common-element-names* :key #'car :test #'equal)) + element-name)) + (defun make-contract-xml-part (id params) (make-instance 'text-mime :type "text" @@ -169,13 +183,16 @@ ~{<~A>~A</~A>~} </sponsor> " - (apply #'append (mapcar #'(lambda (cons) - (list (car cons) - (if (find #\Newline (cdr cons)) - (format nil "<![CDATA[~A]]>" (cdr cons)) - (cdr cons)) - (car cons))) - params))))) + (apply #'append + (mapcar #'(lambda (cons) + (destructuring-bind (element-name content) cons + (setf element-name (lookup-element-name element-name)) + (list element-name + (if (find #\Newline content) + (format nil "<![CDATA[~A]]>" content) + content) + element-name))) + params))))) (defun make-vcard-part (id vcard) (make-instance 'text-mime @@ -194,7 +211,7 @@ :encoding :base64 :content (file-contents (contract-pdf-pathname contract :print t))))))) (send-system-mail :to (contract-office-email contract) - :subject (format nil "~A-Spenderdaten - Sponsor-ID ~D Contract-ID ~D" + :subject (format nil "~A-Sponsor data - Sponsor-ID ~D Contract-ID ~D" type (store-object-id (contract-sponsor contract)) (store-object-id contract)) @@ -214,12 +231,12 @@ (let ((parts (list (make-html-part (format nil " <html> <body> - <h1>Manuell erfasste Sponsordaten:</h1> + <h1>Manually entered sponsor data:</h1> <table border=\"1\"> <tr><td>Contract-ID</td><td>~@[~A~]</td></tr> - <tr><td>Anzahl sqm</td><td>~A</td></tr> + <tr><td>Number of sqm</td><td>~A</td></tr> <tr><td>Name</td><td>~@[~A~]</td></tr> - <tr><td>Adresse</td><td>~@[~A~]</td></tr> + <tr><td>Adress</td><td>~@[~A~]</td></tr> <tr><td>Email</td><td>~@[~A~]</td></tr> </table> </body> @@ -245,7 +262,7 @@ :name name :address address :email email))))) - (mail-contract-data contract "Manuell erfasster Sponsor" parts)))) + (mail-contract-data contract "Manually entered sponsor" parts)))) (defun mail-manual-sponsor-data (req) (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) @@ -254,26 +271,28 @@ (parts (list (make-html-part (format nil " <html> <body> - <h1>Ueberweisungsformulardaten:</h1> + <h1>Sponsor data as entered by the sponsor:</h1> <table border=\"1\"> <tr><td>Contract-ID</td><td>~@[~A~]</td></tr> - <tr><td>Anzahl sqm</td><td>~A</td></tr> - <tr><td>Vorname</td><td>~@[~A~]</td></tr> - <tr><td>Name</td><td>~@[~A~]</td></tr> - <tr><td>Strasse</td><td>~@[~A~]</td></tr> - <tr><td>PLZ</td><td>~@[~A~]</td></tr> - <tr><td>Ort</td><td>~@[~A~]</td></tr> + <tr><td>Number of sqm</td><td>~A</td></tr> + <tr><td>Amount</td><td>EUR~A</td></tr> + <tr><td>First name</td><td>~@[~A~]</td></tr> + <tr><td>Last name</td><td>~@[~A~]</td></tr> + <tr><td>Street</td><td>~@[~A~]</td></tr> + <tr><td>Postcode</td><td>~@[~A~]</td></tr> + <tr><td>City</td><td>~@[~A~]</td></tr> <tr><td>Email</td><td>~@[~A~]</td></tr> - <tr><td>Telefon</td><td>~@[~A~]</td></tr>~@[ + <tr><td>Phone</td><td>~@[~A~]</td></tr>~@[ <tr><td></td></tr> - <tr><td>Spendenbescheinigung am Jahresende</td><td>~A</td></tr>~] + <tr><td>Donation receipt at year's end</td><td>~A</td></tr>~] </table> - <p><a href=\"~A/complete-transfer/~A?email=~A\">Zahlungseingang bestätigen</a></p> + <p><a href=\"~A/complete-transfer/~A?email=~A\">Acknowledge receipt of payment</a></p> </body> </html> " contract-id (length (contract-m2s contract)) + (* 3.0 (length (contract-m2s contract))) vorname name strasse plz ort email telefon (if donationcert-yearly "ja" "nein") *website-url* contract-id email)) Modified: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2007-08-30 06:08:39 UTC (rev 2170) +++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2007-08-30 09:29:34 UTC (rev 2171) @@ -43,6 +43,9 @@ onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Anuller venligst dette felt \'Fornavn\'.','name','#q','0','Anuller venligst dette felt \'Efternavn\'.','strasse','#q','0','Anuller venligst dette felt \'Gade/Nr.\'.','plz','#q','0','Anuller venligst dette felt \'Postnummer\'.','ort','#q','0','Anuller venligst dette felt \'Kommune\'.');return document.MM_returnValue"> <input type="hidden" name="country" value="DK" /> <input type="hidden" name="contract-id" value="$(contract-id)" /> + <input type="hidden" name="amount" value="$(amount)" /> + <input type="hidden" name="numsqm" value="$(numsqm)" /> + <input type="hidden" name="gift" value="$(gift)" /> <input type="hidden" name="donationcert-yearly" value="$(donationcert-yearly)" /> <table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0"> <tr> Modified: trunk/projects/bos/payment-website/templates/de/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2007-08-30 06:08:39 UTC (rev 2170) +++ trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2007-08-30 09:29:34 UTC (rev 2171) @@ -42,6 +42,9 @@ id="mailtransfer" onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue"> <input type="hidden" name="contract-id" value="$(contract-id)" /> + <input type="hidden" name="amount" value="$(amount)" /> + <input type="hidden" name="numsqm" value="$(numsqm)" /> + <input type="hidden" name="gift" value="$(gift)" /> <input type="hidden" name="donationcert-yearly" value="$(donationcert-yearly)" /> <table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0"> <tr>

1 0

[bknr-cvs] r2170 - branches
by bknr＠bknr.net 30 Aug '07

30 Aug '07

Author: hhubner Date: 2007-08-30 02:08:39 -0400 (Thu, 30 Aug 2007) New Revision: 2170 Added: branches/bos/ Log: Create branch to move BOS project in to. Manuel plans on committing a lot of changes to baseline bknr, but the BOS project will stay on this development line for the foreseeable future. Copied: branches/bos (from rev 2169, trunk)

1 0

[bknr-cvs] r2169 - trunk/projects/bos/payment-website/images
by bknr＠bknr.net 16 Aug '07

16 Aug '07

Author: hhubner Date: 2007-08-16 04:30:11 -0400 (Thu, 16 Aug 2007) New Revision: 2169 Modified: trunk/projects/bos/payment-website/images/certificat.jpg Log: New version of this file. Modified: trunk/projects/bos/payment-website/images/certificat.jpg =================================================================== (Binary files differ)

1 0