Anonymous avatar Anonymous committed 376df36 Merge

Merged in latest -dev

Comments (0)

Files changed (102)

 88d26b07f7c2f22061f1e126311b88f99255e223 pre 0.1
+7b0d8ac2dcb522d056971a77e789088532bf5644 before-make-widget-place-writer-merge
 7b1fea8d1d6f872fb5b927062ee3b6716648089c 0.8

contrib/jwr/yui/yui.lisp

+(in-package #:weblocks)
+
+(defpsmacro ensure-dom-ready (&body body)
+  "Take &body and put it in a function that will be called after a
+DOM-ready event is triggered."
+  `(*YAHOO*.util.*event.on-d-o-m-ready (lambda ()
+					 ,@body)))
+
+(defpsmacro with-lazy-loaded-modules ((modules &key (load-optional t) base) &body body)
+  "Take &body and put it in a function that will be called back once
+required modules have been loaded and the DOM is ready."
+  (let ((callback-name (ps-gensym "$yui_callback"))
+	(loader-name (ps-gensym "$yui_loader")))
+    `(progn
+       (defun ,callback-name ()
+	 (ensure-dom-ready ,@body))
+       (defvar ,loader-name (new (*YAHOO*.util.*y-u-i-loader
+				  (create :require (array ,@modules)
+					  :load-optional ,load-optional
+					  ,@(when base `(:base ,base))
+					  :on-success ,callback-name))))
+       (.insert ,loader-name))))
+
+(defpsmacro keywords-to-object (args)
+  `(create ,@args))
+
+
+(defclass yui-any-editor-presentation (textarea-presentation)
+  ((component-config :accessor yui-component-config
+		     :initarg :config
+		     :initform nil
+		     :documentation "A list of JavaScript widget
+		     configuration options. Will be passed straight
+		     through to `(create ,@options) in parenscript
+		     code. Usually a list of keyword value pairs.."))
+  (:documentation "A common superclass for both types of rich text
+  editor widgets available in the YUI library. Used to provide certain
+  common methods. Not to be instantiated directly."))
+
+(defmethod create-and-configure-editor-script ((presentation yui-any-editor-presentation)
+					       widget-variable target-id)
+  (error "yui-any-editor-presentation is not to be used standalone. Please use one of
+its subclasses."))
+
+(defclass yui-simpleeditor-presentation (yui-any-editor-presentation)
+  ()
+  (:documentation "YUI SimpleEditor: a rich text editor, in its simple incarnation."))
+
+(defclass yui-editor-presentation (yui-any-editor-presentation)
+  ()
+  (:documentation "YUI Editor: a rich text editor, in full glory."))
+
+(defmethod create-and-configure-editor-script ((presentation yui-simpleeditor-presentation)
+					       editor-widget target-id)
+  (ps* `(with-lazy-loaded-modules (("simpleeditor"))
+	  (setf ,editor-widget
+		(new (*YAHOO*.widget.*simple-editor ,target-id
+						    (keywords-to-object
+						     ,(yui-component-config presentation)))))
+	  (setf (slot-value ,editor-widget '_default-toolbar.titlebar) false)
+	  (.render ,editor-widget))))
+
+(defmethod create-and-configure-editor-script ((presentation yui-editor-presentation)
+					       editor-widget target-id)
+  (ps* `(with-lazy-loaded-modules (("editor"))
+	  (setf ,editor-widget
+		(new (*YAHOO*.widget.*editor ,target-id
+					     (keywords-to-object
+					      ,(yui-component-config presentation)))))
+	  (setf (slot-value ,editor-widget '_default-toolbar.titlebar) false)
+	  (.render ,editor-widget))))
+
+(defmethod render-view-field-value :around (value (presentation yui-any-editor-presentation)
+						  (field form-view-field) (view form-view) widget obj
+						  &rest args)
+  (declare (special *presentation-dom-id*)
+	   (ignore args))
+  (let ((*presentation-dom-id* (gen-id)))
+    (call-next-method)))
+
+(defmethod render-view-field-value :after (value (presentation yui-any-editor-presentation)
+						 (field form-view-field) (view form-view) widget obj
+						 &rest args &key &allow-other-keys)
+  (declare (ignore args)
+	   (special *on-ajax-complete-scripts*
+		    *presentation-dom-id*
+		    *form-submit-dependencies*))
+  (let ((widget-variable (ps-gensym "$yui_widget")))
+    (send-script (create-and-configure-editor-script presentation
+						     widget-variable
+						     *presentation-dom-id*))
+    (push (make-instance 'javascript-code-dependency
+			 :code (ps* `(.save-H-T-M-L ,widget-variable)))
+	  *form-submit-dependencies*)))
+
+
+
+(export '(yui-grid-page yui-grid-page-type yui-grid-page-template yui-grid-page-header
+	  yui-grid-page-primary-body yui-grid-page-secondary-body yui-grid-page-footer
+	  yui-grid-layout yui-grid-first yui-grid-left yui-grid-right))
+
+(defwidget yui-grid-page ()
+  ((header :accessor yui-grid-page-header :initarg :header)
+   (primary-body :accessor yui-grid-page-primary-body :initarg :primary-body)
+   (secondary-body :accessor yui-grid-page-secondary-body :initarg :secondary-body)
+   (footer :accessor yui-grid-page-footer :initarg :footer)))
+
+
+(defmethod initialize-instance :after ((obj yui-grid-page) &rest initargs
+				       &key
+				       (type "doc")
+				       (template "")
+				       &allow-other-keys)
+  (declare (ignore initargs))
+  ;; we don't actually use this list for rendering, but it is necessary
+  ;; to keep the weblocks widget tree consistent --jwr
+  (set-children-of-type obj (list (yui-grid-page-header obj)
+				  (yui-grid-page-primary-body obj)
+				  (yui-grid-page-secondary-body obj)
+				  (yui-grid-page-footer obj))
+			:yui-grid-page)
+  ;; this will set HTML id for us
+  (setf (widget-name obj) type)
+  (setf (dom-class obj) template))
+
+(defmethod render-widget-body ((obj yui-grid-page) &rest args)
+  (declare (ignore args))
+  (with-html
+    (:div :id "hd" (render-widget (yui-grid-page-header obj)))
+    (:div :id "bd"
+	  (:div :id "yui-main"
+		(:div :class "yui-b" (render-widget (yui-grid-page-primary-body obj))))
+	  (:div :class "yui-b" (render-widget (yui-grid-page-secondary-body obj))))
+    (:div :id "ft" (render-widget (yui-grid-page-footer obj)))))
+
+(defmethod render-widget-children ((obj yui-grid-page) &rest args)
+  "For yui-grid-page, render-widget-body does all the work"
+  (declare (ignore args)))
+
+
+;; TODO: implement various layout types
+(defwidget yui-grid-layout ()
+  ((first :accessor yui-grid-first :initarg :first :initform nil)
+   (left :accessor yui-grid-left :initarg :left :initform nil)
+   (right :accessor yui-grid-right :initarg :right :initform nil)))
+
+(defmethod initialize-instance :after ((obj yui-grid-layout) &rest initargs)
+  (declare (ignore initargs))
+  (setf (dom-class obj) (format nil "yui-g~:[~; first~]" (yui-grid-first obj))))
+
+(defmethod update-children ((obj yui-grid-layout))
+  (set-children-of-type obj (list (yui-grid-left obj) (yui-grid-right obj)) :yui-grid-layout))
+
+(defmethod render-widget-body ((obj yui-grid-layout) &rest args)
+  (declare (ignore args))
+  (with-accessors ((left yui-grid-left) (right yui-grid-right)) obj
+    (with-html
+      (if (eq 'yui-grid-layout (class-of left))
+	  (render-widget left)
+	  (htm (:div :class "yui-u first"
+		     (render-widget left))))
+      (if (eq 'yui-grid-layout (class-of right))
+	  (render-widget right)
+	  (htm (:div :class "yui-u"
+		     (render-widget right)))))))
+
+
+(export '(yui-mixin yui-widget-variable))
+
+(defclass yui-mixin ()
+  ((widget-variable :accessor yui-widget-variable
+                    :documentation "Global JavaScript variable that will
+                    hold the YUI widget."))
+  (:documentation "A mixin used for YUI widgets that need a
+  corresponding javascript variable."))
+
+(defmethod initialize-instance :after ((w yui-mixin) &rest args)
+  (declare (ignore args))
+  (setf (yui-widget-variable w) (ps-gensym "$yui_widget")))
+
+
+(export '(yui-tabview yui-tabview-tab-labels yui-tabview-selected-tab yui-tabview-tabs))
+
+(defwidget yui-tabview (yui-mixin widget)
+  ((tab-labels :accessor yui-tabview-tab-labels
+	       :initarg :tab-labels
+	       :initform nil
+	       :documentation "A list of strings containing tab labels.")
+   (selected-tab :accessor yui-tabview-selected-tab
+		 :initarg :selected-tab
+		 :initform nil
+		 :documentation "A string containing the label of the
+		 tab that is to be initially selected. Will be compared
+		 with tab-labels using EQUAL.")
+   (tabs :accessor yui-tabview-tabs
+	 :initarg :tabs
+	 :initform nil
+	 :documentation "A list of widgets, one for each tab,
+	 corresponding to tab labels."))
+  (:documentation "Implements the YUI TabView widget."))
+
+(defmethod initialize-instance :after ((obj yui-tabview) &rest initargs)
+  (declare (ignore initargs))
+  ;; this will set HTML id for us
+  (setf (dom-class obj) "yui-navset")
+  (set-children-of-type obj (yui-tabview-tabs obj) :yui-tabview))
+
+(defmethod (setf yui-tabview-tabs) ((obj yui-tabview) tab-list)
+  (setf (slot-value obj 'tabs) tab-list)
+  (set-children-of-type obj (yui-tabview-tabs obj) :yui-tabview))
+
+(defun tabview-script (tabview-js-var tabview-id)
+  (ps* `(with-lazy-loaded-modules (("tabview"))
+	  (setf ,tabview-js-var (new (*YAHOO*.widget.*tab-view ,tabview-id))))))
+
+(defmethod render-widget-body ((obj yui-tabview) &rest args)
+  (declare (ignore args))
+  (send-script (tabview-script (yui-widget-variable obj) (dom-id obj)))
+  (let ((tab-counter 0))
+    (with-html
+      (:ul :class "yui-nav"
+	   (mapc (lambda (label)
+		   (incf tab-counter)
+		   (htm (:li :class (when (equal (yui-tabview-selected-tab obj) label)
+				      "selected")
+			 (:a :href (format nil "#tab~D" tab-counter)
+			     (:em (str label))))))
+		 (yui-tabview-tab-labels obj))))))
+
+(defmethod render-widget-children ((obj yui-tabview) &rest args)
+  (with-html (:div :class "yui-content"
+		   (mapc (lambda (tab)
+			   (htm (:div (apply #'render-widget tab args))))
+			 (yui-tabview-tabs obj)))))

contrib/lpolzer/checkboxes.lisp

-
-(in-package :weblocks)
-
-(export '(checkboxes checkboxes-presentation checkboxes-parser))
-
-;;; Checkboxes
-(defclass checkboxes-presentation (form-presentation choices-presentation-mixin)
-  ())
-
-(defmethod render-view-field ((field form-view-field) (view form-view)
-                              widget (presentation checkboxes-presentation) value obj
-                              &rest args &key validation-errors &allow-other-keys)
-  (let* ((attribute-slot-name (attributize-name (view-field-slot-name field)))
-         (validation-error (assoc attribute-slot-name validation-errors
-                                  :test #'string-equal
-                                  :key #'view-field-slot-name))
-         (field-class (concatenate 'string attribute-slot-name
-                                   (when validation-error " item-not-validated"))))
-    (with-html
-      (:li :class field-class
-           (:span :class "label"
-                  (:span :class "slot-name"
-                         (:span :class "extra"
-                                (str (view-field-label field)) ": ")))
-           (apply #'render-view-field-value
-                  value presentation
-                  field view widget obj
-                  args)
-           (when validation-error
-             (htm (:p :class "validation-error"
-                      (:em
-                       (:span :class "validation-error-heading" "Error: ")
-                       (str (format nil "~A" (cdr validation-error)))))))))))
-
-(defmethod render-view-field-value (value (presentation checkboxes-presentation)
-                                    (field form-view-field) (view form-view) widget obj
-                                    &rest args &key intermediate-values &allow-other-keys)
-  (declare (ignore args))
-  (multiple-value-bind (intermediate-value intermediate-value-p)
-      (form-field-intermediate-value field intermediate-values)
-    (render-checkboxes (view-field-slot-name field)
-                          (obtain-presentation-choices presentation obj)
-                          :selected-values (if intermediate-value-p
-                                             intermediate-value
-                                             (when value
-                                               (mapcar #'attributize-name value))))))
-
-(defmethod render-view-field-value (value (presentation checkboxes-presentation)
-                                    field view widget obj &rest args
-                                    &key highlight &allow-other-keys)
-  (declare (ignore highlight args))
-  (if (null value)
-      nil
-      (mapcar #'(lambda (value)
-                  (with-html
-                    (:span value))) value)))
-
-(defun render-checkboxes (name selections &key id (class "checkbox") selected-values)
-  (dolist (val selections)
-    (let ((checked-p (if (find (cdr val) selected-values :test #'equal) "checked" nil))
-          (value (if (consp val) (car val) val)))
-    (with-html
-      (:input :name name :type "checkbox" :id id :class class
-             :checked checked-p :value value (str (humanize-name value)))))))
-
-(defun render-checkboxes2 (name selections &key id (class "checkbox") selected-values)
-  "Renders a group of checkboxes.
-
-'name' - name of checkboxes.
-'selections' - a list of selections. May be an association list, in
-which case its car is used to dispaly selection text, and cdr is used
-for the value.
-'id' - id of a label that holds the checkboxes.
-'class' - class of the label and of checkboxes.
-'selected-value' - list of selected checkbox values."
-  (loop for i in (list->assoc selections)
-        for j from 1
-        with count = (length selections)
-        for label-class = (cond
-                            ((eq j 1) (concatenate 'string class " first"))
-                            ((eq j count) (concatenate 'string class " last"))
-                            (t class))
-        do (progn
-             (with-html
-               (:label :id id :class label-class
-                       (let ((cb-name (concatenate 'string (attributize-name name) "-" (attributize-name j))))
-                         (htm (:input :name cb-name :type "checkbox" :class "checkbox"
-                                      :value (cdr i)
-                                      (if (find (cdr i) selected-values :test 'equal) :checked "checked"))))
-                       (:span (str (format nil "~A " (car i))))))))
-    (with-html (:input :name (attributize-name name) :type "hidden")))
-
-(defclass checkboxes-parser (parser)
-  ()
-  (:documentation "A parser for checkboxes."))
-
-(defun post-parameter->list (param)
-  (let ((result nil))
-    (mapcar (lambda (x)
-              ;(format t "~S~%" x)
-              (when (equalp (car x) param)
-                (push (cdr x) result)))
-            (hunchentoot:post-parameters))
-    result))
-
-(defmethod parse-view-field-value ((parser checkboxes-parser) value obj
-                                   (view form-view) (field form-view-field) &rest args)
-  (declare (ignore args))
-  (let ((result (mapcar (lambda (s)
-                          (intern (string-upcase s) "KEYWORD"))
-                        (post-parameter->list (symbol-name (view-field-slot-name field))))))
-      (values t result result)))
-

contrib/lpolzer/dual-password.lisp

   (:documentation "A presentation for passwords."))
 
 (defun render-dual-password-fields (name value maxlength)
-  (render-password (format nil "~A-weblocks-1" name) (or value "") :maxlength maxlength)
-  (with-html (:br))
-  (render-password (format nil "~A-weblocks-2" name) (or value "") :maxlength maxlength
-                   :class "password confirm"))
+  (let* ((basename (format nil "~A-weblocks" (attributize-name name)))
+         (name1 (format nil "~A-1" basename))
+         (name2 (format nil "~A-2" basename))
+         (status-name (format nil "~A-status" basename)))
+    (with-html
+      (:div
+        (render-password name1 (or value "") :id name1 :maxlength maxlength
+                         :style (when value "border:1px solid green"))))
+    (with-html 
+      (:div
+        (render-password name2 (or value "") :id name2 :maxlength maxlength
+                         :class "password confirm"
+                         :style (when value "border:1px solid green"))))
+    (send-script
+      (concatenate 'string
+        "function checkPasswordFields() {
+          var f1 = $('" name1 "'),
+              f2 = $('" name2 "'),
+              color;
+
+          if (f1.value == f2.value
+              && f1.value != '')
+            color = 'green';
+          else
+            color = 'red';
+
+          f1.style.borderColor = color;
+          f2.style.borderColor = color;
+        }"
+        "
+         $('" name1 "').observe('keyup', checkPasswordFields);
+         $('" name2 "').observe('keyup', checkPasswordFields);
+        "
+    ))))
 
 (defmethod render-view-field-value (value (presentation dual-password-presentation)
 				    (field form-view-field) (view form-view)
 (defmethod parse-view-field-value ((parser dual-password-parser) value obj
 				   (view form-view) (field form-view-field) &rest args)
   (declare (ignore args))
-  (let* ((val1 (hunchentoot:parameter (format nil "~A-weblocks-1" (string-downcase (view-field-slot-name field)))))
-         (val2 (hunchentoot:parameter (format nil "~A-weblocks-2" (string-downcase (view-field-slot-name field)))))
+  (let* ((val1 (hunchentoot:parameter (format nil "~A-weblocks-1" (attributize-name (view-field-slot-name field)))))
+         (val2 (hunchentoot:parameter (format nil "~A-weblocks-2" (attributize-name (view-field-slot-name field)))))
          (present-p (and val1 val2 (text-input-present-p val1) (text-input-present-p val2)))
          (valid-p (and present-p (equal val1 val2)))
          ; XXX min-length < length < max-length
          )
-      (values valid-p present-p val1)))
+    (values valid-p present-p val1)))
 

contrib/lpolzer/yui/yui-base.lisp

 
 (export '(yui-widget yui-widget-variable yui-target-id yui-component-config
 	  yui-settings-mixin add-options
+	  *yui-loader-base* 
           add-component-config js-bool))
 
+(defparameter *yui-loader-base* "http://yui.yahooapis.com/2.6.0/build/"
+  "Default base for yui-loader, change if necessary (eg. for 2.7.0, or a local cache)")
+
 (defclass yui-settings-mixin ()
   ((yui-settings :accessor yui-settings :initarg :settings :initform ""))
   (:documentation "Some YUI widgets require additional settings to be
 DOM-ready event is triggered."
   `(|:YAHOO.util.:Event.:onDOMReady| (lambda () ,@body)))
 
-(defpsmacro with-lazy-loaded-modules ((modules &key (load-optional t) base (include-css-p t)) &body body)
+(defpsmacro with-lazy-loaded-modules ((modules &key (load-optional t) (base *yui-loader-base*) (include-css-p t)) &body body)
   "Take &body and put it in a function that will be called back once
 required modules have been loaded and the DOM is ready."
   (let ((callback-name (ps-gensym "$yui_callback"))

contrib/lpolzer/yui/yui-tabview.lisp

-
 (in-package :weblocks)
 
 (export '(yui-tabview yui-tabview-tabs yui-tabview-selected))
              :documentation "Tab that will be selected by default. An
              integer number, starting from 1 (e.g. the first tab
              corresponds to 1)."))
+  (:default-initargs :modules '("tabview"))
   (:documentation "YUI TabView widget"))
 
 (defmethod initialize-instance :after ((obj yui-tabview) &rest initargs &key &allow-other-keys)
   (declare (ignore initargs))
   (setf (composite-widgets obj) (mapcar #'cdr (yui-tabview-tabs obj)))
-  (setf (yui-target-id obj) (widget-dom-id obj)))
+  (setf (yui-target-id obj) (dom-id obj)))
 
 (defmethod widget-css-classes ((obj yui-tabview))
   (declare (ignore obj))
   "yui-navset")
 
+
 (defmethod render-widget-body ((widget yui-tabview) &rest args)
   (flet ((render-tab (i) (let ((child (cdr (nth i (yui-tabview-tabs widget)))))
                            (render-widget child))))
                                                (when (eql (yui-tabview-selected widget) i)
                                                  " selected"))
                            (:a :href (format nil "#tab~D" i)
-                               (esc (humanize-name name)))))))
+                               (:em (esc (humanize-name name))))))))
       (:div :class "yui-content"
         (loop for child in (mapcar #'cdr (yui-tabview-tabs widget))
               do (htm (:div (render-widget child))))))
     #+OLD(send-script
       (ps:ps* `(new (|:YAHOO.widget.:TabView| ,(widget-dom-id widget)))))
     (send-script
-      (ps* `(with-lazy-loaded-modules (("tabview"))
+      (ps* `(with-lazy-loaded-modules (,(yui-modules widget) 
+				       ,@(yui-loader-args widget))
          (setf ,(yui-widget-variable widget)
                (new (|:YAHOO.widget.:TabView| ,(yui-target-id widget)
                                               (keywords-to-object ,(yui-component-config widget))))))))

contrib/s11001001/presentations.lisp

 
 (in-package #:weblocks-s11)
 
-(export '(us-cents us-cents-presentation us-cents-parser))
+(export '(us-cents us-cents-input us-cents-presentation
+	  us-cents-input-presentation us-cents-parser))
 
 (arnesi:enable-sharp-l-syntax)
 
 ;;;; Money represented in US dollars and stored as #cents
 
-(defclass us-cents-presentation (text-presentation)
+(defclass us-cents-printer ()
+  ()
+  (:documentation "Mixin for data and form; see
+  `us-cents-presentation' and `us-cents-input-presentation'."))
+
+(defclass us-cents-presentation (us-cents-printer text-presentation)
   ()
   (:documentation "Present a count of US cents as a pretty US dollar
   amount."))
 
+(defclass us-cents-input-presentation (us-cents-printer input-presentation)
+  ()
+  (:documentation "The counterpart to `us-cents-presentation' for
+  forms."))
+
 (defclass us-cents-parser (text-parser)
   ()
   (:documentation "Parse a US dollar amount and answer the # of US cents."))
 
 (defmethod print-view-field-value
-    (value (self us-cents-presentation) field view widget obj &rest args)
-  (declare (ignorable args))
+    (value (self us-cents-printer) field view widget obj &rest args)
+  (declare (ignore field view widget obj args))
   (multiple-value-bind (dollars cents) (truncate value 100)
     (format nil "$~:D.~2,'0D" dollars cents)))
 
 (defmethod weblocks:parse-view-field-value
     ((parser us-cents-parser) value obj view field &rest args)
-  (declare (ignorable args))
+  (declare (ignore obj view field args))
   (let* ((present? (text-input-present-p value))
 	 (float-start
 	  (and present?
 	 (float
 	  (and float-start
 	       (ignore-errors (arnesi:parse-float value :start float-start)))))
-    (values (or (not present?) float) present? (round (* 100 float)))))
+    (values (or (not present?) float) present?
+	    (and float (round (* 100 float))))))
 
 ;;; presentations.lisp ends here

contrib/yarek/widgets/popover-gridedit.lisp

      :initform t
      :initarg  :adjust-item-widget-actions
      :documentation
-       "When set to true, the item widget will be passed to 'popover-gridedit-adjust-item-widget-actions-for-dialog'."))
+       "When set to true, the item widget will be passed to 'popover-gridedit-adjust-item-widget-actions-for-dialog'.")
+   (dialog-css-class
+     :accessor popover-gridedit-dialog-css-class
+     :initform nil
+     :initarg  :dialog-css-class
+     :documentation
+       "The CSS class of the popover dialog."))
   (:documentation "A widget based on the gridedit that uses a popover dialog for the editor"))
 
 (defgeneric popover-gridedit-adjust-item-widget-actions-for-dialog (w)
       (do-dialog title item-w
                  :close #'(lambda (&rest args)
                             (declare (ignore args))
-                            (popover-gridedit-close-dialog pg))))))
+                            (popover-gridedit-close-dialog pg))
+                 :css-class (popover-gridedit-dialog-css-class pg)))))
 
 (defmethod render-widget-body ((pg popover-gridedit) &rest args) 
   (dataedit-update-operations pg)

pub/scripts/weblocks.js

     element.update(newBody);
 }
 
+function updateElement(element, newElement) {
+    element.replace(newElement);
+}
+
 function selectionEmpty() {
     if(document.getSelection) {
 	return document.getSelection() == "";
 Ajax.Responders.register({
   onCreate: function() {
 	    $('ajax-progress').innerHTML = "<img src='/pub/images/progress.gif'>";
-	}, 
+	},
   onComplete: function() {
 	    $('ajax-progress').innerHTML = "";
 	}
     } else {
         json = transport.responseText.evalJSON(true);
     }
-    
+
     // See if there are redirects
     var redirect = json['redirect'];
     if (redirect)
 	window.location.href = redirect;
 	return;
     }
-    
+
     execJsonCalls(json['before-load']);
 
     // Update dirty widgets
 	var widget = $(i);
 	if(widget) {
             //console.log("updating widget %s", i);
-	    updateElementBody(widget, dirtyWidgets[i]);
+	    updateElement(widget, dirtyWidgets[i]);
 	}
     }
 
     return url;
 }
 
-function initiateActionWithArgs(actionCode, sessionString, args, method) {
+function initiateActionWithArgs(actionCode, sessionString, args, method, url) {
     if (!method) method = 'get';
-    new Ajax.Request(getActionUrl(actionCode, sessionString),
+    if (!url) url = getActionUrl(actionCode, sessionString);
+    new Ajax.Request(url,
                      {
                          method: method,
                          onSuccess: onActionSuccess,
     delete(serializedForm['action']);
 
     initiateActionWithArgs(actionCode, sessionString, serializedForm, form.method);
-} 
+}
 
 function disableIrrelevantButtons(currentButton) {
     $(currentButton.form).getInputs('submit').each(function(obj)
 	    tableRows.each(function(row) {
 		    Event.observe(row, 'mouseover', function() {
 			    row.addClassName('hover');
-			}); 
+			});
 		    Event.observe(row, 'mouseout', function() {
 			    row.removeClassName('hover');
-			}); 
+			});
 		});
 	});
 }
 	inputBox += 'value="' + value +'"';
     }
     inputBox += '/>';
-    
+
     var suggestHTML = inputBox + '<div id="' + choicesId + '" class="suggest"></div>';
     $(inputId).replace(suggestHTML);
-    
+
     declareSuggest(inputId, choicesId, suggestOptions);
 }
 

scripts/new-app-templates/{APPNAME}.lisp

 (defpackage #:{APPNAME}
   (:use :cl :weblocks
         :f-underscore :anaphora)
+  (:import-from :hunchentoot #:header-in
+		#:set-cookie #:set-cookie* #:cookie-in
+		#:user-agent #:referer)
   (:documentation
    "A web application based on Weblocks."))
 
     :init-user-session '{APPNAME}::init-user-session
     :autostart nil                   ;; have to start the app manually
     :ignore-default-dependencies nil ;; accept the defaults
+    :debug t
     )
 
 ;; Top level start & stop scripts
   "Starts the application by calling 'start-weblocks' with appropriate
 arguments."
   (apply #'start-weblocks args)
-  (start-webapp '{APPNAME})
+  (start-webapp '{APPNAME}))
 
 (defun stop-{APPNAME} ()
   "Stops the application by calling 'stop-weblocks'."
 
 (in-package :weblocks)
 
-(export '(*expired-action-handler* expired-action-handler page-not-found-handler make-action-url make-action))
+(export '(*expired-action-handler*
+          expired-action-handler
+          page-not-found-handler
+          make-action-url
+          make-action
+          function-or-action->action))
 
-(defparameter *expired-action-handler* 'default-expired-action-handler
+(defvar *expired-action-handler* 'default-expired-action-handler
   "Must be bound to a designator of a function with a single optional
 argument - the application. The function gets called when the user
 tries to invoke an expired action (due to a session timeout). The
   "Gets the name of the action from the request."
   (let* ((request-action-name (request-parameter *action-string*))
 	 (get/post-action-name (parameter *action-string*))
-	 (action-name (if request-action-name
-			  request-action-name
-			  get/post-action-name)))
+	 (action-name (or request-action-name get/post-action-name)))
     action-name))
 
 (defun get-request-action ()

src/application.lisp

 	  get-webapps-for-class initialize-webapp finalize-webapp
 	  webapp-application-dependencies webapp-name
 	  webapp-description weblocks-webapp-public-files-path
+          webapp-public-files-path
 	  webapp-public-files-uri-prefix webapp-prefix
 	  running-webapp make-webapp-uri make-webapp-public-file-uri
           reset-webapp-session
 (defvar *registered-webapps* nil
   "A list of applications that the system knows about")
 
-(defvar *webapp-permanent-actions*
-  (make-hash-table))
-
 (defclass weblocks-webapp ()
   ((name :accessor weblocks-webapp-name :initarg :name
 	 :type (or symbol string))
 instance, have different sites (e.g. mobile vs. desktop) with vastly different 
 layout and dependencies running on the same server."))
 
-;; we use a "transform on write" approach for two reasons:
+;; Slash-normalizing accessors
 ;;
-;; 1. sane values in slots all the time (except when someone messes around
+;; We use a "transform on write" approach for two reasons:
+;;
+;; 1. Sane values in slots all the time (except when someone messes around
 ;;    with SLOT-VALUE)
 ;;
-;; 2. increased performance
+;; 2. Increased performance
 ;;
 (defmethod (setf weblocks-webapp-prefix) (prefix (app weblocks-webapp))
   "Set the prefix of the webapp. Ensures normalization."
   (unless (string= prefix "/") ;; XXX multiple slashes?
     (setf (slot-value app 'prefix) (strip-trailing-slashes prefix))))
+
 (defmethod (setf weblocks-webapp-public-files-uri-prefix) (prefix (app weblocks-webapp))
   "Set the public files URI prefix of the webapp. Ensures normalization."
   (setf (slot-value app 'public-files-uri-prefix) (strip-trailing-slashes prefix)))
 
-(defun webapp-public-files-uri-prefix (&optional (app (current-webapp)))
-  (weblocks-webapp-public-files-uri-prefix app))
+(defmethod (setf weblocks-webapp-public-files-path) (path (app weblocks-webapp))
+  "Set the public files URI prefix of the webapp. Ensures normalization."
+  (setf (slot-value app 'public-files-path) (maybe-add-trailing-slash path)))
 
+;; abstraction macro
 (defmacro defwebapp (name &rest initargs &key 
 		     subclasses
 		     slots
     (when (slot-boundp self 'public-files-uri-prefix)
       (setf (weblocks-webapp-public-files-uri-prefix self)
             (slot-value self 'public-files-uri-prefix)))
+    (and (slot-boundp self 'public-files-path)
+         (slot-value self 'public-files-path)
+      (setf (weblocks-webapp-public-files-path self)
+            (slot-value self 'public-files-path)))
     (slot-default html-indent-p (weblocks-webapp-debug self))
     (let ((class-name (class-name (class-of self))))
       (slot-default name (attributize-name class-name))
     (stop-webapp name)
     (start-webapp class :name name)))
 
-;;
-;; These procedures are relative to the current request's selected webapp
-;;
-
-(defvar *current-webapp*)
-(setf (documentation '*current-webapp* 'variable)
-      "A currently active web application.")
-
-(defun current-webapp ()
-  "Returns the currently invoked instance of a web application."
-  (declare (special *current-webapp*))
-  *current-webapp*)
-
-(defun reset-webapp-session (&optional (app (current-webapp)))
-  "Reset sessions on a per-webapp basis"
-  (setf (session-value (class-name (class-of app))) nil))
-
-(defun webapp-application-dependencies (&optional (app (current-webapp)))
-  "Returns a list of dependencies on scripts and/or stylesheets that
-   will persist throughout the whole application. See documentation for
-   'widget-application-dependencies' for more details."
-  (build-local-dependencies
-   (weblocks-webapp-application-dependencies app)))
-
-(defun webapp-name (&optional (app (current-webapp)))
-  "Returns the name of the web application (also see 'defwebapp'). Please
-   note, this name will be used for the composition of the page title
-   displayed to the user. See 'page-title' for details."
-  (weblocks-webapp-name app))
-
-(defun webapp-description (&optional (app (current-webapp)))
-  "Returns the description of the web application. Please note, this
-   description will be used for the composition of the page title
-   displayed to the user. See 'page-title' for details."
-  (weblocks-webapp-description app))
-
-(defun webapp-serves-hostname (hostname &optional (app (current-webapp)))
-  "Does APP serve requests for HOSTNAME?"
-  (or (null (webapp-hostnames app))
-      (member (car (cl-ppcre:split ":" hostname))
-              (webapp-hostnames app)
-              :test #'equalp)))
-
-(defun webapp-hostnames (&optional (app (current-webapp)))
-  "Returns the hostnames this application will serve requests for."
-  (weblocks-webapp-hostnames app))
-
-(defun webapp-prefix (&optional (app (current-webapp)))
-  "Returns the URL prefix of the application."
-  (weblocks-webapp-prefix app))
-
-(defun webapp-init-user-session (&optional (app (current-webapp)))
-  "Returns the init function for the user session."
-  (let ((init (weblocks-webapp-init-user-session app)))
-    (etypecase init
-      (function init)
-      (symbol (symbol-function init)))))
-
+;;; building webapp uris
 (defun make-webapp-uri (uri &optional (app (current-webapp)))
   "Makes a URI for a weblocks application (by concatenating the app
 prefix and the provided uri)."
     (concatenate 'string (weblocks-webapp-public-files-uri-prefix app) "/" uri)
     app))
 
-(defun webapp-session-value (symbol &optional (session *session*))
+
+;;; webapp-scoped session values
+(defun webapp-session-value (symbol &optional (session *session*) (webapp *current-webapp*))
   "Get a session value from the currently running webapp"
-  (declare (special *current-webapp*))
-  (let ((webapp-session (session-value (class-name (class-of *current-webapp*)) session)))
+  
+  (let ((webapp-session (session-value (class-name (class-of webapp)) session)))
     (cond (webapp-session
 	   (gethash symbol webapp-session))
-	  (*current-webapp* (values nil nil))
+	  (webapp (values nil nil))
 	  (t nil))))
 
-(defun (setf webapp-session-value) (value symbol)
-  "Set a session value for the currently runnin webapp"
-  (declare (special *current-webapp*))
-  (let ((webapp-session (session-value (class-name (class-of *current-webapp*)))))
+(defun (setf webapp-session-value) (value symbol &optional (session *session*) (webapp *current-webapp*))
+  "Set a session value for the currently runnin webapp" 
+  (let ((webapp-session (session-value (class-name (class-of webapp)) session)))
     (unless webapp-session
       (setf webapp-session (make-hash-table :test 'equal)
-	    (session-value (class-name (class-of *current-webapp*))) webapp-session))
+	    (session-value (class-name (class-of webapp))) webapp-session))
     (setf (gethash symbol webapp-session) value)))
 
 
 ;; Permanent actions
 ;;
 
-;; NOTES: Should lock-protect this table since users may add actions at runtime
+;; FIXME: lock-protect this table since users may add actions at runtime
+(defvar *webapp-permanent-actions*
+  (make-hash-table))
 
 (defun webapp-permanent-action (action)
   "Returns the action function associated with this symbol in the current webapp"
   "A wrapper around 'compute-webapp-public-files-uri-prefix' that
   handles current app."
   (compute-webapp-public-files-uri-prefix app))
+
+
+;;; Convenience accessors
+;;; These procedures are relative to the current request's selected webapp
+(defvar *current-webapp*)
+(setf (documentation '*current-webapp* 'variable)
+      "A currently active web application.")
+
+(defun current-webapp ()
+  "Returns the currently invoked instance of a web application."
+  (declare (special *current-webapp*))
+  *current-webapp*)
+
+(defun reset-webapp-session (&optional (app (current-webapp)))
+  "Reset sessions on a per-webapp basis"
+  (setf (session-value (class-name (class-of app))) nil))
+
+(defun webapp-application-dependencies (&optional (app (current-webapp)))
+  "Returns a list of dependencies on scripts and/or stylesheets that
+   will persist throughout the whole application. See documentation for
+   'widget-application-dependencies' for more details."
+  (build-local-dependencies
+   (weblocks-webapp-application-dependencies app)))
+
+(defun webapp-name (&optional (app (current-webapp)))
+  "Returns the name of the web application (also see 'defwebapp'). Please
+   note, this name will be used for the composition of the page title
+   displayed to the user. See 'page-title' for details."
+  (weblocks-webapp-name app))
+
+(defun webapp-description (&optional (app (current-webapp)))
+  "Returns the description of the web application. Please note, this
+   description will be used for the composition of the page title
+   displayed to the user. See 'page-title' for details."
+  (weblocks-webapp-description app))
+
+(defun webapp-serves-hostname (hostname &optional (app (current-webapp)))
+  "Does APP serve requests for HOSTNAME?"
+  (or (null (webapp-hostnames app))
+      (member (car (cl-ppcre:split ":" hostname))
+              (webapp-hostnames app)
+              :test #'equalp)))
+
+(defun webapp-hostnames (&optional (app (current-webapp)))
+  "Returns the hostnames this application will serve requests for."
+  (weblocks-webapp-hostnames app))
+
+(defun webapp-prefix (&optional (app (current-webapp)))
+  "Returns the URL prefix of the application."
+  (weblocks-webapp-prefix app))
+
+(defun webapp-public-files-uri-prefix (&optional (app (current-webapp)))
+  (weblocks-webapp-public-files-uri-prefix app))
+
+(defun webapp-public-files-path (&optional (app (current-webapp)))
+  (weblocks-webapp-public-files-path app))
+
+(defun webapp-init-user-session (&optional (app (current-webapp)))
+  "Returns the init function for the user session."
+  (let ((init (weblocks-webapp-init-user-session app)))
+    (etypecase init
+      (function init)
+      (symbol (symbol-function init)))))
+

src/blocks/form.lisp

-
-(in-package :weblocks)
-
-(export '(*submit-control-name* *cancel-control-name* with-html-form))
-
-(defparameter *submit-control-name* "submit"
-  "The name of the control responsible for form submission.")
-
-(defparameter *cancel-control-name* "cancel"
-  "The name of the control responsible for cancellation of form
-  submission.")
-
-(defmacro with-html-form ((method-type action-code &key id class) &body body)
-  "Transforms to cl-who (:form) with standard form code (AJAX support, actions, etc.)"
-  `(with-html
-     (:form :id ,id :class ,class :action "" :method (attributize-name ,method-type)
-	    :onsubmit (format nil "initiateFormAction(\"~A\", $(this), \"~A\"); return false;"
-			      (url-encode ,action-code)
-			      (session-name-string-pair))
-	    (with-extra-tags
-	      (htm (:fieldset
-		    ,@body
-		    (:input :name "action" :type "hidden" :value (url-encode ,action-code))))))))
-

src/blocks/isearch.lisp

-
-(in-package :weblocks)
-
-(export '(render-isearch))
-
-(defun render-isearch (input-name isearch-action &key value
-		       (form-id (gensym))
-		       (input-id (gensym))
-		       (search-id (gensym))
-		       (method :get) &allow-other-keys)
-  "Renders an input bar with 'input-name' that calls back
-'isearch-action' in delayed manner. This is useful for realtime
-searching capabilities. Currently the delay is set to 0.4, similar to
-the suggest block.
-
-When JavaScript is turned off a button is drawn next to the input
-box. The user may invoke 'isearch-action' by clicking the button.
-
-value - an initial value.
-method - form request method, defaults to GET."
-  (let* ((a-input-name (attributize-name input-name)))
-    (with-html-form (method isearch-action :id form-id :class "isearch")
-      (:input :type "text" :id input-id :name a-input-name :class "search-bar" :value value)
-      (unless (ajax-request-p)
-	(htm (:input :id search-id :name *submit-control-name* :type "submit" :class "submit"
-		     :value "Search")))))
-  (with-javascript "~
-new Form.Element.DelayedObserver('~A', 0.4, function(elem, value) {~
-initiateFormAction('~A', $('~A'), '~A');
-});"
-    input-id
-    isearch-action form-id (session-name-string-pair))
-  (unless (ajax-request-p)
-    (with-javascript "$('~A').remove();"
-      search-id)))

src/blocks/suggest.lisp

-
-(in-package :weblocks)
-
-(export '(render-suggest))
-
-(defun render-suggest (input-name localp &key value fetch-fn
-		       (input-id (gensym))
-		       (choices-id (gensym))
-		       (format-fn #'format-suggest-list))
-  "Renders a block that provides functionality similar to google-suggest.
-
-input-name - the 'name' attribute of the input box.
-
-localp - If nil, the completion will be done via an asynchronious call
-to the server. Otherwise, must be set to a list of items which will be
-sent to the client for local autocompletion. In this case, the value
-of 'fetch-action' is ignored. Note, if JavaScript is turned off local
-autocompletion will degrade to a simple drowdown.
-
-value - can be used to set the value of the input box and/or dropdown.
-
-fetch-fn - when 'localp' is false, a function that accepts a single
-argument (the string entered by the user) and returns a list of items
-that will be sent to the client in an appropriate format.
-
-input-id, choices-id - optional IDs of input control and choice div,
-respectively. If an ID isn't provided, it will be generated.
-
-format-fn - a function used to format the results into html sent to
-the client. Accepts a list of results."
-  (let ((a-input-name (attributize-name input-name)))
-    (if localp
-	(with-html
-	  (:select :id input-id :name a-input-name
-		   (mapc (lambda (i)
-			   (if (string-equal i value)
-			       (htm (:option :selected "true" (str i)))
-			       (htm (:option (str i)))))
-			 localp))
-	  (with-javascript (if value
-			       "replaceDropdownWithSuggest('~A', '~A', '~A', '~A');"
-			       "replaceDropdownWithSuggest('~A', '~A', '~A');")
-	    input-id a-input-name choices-id value))
-	(with-html
-	  (:input :type "text" :id input-id :name a-input-name :class "suggest" :value value)
-	  (:div :id choices-id :class "suggest" "")
-	  (with-javascript "declareSuggest('~A', '~A', '~A', '~A');"
-	    input-id choices-id
-	    (make-action
-	     (lambda (&rest keys)
-	       (funcall format-fn (funcall fetch-fn (request-parameter a-input-name)))))
-	    (session-name-string-pair))))))
-
-(defun format-suggest-list (results)
-  "Formats a list of results into
-HTML that can later be sent to a suggest control on the client."
-  (let ((*weblocks-output-stream* (make-string-output-stream)))
-    (declare (special *weblocks-output-stream*))
-    (with-html
-      (:ul
-       (mapc (lambda (res)
-	       (htm (:li (str res))))
-	     results)))
-    (get-output-stream-string *weblocks-output-stream*)))
-

src/control-flow/call-answer.lisp

 
 (in-package :weblocks)
 
-(export '(do-widget do-page do-modal answer))
+(export '(do-widget do-page do-modal answer make-widget-place-writer 
+          adopt-widget widget-not-in-parent))
+
+
+(define-condition widget-not-in-parent (webapp-style-warning)
+  ((widget :accessor widget :initarg :widget)
+   (parent :accessor parent :initarg :parent))
+  (:report report-widget-not-in-parent)
+  (:documentation "This style warning serves as a makeshift
+                  until we find a proper way to have an idempotent
+                  DO-WIDGET."))
+
+(defun report-widget-not-in-parent (c stream)
+  "Display human-readably that a widget could not be found in its parent."
+  (format stream "Widget ~S cannot be found in parent ~S."
+          (widget c) (parent c)))
 
 ;;; Specialize widget-continuation
 (defmethod widget-continuation ((widget function))
 (defun/cc call (callee op)
   "Saves the current continuation to the appropriate place and
 interrupts the computation. Before the computation is interrupted,
-calls 'op' with the value of the widget where the computation is
-saved (may be different from 'callee' because of objects like
-functions). If 'callee' is of class 'widget', the continuation is
-saved in the 'current-continuation' slot of 'callee'. If 'callee' is a
-function, continuation is curried as a first parameter and the result
-is returned. Otherwise, continuation isn't saved."
+calls OP with the value of the widget where the computation is
+saved (may be different from CALLEE because of objects like
+functions).
+
+If CALLEE is of class WIDGET, the continuation is
+saved in the 'current-continuation' slot of CALLEE.
+
+If CALLEE is a function, continuation is curried as a first parameter
+and the result is returned. Otherwise the continuation isn't passed."
   (let/cc k
     (setf (widget-continuation callee) k)
-    (funcall op (if (functionp callee)
-		    (curry callee k)
-		    callee))
+    (safe-funcall op (if (functionp callee)
+			 (curry callee k)
+			 callee))
     t))
 
 (defun answer (continuation &optional result)
-  "Returns control to location saved in 'continuation', which may be a
+  "Returns control to location saved in CONTINUATION, which may be a
 callee widget or the continuation object explicitly. Continuation is
-called with 'result', or nil. If the widget doesn't have a
+called with RESULT (defaulting to NIL). If the widget doesn't have a
 continuation, recursively tries its parents."
   (if (widget-continuation continuation)
       (safe-funcall (widget-continuation continuation) result)
       (when (widget-parent continuation)
 	(answer (widget-parent continuation) result))))
 
-;; Places 'callee' in the place of 'widget', saves the continuation,
-;; and returns from the delimited computation. When 'callee' answers,
-;; restores the original widget and reactivates the computation. If
-;; 'wrapper-fn' is present, passes it the new callee and sets the return
-;; value as the value of a place. By default 'wrapper-fn' is simply an
-;; identity function.
+(defun adopt-widget (parent widget)
+  "Like (setf (widget-parent WIDGET) PARENT), but signal an error when
+WIDGET already has a parent (even if it's PARENT)."
+  (let ((old-parent (widget-parent widget)))
+    (if old-parent
+	(error "Widget ~A already has parent ~A; cannot write parent" 
+	       widget old-parent)
+	(setf (widget-parent widget) parent)))
+  (values))
+
 (defun/cc do-widget (widget callee &optional (wrapper-fn #'identity))
+  "Places CALLEE in the place of WIDGET, saves the continuation,
+and returns from the delimited computation. When CALLEE answers,
+restores the original widget and resumes the computation.
+
+If WRAPPER-FN is present, passes it the new callee and sets the return
+value as the value of a place. By default WRAPPER-FN is simply the
+identity function."
   (if (or (null widget)
 	  (eq widget (root-composite)))
       (do-root-widget callee wrapper-fn)
       (do-widget-aux widget callee wrapper-fn)))
 
+(defun/cc do-widget-aux (widget callee &optional (wrapper-fn #'identity))
+  (let* ((parent (or (widget-parent widget)
+		     (error "Attempted to replace widget ~S which has no parent!"
+			    widget)))
+	 (place-writer (make-widget-place-writer parent widget)))
+    (prog1
+	(call callee
+	      (lambda (new-callee)
+		(funcall place-writer (funcall wrapper-fn new-callee))))
+      ;; the following is the rest of the computation 
+      (funcall place-writer widget))))
+
+;; This function is aware of the internal structure of the root composite;
+;; this should be OK as it's a special case; it does violate the contract.
 (defun/cc do-root-widget (callee  &optional (wrapper-fn #'identity))
+  "Replace the contents of the root composite with CALLEE,
+the latter one being optinonally transformed by WRAPPER-FN."
   (let* ((old-value (composite-widgets (root-composite))))
     (prog1
 	(call callee
       (setf (composite-widgets (root-composite))
 	    old-value))))
 
-(defun/cc do-widget-aux (widget callee &optional (wrapper-fn #'identity))
-  (let* ((parent (widget-parent widget))
-	 (place (member widget (composite-widgets parent))))
-    (unless parent
-      (error "Attempted to replace widget ~S which has no parent!" widget))
-    (unless place
-      (error "Widget ~S cannot be found in parent ~S."
-	     widget parent))
-    (flet ((place-widget (value)
-	     (rplaca place value)
-	     (setf (composite-widgets parent)
-		   (composite-widgets parent))))
-      (prog1
-	  (call callee
-		(lambda (new-callee)
-		  (place-widget (funcall wrapper-fn new-callee))))
-	(place-widget widget)))))
 
-;; Sets 'callee' as the only widget in the root composite, saves the
-;; continuation, and returns from the delimited computation. When
-;; 'callee' answers, restores the original widgets in the root
-;; composite and reactivates the computation.
 (defun/cc do-page (callee)
+  "Sets CALLEE as the only widget in the root composite, saves the
+continuation, and returns from the delimited computation. When
+CALLEE answers, restores the original widgets in the root
+composite and reactivates the computation."
   (do-widget nil callee))
 
 (defun/cc do-modal (title callee &key css-class)
-  "Same as 'do-page', but wraps the callee in a div for styling purposes."
+  "Same as DO-PAGE, but wraps CALLEE in a div container
+for styling purposes."
   (do-widget nil callee
 	     (lambda (new-callee)
 	       (lambda (&rest args)
 		 (declare (ignore args))
+                 (declare (special *uri-tokens-fully-consumed*))
+                 ;; Consume all tokens
+                 (setf *uri-tokens-fully-consumed* t)
+                 ;; Do the content wrrapping
 		 (with-html
 		   (:div :class "modal"
 			 (:h1 (:span (str title)))

src/control-flow/dialog.lisp

 form buttons in a POST form."
   (with-html-form (:post (lambda (&rest args)
 			   (loop for choice in choices
-			      when (member choice args)
+			      when (member choice args :test #'string-equal)
 			      do (progn (answer k choice)
 					(return)))))
     (:p (str msg))

src/debug-mode.lisp

 		 (redirect (make-webapp-uri "/")))
 	       "debug-reset-sessions"))
 
+;;; Further aid in debugging by reporting potential problems
+
+(defun style-warn (condition &rest warn-args)
+  "A variant of `warn' that doesn't guarantee evaluation of its
+arguments."
+  (apply #'warn condition warn-args))
+
+(define-compiler-macro style-warn (condition &rest warn-args)
+  `(when (or (not (boundp '*current-webapp*))
+             (null *current-webapp*)
+	     (weblocks-webapp-debug (current-webapp)))
+     (warn ,condition . ,warn-args)))
+
+(define-condition webapp-style-warning (style-warning)
+  ()
+  (:documentation "Signalled by Weblocks when detecting unwise
+behavior on the part of webapps."))
+
+(define-condition non-idempotent-rendering (webapp-style-warning)
+  ((change-made :initarg :change-made :reader change-made-during-rendering
+		:documentation "A description of the change that
+		should be moved to action handling."))
+  (:report report-non-idempotent-rendering)
+  (:documentation "Signalled in common cases where code that alters
+the webapp state appears in a rendering process."))
+
+(defun report-non-idempotent-rendering (c stream)
+  "Describe a condition where code appears in rendering that should be
+in the action handler."
+  (format stream "During the rendering phase, ~A, which should ~
+		  typically be done only during action handling"
+	  (change-made-during-rendering c)))
+
+(define-condition misunderstood-action (webapp-style-warning)
+  ((action :initarg :action :reader misunderstood-action
+	   :documentation "What the user did to reveal this problem.")
+   (missing :initarg :missing :reader missing-action-handler-part
+	    :documentation "A description of what's missing for ACTION
+	    to be handled correctly."))
+  (:report report-misunderstood-action)
+  (:documentation "Signalled when a user invoked an action, and some
+part of the handler for which the app writer is responsible doesn't
+seem to be implemented correctly."))
+
+(defun report-misunderstood-action (c stream)
+  "Describe a `misunderstood-action'."
+  (format stream "A webapp user did: \"~A\"
+But it was handled incorrectly; this is probably an issue with ~A"
+	  (misunderstood-action c) (missing-action-handler-part c)))

src/default-application.lisp

 	  (:img :src (make-webapp-public-file-uri "images/footer/valid-xhtml11.png") :alt "This site has valid XHTML 1.1.")
 	  (:img :src (make-webapp-public-file-uri "images/footer/valid-css.png") :alt "This site has valid CSS."))))
 
+(defwidget webapp-control ()
+  ())
+
+(defmethod render-widget-body ((widget webapp-control) &rest args)
+  (declare (ignore args))
+  (flet ((remove-classname (cname list)
+           (remove-if (lambda (app)
+                        (eq (class-name (class-of app))
+                            cname))
+                      list)))
+    (with-html
+      (:h3 "Currently running webapps:")
+      (render-list (remove-classname 'weblocks-default *active-webapps*)
+                   :render-fn (lambda (app)
+                                (with-html
+                                  (:a :href (make-webapp-uri "/" app)
+                                      (esc (format nil "~A"
+                                                   (class-name (class-of app))))))))
+      (:h3 "Registered webapps:")
+      (render-list (remove-if (curry #'eq 'weblocks-webapp) *registered-webapps*)
+                   :render-fn (lambda (appname)
+                                (with-html
+                                  (esc (format nil "~A" appname))
+                                  " "
+                                  (if (find appname *active-webapps*
+                                            :key (compose #'class-name #'class-of))
+                                    (render-link (f_% (stop-webapp appname)
+                                                      (mark-dirty widget))
+                                                 "Stop")
+                                    (render-link (f_% (start-webapp appname)
+                                                      (mark-dirty widget)) "Start"))))))))
+
+
 (defun init-user-session (comp)
   (setf (composite-widgets comp)
 	(list
-	 (lambda (&rest args)
-	   (declare (ignore args))
-	   (with-html
-	     (:div :class "header"
-		   (with-extra-tags))
-	     (:h1 "Welcome to " (:em "Weblocks!"))
-	     (:p "To learn more on how to get started
-                 writing " (:em "Weblocks") " applications, please see the "
-                 (:a :href "http://trac.common-lisp.net/cl-weblocks/wiki/UserManual" "user
-                 manual.")
-                 (:br) "For general information
-                 about " (:em "Weblocks") ", information on how to get
-                 support, find documentation, etc. please
-                 start " (:a :href "http://common-lisp.net/project/cl-weblocks" "here") ".")
-	     (:p (:em "Happy hacking!")))))))
+          (f_%
+            (with-html
+              (:div :class "header"
+                    (with-extra-tags))
+              (:h1 "Welcome to " (:em "Weblocks!"))
+              (:p "To learn more on how to get started
+                  writing " (:em "Weblocks") " applications, please see the "
+                  (:a :href "http://trac.common-lisp.net/cl-weblocks/wiki/UserManual" "user
+                      manual.")
+                  (:br) "For general information
+                  about " (:em "Weblocks") ", information on how to get
+                  support, find documentation, etc. please
+                  start " (:a :href "http://common-lisp.net/project/cl-weblocks" "here") ".")
+                  (:h2 "How did I get here?")
+                  (:p "If you expected to see your application here you probably didn't supply
+                      the PREFIX keyword argument to DEFWEBAPP (try " (:code "PREFIX \"/\"") ").")))
+          (make-instance 'webapp-control)
+          (f_% (with-html (:h3 (:em "Happy hacking!")))))))
 
-

src/dependencies.lisp

 (defmethod render-dependency-in-form-submit ((obj javascript-code-dependency))
   (javascript-code obj))
 
+(defmethod render-dependency-in-ajax-response ((obj stylesheet-dependency))
+  (send-script
+   (ps* `(include_css
+	  ,(puri:render-uri (dependency-url obj) nil)))
+   :before-load))
+
+(defmethod render-dependency-in-ajax-response ((obj script-dependency))
+  (send-script
+   (ps* `(include_dom
+	  ,(puri:render-uri (dependency-url obj) nil)))
+   :before-load))
+
 ;; since rendering dependencies for views is more complex than a simple mapc, there is a utility function
 (defun render-form-submit-dependencies (dependency-list)
   (let ((code-string (reduce (lambda (e v)

src/dom-object.lisp

   (:method ((obj dom-object-mixin))
     (if (slot-boundp obj 'dom-id)
 	(slot-value obj 'dom-id)
-	(setf (slot-value obj 'dom-id) (gen-id)))))
+	(when (boundp '*session*)
+	  (setf (slot-value obj 'dom-id) (gen-id))))))
 
 (defgeneric dom-id (obj)
   (:documentation "Provides a consistent interface to identifying widgets

src/request-handler.lisp

 (defmethod handle-client-request (app)
   (let ((*current-webapp* app))
     (declare (special *current-webapp*))
-    (when (hunchentoot::mime-type (script-name))
-      (setf (return-code) +http-not-found+)
-      (throw 'handler-done nil))
     (when (null *session*)
       (when (get-request-action-name)
 	(expired-action-handler app))
 	  (when (weblocks-webapp-debug app)
 	    (initialize-debug-actions))
 	  (setf (root-composite) root-composite)
-          (handler-bind
-            ;; we don't want a half-finished session
-            ((error (lambda (c)
-                      (setf (root-composite) nil)
-                      (reset-webapp-session)
-                      (error c))))
-            (funcall (webapp-init-user-session) root-composite))
+	  (let (finished?)
+	    (unwind-protect
+		 (progn
+		   (funcall (webapp-init-user-session) root-composite)
+		   (setf finished? t))
+	      (unless finished?
+		(setf (root-composite) nil)
+		(reset-webapp-session))))
 	  (push 'update-dialog-on-request (request-hook :session :post-action)))
 	(when (cookie-in *session-cookie-name*)
 	  (redirect (remove-session-from-uri (request-uri)))))
   (declare (special *dirty-widgets* *weblocks-output-stream*
 		    *before-ajax-complete-scripts* *on-ajax-complete-scripts*))
   (setf (content-type) *json-content-type*)
-  (let ((widget-alist (mapcar (lambda (w)
-				(cons
-				 (dom-id w)
-				 (progn
-				   (render-widget w :inlinep t)
-				   (get-output-stream-string *weblocks-output-stream*))))
-			      *dirty-widgets*)))
-    (format *weblocks-output-stream* "{\"widgets\":~A,\"before-load\":~A,\"on-load\":~A}"
-	    (encode-json-to-string widget-alist)
-	    (encode-json-to-string *before-ajax-complete-scripts*)
-	    (encode-json-to-string *on-ajax-complete-scripts*))))
+  (let ((render-state (make-hash-table :test 'eq)))
+    (labels ((circularity-warn (w)
+	       (style-warn 'non-idempotent-rendering
+		:change-made
+		(format nil "~S was marked dirty and skipped after ~
+			     already being rendered" w)))
+	     (render-enqueued (dirty)
+	       (loop for w in dirty
+		     if (gethash w render-state)
+		       do (circularity-warn w)
+		     else
+		       do (render-widget w)
+			  (setf (gethash w render-state) t)
+		       and collect (cons (dom-id w)
+					 (get-output-stream-string
+					     *weblocks-output-stream*))))
+	     (late-propagation-warn (ws)
+	       (style-warn 'non-idempotent-rendering
+		:change-made
+		(format nil "~A widgets were marked dirty" (length ws))))
+	     (absorb-dirty-widgets ()
+	       (loop for dirty = *dirty-widgets*
+		     while dirty
+		     count t into runs
+		     when (= 2 runs)
+		       do (late-propagation-warn dirty)
+		     do (setf *dirty-widgets* '())
+		     nconc (render-enqueued dirty))))
+      (format *weblocks-output-stream*
+	      "{\"widgets\":~A,\"before-load\":~A,\"on-load\":~A}"
+	      (encode-json-to-string (absorb-dirty-widgets))
+	      (encode-json-to-string *before-ajax-complete-scripts*)
+	      (encode-json-to-string *on-ajax-complete-scripts*)))))
 
 (defun action-txn-hook (hooks)
   "This is a dynamic action hook that wraps POST actions using the 
    weblocks transaction functions over all stores"
   (if (eq (request-method) :post)
       (let (tx-error-occurred-p)
-	(unwind-protect
-	     (handler-bind ((error #'(lambda (error)
-				       (declare (ignore error))
-				       (mapstores #'rollback-transaction)
-				       (setf tx-error-occurred-p t))))
-	       (mapstores #'begin-transaction)
-	       (eval-dynamic-hooks hooks))
-	  (unless tx-error-occurred-p
-	    (mapstores #'commit-transaction))))
+	(multiple-value-bind (dynamic-stores non-dynamic-stores)
+	    (loop for store-name in *store-names*
+		  for store = (symbol-value store-name)
+		  when store
+		    if (use-dynamic-transaction-p store)
+		      collect store into dynamic-stores
+		    else collect store into non-dynamic-stores
+		  finally (return (values dynamic-stores non-dynamic-stores)))
+	  (labels ((dynamic-transactions (stores)
+		     (if (null stores)
+			 (eval-dynamic-hooks hooks)
+			 (dynamic-transaction
+			  (car stores)
+			  (f0 (dynamic-transactions (cdr stores))))))
+		   (handle-error (error)
+		     (declare (ignore error))
+		     (mapc #'rollback-transaction non-dynamic-stores)
+		     (setf tx-error-occurred-p t)))
+	    (unwind-protect
+		 (handler-bind ((error #'handle-error))
+		   (mapc #'begin-transaction non-dynamic-stores)
+		   (dynamic-transactions dynamic-stores))
+	      (unless tx-error-occurred-p
+		(mapc #'commit-transaction non-dynamic-stores))))))
       (eval-dynamic-hooks hooks)))
   
 (eval-when (:load-toplevel)
 
 (in-package :weblocks)
 
-(export '(*json-content-type refresh-request-p initial-request-p
-	  ajax-request-p pure-request-p redirect
-	  compose-uri-tokens-to-url))
+(export '(*json-content-type* refresh-request-p initial-request-p
+	  ajax-request-p pure-request-p redirect post-action-redirect
+	  post-render-redirect compose-uri-tokens-to-url))
 
 (defparameter *json-content-type* "application/json; charset=utf-8"
   "A content type sent to the client to identify json data.")
   "Sends a redirect response to the client. If 'redirect' is called on
 a regular request, sends appropriate HTTP headers. If it is called
 during an AJAX request, sends weblocks specific JSON interpreted as
-redirect on the client."
+redirect on the client.
+
+This function returns immediately; any code following it will not be
+executed."
   (if (ajax-request-p)
       (progn
 	(setf (content-type) *json-content-type*)
 	  (format nil "{\"redirect\":\"~A\"}" url)))
       (hunchentoot:redirect url)))
 
+(defun post-action-redirect (url)
+  "A common pattern is to have an action redirect after taking some action.  
+   Typically an action is wrapped in a transaction which will abort if the 
+   redirect happens during the action execution (due to the throw to 
+   'handler-done, a non-local exit).  This pushes a redirect to the url
+   argument onto the post-action hook so it occurs after the action transaction
+   but before rendering"
+  (push (lambda () (redirect url))
+	(request-hook :request :post-action)))
+
+(defun post-render-redirect (url)
+  "Similar to `post-action-redirect', except redirects after completing
+the rendering. This is occassionally useful."
+  (push (lambda () (redirect url))
+	(request-hook :request :post-render)))
+
 (defun compose-uri-tokens-to-url (tokens)
   "Encodes and concatenates uri tokens into a url string. Note that
 the string will not contain separator slashes at the beginning or
   hunchentoot lock in debug mode and nil in release mode by
   'start-weblocks'.")
 
-(defparameter *last-session* nil
+(defvar *last-session* nil
   "Bound to a session object associated with the last handled
   request. Note, this variable is only updated in debug mode.")
 
 ;;; Set outgoing encoding to utf-8
 (setf *default-content-type* "text/html; charset=utf-8")
 
-(defun start-weblocks (&rest keys &key (debug t) (port 8080) (cookie-name "weblocks-session") 
+(defun start-weblocks (&rest keys &key (debug t) (port 8080)
+                             (cookie-name (format nil "weblocks-~(~A~)" (gensym)))
 		       &allow-other-keys)
   "Starts weblocks framework hooked into Hunchentoot server. Set
-':debug' keyword to true in order for stacktraces to be shown to the
-client. Set ':cookie-name' keyword when you want to change the name of the
-cookie. Other keys are passed to 'hunchentoot:start-server'. Opens all
-stores declared via 'defstore'."
+DEBUG to true in order for stacktraces to be shown to the
+client. Set COOKIE-NAME when you want to have a specific cookie name;
+otherwise a random one with prefix 'weblocks' will be generated for
+this server instance. Other keys are passed to HUNCHENTOOT:START-SERVER.
+Opens all stores declared via DEFSTORE."
   #+sbcl
   (unless (member :sb-thread *features*)
     (cerror "I know what I'm doing and will stubbornly continue."
     (let* ((script-name (script-name request))
 	   (app-prefix (webapp-prefix app))
 	   (app-pub-prefix (compute-webapp-public-files-uri-prefix app)))
-      (log-message :debug "Application dispatch for ~S/~S" (hunchentoot:host) script-name)
       (cond
 	((list-starts-with (tokenize-uri script-name nil)
 			   (tokenize-uri "/weblocks-common" nil)
 			   :test #'string=)
-	 (log-message :debug "Dispatching to common public file")
          (return-from weblocks-dispatcher
                       (funcall (create-folder-dispatcher-and-handler 
                                  "/weblocks-common/pub/"
               (list-starts-with (tokenize-uri script-name nil)
 			   (tokenize-uri app-pub-prefix nil)
 			   :test #'string=))
-	 (log-message :debug "Dispatching to public file")
          ;; set caching parameters for static files
          ;; of interest: http://www.mnot.net/blog/2007/05/15/expires_max-age
          (if (weblocks-webapp-debug app)
               (list-starts-with (tokenize-uri script-name nil)
                                 (tokenize-uri app-prefix nil)
                                 :test #'string=))
-	 (log-message :debug "Dispatching to application ~A with prefix ~S"
-		      app app-prefix)
 	 (return-from weblocks-dispatcher 
 	   #'(lambda ()
 	       (handle-client-request app)))))))

src/snippets/html-utils.lisp

                         (:input :name *action-string* :type "hidden" :value ,action-code))))))
        (log-form ,action-code :id ,id :class ,class))))
 
-(defun render-link (action name &key (ajaxp t) id class)
+(defun render-link (action name &key (ajaxp t) id class title)
   "Renders an action into an href link. If 'ajaxp' is true (the
 default), the link will be rendered in such a way that the action will
 be invoked via AJAX, or will fall back to regular request if
 	  :href url :onclick (when ajaxp
 			       (format nil "initiateAction(\"~A\", \"~A\"); return false;"
 				       action-code (session-name-string-pair)))
-	  (str name)))
+	  :title title
+	  (etypecase name
+	    (string (htm (str name)))
+	    (symbol (htm (str name)))
+	    (function (funcall name)))))
     (log-link name action-code :id id :class class)))
 
 (defun render-button (name  &key (value (humanize-name name)) id (class "submit"))
 			 "if(this.form.onsubmit) { this.form.onsubmit(); } else { this.form.submit(); }")
 	     :multiple (when multiple "on" "off")
 	     (mapc (lambda (i)
-		     (if (member (format nil "~A" (or (cdr i) (car i)))
-				 (ensure-list selected-value)
-				 :test #'equalp :key (curry #'format nil "~A"))
+		     (if (member (princ-to-string (or (cdr i) (car i))) (ensure-list selected-value)
+                                 :test #'string-equal :key #'princ-to-string)
 			 (htm (:option :value (cdr i) :selected "selected" (str (car i))))
 			 (htm (:option :value (cdr i) (str (car i))))))
 		   (list->assoc (append (when welcome-name
 	 ,@body))))
 
 (defun send-script (script &optional (place :after-load))
+  "Send JavaScript to the browser. The way of sending depends
+  on whether the current request is via AJAX or not.
+  
+  FIXME: is using PUSH or PUSHLAST correct?"
   (if (ajax-request-p)
     (let ((code (with-javascript-to-string script)))
-    ;(let ((json (format nil "new Function(~A)" (encode-json-to-string script))))
       (declare (special *before-ajax-complete-scripts* *on-ajax-complete-scripts*))
       (ecase place
         (:before-load (push code *before-ajax-complete-scripts*))
 (defun render-message (message &optional caption)
   "Renders a message to the user with standardized markup."
   (with-html
-    (:p (if caption
-	    (htm (:span :class "caption" (str caption) ":&nbsp;")))
+    (:p :class "user-message"
+        (when caption
+          (htm (:span :class "caption" (str caption) ":&nbsp;")))
 	(:span :class "message" (str message)))))
 

src/snippets/menu.lisp

   available.")
 
 (defun render-menu (options &key selected-pane header (container-id (gen-id))
-		    (empty-message *menu-empty-message*))
+                    ordered-list-p (empty-message *menu-empty-message*)
+                    disabled-pane-names)
   "Renders a menu snippet based on given options and selected
 option. An option may be a dotted pair of a label and URL to link to,
 or a name (which will be converted to a label and a URL via
 will be compared to an option's URL tokens via equalp. If the selected
 option isn't specified, first option is rendered as selected.  If
 CONTAINER-ID is provided, it is used as the basis of DOM IDs for the
-menu and each menu item generated with `unattributized-name'."
+menu and each menu item generated with `unattributized-name'. If a
+given pane name is found in `disabled-pane-names', it's rendered in
+the navigation as disabled."
   (declare (special *current-navigation-url*))
-  (with-html
-    (:div :class "view menu"
-	  :id (unattributized-name container-id 'menu)
-	  (with-extra-tags
-	    (when header
-	      (htm (:h1 (str header))))
-	    (if (null options)
-		(htm
-		 (:div :class "empty-menu" (str empty-message)))
-		(htm
-		 (:ul
-		  (mapc (lambda (option)
-			  (unless (consp option)
-			    (setf option
-				  (cons (humanize-name option)
-					(attributize-name option))))
-			  (unless selected-pane
-			    (setf selected-pane (car option)))
-			  (let* ((label (car option))
-				 (target (cdr option))
-				 (pane-selected-p (equalp (attributize-name (car option)) selected-pane))
-				 (pane-class (when pane-selected-p
-					       "selected-item")))
-			    (htm
-			      (:li :id (unattributized-name (format nil "~A-~A" container-id label)
-							    'menu-item)
-				   :class pane-class
-                                  (etypecase target
-                                    (string
-                                      (if pane-selected-p
-                                        (htm (:span (str label)))
+  (flet ((render-menu-items (&optional orderedp)
+           (loop
+              for option in options
+              for item-number from 1
+              do (progn
+                   (unless (consp option)
+                     (setf option
+                           (cons (humanize-name option)
+                                 (attributize-name option))))
+                   (unless selected-pane
+                     (setf selected-pane (car option)))
+                   (let* ((label (car option))
+                          (target (cdr option))
+                          (pane-selected-p (string-equal (attributize-name (car option))
+                                                         (attributize-name selected-pane)))
+                          (pane-disabled-p (member (attributize-name (car option))
+                                                   disabled-pane-names
+                                                   :key #'attributize-name
+                                                   :test #'string-equal))
+                          (pane-class (cond
+                                        (pane-selected-p "selected-item")
+                                        (pane-disabled-p "disabled-item"))))
+                     (with-html
+                       (:li :id (unattributized-name (format nil "~A-~A" container-id label)
+                                                     'menu-item)
+                            :class pane-class
+                            (:span :class (concatenate 'string
+                                                       "item-wrapper"
+                                                       (when orderedp
+                                                         (format nil " item-number-~A" item-number)))
+                                   (etypecase target
+                                     (string
+                                      (if (or pane-selected-p pane-disabled-p)
+                                        (htm (:span :class "label" (str label)))
                                         (htm (:a :href (make-webapp-uri
                                                          (string-left-trim
                                                            "/" (concatenate 'string
                                                                             (string-right-trim "/" *current-navigation-url*)
                                                                             "/"
                                                                             (string-left-trim "/" target))))
-                                                 (str label)))))
-                                    (function
-                                      (render-link target label)))))))
-			options))))))))
+                                                   (str label)))))
+                                     (function
+                                      (render-link target label)))))))))))
+    (with-html
+      (:div :class "view menu"
+            :id (unattributized-name container-id 'menu)
+            (with-extra-tags
+              (when header
+                (htm (:h1 (str header))))
+              (if (null options)
+                  (htm
+                   (:div :class "empty-menu" (str empty-message)))
+                  (if ordered-list-p
+                      (htm (:ol (render-menu-items t)))
+                      (htm (:ul (render-menu-items))))))))))
 

src/store/clsql/clsql.lisp

 
 (in-package :weblocks-clsql)
 
+(export '(order-by-expression range-to-offset range-to-limit))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Initialization/finalization ;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defmethod open-store ((store-type (eql :clsql)) &rest args)
   (setf *default-caching* nil)
-  (setf *default-store* (apply #'connect args)))
+  (setf *default-store* (apply #'make-instance 'fluid-database
+			       :connection-spec args)))
 
 (defmethod close-store ((store database))
   (when (eq *default-store* store)
       (unwind-protect
 	   (progn
 	     (update-records-from-instance object :database store)
-	     (setf success t))
+	     (setf success t)
+             object)
 	(when (and (not success)
 		   (null current-id))
 	  (setf (object-id object) nil))))))

src/store/clsql/weblocks-clsql.asd

   :author "Slava Akhmechet"
   :licence "LLGPL"
   :description "A weblocks backend for clsql."
-  :depends-on (:closer-mop :metatilities :clsql :weblocks)
+  :depends-on (:closer-mop :metatilities :clsql :clsql-fluid :weblocks)
   :components ((:file "clsql")))
 

src/store/elephant/elephant.lisp

 
 (in-package :weblocks-elephant)
 
+(export '(elephant-store))
+
 (defclass elephant-store ()
   ((controller :accessor elephant-controller :initarg :controller)
    (stdidx :accessor elephant-stdobj-index)))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defmethod open-store ((store-type (eql :elephant)) &rest args &key spec &allow-other-keys)
-  (declare (ignore args))
-  (setup-elephant-transaction-hooks)
+  (declare (ignore args)) 
   (setf *default-store*
 	(make-instance 'elephant-store
-		       :controller (setf *store-controller* (elephant:open-store spec :recover t)))))
+		       :controller (setf *store-controller* (elephant:open-store spec)))))
 
 (defmethod close-store ((store elephant-store))
   (when (eq *default-store* store)
     (setf *default-store* nil))
   (elephant:close-store (elephant-controller store))
   (when (eq (elephant-controller store) *store-controller*)
-    (setf *store-controller* nil))
-  (remove-elephant-transaction-hooks))
+    (setf *store-controller* nil)))
 
 (defmethod clean-store ((store elephant-store))
   ;; Drop everything from the root
 ;;; Transactions ;;;
 ;;;;;;;;;;;;;;;;;;;;
 
-(defmethod begin-transaction ((store elephant-store))
+(defmethod use-dynamic-transaction-p ((store elephant-store))
   t)
 
-(defmethod commit-transaction ((store elephant-store))
-  t)
-
-(defmethod rollback-transaction ((store elephant-store))
-  t)
-
-(defun elephant-transaction-hook (hooks)
+(defmethod dynamic-transaction ((store elephant-store) proc)
   "This dynamic hook wraps an elephant transaction macro around the body hooks.
    This allows us to gain the benefits of the stable transaction system in elephant"
-  (let ((valid-sc (get-valid-sc)))
-    (if valid-sc
-	(ensure-transaction (:store-controller valid-sc)
-	  (eval-dynamic-hooks hooks))
-	(eval-dynamic-hooks hooks))))
-
-(defun get-valid-sc ()
-  "This function provides some reasonable defaults for elephant.  Namely, that
-   the default transaction is either the default store or the current store controller.
-   Care must be taken when using multiple elephant stores with weblocks.  The 
-   consequences are as yet undefined."
-  (cond ((subtypep (type-of *default-store*) 'elephant-store)
-	 (elephant-controller *default-store*))
-	((not (null *store-controller*))
-	 *store-controller*)))
-
-(defun setup-elephant-transaction-hooks ()
-  "Ensure that the elephant transaction hook is registered on action and rendering code"
-  (pushnew 'elephant-transaction-hook (request-hook :application :dynamic-action)))
-;;  (pushnew 'elephant-transaction-hook (request-hook :application :dynamic-render)))
-
-(defun remove-elephant-transaction-hooks ()
-  "Remove the elephant-specific transaction hooks"
-  (symbol-macrolet ((action-list (request-hook :application :dynamic-action))
-		    (render-list (request-hook :application :dynamic-render)))
-    (setf action-list (delete 'elephant-transaction-hook action-list))
-    (setf render-list (delete 'elephant-transaction-hook render-list))))
+  (ensure-transaction (:store-controller store)
+    (funcall proc)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Creating and deleting persistent objects ;;;
 	(catch 'finish-map
 	  (cond (filter-fn
 		 (range-objects-in-memory
-		  (order-objects-in-memory
+		  (weblocks-memory::advanced-order-objects-in-memory
 		   (filter-objects-in-memory
 		    (get-instances-by-class class-name)
 		    filter-fn)
 		      :collect t)))
 		((consp order-by)
 		 (range-objects-in-memory
-		  (order-objects-in-memory
+		  (weblocks-memory::advanced-order-objects-in-memory
 		   (get-instances-by-class class-name)
 		   order-by)
 		  range))
 		   (map-class collector class-name :oids t)))
 		(t
 		 (get-instances-by-class class-name)))))
-      (find-persistent-standard-objects store class-name :order-by order-by :range range)))
+      (find-persistent-standard-objects store class-name
+                                        :order-by order-by
+                                        :range range
+                                        :filter-fn filter-fn)))