Author: hhubner Date: Thu Jan 31 05:50:52 2008 New Revision: 2430 Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp branches/trunk-reorg/bknr/modules/text/article-tags.lisp branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-tags.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/menu.lisp branches/trunk-reorg/bknr/web/src/web/sessions.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Log: Replace (request-uri) by (script-name), as the former may contain query parameters. 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 Thu Jan 31 05:50:52 2008 @@ -54,8 +54,6 @@ #:group-on #:find-all #:genlist - #+no-alexandria - #:rotate #:nrotate #:shift-until #:count-multiple @@ -67,8 +65,6 @@ #:incf-hash ;; randomize - #+no-alexandria - #:random-elt #:random-elts #:randomize-list Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Thu Jan 31 05:50:52 2008 @@ -351,11 +351,6 @@ (setf l (randomize l))))) l) -#+no-alexandria -(defun random-elt (choices) - (when choices - (elt choices (random (length choices))))) - (defun random-elts (choices num) (subseq (randomize-list choices) 0 num)) Modified: branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -45,7 +45,7 @@ object) (let* ((title (object-list-handler-title handler object)) (feeds (object-list-handler-get-objects handler object)) - (rss-feed (merge-feeds title (render-uri (request-uri) nil) + (rss-feed (merge-feeds title (render-uri (script-name) nil) title (remove nil (mapcar #'feed-rss-feed feeds)))) (grouped-items (rss-feed-group-items rss-feed))) grouped-items)) @@ -135,7 +135,7 @@ (defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword) (let ((feeds (object-list-handler-get-objects handler keyword))) (merge-feeds (object-list-handler-title handler keyword) - (render-uri (request-uri) nil) + (render-uri (script-name) nil) (object-list-handler-title handler keyword) (remove nil (mapcar #'feed-rss-feed feeds))))) Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -172,7 +172,7 @@ ((:table :border "1") (:tr (:td "Name") (:td (:princ-safe (mailinglist-name mailinglist)))) (:tr (:td "Email") (:td (:princ-safe (mailinglist-email mailinglist))))) - ((:form :action (request-uri) :method "post") + ((:form :action (script-name) :method "post") (:table (:tr (:td "Subscribe email") (:td (text-field "email")))) (submit-button "subscribe" "subscribe")))) Modified: branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp Thu Jan 31 05:50:52 2008 @@ -41,7 +41,7 @@ (html (:table (:tr (:td "Date") (:td (:princ-safe (format-date-time time)))) (:tr (:td "URL") (:td (cmslink - (render-uri (merge-uris url (request-uri)) nil) + (render-uri (merge-uris url (script-name)) nil) (:princ-safe url)))) (:tr ((:td :colspan "2") (:princ-safe error))) (:tr ((:td :colspan "2") (:pre (:princ-safe backtrace)))))))))) Modified: branches/trunk-reorg/bknr/modules/text/article-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-tags.lisp Thu Jan 31 05:50:52 2008 @@ -221,7 +221,7 @@ (if (= i page) (html (:princ-safe i)) (html ((:a :href (format nil "~A?page=~A" - (request-uri) i)) + (script-name) i)) (:princ-safe i)))) " ")) (loop for result in results Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -22,7 +22,7 @@ (let ((may-edit (admin-p (bknr-session-user)))) (with-bknr-page (:title "billboards") (html - ((:form :method "post" :action (request-uri)) + ((:form :method "post" :action (script-name)) ((:table :width "640") (:tr (:th "name") (:th "new" :br "msgs") Modified: branches/trunk-reorg/bknr/web/src/images/image-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-tags.lisp Thu Jan 31 05:50:52 2008 @@ -13,7 +13,7 @@ (html (:princ " ") (if (= i page) (html (:princ-safe i)) - (html (cmslink (format nil "~A?page=~A" (request-uri) i) (:princ-safe i)))) + (html (cmslink (format nil "~A?page=~A" (script-name) i) (:princ-safe i)))) (:princ " "))))))) (define-bknr-tag banner (&key link keyword width height) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Thu Jan 31 05:50:52 2008 @@ -133,8 +133,6 @@ (with-default-image (input-image) (let ((colors (loop for (old new) on color-mappings by #'cddr collect (cons (parse-color old) (parse-color new))))) - #+nil - (format t "color: ~A~%" colors) (do-pixels (input-image) (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) (when (cdr new-color) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Thu Jan 31 05:50:52 2008 @@ -401,6 +401,7 @@ :cl-gd :cl-interpol :cl-ppcre + :alexandria :hunchentoot :puri :xhtml-generator @@ -411,6 +412,7 @@ :bknr.utils :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:shadowing-import-from :bknr.indices #:array-index) (:export #:imageproc #:define-imageproc-handler #:image-handler ; plain images only 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 Thu Jan 31 05:50:52 2008 @@ -196,7 +196,7 @@ (defgeneric page-handler-url (page-handler)) (defmethod handler-path ((handler page-handler)) - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler)))) (defmethod decoded-handler-path ((handler page-handler)) @@ -233,7 +233,7 @@ (if (not (authorized-p handler)) (progn (setf (session-value :login-redirect-uri) - (redirect-uri (request-uri))) + (redirect-uri (script-name))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* (handle handler) @@ -320,13 +320,18 @@ ((destination :initarg :destination :reader page-handler-destination))) +(defmethod request-pathname ((handler directory-handler)) + (or (aux-request-value 'request-pathname) + (setf (aux-request-value 'request-pathname) + (subseq (script-name) (1+ (length (page-handler-prefix handler))))))) + (defmethod handler-matches ((handler directory-handler)) (and (call-next-method) - (probe-file (merge-pathnames (script-name) + (probe-file (merge-pathnames (request-pathname handler) (page-handler-destination handler))))) (defmethod handle ((handler directory-handler)) - (handle-static-file (merge-pathnames (subseq (script-name) (1+ (length (page-handler-prefix handler)))) + (handle-static-file (merge-pathnames (request-pathname handler) (page-handler-destination handler)))) (defclass file-handler (page-handler) Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/menu.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/menu.lisp Thu Jan 31 05:50:52 2008 @@ -50,7 +50,7 @@ (when title (html ((:div :class "title") (:princ-safe title)))) (dolist (item (menu-items menu)) - (let ((item-is-active (in-subtree (request-uri) (item-url item)))) + (let ((item-is-active (in-subtree (script-name) (item-url item)))) (with-slots (url title active-image inactive-image) item (let ((link-url (format nil "~A~A" (website-base-href *website*) url))) (cond Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Thu Jan 31 05:50:52 2008 @@ -18,13 +18,13 @@ (slot-value (bknr-session) 'user)) (defun do-log-request () - (format *debug-io* "Log: ~A~%" (request-uri)) + (format *debug-io* "Log: ~A~%" (script-name)) (return-from do-log-request) #+(or) (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (user-agent (header-in :user-agent)) (time (get-universal-time))) @@ -46,7 +46,7 @@ (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (time (get-universal-time))) (make-event 'web-server-error-event Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Thu Jan 31 05:50:52 2008 @@ -198,7 +198,7 @@ (define-bknr-tag navi-button (&key url text) (html (:princ " ")) - (if (equal (request-uri) + (if (equal (script-name) url) (html (:princ-safe text)) (html (cmslink url (:princ-safe text)))) @@ -255,7 +255,7 @@ (define-bknr-tag site-menu () (destructuring-bind (empty first-level &optional second-level &rest rest) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty rest)) (html ((:div :id "navcontainer") (let ((*standard-output* *html-stream*)) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 31 05:50:52 2008 @@ -294,7 +294,7 @@ (defmethod handler-matches ((handler template-handler)) (handler-case - (find-template-pathname handler (request-uri)) + (find-template-pathname handler (script-name)) (template-not-found (c) (declare (ignore c)) nil))) @@ -304,7 +304,7 @@ ;; Erst body ausfuehren... (let ((body (expand-template handler - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler))) :env (initial-template-environment handler)))) ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Thu Jan 31 05:50:52 2008 @@ -59,7 +59,7 @@ (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (request-uri)) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name)) (unless match (http-error +http-bad-request+ "bad request - missing image path or loid")) (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Thu Jan 31 05:50:52 2008 @@ -108,7 +108,7 @@ (mapcar (lambda (param) (cons (car param) (iconv:iconv request-charset "utf-8" (cdr param)))) - (remove "" (append (form-urlencoded-to-query (uri-query (request-uri))) + (remove "" (append (form-urlencoded-to-query (uri-query (script-name))) (aux-request-value 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) (aux-request-value 'bknr-parsed-parameters)) @@ -157,11 +157,11 @@ (#\> ">"))))) (defun parse-url () - (values-list (cddr (mapcar #'url-decode (split "/" (request-uri)))))) + (values-list (cddr (mapcar #'url-decode (split "/" (script-name)))))) (defun last-url-component () (register-groups-bind (last) - ("/([^\\/]+)$" (request-uri)) + ("/([^\\/]+)$" (script-name)) last)) (defun parse-date-field (name) @@ -180,12 +180,12 @@ (defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" (let ((len (length (page-handler-prefix handler)))) - (subseq (request-uri) len))) + (subseq (script-name) len))) (defun self-url (&key command prefix) (destructuring-bind (empty old-prefix object-id &rest old-command) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))"))