[claw-cvs] r43 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Sun Apr 27 16:15:24 UTC 2008
Author: achiumenti
Date: Sun Apr 27 12:15:22 2008
New Revision: 43
Modified:
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/translators.lisp
trunk/main/claw-core/src/validators.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
API cleanup
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Sun Apr 27 12:15:22 2008
@@ -86,7 +86,7 @@
(setf *http-error-handler*
;;overrides the default hunchentoot error handling
#'(lambda (error-code)
- (let* ((error-handlers (lisplet-error-hadlers (current-lisplet)))
+ (let* ((error-handlers (lisplet-error-handlers (current-lisplet)))
(handler (gethash error-code error-handlers)))
(if handler
(funcall handler)
@@ -112,7 +112,7 @@
:accessor lisplet-pages
:documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
(error-handlers :initform (make-hash-table)
- :accessor lisplet-error-hadlers
+ :accessor lisplet-error-handlers
:documentation "An hash table where keys are http error codes and values are functions with no parameters")
(protected-resources :initform nil
:accessor lisplet-protected-resources
@@ -192,9 +192,7 @@
(uri (request-uri))
(welcome-page (lisplet-welcome-page lisplet)))
(progn
- ;;(setf (aux-request-value 'lisplet) lisplet)
(setf (current-lisplet) lisplet)
- ;;(setf (aux-request-value 'realm) (lisplet-realm lisplet))
(setf (current-realm) (lisplet-realm lisplet))
(lisplet-check-authorization lisplet)
(when (= (return-code) +http-ok+)
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Sun Apr 27 12:15:22 2008
@@ -74,7 +74,7 @@
(let ((result (remove-by-location (car location-cons) cons-list)))
(setf result (push location-cons result))))
-(defun lisplet-start-session ()
+(defun start-session ()
"Starts a session bound to the current lisplet base path"
(start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
@@ -119,7 +119,7 @@
(defun (setf current-principal) (principal &optional (session *session*))
"Setf the principal(user) that logged into the application"
(unless session
- (setf session (lisplet-start-session)))
+ (setf session (start-session)))
(setf (session-value 'principal session) principal))
(defun user-in-role-p (roles &optional (session *session*))
@@ -191,7 +191,7 @@
,default-val)))))
(defun do-message (key &optional (default "") locale)
- "This function call the lambda function returned by the WITH-MESSAGE macro."
+ "This function calls the lambda function returned by the WITH-MESSAGE macro."
(funcall (with-message key default locale)))
(defun user-locale (&optional (request *request*) (session *session*))
@@ -211,7 +211,7 @@
"This function forces the locale for the current user, binding it to the user session,
that is created if no session exists."
(unless session
- (setf session (lisplet-start-session)))
+ (setf session (start-session)))
(setf (session-value 'locale session) locale))
(defun validation-errors (&optional (request *request*))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Sun Apr 27 12:15:22 2008
@@ -34,7 +34,7 @@
(defpackage :claw
(:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time)
- (:shadow :flatten)
+ (:shadow :flatten :start-session)
(:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
(:export :*html-4.01-strict*
:*html-4.01-transitional*
@@ -52,46 +52,29 @@
:strings-to-jsarray
:empty-string-p
:build-tagf
- :parse-htcomponent-function
- :page ;page classes hadle the whole rendering cycle
- :message-dispatch
- :page-writer
- :page-can-print
- :page-url
+ :page
+ :message-dispatch
:page-lisplet
:page-current-form
- :page-req-parameter
- :page-json-id-list
- :page-format
- :page-format-raw
+ :page-req-parameter
:page-script-files
:page-stylesheet-files
:page-class-initscripts
:page-instance-initscripts
- :page-indent
- :page-xmloutput
- :page-doc-type
- :page-current-component
- :page-content-type
- :htclass-body
+ :page-current-component
:htcomponent
:htcomponent-page
:htcomponent-body
-; :setf-htcomponent-page
- :htcomponent-attributes
- :htcomponent-can-print
:htcomponent-empty
:htcomponent-client-id
:htcomponent-script-files
:htcomponent-stylesheet-files
:htcomponent-class-initscripts
:htcomponent-instance-initscript
- :tag ;class for tags that accept body
+ :tag
:tag-name
- :tag-render-starttag
- :tag-render-endtag
+ :tag-attributes
:htbody
- :page-body-init-scripts
:htscript
:htlink
:hthead
@@ -193,32 +176,23 @@
:var>
;; class modifiers
:page-content
- :page-render
:generate-id
:metacomponent
:wcomponent
- :wcomponent-parameters
:wcomponent-informal-parameters
:wcomponent-allow-informal-parametersp
:wcomponent-template
- :wcomponent-parameter-value
:wcomponent-before-rewind
:wcomponent-after-rewind
:wcomponent-before-prerender
:wcomponent-after-prerender
:wcomponent-before-render
:wcomponent-after-render
- :make-component
:cform
:cform>
:action-link
:action-link>
- :base-cinput
:cinput
- :cinput-reader
- :cinput-writer
- :cinput-accessor
- :cinput-visit-object
:cinput>
:cselect
:cselect>
@@ -227,18 +201,12 @@
:submit-link
:submit-link>
:lisplet
- :lisplet-realm
:lisplet-pages
- :lisplet-base-path
- :lisplet-dispatch-method
:lisplet-register-page-location
:lisplet-register-function-location
:lisplet-register-resource-location
- :lisplet-protect
- :lisplet-authentication-type
- :lisplet-start-session
- :lisplet-error-handlers
- :lisplet-redirect-protected-resources-p
+ :lisplet-protect
+ :start-session
;; clawserver
:clawserver
:clawserver-register-lisplet
@@ -255,8 +223,7 @@
:clawserver-input-chunking-p
:clawserver-read-timeout
:clawserver-write-timeout
- :clawserver-login-config
- :login
+ :clawserver-login-config
#+(and :unix (not :win32)) :clawserver-setuid
#+(and :unix (not :win32)) :clawserver-setgid
#-:hunchentoot-no-ssl :clawserver-ssl-certificate-file
@@ -266,8 +233,7 @@
:*id-and-static-id-description*
:describe-component-behaviour
:describe-html-attributes-from-class-slot-initargs
- :clawserver-register-configuration
- :claw-require-authorization
+ :clawserver-register-configuration
:configuration
:configuration-login
:principal
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Sun Apr 27 12:15:22 2008
@@ -161,6 +161,9 @@
- TAG is the tag instance
- PAGE the page instance"))
+(defgeneric tag-attributes (tag)
+ (:documentation "Returns an alist of tag attributes"))
+
(defgeneric (setf htcomponent-page) (page htcomponent)
(:documentation "Internal method to set the component owner page and to assign
an unique id attribute when provided.
@@ -170,20 +173,6 @@
(defgeneric (setf slot-initialization) (value wcomponent slot-initarg)
(:documentation "Sets a slot by its :INITARG. It's used just after instance creation"))
-(defgeneric wcomponent-parameter-value (wcomponent key)
- (:documentation "Returns the value of a parameter passed to the wcomponent initialization
-function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed.
- - WCOMPONENT is the wcomponent instance
- - KEY the parameter key to query"))
-
-(defgeneric wcomponent-check-parameters(wcomponent)
- (:documentation "This internal method check if all :REQUIRED parameters are provided
- - WCOMPONENT is the wcomponent instance"))
-
-(defgeneric wcomponent-parameters(wcomponent)
- (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component)
- - WCOMPONENT is the wcomponent instance"))
-
(defgeneric wcomponent-informal-parameters(wcomponent)
(:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component,
usually rendered as tag attributes withot any kind of evaluation)
@@ -528,7 +517,6 @@
(member tag-name *empty-tags* :test #'string-equal))
;;;--------------------METHODS implementation----------------------------------------------
-
(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent))
(let ((id (getf (htcomponent-attributes htcomponent) :id))
(static-id (getf (htcomponent-attributes htcomponent) :static-id))
@@ -779,6 +767,9 @@
(htcomponent-json-print-end-component htcomponent))))
;;;========= TAG =====================================
+(defmethod tag-attributes ((tag tag))
+ (htcomponent-attributes tag))
+
(defmethod tag-render-attributes ((tag tag) (page page))
(when (htcomponent-attributes tag)
(loop for (k v) on (htcomponent-attributes tag) by #'cddr
@@ -992,11 +983,7 @@
;;;========= WCOMPONENT ===================================
(defclass wcomponent (htcomponent)
- ((parameters :initarg :parameters
- :accessor wcomponent-parameters
- :type cons
- :documentation "must be a plist or nil")
- (reserved-parameters :initarg :reserved-parameters
+ ((reserved-parameters :initarg :reserved-parameters
:accessor wcomponent-reserved-parameters
:type cons
:documentation "Parameters that may not be used in the constructor function")
@@ -1036,8 +1023,6 @@
finally (return result))))
(setf (slot-value instance 'informal-parameters) informal-parameters)))
-(defmethod wcomponent-check-parameters((comp wcomponent)))
-
(defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg)
(let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg))
(new-value (if (eq slot-initarg :id) (generate-id value) value))
@@ -1065,7 +1050,6 @@
(remf parameters :id))
(loop for (initarg value) on parameters by #'cddr
do (setf (slot-initialization instance initarg) value))
- (wcomponent-check-parameters instance)
(setf (htcomponent-body instance) content)
instance))
@@ -1076,13 +1060,6 @@
(let ((fbody (parse-htcomponent-function (flatten rest))))
(make-component component-name (first fbody) (second fbody))))
-
-(defmethod wcomponent-parameter-value ((c wcomponent) key)
- (let ((result (getf (htcomponent-attributes c) key :undefined)))
- (if (eq result :undefined)
- (getf (wcomponent-parameters c) key)
- result)))
-
(defmethod htcomponent-rewind ((wcomponent wcomponent) (page page))
(let ((template (wcomponent-template wcomponent)))
(wcomponent-before-rewind wcomponent page)
Modified: trunk/main/claw-core/src/translators.lisp
==============================================================================
--- trunk/main/claw-core/src/translators.lisp (original)
+++ trunk/main/claw-core/src/translators.lisp Sun Apr 27 12:15:22 2008
@@ -280,7 +280,7 @@
(and (> day 0) (<= day (days-in-month month year))))
:component wcomponent
:message (format nil (do-message "VALIDATOR-DATE" "Field ~a is not a valid date or wrong format: ~a")
- (wcomponent-parameter-value wcomponent :label)
+ (label wcomponent)
old-value))
(if (component-validation-errors wcomponent)
old-value
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Sun Apr 27 12:15:22 2008
@@ -73,7 +73,7 @@
(when (stringp value)
(validate (and value (string-not-equal value ""))
:component component
- :message (format nil (do-message "VALIDATOR-REQUIRED" "Field ~a may not be null.") (wcomponent-parameter-value component :label)))))
+ :message (format nil (do-message "VALIDATOR-REQUIRED" "Field ~a may not be null.") (label component)))))
(defun validator-size (component value &key min-size max-size)
"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
@@ -90,13 +90,13 @@
(validate (>= value-len min-size)
:component component
:message (format nil (do-message "VALIDATOR-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
- (wcomponent-parameter-value component :label)
+ (label component)
min-size)))
(when max-size
(validate (<= value-len max-size)
:component component
:message (format nil (do-message "VALIDATOR-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
- (wcomponent-parameter-value component :label)
+ (label component)
max-size)))))))
(defun validator-range (component value &key min max)
@@ -110,7 +110,7 @@
(validate (>= value min)
:component component
:message (format nil (do-message "VALIDATOR-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
- (wcomponent-parameter-value component :label)
+ (label component)
(if (typep min 'ratio)
(coerce min 'float)
min))))
@@ -118,7 +118,7 @@
(validate (<= value max)
:component component
:message (format nil (do-message "VALIDATOR-RANGE-MAX" "Field ~a is not less then or equal to ~d")
- (wcomponent-parameter-value component :label)
+ (label component)
(if (typep max 'ratio)
(coerce max 'float)
max)))))))
@@ -131,7 +131,7 @@
(let ((test (numberp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (wcomponent-parameter-value component :label)))
+ :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (label component)))
(validator-range component value :min min :max max)))))
(defun validator-integer (component value &key min max)
@@ -142,7 +142,7 @@
(let ((test (integerp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (wcomponent-parameter-value component :label)))
+ :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (label component)))
(validator-range component value :min min :max max)))))
@@ -156,7 +156,7 @@
If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword."
(unless (component-validation-errors component)
- (let ((local-time-format '(:date "-" :month "-" :year));(translator-local-time-format (wcomponent-parameter-value component :translator)))
+ (let ((local-time-format '(:date "-" :month "-" :year))
(new-value (make-instance 'local-time
:nsec (nsec-of value)
:sec (sec-of value)
@@ -181,13 +181,13 @@
(validate (local-time> new-value min)
:component component
:message (format nil (do-message "VALIDATOR-DATE-RANGE-MIN" "Field ~a is less then ~a.")
- (wcomponent-parameter-value component :label)
+ (label component)
(local-time-to-string min local-time-format))))
(when max
(validate (local-time< new-value max)
:component component
:message (format nil (do-message "VALIDATOR-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
- (wcomponent-parameter-value component :label)
+ (label component)
(local-time-to-string max local-time-format))))))))
@@ -207,10 +207,6 @@
(describe-html-attributes-from-class-slot-initargs class)
(describe-component-behaviour class))))
-(defmethod wcomponent-parameters ((exception-monitor exception-monitor))
- (declare (ignore exception-monitor))
- (list :class nil))
-
(defmethod wcomponent-template ((exception-monitor exception-monitor))
(let ((client-id (htcomponent-client-id exception-monitor))
(validation-errors (aux-request-value :validation-errors)))
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Sun Apr 27 12:15:22 2008
@@ -73,12 +73,8 @@
(defun test-configuration-do-login (request user password)
(let ((session *session*))
(when (and (string-equal user "kiuma")
- (string-equal password "password"))
- (progn
- ;;(unless session
- ;; (setf session (lisplet-start-session)))
- ;;(setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user")))))))
- (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))))
+ (string-equal password "password"))
+ (setf (current-principal session) (make-instance 'principal :name user :roles '("user"))))))
@@ -216,7 +212,7 @@
(defmethod page-content ((o realm-page))
(when (null *session*)
- (lisplet-start-session))
+ (start-session))
(unless (session-value 'RND-NUMBER)
(setf (session-value 'RND-NUMBER) (random 1000)))
(site-template> :title "Realm test page"
More information about the Claw-cvs
mailing list