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

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

28 Jul '08

Revision: 3663 Author: hans URL: http://bknr.net/trac/changeset/3663 Remove stripe related code and definitions. U trunk/projects/bos/m2/bos.dtd U trunk/projects/bos/m2/export.lisp U trunk/projects/bos/m2/import.lisp Modified: trunk/projects/bos/m2/bos.dtd =================================================================== --- trunk/projects/bos/m2/bos.dtd 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/bos.dtd 2008-07-28 14:39:46 UTC (rev 3663) @@ -72,7 +72,7 @@ ! Zustand der Vergabe werden anhand von internen (x,y) Koordinaten gefuehrt. --> <!ELEMENT allocation-areas (allocation-area*)> -<!ELEMENT allocation-area (polygon,stripes?)> +<!ELEMENT allocation-area (polygon)> <!ATTLIST allocation-area active (yes|no) #REQUIRED y CDATA #REQUIRED @@ -104,14 +104,3 @@ x CDATA #REQUIRED y CDATA #REQUIRED > - - -<!ELEMENT stripes (stripe*)> -<!ELEMENT stripe (rectangle,seen?)> -<!ATTLIST stripe - x CDATA #REQUIRED - y CDATA #REQUIRED - > -<!ELEMENT seen (point*)> Modified: trunk/projects/bos/m2/export.lisp =================================================================== --- trunk/projects/bos/m2/export.lisp 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/export.lisp 2008-07-28 14:39:46 UTC (rev 3663) @@ -29,15 +29,6 @@ (defun area< (a b) (< (store-object-id a) (store-object-id b))) -(defun stripe< (a b) - (let ((ha (stripe-height a)) - (hb (stripe-height b))) - (or (< ha hb) - (and (eql ha hb) - (or (< (stripe-top a) (stripe-top b)) - (and (eql (stripe-top a) (stripe-top b)) - (< (stripe-left a) (stripe-left b)))))))) - (defun export-m2 (m2) (with-element "m2" (attribute "utm-x" (write-to-string (m2-utm-x m2))) @@ -73,19 +64,8 @@ (attribute "width" (write-to-string width)) (attribute "height" (write-to-string height)))) -(defun export-stripe (stripe) - (with-slots (left top width height x y seen) stripe - (with-element "stripe" - (attribute "x" (write-to-string x)) - (attribute "y" (write-to-string y)) - (export-rectangle left top width height) - (when seen - (with-element "seen" - (dolist (m2 seen) - (export-point (m2-x m2) (m2-y m2)))))))) - (defun export-area (area) - (with-slots (left top width height active-p y vertices stripes) area + (with-slots (left top width height active-p y vertices) area (with-element "allocation-area" (attribute "active" (if active-p "yes" "no")) (attribute "y" (write-to-string y)) @@ -93,9 +73,7 @@ (map nil (lambda (vertex) (export-point (car vertex) (cdr vertex))) - vertices)) - (with-element "stripes" - (map-sorted #'export-stripe #'stripe< stripes))))) + vertices))))) (defun export-sponsor (sponsor) (with-element "sponsor" Modified: trunk/projects/bos/m2/import.lisp =================================================================== --- trunk/projects/bos/m2/import.lisp 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/import.lisp 2008-07-28 14:39:46 UTC (rev 3663) @@ -8,10 +8,7 @@ (area-active-p :accessor importer-area-active-p) (area-y :accessor importer-area-y) (area-vertices :accessor importer-area-vertices) - (area :accessor importer-area) - (stripe :accessor importer-stripe) - (stripe-x :accessor importer-stripe-x) - (stripe-y :accessor importer-stripe-y))) + (area :accessor importer-area))) (defun import-database (pathname) (cxml:parse-file pathname (cxml:make-recoder (make-instance 'importer)))) @@ -79,43 +76,9 @@ (setf (importer-area handler) nil) (setf (importer-area-vertices handler) nil)) ((string= qname "point") - (if (importer-area handler) - (let ((stripe (importer-stripe handler))) - (change-slot-values - stripe - 'seen - (append (stripe-seen stripe) - (list - (ensure-m2 (parse-integer (getattribute "x" attrs)) - (parse-integer (getattribute "y" attrs))))))) - (push (cons (parse-integer (getattribute "x" attrs)) - (parse-integer (getattribute "y" attrs))) - (importer-area-vertices handler)))) - ((string= qname "stripes") - (let* ((*preallocate-stripes* nil) - (a (make-allocation-area - (coerce (reverse (importer-area-vertices handler)) 'vector)))) - (change-slot-values - a - 'y (importer-area-y handler) - 'active-p (importer-area-active-p handler)) - (setf (importer-area handler) a))) - ((string= qname "stripe") - (setf (importer-stripe-x handler) - (parse-integer (getattribute "x" attrs))) - (setf (importer-stripe-y handler) - (parse-integer (getattribute "y" attrs)))) - ((string= qname "rectangle") - (setf (importer-stripe handler) - (make-stripe (importer-area handler) - (parse-integer (getattribute "left" attrs)) - (parse-integer (getattribute "top" attrs)) - (parse-integer (getattribute "width" attrs)) - (parse-integer (getattribute "height" attrs)))) - (change-slot-values - (importer-stripe handler) - 'x (importer-stripe-x handler) - 'y (importer-stripe-y handler))))) + (push (cons (parse-integer (getattribute "x" attrs)) + (parse-integer (getattribute "y" attrs))) + (importer-area-vertices handler))))) (defmethod sax:end-element ((handler importer) namespace-uri local-name qname) (declare (ignore namespace-uri local-name))

1 0

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

28 Jul '08

Revision: 3662 Author: ksprotte URL: http://bknr.net/trac/changeset/3662 corrected method definition order in poi.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-28 14:31:11 UTC (rev 3661) +++ trunk/projects/bos/m2/poi.lisp 2008-07-28 14:37:24 UTC (rev 3662) @@ -73,15 +73,6 @@ ((poi :read) (url :update :initform nil))) -(defmethod poi-movies :before ((poi poi)) - "Lazily update the db schema. Method can be removed later." - (macrolet ((movie (tail) `(car ,tail))) - (mapl (lambda (tail) - (when (stringp (movie tail)) - (setf (movie tail) - (make-object 'poi-movie :poi poi :url (movie tail))))) - (slot-value poi 'movies)))) - ;;; poi (define-persistent-class poi () ((name :read :index-type string-unique-index @@ -98,6 +89,15 @@ (movies :update :initform nil) (published :update :initform nil))) +(defmethod poi-movies :before ((poi poi)) + "Lazily update the db schema. Method can be removed later." + (macrolet ((movie (tail) `(car ,tail))) + (mapl (lambda (tail) + (when (stringp (movie tail)) + (setf (movie tail) + (make-object 'poi-movie :poi poi :url (movie tail))))) + (slot-value poi 'movies)))) + (deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) (setf (slot-string poi 'title language) title)

1 0

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

28 Jul '08

Revision: 3661 Author: hans URL: http://bknr.net/trac/changeset/3661 Remove old graphics generation files that are no longer useful. D trunk/projects/bos/m2/bitmap.lisp U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/packages.lisp Deleted: trunk/projects/bos/m2/bitmap.lisp =================================================================== --- trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:31:11 UTC (rev 3661) @@ -1,200 +0,0 @@ -;;; Anleitung: -;;; * (write-allocation-bitmaps ...) -;;; $ mogrify -format gif test-*.png # pkg_add -r ImageMagick -;;; $ whirlgif -o test.gif test-???.gif # pkg_add -r whirlgif -;;; Heraus kommt ein animated gif aller Contracts in Erzeugungsreihenfolge, -;;; die im angegebenen Rechteck sichtbar sind (siehe Argumente zu W-A-B). - -(in-package :bos.m2) - -(defun make-vga-colors (&optional (image cl-gd:*default-image*)) - (cl-gd:with-default-image (image) - (let ((colors (make-array 16))) - (setf (elt colors 01) (cl-gd:find-color #xff #xff #xff :resolve t)) - (setf (elt colors 02) (cl-gd:find-color #xff #x00 #x00 :resolve t)) - (setf (elt colors 03) (cl-gd:find-color #x00 #xff #x00 :resolve t)) - (setf (elt colors 04) (cl-gd:find-color #x00 #x00 #xff :resolve t)) - (setf (elt colors 05) (cl-gd:find-color #x00 #xff #xff :resolve t)) - (setf (elt colors 06) (cl-gd:find-color #xff #x00 #xff :resolve t)) - (setf (elt colors 07) (cl-gd:find-color #xff #xff #x00 :resolve t)) - (setf (elt colors 08) (cl-gd:find-color #x80 #x80 #x80 :resolve t)) - (setf (elt colors 09) (cl-gd:find-color #xc0 #xc0 #xc0 :resolve t)) - (setf (elt colors 10) (cl-gd:find-color #x80 #x00 #x00 :resolve t)) - (setf (elt colors 11) (cl-gd:find-color #x00 #x80 #x00 :resolve t)) - (setf (elt colors 12) (cl-gd:find-color #x00 #x00 #x80 :resolve t)) - (setf (elt colors 13) (cl-gd:find-color #x00 #x80 #x80 :resolve t)) - (setf (elt colors 14) (cl-gd:find-color #x80 #x00 #x80 :resolve t)) - (setf (elt colors 15) (cl-gd:find-color #x80 #x80 #x00 :resolve t)) - colors))) - -(defvar *bitmap* nil) - -(defun make-allocation-bitmap (left top width height) - (let ((image (cl-gd:create-image width height))) - (cl-gd:with-default-image (image) - (let ((colors (make-vga-colors image))) - (cl-gd:draw-rectangle* 0 0 (1- width) (1- height) - :filled t - :color (elt colors 0)) - (setf *bitmap* - (list image left top width height colors (make-hash-table))))))) - -(defun free-allocation-bitmap () - (cl-gd:destroy-image (car *bitmap*)) - (setf *bitmap* nil) - nil) - -(defun all-contracts () - (store-objects-with-class 'contract)) - -(defun draw-contracts (image left top width height colors contracts &optional seen) - (cl-gd:with-default-image (image) - ;; We manipulate pixels in a temporary array which is copied to the GD image as - ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. - (let ((work-array (make-array (list width height) :element-type 'fixnum))) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (aref work-array x y) (cl-gd:raw-pixel)))) - (flet ((set-pixel (x y color) - (decf x left) - (decf y top) - (when (and (<= 0 x (1- width)) (<= 0 y (1- height))) - (setf (aref work-array x y) color))) - (get-pixel (x y) - (decf x left) - (decf y top) - (if (and (<= 0 x (1- width)) (<= 0 y (1- height))) - (aref work-array x y) - nil))) - (loop for contract in contracts - do (when (or (not seen) - (not (gethash contract seen))) - (when seen (setf (gethash contract seen) t)) - (let ((free (copy-seq (cdr (coerce colors 'list))))) - (dolist (m2 (contract-m2s contract)) - (flet ((doit (x y) - (let ((c (get-pixel x y))) - (when c - (setf free (delete c free)))))) - (doit (+ (m2-x m2) 0) (+ (m2-y m2) -1)) - (doit (+ (m2-x m2) -1) (+ (m2-y m2) 0)) - (doit (+ (m2-x m2) +1) (+ (m2-y m2) 0)) - (doit (+ (m2-x m2) 0) (+ (m2-y m2) +1)))) - (let ((color (or (car free) - (elt colors (1+ (random 15)))))) - (dolist (m2 (contract-m2s contract)) - (set-pixel (m2-x m2) (m2-y m2) color))))))) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (cl-gd:raw-pixel) (aref work-array x y))))))) - -(defun write-allocation-bitmap (filename &optional ncontracts) - (destructuring-bind (image left top width height colors seen) *bitmap* - (let ((contracts (sort (copy-list (all-contracts)) #'< :key #'store-object-id))) - (draw-contracts image left top width height colors (subseq contracts 0 ncontracts) seen) - (when (probe-file filename) - (delete-file filename)) - (cl-gd:write-image-to-file filename :image image :type :png)) - filename)) - -(defun draw-stripes () - (destructuring-bind (image left top width height colors seen) *bitmap* - (declare (ignore left top width height seen)) - (cl-gd:with-default-image (image) - (dolist (stripe (store-stripes)) - (with-slots (left top width height) stripe - (cl-gd:draw-rectangle* left top (1- (+ left width)) (1- (+ top height)) - :color (elt colors 1))))))) - -(defun write-allocation-bitmaps - (&key (step 100) left top width height draw-stripes - (directory "/home/david/animate/")) - (when *bitmap* - (free-allocation-bitmap)) - (unless (and left top width height) - ;; automatisch den kleinesten ausschnitt waehlen, der alle allocation - ;; areas enthaelt, falls nicht anders vorgegeben. - (let ((points '())) - (dolist (area (all-allocation-areas)) - (with-slots (left top width height) area - (push (cons left top) points) - (push (cons (+ left width) (+ top height)) points))) - (multiple-value-setq (left top width height) - (compute-bounding-box points)))) - (make-allocation-bitmap left top width height) - (when draw-stripes - (draw-stripes)) - (if step - (loop for i from 0 to (ceiling (length (all-contracts)) step) - do - (let ((filename - (merge-pathnames (format nil "test-~3,'0D.png" i) - directory))) - (print filename) - (force-output) - (write-allocation-bitmap filename (* i step)))) - (write-allocation-bitmap - (merge-pathnames "test.png" directory)))) - -(defvar *initial-random-state* (make-random-state)) - -(defun test-allocation - (&key (initial-random-state *initial-random-state*) - (limit nil)) - (let ((*random-state* (make-random-state initial-random-state))) - (when *bitmap* - (free-allocation-bitmap)) - (make-allocation-bitmap 0 0 400 400) - (let ((u (or (find-user 123) - (make-sponsor :profile-id 123 - :first-name "Otto" - :last-name "Mustermann" - :email-address "otto.mustermann(a)t-online.de")))) - (flet ((make-one-contract () - (let* ((limit 0.0001) - (n (max 1 (round (/ 0.5 (+ (random (- 1.0 limit)) limit)))))) - - (format t " ~D" n) - (force-output) - (make-contract u n)))) - (if limit - (dotimes (x limit) - (make-one-contract)) - (loop - (make-one-contract))))))) - -#+(or) -(progn - (reinit :delete t :directory "home:tmp/mytest-datastore/") - (let ((p #((66 . 0) (134 . 0) - (200 . 66) (200 . 134) - (134 . 200) (66 . 200) - (0 . 134) (0 . 66))) - (q #((200 . 180) (400 . 0) (400 . 200))) - (r (map 'vector - (lambda (x) - (cons (+ (* (car x) 40) 20) - (+ (* (cdr x) 40) 200))) - #((0 . 0) (1 . 0) (1 . 3) (2 . 4) (3 . 3) (3 . 0) (4 . 0) - (4 . 4) (2 . 5) (0 . 4)))) - (s #((400 . 0) (600 . 0) (600 . 200) (400 . 200)))) - (bknr.datastore::without-sync () - (make-allocation-area p) - (make-allocation-area q) - (make-allocation-area r) - (make-allocation-area s))) - (bknr.datastore::without-sync () - (time - (with-simple-restart (ok "ok") - (test-allocation :limit nil))))) - -#+(or) -(bknr.datastore::without-sync () - (make-allocation-area - #((66 . 0) (134 . 0) - (200 . 66) (200 . 134) - (134 . 200) (66 . 200) - (0 . 134) (0 . 66)))) - -#+(or) -(bos.m2::make-allocation-area #((0 . 0) (200 . 0) (200 . 200) (0 . 200))) Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:31:11 UTC (rev 3661) @@ -1,34 +1,35 @@ - (in-package :cl-user) +;; -*- Lisp -*- - (asdf:defsystem :bos.m2 - :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime - :kmrcl :iterate :arnesi - :cl-pdf :screamer :cl-fad) - :components ((:file "packages") - (:file "geo-utm" :depends-on ("packages")) - (:file "geometry" :depends-on ("packages" "m2-store")) - (:file "config" :depends-on ("packages")) - (:file "utils" :depends-on ("config")) - (:file "news" :depends-on ("poi")) - (:file "tiled-index" :depends-on ("config")) - (:file "mail-generator" :depends-on ("config")) - (:file "make-certificate" :depends-on ("config")) - (:file "initialization-subsystem" :depends-on ("packages")) - (:file "m2-store" :depends-on ("packages" "utils")) - (:file "m2" :depends-on ("initialization-subsystem" - "tiled-index" - "utils" - "make-certificate" - "mail-generator" - "geo-utm" - "geometry")) - (:file "m2-pdf" :depends-on ("m2")) - (:file "contract-expiry" :depends-on ("m2")) - (:file "allocation" :depends-on ("m2")) - (:file "allocation-cache" :depends-on ("packages" "geometry")) - (:file "poi" :depends-on ("utils" "allocation")) - (:file "bitmap" :depends-on ("allocation")) - (:file "import" :depends-on ("m2")) - (:file "map" :depends-on ("m2" "allocation" "geometry")) - (:file "export" :depends-on ("m2")) - (:file "cert-daemon" :depends-on ("config")))) +(in-package :cl-user) + +(asdf:defsystem :bos.m2 + :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime + :kmrcl :iterate :arnesi + :cl-pdf :screamer :cl-fad) + :components ((:file "packages") + (:file "geo-utm" :depends-on ("packages")) + (:file "geometry" :depends-on ("packages" "m2-store")) + (:file "config" :depends-on ("packages")) + (:file "utils" :depends-on ("config")) + (:file "news" :depends-on ("poi")) + (:file "tiled-index" :depends-on ("config")) + (:file "mail-generator" :depends-on ("config")) + (:file "make-certificate" :depends-on ("config")) + (:file "initialization-subsystem" :depends-on ("packages")) + (:file "m2-store" :depends-on ("packages" "utils")) + (:file "m2" :depends-on ("initialization-subsystem" + "tiled-index" + "utils" + "make-certificate" + "mail-generator" + "geo-utm" + "geometry")) + (:file "m2-pdf" :depends-on ("m2")) + (:file "contract-expiry" :depends-on ("m2")) + (:file "allocation" :depends-on ("m2")) + (:file "allocation-cache" :depends-on ("packages" "geometry")) + (:file "poi" :depends-on ("utils" "allocation")) + (:file "import" :depends-on ("m2")) + (:file "map" :depends-on ("m2" "allocation" "geometry")) + (:file "export" :depends-on ("m2")) + (:file "cert-daemon" :depends-on ("config")))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/packages.lisp 2008-07-28 14:31:11 UTC (rev 3661) @@ -200,10 +200,6 @@ #:allocation-area-percent-used #:left #:top #:width #:height #:active-p - ;; bitmap routines for drawing of allocation areas - #:make-vga-colors - #:draw-contracts - ;; pois #:*current-language* #:slot-string

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/dictionary.lisp
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3660 Author: hans URL: http://bknr.net/trac/changeset/3660 Use TRUENAME for XML file to parse in as cxml does not support logical path names. U trunk/projects/bos/web/dictionary.lisp Modified: trunk/projects/bos/web/dictionary.lisp =================================================================== --- trunk/projects/bos/web/dictionary.lisp 2008-07-28 14:18:12 UTC (rev 3659) +++ trunk/projects/bos/web/dictionary.lisp 2008-07-28 14:20:06 UTC (rev 3660) @@ -92,7 +92,7 @@ (string-trim '(#\space #\newline #\tab) string)) (load-language (language xml-path) (handler-case - (let ((xmls (cxml:parse-file xml-path (cxml-xmls:make-xmls-builder)))) + (let ((xmls (cxml:parse-file (truename xml-path) (cxml-xmls:make-xmls-builder)))) (assert (equal "dictionary" (cxml-xmls:node-name xmls)) nil "root element should be \"dictionary\"") (dolist (element (cxml-xmls:node-children xmls))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3659 Author: hans URL: http://bknr.net/trac/changeset/3659 Make locks non-recursive - Recursive locks are not needed for the kind of application, and it helps cmucl which does not seem to have recursive locks. U trunk/thirdparty/hunchentoot/lispworks.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/lispworks.lisp =================================================================== --- trunk/thirdparty/hunchentoot/lispworks.lisp 2008-07-28 14:07:28 UTC (rev 3658) +++ trunk/thirdparty/hunchentoot/lispworks.lisp 2008-07-28 14:18:12 UTC (rev 3659) @@ -97,14 +97,6 @@ "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." (mp:make-lock :name name)) -(defun make-recursive-lock (name) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - (mp:make-lock :name name)) - -(defmacro with-recursive-lock-held ((lock) &body body) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - `(mp:with-lock (,lock) ,@body)) - (defmacro with-lock-held ((lock) &body body) "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." `(mp:with-lock (,lock) ,@body)) Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2008-07-28 14:07:28 UTC (rev 3658) +++ trunk/thirdparty/hunchentoot/session.lisp 2008-07-28 14:18:12 UTC (rev 3659) @@ -29,7 +29,7 @@ (in-package :hunchentoot) -(defvar *session-data-lock* (make-recursive-lock "session-data-lock") +(defvar *session-data-lock* (make-lock "session-data-lock") "A lock to prevent two threads from modifying *SESSION-DATA* at the same time.") @@ -123,7 +123,7 @@ (defun session-gc () "Removes sessions from *session-data* which are too old - see SESSION-TOO-OLD-P." - (with-recursive-lock-held (*session-data-lock*) + (with-lock-held (*session-data-lock*) (setq *session-data* (loop for id-session-pair in *session-data* for (nil . session) = id-session-pair @@ -148,7 +148,7 @@ there's no session for the current request." (with-rebinding (symbol) (with-unique-names (place %session) - `(with-recursive-lock-held (*session-data-lock*) + `(with-lock-held (*session-data-lock*) (let* ((,%session (or ,session (start-session))) (,place (assoc ,symbol (session-data ,%session) :test #'eq))) (cond @@ -189,7 +189,7 @@ (return-from start-session session)) (setf session (make-instance 'session) (session *request*) session) - (with-recursive-lock-held (*session-data-lock*) + (with-lock-held (*session-data-lock*) (setq *session-data* (acons (session-id session) session *session-data*))) (set-cookie *session-cookie-name* :value (session-cookie-value session) @@ -199,7 +199,7 @@ (defun remove-session (session) "Completely removes the SESSION object SESSION from Hunchentoot's internal session database." - (with-recursive-lock-held (*session-data-lock*) + (with-lock-held (*session-data-lock*) (funcall *session-removal-hook* session) (setq *session-data* (delete (session-id session) *session-data* @@ -279,7 +279,7 @@ (defun reset-sessions () "Removes ALL stored sessions and creates a new session secret." (reset-session-secret) - (with-recursive-lock-held (*session-data-lock*) + (with-lock-held (*session-data-lock*) (loop for (nil . session) in *session-data* do (funcall *session-removal-hook* session)) (setq *session-data* nil)) Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-07-28 14:07:28 UTC (rev 3658) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-07-28 14:18:12 UTC (rev 3659) @@ -370,16 +370,6 @@ (bt:make-lock name)) #-:lispworks -(defun make-recursive-lock (name) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - (bt:make-recursive-lock name)) - -#-:lispworks -(defmacro with-recursive-lock-held ((lock) &body body) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - `(bt:with-recursive-lock-held (,lock) ,@body)) - -#-:lispworks (defmacro with-lock-held ((lock) &body body) "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." `(bt:with-lock-held (,lock) ,@body)) \ No newline at end of file

1 0

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

28 Jul '08

Revision: 3658 Author: ksprotte URL: http://bknr.net/trac/changeset/3658 added support for displaying and uploading multiple poi movies U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/payment-website/static/cms.js U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-28 13:41:45 UTC (rev 3657) +++ trunk/projects/bos/m2/packages.lisp 2008-07-28 14:07:28 UTC (rev 3658) @@ -220,6 +220,9 @@ #:panoramas #:poi-movies #:movies + #:poi-movie + #:poi-movie-poi + #:poi-movie-url #:make-poi-image #:update-poi-image #:poi Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-28 13:41:45 UTC (rev 3657) +++ trunk/projects/bos/m2/poi.lisp 2008-07-28 14:07:28 UTC (rev 3658) @@ -31,8 +31,9 @@ (loop for (slot-name value) on args by #'cddr do (setf (slot-string object slot-name language) value))) -;; POI-Anwendungsklassen und Konstruktoren +;;; POI-Anwendungsklassen und Konstruktoren +;;; poi-image (define-persistent-class poi-image (store-image) ((poi :read) (title :update :initform (make-string-hash-table)) @@ -67,6 +68,21 @@ (when description (setf (slot-string poi-image 'description language) description))) +;;; poi-movie +(define-persistent-class poi-movie () + ((poi :read) + (url :update :initform nil))) + +(defmethod poi-movies :before ((poi poi)) + "Lazily update the db schema. Method can be removed later." + (macrolet ((movie (tail) `(car ,tail))) + (mapl (lambda (tail) + (when (stringp (movie tail)) + (setf (movie tail) + (make-object 'poi-movie :poi poi :url (movie tail))))) + (slot-value poi 'movies)))) + +;;; poi (define-persistent-class poi () ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois Modified: trunk/projects/bos/payment-website/static/cms.js =================================================================== --- trunk/projects/bos/payment-website/static/cms.js 2008-07-28 13:41:45 UTC (rev 3657) +++ trunk/projects/bos/payment-website/static/cms.js 2008-07-28 14:07:28 UTC (rev 3658) @@ -3,7 +3,6 @@ // Allgemeine Initialisierungsfunktion fuer alle CMS-Seiten function init() { - update_movie_preview(); } // Formularcheck für Sponsoren-Erzeugung @@ -65,18 +64,6 @@ function $(id) { return document.getElementById(id); } -function update_movie_preview() -{ - if ($('movie') && $('movie_preview')) { - var url = $('movie').value; - if (url == "") { - $('movie_preview').innerHTML = ''; - } else { - $('movie_preview').innerHTML = '<object width="360" height="340"> <param name="movie" value=" ' + url + '"> </param> <embed src=" ' + url + '" type="application/x-shockwave-flash" width="360" height="340"> </embed> </object>'; - } - } -} - function parse_youtube_link (input) { var text = input.value; @@ -88,7 +75,6 @@ input.value = ""; return false; } else { - update_movie_preview(); return true; } } @@ -97,4 +83,5 @@ { $(field_name).value = value; return confirm(confirm_string); -} \ No newline at end of file +} + Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 13:41:45 UTC (rev 3657) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 14:07:28 UTC (rev 3658) @@ -154,20 +154,25 @@ (html "Upload new panorama view" ((:input :type "file" :name "image-file")) :br - (submit-button "upload-panorama" "upload-panorama")))) - (:tr (:td "movie") - (:td (html "URL or 'embed' string: " + (submit-button "upload-panorama" "upload-panorama")))) + (:tr (:td "movies" + ((:input :id "movie-id" :type "hidden" :name "movie-id"))) + (:td (dolist (movie (poi-movies poi)) + (html (:princ-safe (format-date-time (store-object-last-change movie 0))) + ((:a :href (format nil "/poi-movie/~D" (store-object-id movie)) :target "_new" :class "cmslink") + " view ") + (submit-button "delete-movie" "delete-movie" + :formcheck #?"javascript:confirm_delete('movie-id', $((store-object-id movie)), 'Really delete this movie?')") + :br)) + (html "URL or 'embed' string: " ((:input :type "text" :size "50" - :name "movie" + :name "movie-url" :id "movie" - :value (or (first (poi-movies poi)) "") + :value "" :onchange "parse_youtube_link(this)")) - " " - (when (poi-movies poi) - (html :br (submit-button "delete-movie" "delete-movie" :confirm "Really delete the movie?"))) :br - ((:div :id "movie_preview" :style "height: 340px; width: 360px;") "")))) + (submit-button "add-movie" "add-movie")))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) @@ -225,12 +230,27 @@ (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) + (defmethod handle-object-form ((handler edit-poi-handler) + (action (eql :add-movie)) + (poi poi)) + (with-query-params (movie-url) + (with-transaction ("add poi movie") + (push (make-object 'poi-movie :poi poi :url movie-url) + (poi-movies poi))) + (redirect (format nil "/edit-poi/~D" (store-object-id poi))))) + + +(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-movie)) (poi poi)) - (with-transaction ("setf poi-movies nil") - (setf (poi-movies poi) nil)) - (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) + (with-query-params (movie-id) + (let ((movie (find-store-object (parse-integer movie-id)))) + (with-transaction ("delete poi-movie") + (alexandria:deletef (poi-movies poi) movie)) + (delete-object movie))) + (redirect (format nil "/edit-poi/~D" + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-panorama)) @@ -402,7 +422,23 @@ imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) +(defclass poi-movie-handler (admin-only-handler object-handler) + () + (:default-initargs :object-class 'poi-movie)) +(defmethod handle-object ((handler poi-movie-handler) (poi-movie (eql nil))) + (error "poi-movie not found")) + +(defmethod handle-object ((handler poi-movie-handler) poi-movie) + (with-bos-cms-page (:title "POI movie preview") + (:p (cmslink (edit-object-url (poi-movie-poi poi-movie)) "Back to POI")) + ((:object :width "425" :height "344") + ((:param :name "movie" :value (poi-movie-url poi-movie))) + ((:param :name "allowFullScreen" :value "true")) + ((:embed :src (poi-movie-url poi-movie) :type "application/x-shockwave-flash" + :allowFullScreen "true" + :width "425" :height "344"))))) + (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used to generate the POI microsite using XSLT (client side)." @@ -452,9 +488,9 @@ (dolist (panorama panoramas) (with-media ("panorama" "Panorama" (store-image-name panorama)) (format-image panorama))) - (dolist (url movies) + (dolist (movie movies) (with-media ("movie" "Video") - (with-element "url" (text url))))))))) + (with-element "url" (text (poi-movie-url movie)))))))))) (defun poi-description-google-earth (poi language &key (image-width 120)) (labels ((website-path (path &rest args) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-28 13:41:45 UTC (rev 3657) +++ trunk/projects/bos/web/webserver.lisp 2008-07-28 14:07:28 UTC (rev 3658) @@ -175,6 +175,7 @@ ("/edit-news" edit-news-handler) ("/make-poi" make-poi-handler) ("/poi-image" poi-image-handler) + ("/poi-movie" poi-movie-handler) ("/poi-xml" poi-xml-handler) ("/poi-kml-all" poi-kml-all-handler) ("/poi-kml" poi-kml-handler)

1 0

[bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi/bos_style.css
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3657 Author: hans URL: http://bknr.net/trac/changeset/3657 Fix font to match font used in the rest of the system. U trunk/projects/bos/payment-website/static/poi/bos_style.css Modified: trunk/projects/bos/payment-website/static/poi/bos_style.css =================================================================== --- trunk/projects/bos/payment-website/static/poi/bos_style.css 2008-07-28 12:31:09 UTC (rev 3656) +++ trunk/projects/bos/payment-website/static/poi/bos_style.css 2008-07-28 13:41:45 UTC (rev 3657) @@ -5,7 +5,7 @@ margin-left: 0px;*/ margin: 0px; font-size: 11px;/*100.1%;*/ - font-family:Georgia, serif; + font-family: Verdana, Arial, Helvetica, sans-serif; overflow:auto; overflow: -moz-scrollbars-vertical; }

1 0

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

28 Jul '08

Revision: 3656 Author: ksprotte URL: http://bknr.net/trac/changeset/3656 whitespace cleanup U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/bitmap.lisp U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/cert-daemon.lisp U trunk/projects/bos/m2/config.lisp U trunk/projects/bos/m2/export.lisp U trunk/projects/bos/m2/geo-utm.lisp U trunk/projects/bos/m2/geometry.lisp U trunk/projects/bos/m2/import.lisp U trunk/projects/bos/m2/initialization-subsystem.lisp U trunk/projects/bos/m2/m2-pdf.lisp U trunk/projects/bos/m2/m2-store.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/mail-generator.lisp U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/m2/news.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/m2/tiled-index.lisp U trunk/projects/bos/m2/utils.lisp U trunk/projects/bos/m2/warm-kml-cache.lisp U trunk/projects/bos/test/allocation.lisp U trunk/projects/bos/test/bos.test.asd U trunk/projects/bos/test/fixtures.lisp U trunk/projects/bos/test/geo-utm.lisp U trunk/projects/bos/test/geometry.lisp U trunk/projects/bos/test/package.lisp U trunk/projects/bos/test/suites.lisp U trunk/projects/bos/test/web/drakma-requests.lisp U trunk/projects/bos/test/web/quad-tree.lisp U trunk/projects/bos/test/web/sat-tree.lisp U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/allocation-cache-handlers.lisp U trunk/projects/bos/web/boi-handlers.lisp U trunk/projects/bos/web/cms-links.lisp U trunk/projects/bos/web/config.lisp U trunk/projects/bos/web/contract-handlers.lisp U trunk/projects/bos/web/contract-image-handler.lisp U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/countries.lisp U trunk/projects/bos/web/daily.lisp U trunk/projects/bos/web/dictionary.lisp U trunk/projects/bos/web/geo-coord.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/kml-utils.lisp U trunk/projects/bos/web/map-browser-handler.lisp U trunk/projects/bos/web/map-handlers.lisp U trunk/projects/bos/web/news-handlers.lisp U trunk/projects/bos/web/news-tags.lisp U trunk/projects/bos/web/packages.lisp U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/quad-tree.lisp U trunk/projects/bos/web/reports-xml-handler.lisp U trunk/projects/bos/web/rss.lisp U trunk/projects/bos/web/sat-tree.lisp U trunk/projects/bos/web/spendenquittung.lisp U trunk/projects/bos/web/sponsor-handlers.lisp U trunk/projects/bos/web/startup.lisp U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/utf-8.lisp U trunk/projects/bos/web/utils.lisp U trunk/projects/bos/web/web-macros.lisp U trunk/projects/bos/web/web-utils.lisp U trunk/projects/bos/web/webserver.lisp U trunk/projects/bos/web/website-language.lisp Change set too large, please see URL above

1 0

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

28 Jul '08

Revision: 3655 Author: ksprotte URL: http://bknr.net/trac/changeset/3655 added support for displaying and uploading multiple airals U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 11:35:12 UTC (rev 3654) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 12:04:59 UTC (rev 3655) @@ -127,18 +127,21 @@ (unless (eql 6 (length (poi-images poi))) (html :br - (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) - (:tr (:td "airal view") - (:td (if (poi-airals poi) - (html ((:a :href (format nil "/image/~D" (store-object-id (first (poi-airals poi)))) - :target "_new") - ((:img :src (format nil "/image/~D" (store-object-id (first (poi-airals poi)))) - :width "90" :height "90"))) - (submit-button "delete-airal" "delete-airal" :confirm "Really delete the airal image?")) - (html "Upload new airal view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-airal" "upload-airal"))))) + (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) + (:tr (:td "airal view" + ((:input :id "airal-id" :type "hidden" :name "airal-id"))) + (:td (:table (dolist (airal (poi-airals poi)) + (html (:tr (:td ((:a :href (format nil "/image/~D" (store-object-id airal)) + :target "_new") + ((:img :src (format nil "/image/~D" (store-object-id airal)) + :width "90" :height "90")))) + (:td (submit-button "delete-airal" "delete-airal" + :formcheck #?"javascript:confirm_delete('airal-id', $((store-object-id airal)), 'Really delete the airal?')"))))) + (:tr ((:td :colspan "2") + "Upload new airal view" + ((:input :type "file" :name "image-file")) + :br + (submit-button "upload-airal" "upload-airal")))))) (:tr (:td "panorama view" ((:input :id "panorama-id" :type "hidden" :name "panorama-id"))) (:td (dolist (panorama (poi-panoramas poi)) @@ -197,7 +200,7 @@ ((and (eql (cl-gd:image-width) *poi-image-width*) (eql (cl-gd:image-height) *poi-image-height*)) (with-transaction ("set airals") - (setf (poi-airals poi) (print (list (import-image uploaded-file :class-name 'store-image))))) + (push (import-image uploaded-file :class-name 'store-image) (poi-airals poi))) (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) (t @@ -214,10 +217,11 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-airal)) (poi poi)) - (let ((airals (poi-airals poi))) - (with-transaction ("setf poi-airals nil") - (setf (poi-airals poi) nil)) - (mapc #'delete-object airals)) + (with-query-params (airal-id) + (let ((airal (find-store-object (parse-integer airal-id)))) + (with-transaction ("delete poi-airal") + (alexandria:deletef (poi-airals poi) airal)) + (delete-object airal))) (redirect (format nil "/edit-poi/~D" (store-object-id poi))))

1 0

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

28 Jul '08

Revision: 3654 Author: ksprotte URL: http://bknr.net/trac/changeset/3654 some corrections in the order of website handler-definitions U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-28 10:48:50 UTC (rev 3653) +++ trunk/projects/bos/web/webserver.lisp 2008-07-28 11:35:12 UTC (rev 3654) @@ -157,8 +157,8 @@ (make-instance 'bos-website :name "create-rainforest.org CMS" - :handler-definitions `(("/edit-poi" edit-poi-handler) - ("/edit-poi-image" edit-poi-image-handler) + :handler-definitions `(("/edit-poi-image" edit-poi-image-handler) + ("/edit-poi" edit-poi-handler) ("/edit-sponsor" edit-sponsor-handler) ("/kml-upload" kml-upload-handler) ("/kml-root-dynamic" kml-root-dynamic-handler) @@ -184,8 +184,8 @@ ("/m2-javascript" m2-javascript-handler) ("/sponsor-login" sponsor-login-handler) ("/create-allocation-area" create-allocation-area-handler) - ("/allocation-area" allocation-area-handler) ("/allocation-area-gfx" allocation-area-gfx-handler) + ("/allocation-area" allocation-area-handler) ("/allocation-cache" allocation-cache-handler) ("/certificate" certificate-handler) ("/cert-regen" cert-regen-handler)

1 0