Hi,
"Leslie P. Polzer" <[email protected]> writes:
> Would you be interested in integrating Marco's patch (as posted by Ian
> under the subject "Fwd: State of the test-instance") into the current
> weblocks-dev?
Starting from Marco's patch, I wrote this new patch with which I'm
reasonably happy.
What do you think about it? (please recall that I'm a Common Lisp newbie
:-)
--
Reclama i tuoi diritti digitali, elimina il DRM. Approfondisci su
http://www.no1984.org
Reclaim your digital rights, eliminate DRM. Learn more at
http://www.defectivebydesign.org/what_is_drm
--~--~---------~--~----~------------~-------~--~----~
You received this message because you are subscribed to the Google Groups
"weblocks" group.
To post to this group, send email to [email protected]
To unsubscribe from this group, send email to
[email protected]
For more options, visit this group at
http://groups.google.com/group/weblocks?hl=en
-~----------~----~----~----~------~----~------~--~---
diff -r d408e2863ac1 src/control-flow/dialog.lisp
--- a/src/control-flow/dialog.lisp Tue Apr 07 20:08:45 2009 +0200
+++ b/src/control-flow/dialog.lisp Thu Apr 09 05:50:33 2009 +0200
@@ -70,15 +70,17 @@
(assert (stringp title))
(if (ajax-request-p)
(prog2
- (when (current-dialog)
- (error "Multiple dialogs not allowed."))
- (call callee (lambda (new-callee)
- (setf (current-dialog) (make-dialog :title title
- :widget new-callee
- :close close
- :css-class css-class))
+ (when (current-dialog)
+ (cerror "Ignore the current dialog."
+ "Multiple dialogs not allowed, currently have ~S." (current-dialog))
+ (setf (current-dialog) nil))
+ (call callee (lambda (new-callee)
+ (setf (current-dialog) (make-dialog :title title
+ :widget new-callee
+ :close close
+ :css-class css-class))
(send-script (ps* (make-dialog-js title new-callee css-class close)))))
- (setf (current-dialog) nil)
+ (setf (current-dialog) nil)
(send-script (ps (remove-dialog))))
(do-modal title callee :css-class css-class)))
diff -r d408e2863ac1 src/request-handler.lisp
--- a/src/request-handler.lisp Tue Apr 07 20:08:45 2009 +0200
+++ b/src/request-handler.lisp Thu Apr 09 05:50:33 2009 +0200
@@ -18,8 +18,10 @@
(defvar *dispatch/render-lock* (bordeaux-threads:make-lock
"*dispatch-render-lock*"))
-;; remove this when Hunchentoot reintroduces *catch-errors-p*
-(defvar *catch-errors-p* t)
+;; Select which restart the request handler should choose.
+;; Possible values are: abort-request, show-backtrace.
+;; Set to NIL to invoke the debugger.
+(defvar *default-restart* 'show-backtrace)
(defgeneric handle-client-request (app)
(:documentation
@@ -50,74 +52,85 @@
Override this method (along with :before and :after specifiers) to
customize behavior."))
-(defmethod handle-client-request :around (app)
- (handler-bind ((error (lambda (c)
- (if *catch-errors-p*
- (return-from handle-client-request
- (handle-error-condition app c))
- (invoke-debugger c)))))
- (call-next-method)))
+(defmethod handle-client-request ((app weblocks-webapp))
+ (let ((*current-webapp* app)
+ condition)
+ (declare (special *current-webapp*))
+ (handler-bind ((error (lambda (c)
+ (setf condition c)
+ (if *default-restart*
+ (invoke-restart *default-restart*)
+ (invoke-debugger c)))))
+ (restart-case
+ (progn
+ (when (null *session*)
+ (when (get-request-action-name)
+ (expired-action-handler app))
+ (start-session)
+ (setf (webapp-session-value 'last-request-uri) :none)
+ (redirect (request-uri*)))
+ (when *maintain-last-session*
+ (bordeaux-threads:with-lock-held (*maintain-last-session*)
+ (setf *last-session* *session*)))
+ (let ((*request-hook* (make-instance 'request-hooks)))
+ (when (null (root-widget))
+ (let ((root-widget (make-instance 'widget :name "root")))
+ (when (weblocks-webapp-debug app)
+ (initialize-debug-actions))
+ (setf (root-widget) root-widget)
+ (let (finished?)
+ (unwind-protect
+ (progn
+ (funcall (webapp-init-user-session) root-widget)
+ (setf finished? t))
+ (unless finished?
+ (setf (root-widget) nil)
+ (reset-webapp-session))))
+ (push 'update-dialog-on-request (request-hook :session :post-action)))
+ (when (cookie-in (session-cookie-name *weblocks-server*))
+ (redirect (remove-session-from-uri (request-uri*)))))
-(defmethod handle-client-request ((app weblocks-webapp))
- (let ((*current-webapp* app))
- (declare (special *current-webapp*))
- (when (null *session*)
- (when (get-request-action-name)
- (expired-action-handler app))
- (start-session)
- (setf (webapp-session-value 'last-request-uri) :none)
- (redirect (request-uri*)))
- (when *maintain-last-session*
- (bordeaux-threads:with-lock-held (*maintain-last-session*)
- (setf *last-session* *session*)))
- (let ((*request-hook* (make-instance 'request-hooks)))
- (when (null (root-widget))
- (let ((root-widget (make-instance 'widget :name "root")))
- (when (weblocks-webapp-debug app)
- (initialize-debug-actions))
- (setf (root-widget) root-widget)
- (let (finished?)
- (unwind-protect
- (progn
- (funcall (webapp-init-user-session) root-widget)
- (setf finished? t))
- (unless finished?
- (setf (root-widget) nil)
- (reset-webapp-session))))
- (push 'update-dialog-on-request (request-hook :session :post-action)))
- (when (cookie-in (session-cookie-name *weblocks-server*))
- (redirect (remove-session-from-uri (request-uri*)))))
-
- (let ((*weblocks-output-stream* (make-string-output-stream))
- (*uri-tokens* (make-instance 'uri-tokens :tokens (tokenize-uri (request-uri*))))
- *dirty-widgets*
- *before-ajax-complete-scripts* *on-ajax-complete-scripts*
- *page-dependencies* *current-page-description*
- (cl-who::*indent* (weblocks-webapp-html-indent-p app)))
- (declare (special *weblocks-output-stream* *dirty-widgets*
- *on-ajax-complete-scripts* *uri-tokens* *page-dependencies*))
- (when (pure-request-p)
- (throw 'hunchentoot::handler-done (eval-action)))
- ;; a default dynamic-action hook function wraps get operations in a transaction
- (eval-hook :pre-action)
- (with-dynamic-hooks (:dynamic-action)
- (eval-action))
- (eval-hook :post-action)
- (when (and (not (ajax-request-p))
- (find *action-string* (get-parameters*)
- :key #'car :test #'string-equal))
- (redirect (remove-action-from-uri (request-uri*))))
- (eval-hook :pre-render)
- (with-dynamic-hooks (:dynamic-render)
- (if (ajax-request-p)
- (handle-ajax-request app)
- (handle-normal-request app)))
- (eval-hook :post-render)
- (unless (ajax-request-p)
- (setf (webapp-session-value 'last-request-uri) (all-tokens *uri-tokens*)))
- (if (member (return-code*) *approved-return-codes*)
- (get-output-stream-string *weblocks-output-stream*)
- (handle-http-error app (return-code*)))))))
+ (let ((*weblocks-output-stream* (make-string-output-stream))
+ (*uri-tokens* (make-instance 'uri-tokens :tokens (tokenize-uri (request-uri*))))
+ *dirty-widgets*
+ *before-ajax-complete-scripts* *on-ajax-complete-scripts*
+ *page-dependencies* *current-page-description*
+ (cl-who::*indent* (weblocks-webapp-html-indent-p app)))
+ (declare (special *weblocks-output-stream* *dirty-widgets*
+ *on-ajax-complete-scripts* *uri-tokens* *page-dependencies*))
+ (when (pure-request-p)
+ (throw 'hunchentoot::handler-done (eval-action)))
+ ;; a default dynamic-action hook function wraps get operations in a transaction
+ (eval-hook :pre-action)
+ (with-dynamic-hooks (:dynamic-action)
+ (eval-action))
+ (eval-hook :post-action)
+ (when (and (not (ajax-request-p))
+ (find *action-string* (get-parameters*)
+ :key #'car :test #'string-equal))
+ (redirect (remove-action-from-uri (request-uri*))))
+ (eval-hook :pre-render)
+ (with-dynamic-hooks (:dynamic-render)
+ (if (ajax-request-p)
+ (handle-ajax-request app)
+ (handle-normal-request app)))
+ (eval-hook :post-render)
+ (unless (ajax-request-p)
+ (setf (webapp-session-value 'last-request-uri) (all-tokens *uri-tokens*)))
+ (if (member (return-code*) *approved-return-codes*)
+ (get-output-stream-string *weblocks-output-stream*)
+ (handle-http-error app (return-code*))))))
+ (abort-request ()
+ :report "Abort this request."
+ (return-from handle-client-request "<h1>aborted</h1>"))
+ (rehandle-request ()
+ :report "Rehandle this request."
+ (return-from handle-client-request
+ (handle-client-request app)))
+ (show-backtrace ()
+ :report "Send a backtrace page to the browser."
+ (return-from handle-client-request
+ (handle-error-condition app condition)))))))
(defmethod handle-ajax-request ((app weblocks-webapp))
(declare (special *weblocks-output-stream* *dirty-widgets*
