[bknr-cvs] r2430 - in branches/trunk-reorg/bknr: datastore/src/utils modules/feed modules/mail modules/stats modules/text web/src web/src/images web/src/web
hhubner at common-lisp.net
hhubner at common-lisp.net
Thu Jan 31 10:50:55 UTC 2008
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))"))
More information about the Bknr-cvs
mailing list