bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] edi changed tags/thirdparty/cl-unicode-0.1.1/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3623 Author: edi URL: http://bknr.net/trac/changeset/3623 Tag version 0.1.1 A tags/thirdparty/cl-unicode-0.1.1/ Copied: tags/thirdparty/cl-unicode-0.1.1 (from rev 3622, trunk/thirdparty/cl-unicode)

1 0

[bknr-cvs] edi changed trunk/thirdparty/cl-unicode/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3622 Author: edi URL: http://bknr.net/trac/changeset/3622 Update to 0.1.1 U trunk/thirdparty/cl-unicode/CHANGELOG.txt U trunk/thirdparty/cl-unicode/api.lisp U trunk/thirdparty/cl-unicode/cl-unicode.asd U trunk/thirdparty/cl-unicode/doc/index.html U trunk/thirdparty/cl-unicode/packages.lisp U trunk/thirdparty/cl-unicode/specials.lisp U trunk/thirdparty/cl-unicode/util.lisp Modified: trunk/thirdparty/cl-unicode/CHANGELOG.txt =================================================================== --- trunk/thirdparty/cl-unicode/CHANGELOG.txt 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/CHANGELOG.txt 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,3 +1,7 @@ +Version 0.1.1 +2008-07-24 +Make ADD-HANGUL-NAMES faster for ClozureCL + Version 0.1.0 2008-07-24 Initial release Modified: trunk/thirdparty/cl-unicode/api.lisp =================================================================== --- trunk/thirdparty/cl-unicode/api.lisp 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/api.lisp 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/api.lisp,v 1.30 2008/07/22 02:42:13 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/api.lisp,v 1.31 2008/07/24 14:46:20 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -39,6 +39,7 @@ (unicode-name (char-code char))) (:method ((code-point integer)) (or (gethash code-point *code-points-to-names*) + (maybe-compute-hangul-syllable-name code-point) (maybe-compute-cjk-name code-point)))) (defgeneric unicode1-name (c) @@ -102,6 +103,7 @@ (setq scripts-to-try (list scripts-to-try))) (let* ((canonicalized-name (canonicalize-name name)) (code-point (or (gethash canonicalized-name *names-to-code-points*) + (maybe-find-hangul-syllable-code-point canonicalized-name) (maybe-find-cjk-code-point canonicalized-name) (and try-unicode1-names-p (gethash canonicalized-name *unicode1-names-to-code-points*)) Modified: trunk/thirdparty/cl-unicode/cl-unicode.asd =================================================================== --- trunk/thirdparty/cl-unicode/cl-unicode.asd 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/cl-unicode.asd 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/cl-unicode.asd,v 1.21 2008/07/21 22:09:22 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/cl-unicode.asd,v 1.22 2008/07/24 14:56:31 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -63,7 +63,7 @@ (call-next-method)) (defsystem :cl-unicode - :version "0.1.0" + :version "0.1.1" :serial t :depends-on (:cl-ppcre) :components ((:file "packages") Modified: trunk/thirdparty/cl-unicode/doc/index.html =================================================================== --- trunk/thirdparty/cl-unicode/doc/index.html 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/doc/index.html 2008-07-24 14:58:40 UTC (rev 3622) @@ -72,7 +72,7 @@ CL-UNICODE together with this documentation can be downloaded from <a href="http://weitz.de/files/cl-unicode.tar.gz">http://weitz.de/files/cl-unicode.tar.gz</a>. The -current version is 0.1.0. +current version is 0.1.1. <p> The library comes with a system definition for <a href="http://www.cliki.net/asdf">ASDF</a> and you compile and @@ -1270,7 +1270,7 @@ This documentation was prepared with <a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>. </p> <p> -$Header: /usr/local/cvsrep/cl-unicode/doc/index.html,v 1.12 2008/07/23 14:55:26 edi Exp $ +$Header: /usr/local/cvsrep/cl-unicode/doc/index.html,v 1.13 2008/07/24 14:56:33 edi Exp $ <p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body> Modified: trunk/thirdparty/cl-unicode/packages.lisp =================================================================== --- trunk/thirdparty/cl-unicode/packages.lisp 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/packages.lisp 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/packages.lisp,v 1.23 2008/07/22 02:42:13 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/packages.lisp,v 1.24 2008/07/24 14:46:20 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -31,7 +31,9 @@ (defpackage :cl-unicode (:use :cl) - (:import-from :cl-ppcre :with-rebinding) + (:import-from :cl-ppcre + :*standard-optimize-settings* + :with-rebinding) (:export :+code-point-limit+ :*scripts-to-try* :*try-abbreviations-p* Modified: trunk/thirdparty/cl-unicode/specials.lisp =================================================================== --- trunk/thirdparty/cl-unicode/specials.lisp 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/specials.lisp 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/specials.lisp,v 1.14 2008/07/23 01:08:24 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/specials.lisp,v 1.16 2008/07/24 14:50:37 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -36,7 +36,7 @@ "A hash tables which maps property symbols \(see PROPERTY-SYMBOL) to their \"canonical names\", i.e. to strings.") -(defvar *names-to-code-points* (make-hash-table :test 'equalp :size 31000) +(defvar *names-to-code-points* (make-hash-table :test 'equalp :size 20000) "A hash table which \(case-insensitively) maps \"canonicalized\" character names to their code points.") @@ -44,7 +44,7 @@ "A hash table which \(case-insensitively) maps \"canonicalized\" Unicode 1.0 character names to their code points.") -(defvar *code-points-to-names* (make-hash-table :size 31000) +(defvar *code-points-to-names* (make-hash-table :size 20000) "A hash table which maps code points to the corresponding character names.") @@ -85,6 +85,10 @@ "A hash table which maps code points to their Jamo short names. Needed to compute Hangul syllable names - see COMPUTE-HANGUL-NAME.") +(defvar *hangul-syllables-to-code-points* (make-hash-table :test 'equalp :size 12000) + "A hash table which \(case-insensitively) maps Hangul syllable name +parts to their code points.") + (defvar *try-unicode1-names-p* t "This is the default value for the :TRY-UNICODE1-NAMES-P keyword argument to CHARACTER-NAMED.") Modified: trunk/thirdparty/cl-unicode/util.lisp =================================================================== --- trunk/thirdparty/cl-unicode/util.lisp 2008-07-24 14:50:37 UTC (rev 3621) +++ trunk/thirdparty/cl-unicode/util.lisp 2008-07-24 14:58:40 UTC (rev 3622) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/util.lisp,v 1.27 2008/07/23 14:11:40 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/util.lisp,v 1.29 2008/07/24 14:46:20 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -166,45 +166,75 @@ (when (cjk-unified-ideograph-p code-point) code-point))) -(defconstant +s-base+ #xac00 - "The constant `SBase' from chapter 3 of the Unicode book.") -(defconstant +l-base+ #x1100 - "The constant `LBase' from chapter 3 of the Unicode book.") -(defconstant +v-base+ #x1161 - "The constant `VBase' from chapter 3 of the Unicode book.") -(defconstant +t-base+ #x11a7 - "The constant `TBase' from chapter 3 of the Unicode book.") -(defconstant +v-count+ 21 - "The constant `VCount' from chapter 3 of the Unicode book.") -(defconstant +t-count+ 28 - "The constant `TCount' from chapter 3 of the Unicode book.") -(define-symbol-macro +n-count+ - ;; the constant `NCount' from chapter 3 of the Unicode book - (* +v-count+ +t-count+)) +(defmacro define-hangul-constant (name value) + (flet ((create-symbol (name) + (intern (format nil "+~:@(~C-~A~)+" (char name 0) (subseq name 1)) :cl-unicode))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,(create-symbol name) ,value + ,(format nil "The constant `~A' from chapter 3 of the Unicode book." name))))) +(define-hangul-constant "SBase" #xac00) +(define-hangul-constant "LBase" #x1100) +(define-hangul-constant "VBase" #x1161) +(define-hangul-constant "TBase" #x11a7) +(define-hangul-constant "VCount" 21) +(define-hangul-constant "TCount" 28) +(define-hangul-constant "NCount" (* +v-count+ +t-count+)) + +(declaim (inline compute-hangul-name)) (defun compute-hangul-name (code-point) - "Algorithmically derives the Hangul syllable name of the character -with code point CODE-POINT as described in section 3.12 of the Unicode -book." + "Algorithmically derives the Hangul syllable name \(the part behind +\"HANGUL SYLLABLE \") of the character with code point CODE-POINT as +described in section 3.12 of the Unicode book." + (declare #.*standard-optimize-settings*) + (declare (fixnum code-point)) (let* ((s-index (- code-point +s-base+)) (l-value (+ +l-base+ (floor s-index +n-count+))) (v-value (+ +v-base+ (floor (mod s-index +n-count+) +t-count+))) (t-value (+ +t-base+ (mod s-index +t-count+)))) - (format nil "HANGUL SYLLABLE ~A~A~@[~A~]" + (declare (fixnum s-index t-value)) + (format nil "~A~A~@[~A~]" (gethash l-value *jamo-short-names*) (gethash v-value *jamo-short-names*) (and (/= t-value +t-base+) (gethash t-value *jamo-short-names*))))) +(defconstant +first-hangul-syllable+ #xac00 + "The code point of the first Hangul syllable the name of which can +be algorithmically derived.") +(defconstant +last-hangul-syllable+ #xd7a3 + "The code point of the last Hangul syllable the name of which can be +algorithmically derived.") + (defun add-hangul-names () "Computes the names for all Hangul syllables and registers them in -the appropriate hash tables." +the *HANGUL-SYLLABLES-TO-CODE-POINTS* hash table. Used for +CHARACTER-NAMED." + (declare #.*standard-optimize-settings*) (format t "~&;;; Computing Hangul syllable names") - (loop for code-point from #xac00 to #xd7a3 + (loop for code-point from +first-hangul-syllable+ to +last-hangul-syllable+ for name = (compute-hangul-name code-point) - do (setf (gethash (canonicalize-name name) *names-to-code-points*) code-point - (gethash code-point *code-points-to-names*) name))) + do (setf (gethash name *hangul-syllables-to-code-points*) code-point))) +(defun hangul-syllable-p (code-point) + "Returns a true value if CODE-POINT is the code point of a Hangul +syllable for which we can algorithmically derive the name." + (<= +first-hangul-syllable+ code-point +last-hangul-syllable+)) + +(defun maybe-compute-hangul-syllable-name (code-point) + "Computes the name for CODE-POINT if CODE-POINT denotes a Hangul +syllable the name of which can be algorithmically derived." + (when (hangul-syllable-p code-point) + (format nil "HANGUL SYLLABLE ~X" (compute-hangul-name code-point)))) + +(defun maybe-find-hangul-syllable-code-point (name) + "Computes the code point for NAME if NAME is the name of a Hangul +syllable the name of which can be algorithmically derived." + (ppcre:register-groups-bind (name) + ;; canonicalized + ("(?i)^HANGULSYLLABLE([A-Z]*)$" name) + (gethash name *hangul-syllables-to-code-points*))) + (defmacro ensure-code-point (c) "Helper macro so that C can be treated like a code point even if it is a Lisp character." @@ -214,7 +244,7 @@ (character (char-code ,c))))) (defun unicode-name-reader (stream char arg) - "The reader functino used when the alternative character syntax is + "The reader function used when the alternative character syntax is enabled." (declare (ignore char arg)) (let ((name (with-output-to-string (out)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3621 Author: ksprotte URL: http://bknr.net/trac/changeset/3621 renamed old kml-root handler to kml-root-dynamic U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 14:43:28 UTC (rev 3620) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 14:50:37 UTC (rev 3621) @@ -121,7 +121,7 @@ (when (sponsor-info-text sponsor) (text (sponsor-info-text sponsor)))))))) -(defclass kml-root-handler (object-handler) +(defclass kml-root-dynamic-handler (object-handler) ((timestamp :accessor timestamp :initform (get-universal-time)))) (defun write-root-kml (handler sponsor) @@ -187,13 +187,13 @@ :name (dictionary-entry "Country-Stats" lang) :hide-children t)))))) -(defmethod handle-object ((handler kml-root-handler) (object sponsor)) +(defmethod handle-object ((handler kml-root-dynamic-handler) (object sponsor)) (write-root-kml handler object)) -(defmethod handle-object ((handler kml-root-handler) (object contract)) +(defmethod handle-object ((handler kml-root-dynamic-handler) (object contract)) (handle-object handler (contract-sponsor object))) -(defmethod handle-object ((handler kml-root-handler) (object null)) +(defmethod handle-object ((handler kml-root-dynamic-handler) (object null)) (write-root-kml handler nil)) (defclass country-stats-handler (page-handler) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 14:43:28 UTC (rev 3620) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 14:50:37 UTC (rev 3621) @@ -200,6 +200,7 @@ ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) ("/kml-upload" kml-upload-handler) + ("/kml-root-dynamic" kml-root-dynamic-handler) ("/kml-root" kml-root-handler) ("/country-stats" country-stats-handler) ("/contract-tree-kml" contract-tree-kml-handler)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/kml-handlers.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3620 Author: ksprotte URL: http://bknr.net/trac/changeset/3620 kml-upload-handler allows also for downloading the kml-root file U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 13:51:29 UTC (rev 3619) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 14:43:28 UTC (rev 3620) @@ -55,9 +55,20 @@ line column))))))))) ;; we want this after the processing (:p (:format "last-change: ~A" - (format-date-time (store-object-last-change kml-root-data 0))))))) + (format-date-time (store-object-last-change kml-root-data 0))) + (cmslink (format nil "/kml-upload?lang=~A&action=download" language) + "download current version"))))) (submit-button "upload" "upload")))))) +(defmethod handle-form ((handler kml-upload-handler) (action (eql :download))) + (with-query-params (lang) + (setf (hunchentoot:header-out :content-type) + "application/binary" + (hunchentoot:header-out :content-disposition) + (format nil "attachment; filename=kml-root-~A.kml" lang)) + (let ((kml-root-data (kml-root-data-with-language lang))) + (kml-string kml-root-data)))) + ;;; kml-format utils (defun kml-format-points (points stream) (mapc #'(lambda (point) (kml-format-point point stream)) points))

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3619 Author: hans URL: http://bknr.net/trac/changeset/3619 Send out contract mails asynchronously, from separate thread. U trunk/projects/bos/build.lisp U trunk/projects/bos/m2/mail-generator.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/sponsor-handlers.lisp U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/build.lisp =================================================================== --- trunk/projects/bos/build.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/build.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -71,6 +71,7 @@ (apply #'bos.m2::reinit (read-configuration "m2.rc")) (apply #'bos.web::init (read-configuration "web.rc")) (bos.web::start-contract-tree-image-update-daemon) + (bos.m2::start-postmaster) (bknr.cron::start-cron)) (defun start-cert-daemon () Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -2,6 +2,43 @@ (enable-interpol-syntax) +(defvar *postmaster-queue-lock* (bt:make-lock "Postmaster Queue Lock")) + +(defvar *postmaster-queue* (make-queue)) + +(defvar *postmaster* nil) + +(defun postmaster-loop () + (loop + (sleep 2) + (loop + (let ((entry (bt:with-lock-held (*postmaster-queue-lock*) + (peek-queue *postmaster-queue*)))) + (when (or (null entry) + (not (contract-certificates-generated-p (second entry)))) + (return))) + (let ((entry (bt:with-lock-held (*postmaster-queue-lock*) + (dequeue *postmaster-queue*)))) + (handler-case + (destructuring-bind (function contract args) entry + (apply function contract args)) + (error (e) + (warn "; could not send mail ~S: ~A" entry e))))))) + +(defun postmaster-running-p () + (and *postmaster* + (bt:thread-alive-p *postmaster*))) + +(defun start-postmaster () + (unless (postmaster-running-p) + (setq *postmaster* + (bt:make-thread #'postmaster-loop + :name "postmaster")))) + +(defun send-to-postmaster (function contract &rest args) + (bt:with-lock-held (*postmaster-queue-lock*) + (enqueue (list function contract args) *postmaster-queue*))) + (defvar *country->office-email* '(("DK" . "bosdanmark.regnskov(a)gmail.com") ("SE" . "bosdanmark.regnskov(a)gmail.com"))) @@ -251,9 +288,9 @@ (ignore-errors (delete-file (contract-pdf-pathname contract :print t)))) -(defun mail-backoffice-sponsor-data (contract) - (with-query-params (numsqm country email name address date language) - (let ((parts (list (make-html-part (format nil " +(defun mail-backoffice-sponsor-data (contract numsqm country email name address language request-params) + (let* ((contract-id (store-object-id contract)) + (parts (list (make-html-part (format nil " <html> <body> <h1>Manually entered sponsor data:</h1> @@ -268,36 +305,35 @@ </table> </body> </html>" - (store-object-id contract) - numsqm - name - address - email - country - language)) - (make-contract-xml-part (store-object-id contract) (all-request-params)) - (make-vcard-part (store-object-id contract) - (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) - :note (format nil "Paid-by: Back office + contract-id + numsqm + name + address + email + country + language)) + (make-contract-xml-part (store-object-id contract) request-params) + (make-vcard-part (store-object-id contract) + (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) + :note (format nil "Paid-by: Back office Contract ID: ~A Sponsor ID: ~A Number of sqms: ~A Amount: EUR~A.00 " - (store-object-id contract) - (store-object-id (contract-sponsor contract)) - numsqm - (* 3 (parse-integer numsqm))) - :name name - :address address - :email email))))) - (mail-contract-data contract "Manually entered sponsor" parts)))) + (store-object-id contract) + (store-object-id (contract-sponsor contract)) + numsqm + (* 3 (parse-integer numsqm))) + :name name + :address address + :email email))))) + (mail-contract-data contract "Manually entered sponsor" parts))) -(defun mail-manual-sponsor-data () - (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) - (let* ((contract (store-object-with-id (parse-integer contract-id))) - (sponsor-id (store-object-id (contract-sponsor contract))) - (parts (list (make-html-part (format nil " +(defun mail-manual-sponsor-data (contract vorname name strasse plz ort email telefon want-print donationcert-yearly request-params) + (let* ((sponsor-id (store-object-id (contract-sponsor contract))) + (contract-id (store-object-id contract)) + (parts (list (make-html-part (format nil " <html> <body> <h1>Sponsor data as entered by the sponsor:</h1> @@ -320,35 +356,35 @@ </body> </html> " - contract-id - (length (contract-m2s contract)) - (* 3.0 (length (contract-m2s contract))) - vorname name strasse plz ort email telefon - (if want-print "yes" "no") - (if donationcert-yearly "yes" "no") - *website-url* contract-id (or email ""))) - (make-contract-xml-part contract-id (all-request-params)) - (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id - :note (format nil "Paid-by: Manual money transfer + (store-object-id contract) + (length (contract-m2s contract)) + (* 3.0 (length (contract-m2s contract))) + vorname name strasse plz ort email telefon + (if want-print "yes" "no") + (if donationcert-yearly "yes" "no") + *website-url* contract-id (or email ""))) + (make-contract-xml-part contract-id request-params) + (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id + :note (format nil "Paid-by: Manual money transfer Contract ID: ~A Sponsor ID: ~A Number of sqms: ~A Amount: EUR~A.00 Donationcert yearly: ~A " - contract-id - sponsor-id - (length (contract-m2s contract)) - (* 3 (length (contract-m2s contract))) - (if donationcert-yearly "Yes" "No")) - :vorname vorname - :nachname name - :strasse strasse - :postcode plz - :ort ort - :email email - :tel telefon))))) - (mail-contract-data contract "Ueberweisungsformular" parts)))) + contract-id + sponsor-id + (length (contract-m2s contract)) + (* 3 (length (contract-m2s contract))) + (if donationcert-yearly "Yes" "No")) + :vorname vorname + :nachname name + :strasse strasse + :postcode plz + :ort ort + :email email + :tel telefon))))) + (mail-contract-data contract "Ueberweisungsformular" parts))) (defvar *worldpay-params-hash* (make-hash-table :test #'equal)) @@ -356,17 +392,16 @@ "Remember the parameters sent in a callback request from Worldpay so that they can be mailed to the BOS office later on" (setf (gethash contract-id *worldpay-params-hash*) params)) -(defun get-worldpay-params (contract-id) +(defun get-worldpay-params (contract) (or (prog1 - (gethash contract-id *worldpay-params-hash*) - (remhash contract-id *worldpay-params-hash*)) - (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) + (gethash contract *worldpay-params-hash*) + (remhash contract *worldpay-params-hash*)) + (error "cannot find WorldPay callback params for contract ~A~%" contract))) -(defun mail-worldpay-sponsor-data () - (with-query-params (contract-id) - (let* ((contract (store-object-with-id (parse-integer contract-id))) - (params (get-worldpay-params contract-id)) - (parts (list (make-html-part (format nil " +(defun mail-worldpay-sponsor-data (contract) + (let* ((contract-id (store-object-id contract)) + (params (get-worldpay-params contract)) + (parts (list (make-html-part (format nil " <table border=\"1\"> <tr> <th>Parameter</th> @@ -375,10 +410,10 @@ ~{<tr><td>~A</td><td>~A</td></tr>~} </table> " - (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) - (sort (copy-list params) - #'string-lessp - :key #'car))))) - (make-contract-xml-part contract-id params) - (make-vcard-part contract-id (worldpay-callback-params-to-vcard params))))) - (mail-contract-data contract "WorldPay" parts)))) + (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) + (sort (copy-list params) + #'string-lessp + :key #'car))))) + (make-contract-xml-part contract-id params) + (make-vcard-part contract-id (worldpay-callback-params-to-vcard params))))) + (mail-contract-data contract "WorldPay" parts))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/m2/packages.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -251,6 +251,7 @@ #:news-item-title #:news-item-text + #:send-to-postmaster #:mail-fiscal-certificate-to-office #:mail-instructions-to-sponsor #:mail-info-request Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -114,7 +114,7 @@ (user-login (bknr.web:bknr-session-user))) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) - (mail-backoffice-sponsor-data contract) + (send-to-postmaster #'mail-backoffice-sponsor-data contract numsqm country email name address language (all-request-params)) (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)))))) (defun contract-checkbox-name (contract) Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/tags.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -42,7 +42,7 @@ (when (equal want-print "no") (contract-set-download-only-p contract t)) (contract-issue-cert contract name :address address :language (request-language)) - (mail-worldpay-sponsor-data) + (send-to-postmaster #'mail-worldpay-sponsor-data contract) (bknr.web::redirect-request :target (if gift "index" (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" (encode-urlencoded name) (encode-urlencoded email) @@ -122,7 +122,8 @@ (define-bknr-tag mail-transfer () (with-query-params (country contract-id - name vorname strasse plz ort) + name vorname strasse plz ort telefon want-print + email donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (download-only (< (contract-price contract) *mail-certificate-threshold*))) (with-transaction (:prepare-before-mail) @@ -134,7 +135,9 @@ strasse plz ort) :language (request-language)) - (mail-manual-sponsor-data)))) + (send-to-postmaster #'mail-manual-sponsor-data + contract vorname name strasse plz ort email telefon want-print donationcert-yearly + (all-request-params))))) (define-bknr-tag when-certificate () (let ((sponsor (bknr-session-user))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -29,8 +29,8 @@ (with-query-params (cartId name address country transStatus lang MC_gift) (unless (website-supports-language lang) (setf lang *default-language*)) - (bos.m2::remember-worldpay-params cartId (all-request-params)) (let ((contract (get-contract (parse-integer cartId)))) + (bos.m2::remember-worldpay-params contract (all-request-params)) (sponsor-set-language (contract-sponsor contract) lang) (cond ((not (typep contract 'contract))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3618 Author: ksprotte URL: http://bknr.net/trac/changeset/3618 tuned min lod for small-contracts, so that placemarks should be visible again on close-up U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-24 13:12:57 UTC (rev 3617) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-24 13:44:53 UTC (rev 3618) @@ -190,7 +190,7 @@ :key #'contract-area))) (when small-contracts (with-element "Folder" - (kml-region rect `(:min ,(* 6 (getf lod :min)) :max -1)) + (kml-region rect `(:min ,(* 3 (getf lod :min)) :max -1)) (dolist (c small-contracts) (write-contract-placemark-kml c lang)))) (when big-contracts

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3617 Author: ksprotte URL: http://bknr.net/trac/changeset/3617 made search-adjacent more robust for the (pathological) cases of the test-suite U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 12:46:58 UTC (rev 3616) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 13:12:57 UTC (rev 3617) @@ -304,10 +304,12 @@ (setf (gethash m2 allocated) t) (enqueue m2 border-queue)) (try-get (x y) - (let ((m2 (ensure-m2 x y))) - (when (and (not (gethash m2 allocated)) - (funcall pred m2)) - m2))) + (when (and (<= 0 x (1- +width+)) + (<= 0 y (1- +width+))) + (let ((m2 (ensure-m2 x y))) + (when (and (not (gethash m2 allocated)) + (funcall pred m2)) + m2)))) (get-next-neighbor (m2) (let ((x (m2-x m2)) (y (m2-y m2)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3616 Author: ksprotte URL: http://bknr.net/trac/changeset/3616 lets again have only 9 contract-tree layers U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-24 11:42:29 UTC (rev 3615) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-24 12:46:58 UTC (rev 3616) @@ -39,7 +39,7 @@ (defparameter *contract-tree-images-size* 128) ; was 256 (defmethod leaf-node-p ((node contract-node)) - (= 10 (depth node))) + (= 9 (depth node))) (defun contract-geo-box (contract) (destructuring-bind (x y width height)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3615 Author: hans URL: http://bknr.net/trac/changeset/3615 Replace a COND by an UNLESS to save two more lines and improve readability a little bit. U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:37 UTC (rev 3614) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:42:29 UTC (rev 3615) @@ -323,12 +323,10 @@ (if (queue-empty-p border-queue) (return nil) (let ((next (get-next-neighbor (peek-queue border-queue)))) - (cond - (next - (to-border-queue next)) - (t - (push (dequeue border-queue) completely-checked) - (go check-next))))))))))) + (unless next + (push (dequeue border-queue) completely-checked) + (go check-next)) + (to-border-queue next))))))))) (defun allocate-in-area (area n) (let* ((area-left (allocation-area-left area))

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3614 Author: hans URL: http://bknr.net/trac/changeset/3614 LET* -> LET U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:12 UTC (rev 3613) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:37 UTC (rev 3614) @@ -296,9 +296,9 @@ returns a true value if the argument specifies an allocatable square meter." (when (funcall pred m2) - (let* ((allocated (make-hash-table :test #'eq)) - (border-queue (make-queue)) - completely-checked) + (let ((allocated (make-hash-table :test #'eq)) + (border-queue (make-queue)) + completely-checked) (labels ((to-border-queue (m2) (setf (gethash m2 allocated) t)

1 0

← Newer
1
...
7
8
9
10
11
12
13
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008