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

[bknr-cvs] r2462 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 11 Feb '08

11 Feb '08

Author: hhubner Date: Mon Feb 11 07:12:57 2008 New Revision: 2462 Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp Log: Fix password setting through CMS. Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/bos/projects/bos/web/sponsor-handlers.lisp Mon Feb 11 07:12:57 2008 @@ -181,7 +181,9 @@ (let ((field-value (query-param req (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) - (change-slot-values sponsor field-name field-value) + (if (eq field-name 'password) + (set-user-password sponsor field-value) + (change-slot-values sponsor field-name field-value)) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor))

1 0

[bknr-cvs] r2461 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 06:39:55 2008 New Revision: 2461 Modified: branches/bos/projects/bos/web/tags.lisp Log: added new template var :geo-coord for save-profile and removed sqm-x sqm-y not tested yet Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Mon Feb 11 06:39:55 2008 @@ -168,8 +168,11 @@ (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) - (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) - (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) + (setf (get-template-var :geo-coord) (multiple-value-bind (left top) + (contract-bounding-box contract) + (apply #'geometry:format-lon-lat nil + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) + (- +nw-utm-y+ top) +utm-zone+ t)))) (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))

1 0

[bknr-cvs] r2460 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 11 Feb '08

11 Feb '08

Author: hhubner Date: Mon Feb 11 05:46:15 2008 New Revision: 2460 Modified: branches/bos/projects/bos/web/webserver.lisp Log: Fix for #20, set session's language when / page is sent out. Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Mon Feb 11 05:46:15 2008 @@ -47,8 +47,11 @@ ((and (not (scan "/" template-name)) (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") (template-handler-destination handler))))) - (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) - *default-language*) + (unless (session-variable :language) + (setf (session-variable :language) (or (find-browser-prefered-language request) + *default-language*))) + (setf template-name (format nil "~A/~A" + (session-variable :language) (if (equal "" template-name) "index" template-name))))) (call-next-method handler template-name))

1 0

[bknr-cvs] r2459 - branches/bos/projects/bos/payment-website/infosystem
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 05:13:22 2008 New Revision: 2459 Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js Log: Fixed YouTube-Fenster #6 by changing height Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js ============================================================================== --- branches/bos/projects/bos/payment-website/infosystem/javascript.js (original) +++ branches/bos/projects/bos/payment-website/infosystem/javascript.js Mon Feb 11 05:13:22 2008 @@ -899,7 +899,7 @@ document.getElementById("MovieApplet").innerHTML = '<object width="360" height="340"> <param name="movie" value=" ' + movie_url + '"> </param> <embed src=" ' - + movie_url + '" type="application/x-shockwave-flash" width="360" height="340"> </embed> </object>'; + + movie_url + '" type="application/x-shockwave-flash" width="360" height="302"> </embed> </object>'; } }

1 0

[bknr-cvs] r2458 - in branches/trunk-reorg/bknr: datastore/src/utils modules/bug web/src/images web/src/web
by hhubner＠common-lisp.net 10 Feb '08

10 Feb '08

Author: hhubner Date: Sun Feb 10 17:47:54 2008 New Revision: 2458 Modified: branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/modules/bug/package.lisp branches/trunk-reorg/bknr/web/src/images/image.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Log: openmcl fixes. Modified: branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp Sun Feb 10 17:47:54 2008 @@ -18,15 +18,15 @@ (defmethod actor-start ((actor bknr-actor)) (actor-stop actor) (setf (slot-value actor 'process) - (mp:make-process (lambda () - (funcall #'run-function actor)) - :name (bknr-actor-name actor)))) + (make-process (lambda () + (funcall #'run-function actor)) + :name (bknr-actor-name actor)))) (defmethod actor-running-p ((actor bknr-actor)) (and (slot-boundp actor 'process) - (mp:process-active-p (bknr-actor-process actor)))) + (process-active-p (bknr-actor-process actor)))) (defmethod actor-stop ((actor bknr-actor)) (when (slot-boundp actor 'process) - (mp:destroy-process (bknr-actor-process actor)) + (destroy-process (bknr-actor-process actor)) (slot-makunbound actor 'process))) Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Sun Feb 10 17:47:54 2008 @@ -2,140 +2,144 @@ (defpackage :bknr.utils (:use :cl - :cl-ppcre - :cl-interpol - :md5 + :cl-ppcre + :cl-interpol + :md5 #+cmu :extensions - #+sbcl :sb-ext) + #+sbcl :sb-ext + #+cmu :mp + #+openmcl :ccl) + #+openmcl + (:shadow :ccl #:copy-file) (:shadowing-import-from :cl-interpol quote-meta-chars) (:export #:define-bknr-class ;; byte size formatting #:scale-bytes - ;; date format - #:format-date-time - #:format-time-interval - #:format-duration - #:year-interval - #:month-interval - #:day-interval - #:timetag - #:daytag - #:get-daytime - #:get-hourtime - #:get-monthtime - #:previous-day - #:next-day - #:month-num-days + ;; date format + #:format-date-time + #:format-time-interval + #:format-duration + #:year-interval + #:month-interval + #:day-interval + #:timetag + #:daytag + #:get-daytime + #:get-hourtime + #:get-monthtime + #:previous-day + #:next-day + #:month-num-days - #:hostname + #:hostname #:parse-time - ;; filesystem functions - #:copy-stream - #:copy-file - #:move-file - #:directory-empty-p - #:subdir-p - #:temporary-file - #:with-temp-file - #:file-contents - #:parent-directory + ;; filesystem functions + #:copy-stream + #:copy-file + #:move-file + #:directory-empty-p + #:subdir-p + #:temporary-file + #:with-temp-file + #:file-contents + #:parent-directory - ;; list functions - #:delete-first - #:make-keyword-from-string - - #:assoc-values - #:assoc-to-keywords - #:insert-at-index - #:find-neighbourhood - #:group-by - #:group-on - #:find-all - #:genlist - #:nrotate - #:shift-until - #:count-multiple - - ;; hash table - #:hash-to-list - #:hash-values - #:hash-keys - #:incf-hash - - ;; randomize - #:random-elts - #:randomize-list - - ;; md5 - #:hash-to-hex - #:md5-string - - ;; capabilty - #:make-capability-string - - ;; content-types - #:pathname-type-symbol - #:image-content-type - #:pathname-content-type - #:image-type-symbol - - ;; utf-8 - #:convert-utf8-to-latin1 - - ;; strings - #:find-matching-strings - #:make-extendable-string - - ;; stream - #:read-delimited - #:read-file - - ;; smbpasswd - #:set-smb-password - #:smb-password-error - - ;; actor - #:bknr-actor - #:bknr-actor-name - #:run-function - #:actor-start - #:actor-stop - #:actor-running-p - - ;; cron - #:cron-actor - - ;; reader - #:whitespace-char-p - #:whitespace-p - #:bknr-read-delimited-list - #:bknr-read - #:string-beginning-with-p - #:string-delimited-by-p - - ;; crypt-md5 - #:crypt-md5 - #:verify-md5-password - - ;; FDF creation - #:make-fdf-file - - #:remove-keys - #:eval-initargs - - ;; Package cleaning for the build process - #:within-temporary-package - - ;; mp compatibility - #:mp-make-lock - #:mp-with-lock-held - #:mp-with-recursive-lock-held + ;; list functions + #:delete-first + #:make-keyword-from-string + + #:assoc-values + #:assoc-to-keywords + #:insert-at-index + #:find-neighbourhood + #:group-by + #:group-on + #:find-all + #:genlist + #:nrotate + #:shift-until + #:count-multiple + + ;; hash table + #:hash-to-list + #:hash-values + #:hash-keys + #:incf-hash + + ;; randomize + #:random-elts + #:randomize-list + + ;; md5 + #:hash-to-hex + #:md5-string + + ;; capabilty + #:make-capability-string + + ;; content-types + #:pathname-type-symbol + #:image-content-type + #:pathname-content-type + #:image-type-symbol + + ;; utf-8 + #:convert-utf8-to-latin1 + + ;; strings + #:find-matching-strings + #:make-extendable-string + + ;; stream + #:read-delimited + #:read-file + + ;; smbpasswd + #:set-smb-password + #:smb-password-error + + ;; actor + #:bknr-actor + #:bknr-actor-name + #:run-function + #:actor-start + #:actor-stop + #:actor-running-p + + ;; cron + #:cron-actor + + ;; reader + #:whitespace-char-p + #:whitespace-p + #:bknr-read-delimited-list + #:bknr-read + #:string-beginning-with-p + #:string-delimited-by-p + + ;; crypt-md5 + #:crypt-md5 + #:verify-md5-password + + ;; FDF creation + #:make-fdf-file + + #:remove-keys + #:eval-initargs + + ;; Package cleaning for the build process + #:within-temporary-package + + ;; mp compatibility + #:mp-make-lock + #:mp-with-lock-held + #:mp-with-recursive-lock-held - ;; class utils - #:class-subclasses + ;; class utils + #:class-subclasses - ;; norvig - #:find-all)) + ;; norvig + #:find-all)) Modified: branches/trunk-reorg/bknr/modules/bug/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/bug/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/bug/package.lisp Sun Feb 10 17:47:54 2008 @@ -12,7 +12,7 @@ :bknr.indices :bknr.datastore :bknr.mail) - (:shadowing-import-from :cl-interpol quote-meta-chars) + (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:bug-tracker #:bug-tracker-bug-reports #:bug-tracker-add-bug-report @@ -32,6 +32,5 @@ #:priority-to-num #:bug-report-add-annotation #:bug-report-owner - #:edit-bug-report-handler) - (:shadowing-import-from :cl-interpol #:quote-meta-chars)) + #:edit-bug-report-handler)) Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image.lisp Sun Feb 10 17:47:54 2008 @@ -194,4 +194,6 @@ #+cmu (unix:unix-rmdir (namestring file)) #+sbcl - (sb-posix:rmdir (namestring file))))) + (sb-posix:rmdir (namestring file)) + #+openmcl + (ccl::%rmdir (namestring file))))) Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Sun Feb 10 17:47:54 2008 @@ -13,7 +13,7 @@ "/usr/local/share/xml/catalog")) (eval-when (:load-toplevel :execute) - (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG"))) + (let ((env-catalog (#+sbcl sb-ext:posix-getenv #+openmcl ccl:getenv "XMLCATALOG"))) (when env-catalog (pushnew env-catalog *template-dtd-catalog* :test #'equal))) (setf cxml:*catalog* (cxml:make-catalog (remove-if-not #'probe-file *template-dtd-catalog*))

1 0

[bknr-cvs] r2457 - branches/trunk-reorg/thirdparty/hunchentoot-0.15.0
by hhubner＠common-lisp.net 10 Feb '08

10 Feb '08

Author: hhubner Date: Sun Feb 10 17:47:10 2008 New Revision: 2457 Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd Log: acl-compat does not actually seem to be needed with current CCL and Hunchentoot. Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd ============================================================================== --- branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd (original) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd Sun Feb 10 17:47:10 2008 @@ -51,7 +51,7 @@ :rfc2388 #+:sbcl :sb-bsd-sockets #+:sbcl :sb-posix - #+:openmcl :acl-compat + ; #+:openmcl :acl-compat :url-rewrite) :components ((:file "packages") (:file "conditions")

1 0

[bknr-cvs] r2456 - branches/trunk-reorg/bknr/datastore/src/skip-list
by hhubner＠common-lisp.net 10 Feb '08

10 Feb '08

Author: hhubner Date: Sun Feb 10 17:35:23 2008 New Revision: 2456 Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp Log: Fix bug in skip-list random number generator that caused skip list insertion performance to drop drastically on SBCL with 64bits. It appears as if the original algorithm returned NIL to approximately half the invocations, despite the comment claiming that NIL would be returned in 3/4 of the times. I replaced the explicit random number generator by a call to (RANDOM) with a separate random state for skip-lists. Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp Sun Feb 10 17:35:23 2008 @@ -6,23 +6,14 @@ ;;; Pseudo-random number generator from FreeBSD -(defparameter *random-n* - (the fixnum (get-internal-real-time)) - "Internal status of the pseudo-random number generator.") - -(defun random-seed (seed) - "Seed the pseudo-random number generator." - (setf *random-n* seed)) +(defparameter *sl-random-state* + (make-random-state) + "Internal status of the random number generator.") (defun sl-random () - "Pseudo-random number generator from FreeBSD, returns NIL 3/4 of the time." - (declare (optimize (speed 3)) - (type integer *random-n*)) - (logtest (logand most-positive-fixnum - (setf *random-n* - (mod (+ (the number (* *random-n* 1103515245)) 12345) - 2147483648))) - (ash 1 (- (integer-length most-positive-fixnum) 1)))) + "Pseudo-random number generator, returns NIL 3/4 of the time." + (declare (optimize (speed 3))) + (< 2 (random 4 *sl-random-state*))) (defconstant +max-level+ (the fixnum 32) "Maximum level of skip-list, should be enough for 2^32 elements.")

1 0

[bknr-cvs] r2455 - branches/trunk-reorg/bknr/web/src/web
by hhubner＠common-lisp.net 10 Feb '08

10 Feb '08

Author: hhubner Date: Sun Feb 10 04:02:46 2008 New Revision: 2455 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp Log: fix syntax error that has not been detected by cmucl Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Sun Feb 10 04:02:46 2008 @@ -406,8 +406,8 @@ (defgeneric object-date-list-handler-grouped-objects (handler object)) -(defmethod object-date-list-handler-date ((handler object-date-list-handler object-list-handler) - object) +(defmethod object-date-list-handler-date ((handler object-date-list-handler) + object) (with-query-params (date) (get-daytime (if date (or (parse-integer date :junk-allowed t)

1 0

[bknr-cvs] r2454 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 08 Feb '08

08 Feb '08

Author: ksprotte Date: Fri Feb 8 10:36:04 2008 New Revision: 2454 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/make-certificate.lisp branches/bos/projects/bos/m2/packages.lisp Log: Geo-Koordinaten im PDF anzeigen #5 done (Template still needs to be changed in Acrobat for larger font) Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Fri Feb 8 10:36:04 2008 @@ -258,10 +258,10 @@ (defun format-decimal-degree (degree) - (format-mixed-radix-number nil (* 60 degree) '(60 360) '("~,2F�" "~D�"))) + (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F´´" " ~D´" "~D°"))) -(defun format-lon-lat (lon lat) - (format nil "~A ~:[S~;N~], ~A~:[W~;E~]" +(defun format-lon-lat (stream lon lat) + (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]" (format-decimal-degree (abs lat)) (plusp lat) (format-decimal-degree (abs lon)) Modified: branches/bos/projects/bos/m2/make-certificate.lisp ============================================================================== --- branches/bos/projects/bos/m2/make-certificate.lisp (original) +++ branches/bos/projects/bos/m2/make-certificate.lisp Fri Feb 8 10:36:04 2008 @@ -42,8 +42,19 @@ :sponsor-id (sponsor-id sponsor) :master-code (sponsor-master-code sponsor) :sqm-count (length (contract-m2s contract)) - :sqm-ids (with-output-to-string (s) - (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) - do (loop for nums on group - do (princ (car nums) s) - do (princ (if (cdr nums) #\Tab #\Newline) s))))))) + ;; :sqm-ids (with-output-to-string (s) + ;; (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) + ;; do (loop for nums on group + ;; do (princ (car nums) s) + ;; do (princ (if (cdr nums) #\Tab #\Newline) s)))) + ;; should later be called :sqm-coordinates + :sqm-ids + (flet ((format-point (stream x y) + (apply #'geometry:format-lon-lat stream + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) + (- +nw-utm-y+ y) +utm-zone+ t)))) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (with-output-to-string (out) + (format-point out left top) (terpri out) + (format-point out (+ left width) (+ top height)) (terpri out))))))) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Feb 8 10:36:04 2008 @@ -9,7 +9,8 @@ #:point-in-polygon-p #:point-in-circle-p #:find-boundary-point - #:region-to-polygon)) + #:region-to-polygon + #:format-lon-lat)) (defpackage :geo-utm (:use :cl)

1 0

[bknr-cvs] r2453 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 08 Feb '08

08 Feb '08

Author: ksprotte Date: Fri Feb 8 09:45:54 2008 New Revision: 2453 Modified: branches/bos/projects/bos/m2/geometry.lisp Log: added new function: FORMAT-LON-LAT Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Fri Feb 8 09:45:54 2008 @@ -214,3 +214,56 @@ (traverse boundary-point initial-direction) (nreverse polygon)))) + +;;; formatting +;; proposed by Michael Weber on alexandria-devel +(defun format-mixed-radix-number (stream number radix-list format-list + &key lsb-first leading-zeros + (trailing-zeros t)) + "Prints NUMBER to STREAM in mixed-radix RADIX. +representation-LIST is a list of radixes, least-significant first. +FORMAT-LIST is a list of format directives, one for each digit. +When LSB-FIRST is nil (default), print most-significant digit first, +otherwise least-significant digit first. +When LEADING-ZEROS and TRAILING-ZEROS are nil, leading and +trailing zero digits are not printed, respectively. \(default: remove +leading zeros, keep trailing zeros)" + (let ((format-pairs + (loop with digit and fraction + initially (setf (values number fraction) + (truncate number)) + for f-list on format-list + and r-list = radix-list then (rest r-list) + collect (list (first f-list) + (cond ((endp r-list) + (shiftf number 0)) + ((rest f-list) + (setf (values number digit) + (truncate number (first r-list))) + digit) + (t number))) + into list + finally (progn + (incf (cadar list) fraction) + (return (nreverse list)))))) + (unless trailing-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (when lsb-first + (setf format-pairs (nreverse format-pairs))) + (unless leading-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (format stream "~{~{~@?~}~}" format-pairs))) + + +(defun format-decimal-degree (degree) + (format-mixed-radix-number nil (* 60 degree) '(60 360) '("~,2F�" "~D�"))) + +(defun format-lon-lat (lon lat) + (format nil "~A ~:[S~;N~], ~A~:[W~;E~]" + (format-decimal-degree (abs lat)) + (plusp lat) + (format-decimal-degree (abs lon)) + (plusp lon))) +

1 0