Author: achiumenti Date: Mon May 12 03:10:02 2008 New Revision: 45 Modified: trunk/main/claw-core/claw.asd 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 Log: some indentaion corrected, informal parameters rendering corrected Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Mon May 12 03:10:02 2008 @@ -33,14 +33,14 @@ :description "Common Lisp Active Web.A famework to write web applications" :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) :components ((:module src - :components ((:file "packages") - (:file "misc" :depends-on ("packages")) - (:file "i18n" :depends-on ("packages")) - (:file "locales" :depends-on ("i18n")) - (:file "hunchentoot-overrides" :depends-on ("packages")) - (:file "tags" :depends-on ("misc")) - (:file "components" :depends-on ("tags")) - (:file "validators" :depends-on ("components")) - (:file "translators" :depends-on ("validators")) - (:file "server" :depends-on ("components")) - (:file "lisplet" :depends-on ("server")))))) + :components ((:file "packages") + (:file "misc" :depends-on ("packages")) + (:file "i18n" :depends-on ("packages")) + (:file "locales" :depends-on ("i18n")) + (:file "hunchentoot-overrides" :depends-on ("packages")) + (:file "tags" :depends-on ("misc")) + (:file "components" :depends-on ("tags")) + (:file "validators" :depends-on ("components")) + (:file "translators" :depends-on ("validators")) + (:file "server" :depends-on ("components")) + (:file "lisplet" :depends-on ("server")))))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Mon May 12 03:10:02 2008 @@ -204,7 +204,7 @@ (defmethod lisplet-dispatch-request ((lisplet lisplet)) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq (script-name) (length (build-lisplet-location lisplet))))) + (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Mon May 12 03:10:02 2008 @@ -40,27 +40,27 @@ (defun strings-to-jsarray (strings) "Transforms a list of strings into a javascript array." (let ((st-size (length strings)) - (items "")) + (items "")) (cond ((= st-size 0) "[]") - ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) - (t (format nil (format nil "[~a~a]" - (prin1-to-string (first strings)) - (progn - (dolist (str (rest strings)) - (setf items (format nil "~a,~a" - items (prin1-to-string str)))) - items))))))) - + ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) + (t (format nil (format nil "[~a~a]" + (prin1-to-string (first strings)) + (progn + (dolist (str (rest strings)) + (setf items (format nil "~a,~a" + items (prin1-to-string str)))) + items))))))) + (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." (sort location-list #'(lambda (item1 item2) - (string-not-lessp (first item1) (first item2))))) + (string-not-lessp (first item1) (first item2))))) (defun sort-protected-resources (protected-resources) "Sorts a list of protected resources. A protected resource is a cons where the car is the url of the resource and the cdr is a list of roles allowhed to access that resource." (sort protected-resources #'(lambda (item1 item2) - (string-lessp (car item1) (car item2))))) + (string-lessp (car item1) (car item2))))) (defun remove-by-location (location location-list) "Removes an item from LOCATION-LIST checking its first element @@ -140,54 +140,54 @@ (let ((result result-list)) (loop for element in tree do (cond - ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) - (t (push element result)))) + ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) + (t (push element result)))) (nreverse result))) (defun msie-p (&optional (request *request*)) "Returns nil when the calling browser is not the evil of MSIE" (let* ((header-props (headers-in request)) - (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value)))))) - (when user-agent - (all-matches "MSIE" (string-upcase (cdr user-agent)))))) + (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value)))))) + (when user-agent + (all-matches "MSIE" (string-upcase (cdr user-agent)))))) (defmacro with-message (key &optional (default "") locale) -"Returns a lambda function that can localize a message by its key. + "Returns a lambda function that can localize a message by its key. The first message dispatching is made by the lisplet, then, if the message is not already vlorized the computation is left to the current rendering page, then to the current rendering web component. If the message is null after these passages the default value is used." (let ((current-lisplet (gensym)) - (current-page (gensym)) - (current-component (gensym)) - (result (gensym)) - (key-val key) - (locale-val (gensym)) - (default-val default)) + (current-page (gensym)) + (current-component (gensym)) + (result (gensym)) + (key-val key) + (locale-val (gensym)) + (default-val default)) `#'(lambda () - (let ((,current-lisplet (current-lisplet)) - (,current-page (current-page)) - (,current-component (current-component)) - (,locale-val ,locale) - (,result)) - (unless ,locale-val - (setf ,locale-val (user-locale))) - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) - (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) - (when (null ,result) - (setf ,locale-val "") - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) - (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) - (if ,result - ,result - ,default-val))))) + (let ((,current-lisplet (current-lisplet)) + (,current-page (current-page)) + (,current-component (current-component)) + (,locale-val ,locale) + (,result)) + (unless ,locale-val + (setf ,locale-val (user-locale))) + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) + (when (null ,result) + (setf ,locale-val "") + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) + (if ,result + ,result + ,default-val))))) (defun do-message (key &optional (default "") locale) "This function calls the lambda function returned by the WITH-MESSAGE macro." @@ -196,14 +196,14 @@ (defun user-locale (&optional (request *request*) (session *session*)) "This function returns the user locale. If no locale was directly set, the browser default locale is used." (let ((locale (when session - (session-value 'locale session)))) + (session-value 'locale session)))) (unless locale (setf locale (first (loop for str in (all-matches-as-strings - "[A-Z|a-z|_]+" - (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) - collect (if (> (length str) 2) - (string-upcase str :start 2) - str))))) + "[A-Z|a-z|_]+" + (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) + collect (if (> (length str) 2) + (string-upcase str :start 2) + str))))) locale)) (defun (setf user-locale) (locale &optional (session *session*)) @@ -231,12 +231,12 @@ "Returns the first class default init arg value matching matching the given INITARG" (loop for current-initarg in initargs do (when (eq (first current-initarg) initarg) - (return (second current-initarg))))) + (return (second current-initarg))))) (defmethod initialize-instance :after ((class metacomponent) &key) (let* ((name (class-name class)) - (builder-function (format nil "~a>" name)) - (symbolf (find-symbol builder-function))) + (builder-function (format nil "~a>" name)) + (symbolf (find-symbol builder-function))) (unless symbolf (setf symbolf (intern builder-function))) (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest))))) @@ -245,15 +245,15 @@ "Helper function that generates documentation for wcomponent init functions" (let* ((class-slots (closer-mop:class-direct-slots class))) (format nil "~{~%~a~}" - (remove-if #'null - (reverse (loop for slot in class-slots - collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot)))) - (when slot-initarg - (format nil - "- :~a ~a" - slot-initarg - (documentation slot 't)))))))))) - + (remove-if #'null + (reverse (loop for slot in class-slots + collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot)))) + (when slot-initarg + (format nil + "- :~a ~a" + slot-initarg + (documentation slot 't)))))))))) + (defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal - :STATIC-ID Like the :ID parameter, it sets the htcomponent-client-id instance property, but CLAW will not manage its value to manage its univocity." "Description used for describing :ID and :STATIC-ID used in claw component init functions documentation ") @@ -261,43 +261,45 @@ (defun describe-component-behaviour (class) "Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters" (let* ((initargs (closer-mop:class-default-initargs class)) - (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters))) + (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters))) (format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a" - (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters) - "Yes" - "No") - (if (find-first-classdefault-initarg-value initargs :empty) - "No" - "Yes") - (if reserved-parameters - (format nil "~{:~a ~}" (eval reserved-parameters)) - "NONE")))) + (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters) + "Yes" + "No") + (if (find-first-classdefault-initarg-value initargs :empty) + "No" + "Yes") + (if reserved-parameters + (format nil "~{:~a ~}" (eval reserved-parameters)) + "NONE")))) (defun register-library-resource (location resource-path &optional content-type) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* - (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) - #'(lambda () - (let ((resource-full-path (merge-pathnames - (uri-to-pathname (subseq (script-name) - (+ (length (clawserver-base-path (current-server))) - (length location)))) - resource-path))) - (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) - *claw-libraries-resources*)))) + (sort-by-location (pushnew-location + (cons location + (if (directory-pathname-p resource-path) + #'(lambda () + (let ((resource-full-path (merge-pathnames + (uri-to-pathname (subseq (script-name) + (+ (length (clawserver-base-path (current-server))) + (length location)))) + resource-path))) + (handle-static-file resource-full-path content-type))) + #'(lambda () (handle-static-file resource-path content-type)))) + *claw-libraries-resources*)))) -(defun uri-to-pathname (uri) +(defun uri-to-pathname (uri &optional (relative t)) "Convert an URI to a pathname" (let* ((splitted-uri (split-sequence #\/ uri)) - (directory-list (butlast splitted-uri)) - (file (first (last splitted-uri))) - (pos (position #\. file :from-end t)) - (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) - (list (subseq file 0 pos)(subseq file (1+ pos))) - (list file)))) - (make-pathname :directory directory-list - :name (first file-name-and-type) - :type (second file-name-and-type)))) + (directory-list (butlast splitted-uri)) + (file (first (last splitted-uri))) + (pos (position #\. file :from-end t)) + (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) + (list (subseq file 0 pos)(subseq file (1+ pos))) + (list file)))) + (make-pathname :directory (if relative + (cons :relative directory-list) + (cons :absolute directory-list)) + :name (first file-name-and-type) + :type (second file-name-and-type)))) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Mon May 12 03:10:02 2008 @@ -37,245 +37,248 @@ (:shadow :flatten) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") (:export :*html-4.01-strict* - :*html-4.01-transitional* - :*html-4.01-frameset* - :*xhtml-1.0-strict* - :*xhtml-1.0-transitional* - :*xhtml-1.0-frameset* - :*default-encoding* - :*rewind-parameter* - :*clawserver-base-path* - :*apache-http-port* - :*apache-https-port* - :*empty-tags* - :tag-emptyp - :strings-to-jsarray - :empty-string-p - :build-tagf - :page - :message-dispatch - :page-lisplet - :page-current-form - :page-req-parameter - :page-script-files - :page-stylesheet-files - :page-class-initscripts - :page-instance-initscripts - :page-current-component - :htcomponent - :htcomponent-page - :htcomponent-body - :htcomponent-empty - :htcomponent-client-id - :htcomponent-script-files - :htcomponent-stylesheet-files - :htcomponent-class-initscripts - :htcomponent-instance-initscript - :tag - :tag-name - :tag-attributes - :htbody - :htscript - :htlink - :hthead - :htstring - :$> - :$raw> - ;empty tags definition - :area> - :base> - :basefont> - :br> - :col> - :frame> - :hr> - :img> - :input> - :isindex> - :link> - :meta> - :param> - ;standard tags - :a> - :abbr> - :acronym> - :address> - :applet> - :b> - :bdo> - :big> - :blockquote> - :body> - :button> - :caption> - :center> - :cite> - :code> - :colgroup> - :dd> - :del> - :dfn> - :dir> - :div> - :dl> - :dt> - :em> - :fieldset> - :font> - :form> - :frameset> - :h1> - :h2> - :h3> - :h4> - :h5> - :h6> - :head> - :html> - :i> - :iframe> - :ins> - :kbd> - :label> - :legend> - :li> - :map> - :menu> - :noframes> - :noscript> - :object> - :ol> - :optgroup> - :option> - :p> - :pre> - :q> - :s> - :samp> - :script> - :select> - :small> - :span> - :strike> - :strong> - :style> - :sub> - :sup> - :table> - :tbody> - :td> - :textarea> - :tfoot> - :th> - :thead> - :title> - :tr> - :tt> - :u> - :ul> - :var> - ;; class modifiers - :page-content - :generate-id - :metacomponent - :wcomponent - :wcomponent-informal-parameters - :wcomponent-allow-informal-parametersp - :wcomponent-template - :wcomponent-before-rewind - :wcomponent-after-rewind - :wcomponent-before-prerender - :wcomponent-after-prerender - :wcomponent-before-render - :wcomponent-after-render - :cform - :cform> - :action-link - :action-link> - :cinput - :cinput> - :cselect - :cselect> - :csubmit - :csubmit> - :submit-link - :submit-link> - :lisplet - :lisplet-pages - :lisplet-register-page-location - :lisplet-register-function-location - :lisplet-register-resource-location - :lisplet-protect - :lisplet-authentication-type - :claw-start-session - ;; clawserver - :clawserver - :clawserver-base-path - :clawserver-register-lisplet - :clawserver-unregister-lisplet - :clawserver-start - :clawserver-stop - :clawserver-port - :clawserver-sslport - :clawserver-address - :clawserver-name - :clawserver-sslname - :clawserver-mod-lisp-p - :clawserver-use-apache-log-p - :clawserver-input-chunking-p - :clawserver-read-timeout - :clawserver-write-timeout - :clawserver-login-config - #+(and :unix (not :win32)) :clawserver-setuid - #+(and :unix (not :win32)) :clawserver-setgid - #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file - #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file - #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password - :msie-p - :*id-and-static-id-description* - :describe-component-behaviour - :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration - :configuration - :configuration-login - :principal - :current-principal - :principal-name - :principal-roles - :current-lisplet - :current-server - :current-realm - :current-page - :current-component - :user-locale - :page-current-component - :user-in-role-p - :login - :register-library-resource - ;;i18n - :message-dispatcher - :message-dispatch - :simple-message-dispatcher - :simple-message-dispatcher-add-message - :with-message - :do-message - ;;validation - :translator - :translator-integer - :translator-number - :translator-date - :translator-encode - :translator-decode - :*simple-translator* - :*locales* - :validate - :validation-errors - :component-validation-errors - :validate-required - :validate-size - :validate-range - :validate-number - :validate-integer - :validate-date-range - :exception-monitor - :exception-monitor>)) \ No newline at end of file + :*html-4.01-transitional* + :*html-4.01-frameset* + :*xhtml-1.0-strict* + :*xhtml-1.0-transitional* + :*xhtml-1.0-frameset* + :*default-encoding* + :*rewind-parameter* + :*clawserver-base-path* + :*apache-http-port* + :*apache-https-port* + :*empty-tags* + :tag-emptyp + :strings-to-jsarray + :empty-string-p + :build-tagf + :page + :page-url + :page-lisplet + :page-current-form + :page-req-parameter + :page-script-files + :page-stylesheet-files + :page-class-initscripts + :page-instance-initscripts + :page-current-component + :page-body-init-scripts + :htcomponent + :htcomponent-page + :htcomponent-body + :htcomponent-empty + :htcomponent-client-id + :htcomponent-script-files + :htcomponent-stylesheet-files + :htcomponent-class-initscripts + :htcomponent-instance-initscript + :tag + :tag-name + :tag-attributes + :htbody + :htscript + :htlink + :hthead + :htstring + :$> + :$raw> + ;empty tags definition + :area> + :base> + :basefont> + :br> + :col> + :frame> + :hr> + :img> + :input> + :isindex> + :link> + :meta> + :param> + ;standard tags + :a> + :abbr> + :acronym> + :address> + :applet> + :b> + :bdo> + :big> + :blockquote> + :body> + :button> + :caption> + :center> + :cite> + :code> + :colgroup> + :dd> + :del> + :dfn> + :dir> + :div> + :dl> + :dt> + :em> + :fieldset> + :font> + :form> + :frameset> + :h1> + :h2> + :h3> + :h4> + :h5> + :h6> + :head> + :html> + :i> + :iframe> + :ins> + :kbd> + :label> + :legend> + :li> + :map> + :menu> + :noframes> + :noscript> + :object> + :ol> + :optgroup> + :option> + :p> + :pre> + :q> + :s> + :samp> + :script> + :select> + :small> + :span> + :strike> + :strong> + :style> + :sub> + :sup> + :table> + :tbody> + :td> + :textarea> + :tfoot> + :th> + :thead> + :title> + :tr> + :tt> + :u> + :ul> + :var> + ;; class modifiers + :page-content + :generate-id + :metacomponent + :wcomponent + :wcomponent-informal-parameters + :wcomponent-allow-informal-parametersp + :wcomponent-template + :wcomponent-before-rewind + :wcomponent-after-rewind + :wcomponent-before-prerender + :wcomponent-after-prerender + :wcomponent-before-render + :wcomponent-after-render + :cform + :cform> + :action + :action-link + :action-link> + :cinput + :cinput> + :cselect + :cselect> + :csubmit + :csubmit> + :csubmit-value + :submit-link + :submit-link> + :lisplet + :lisplet-pages + :lisplet-register-page-location + :lisplet-register-function-location + :lisplet-register-resource-location + :lisplet-protect + :lisplet-authentication-type + :claw-start-session + ;; clawserver + :clawserver + :clawserver-base-path + :clawserver-register-lisplet + :clawserver-unregister-lisplet + :clawserver-start + :clawserver-stop + :clawserver-port + :clawserver-sslport + :clawserver-address + :clawserver-name + :clawserver-sslname + :clawserver-mod-lisp-p + :clawserver-use-apache-log-p + :clawserver-input-chunking-p + :clawserver-read-timeout + :clawserver-write-timeout + :clawserver-login-config + #+(and :unix (not :win32)) :clawserver-setuid + #+(and :unix (not :win32)) :clawserver-setgid + #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file + #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file + #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :msie-p + :*id-and-static-id-description* + :describe-component-behaviour + :describe-html-attributes-from-class-slot-initargs + :clawserver-register-configuration + :configuration + :configuration-login + :principal + :current-principal + :principal-name + :principal-roles + :current-lisplet + :current-server + :current-realm + :current-page + :current-component + :user-locale + :page-current-component + :user-in-role-p + :login + :register-library-resource + ;;i18n + :message-dispatcher + :message-dispatch + :simple-message-dispatcher + :simple-message-dispatcher-add-message + :with-message + :do-message + ;;validation + :translator + :translator-integer + :translator-number + :translator-date + :translator-encode + :translator-decode + :*simple-translator* + :*locales* + :validate + :validation-errors + :component-validation-errors + :validate-required + :validate-size + :validate-range + :validate-number + :validate-integer + :validate-date-range + :exception-monitor + :exception-monitor>)) \ No newline at end of file Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Mon May 12 03:10:02 2008 @@ -142,7 +142,7 @@ - HTCOMPONENT is the htcomponent instance")) (defgeneric htcomponent-json-print-end-component (htcomponent) - (:documentation "Internal method called to render the json reply during the render cycle phase + (:documentation "Internal method called to render the json reply during the render cycle phase on component end. - HTCOMPONENT is the htcomponent instance")) @@ -173,11 +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-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) - - WCOMPONENT is the wcomponent instance")) - (defgeneric wcomponent-before-rewind (wcomponent page) (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. - WCOMPONENT is the tag instance @@ -238,8 +233,8 @@ (defvar *empty-tags* (list "area" "base" "basefont" "br" "col" "frame" - "hr" "img" "input" "isindex" "meta" - "param" "link") + "hr" "img" "input" "isindex" "meta" + "param" "link") "List of html empty tags") (defun request-id-table-map () @@ -249,9 +244,9 @@ (when (boundp '*request*) (let ((id-table-map (aux-request-value :id-table-map))) (if (null id-table-map) - (progn - (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) - id-table-map)))) + (progn + (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) + id-table-map)))) (defun reset-request-id-table-map () "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. @@ -262,15 +257,15 @@ (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" (let ((attributes) - (body)) - (loop for last-elem = nil then elem - for elem in function-body - do (if (and (null body) - (or (keywordp elem) - (keywordp last-elem))) - (push elem attributes) - (when elem - (push elem body)))) + (body)) + (loop for last-elem = nil then elem + for elem in function-body + do (if (and (null body) + (or (keywordp elem) + (keywordp last-elem))) + (push elem attributes) + (when elem + (push elem body)))) (list (reverse attributes) (reverse body)))) @@ -278,38 +273,38 @@ "This function is very useful when having references to components id inside component body. When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." (let* ((id-ht (request-id-table-map)) - (client-id-index (gethash id id-ht 0)) - (result)) + (client-id-index (gethash id id-ht 0)) + (result)) (if (= 0 client-id-index) - (setf result id) - (setf result (format nil "~a_~d" id client-id-index))) + (setf result id) + (setf result (format nil "~a_~d" id client-id-index))) (setf (gethash id id-ht) (1+ client-id-index)) result)) (defun build-tagf (tag-name parent emptyp &rest rest) "This function is used to create a tag object instance - TAG-NAME the a string tag name to create, for example \"span\" -- PARENT the parent class. usually 'TAG +- PARENT the parent class. usually TAG - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase. - REST a list of attribute/value pairs and the component body" (let* ((fbody (parse-htcomponent-function (flatten rest))) - (id-table-map (request-id-table-map)) - (id (getf (first fbody) :id)) - (static-id (getf (first fbody) :static-id)) - (instance)) + (id-table-map (request-id-table-map)) + (id (getf (first fbody) :id)) + (static-id (getf (first fbody) :static-id)) + (instance)) (when static-id (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent - :empty emptyp - :name (string-downcase tag-name) - :attributes (first fbody) - :body (second fbody))) + :empty emptyp + :name (string-downcase tag-name) + :attributes (first fbody) + :body (second fbody))) (if (null static-id) - (when (and id-table-map id) - (setf (htcomponent-client-id instance) - (generate-id id))) - (setf (htcomponent-client-id instance) static-id)) + (when (and id-table-map id) + (setf (htcomponent-client-id instance) + (generate-id id))) + (setf (htcomponent-client-id instance) static-id)) instance)) (defun generate-tagf (tag-name emptyp) @@ -318,12 +313,12 @@ - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." (let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name))))) (setf (fdefinition fsymbol) - #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest))) + #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest))) (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag" - (if emptyp - "empty " - "") - tag-name)))) + (if emptyp + "empty " + "") + tag-name)))) ;;;---------------------------------------------------------------- @@ -333,58 +328,58 @@ (defclass simple-message-dispatcher (message-dispatcher) ((locales :initform (make-hash-table :test #'equal) - :accessor simple-message-dispatcher-locales - :documentation "Hash table of locales strings and KEY/VALUE message pairs")) + :accessor simple-message-dispatcher-locales + :documentation "Hash table of locales strings and KEY/VALUE message pairs")) (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) (defclass i18n-aware (message-dispatcher) ((message-dispatcher :initarg :message-dispatcher - :accessor message-dispatcher - :documentation "Reference to a MESSAGE-DISPATCHER instance")) + :accessor message-dispatcher + :documentation "Reference to a MESSAGE-DISPATCHER instance")) (:default-initargs :message-dispatcher nil) (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE")) (defclass page(i18n-aware) ((writer :initarg :writer - :accessor page-writer :documentation "The output stream for this page instance") + :accessor page-writer :documentation "The output stream for this page instance") (lisplet :initarg :lisplet - :reader page-lisplet :documentation "The lisplet that owns this page instance") + :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil - :accessor page-can-print - :documentation "Controls the printing process when a json request is dispatched. + :accessor page-can-print + :documentation "Controls the printing process when a json request is dispatched. Only components with a matching id and their contents can be printed") (script-files :initarg :script-files - :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") + :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") (stylesheet-files :initarg :stylesheet-files - :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") + :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") (class-initscripts :initarg :class-initscripts - :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") + :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") (instancee-initscripts :initarg :instance-initscripts - :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") + :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") (indent :initarg :indent - :accessor page-indent :documentation "Determine if the output must be indented or not") + :accessor page-indent :documentation "Determine if the output must be indented or not") (tabulator :initarg :tabulator - :accessor page-tabulator :documentation "Holds the indentation level") + :accessor page-tabulator :documentation "Holds the indentation level") (xmloutput :initarg :xmloutput - :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") + :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") (current-form :initform :nil - :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") + :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") (doc-type :initarg :doc-type - :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") + :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") (lasttag :initform nil - :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") + :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") (json-component-count :initarg :json-component-count - :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") + :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") (request-parameters :initarg :request-parameters - :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") + :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") (components-stack :initform nil - :accessor page-components-stack - :documentation "A stack of components enetered into rendering process.") + :accessor page-components-stack + :documentation "A stack of components enetered into rendering process.") (content-type :initarg :content-type - :accessor page-content-type - :documentation "Define the content type of the page when rendered") + :accessor page-content-type + :documentation "Define the content type of the page when rendered") (url :initarg :url - :accessor page-url :documentation "The URL provided with this page instance")) + :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t :script-files nil :json-component-count 0 @@ -402,23 +397,23 @@ (defclass htcomponent (i18n-aware) ((page :initarg :page - :reader htcomponent-page :documentation "The owner page") + :reader htcomponent-page :documentation "The owner page") (body :initarg :body - :accessor htcomponent-body :documentation "The tag body") + :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id - :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") + :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") (attributes :initarg :attributes - :accessor htcomponent-attributes :documentation "The tag attributes") + :accessor htcomponent-attributes :documentation "The tag attributes") (empty :initarg :empty - :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") + :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") (script-files :initarg :script-files - :accessor htcomponent-script-files :documentation "Page injectable script files") + :accessor htcomponent-script-files :documentation "Page injectable script files") (stylesheet-files :initarg :stylesheet-files - :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") + :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") (class-initscripts :initarg :class-initscripts - :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") + :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") (instance-initscript :initarg :instance-initscript - :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) + :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) (:default-initargs :page nil :body nil :client-id nil @@ -432,13 +427,13 @@ (defclass tag (htcomponent) ((name :initarg :name - :reader tag-name :documentation "The tag name to be rendered")) + :reader tag-name :documentation "The tag name to be rendered")) (:default-initargs :name nil) (:documentation "This class is used to render the most part of html tags")) (defclass htstring (htcomponent) ((raw :initarg :raw - :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) + :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) (:default-initargs :raw nil) (:documentation "Component needed to render strings")) @@ -446,9 +441,9 @@ (defmethod initialize-instance :after ((inst tag) &rest keys) (let ((emptyp (getf keys :empty)) - (body (getf keys :body))) + (body (getf keys :body))) (when (and (not (null emptyp)) - (not (null body))) + (not (null body))) (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) (defun $> (value) @@ -488,29 +483,29 @@ (build-tagf "head" 'hthead nil rest)) (mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) - ;;Creates empty tag initialization functions. But the ones directly defined - *empty-tags*) + ;;Creates empty tag initialization functions. But the ones directly defined + *empty-tags*) (mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) - ;;Creates non empty tag initialization functions. But the ones directly defined - '("a" "abbr" "acronym" "address" "applet" - "b" "bdo" "big" "blockquote" "button" - "caption" "center" "cite" "code" "colgroup" - "dd" "del" "dfn" "dir" "div" "dl" "dt" - "em" - "fieldset" "font" "form" "frameset" - "h1" "h2" "h3" "h4" "h5" "h6" "html" - "i" "iframe" "ins" - "kbd" - "label" "legend" "li" - "map" "menu" - "noframes" "noscript" - "object" "ol" "optgroup" "option" - "p" "pre" - "q" - "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" - "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" - "u" "ul" "var")) + ;;Creates non empty tag initialization functions. But the ones directly defined + '("a" "abbr" "acronym" "address" "applet" + "b" "bdo" "big" "blockquote" "button" + "caption" "center" "cite" "code" "colgroup" + "dd" "del" "dfn" "dir" "div" "dl" "dt" + "em" + "fieldset" "font" "form" "frameset" + "h1" "h2" "h3" "h4" "h5" "h6" "html" + "i" "iframe" "ins" + "kbd" + "label" "legend" "li" + "map" "menu" + "noframes" "noscript" + "object" "ol" "optgroup" "option" + "p" "pre" + "q" + "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" + "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" + "u" "ul" "var")) (defun tag-emptyp (tag-name) "Returns if a tag defined by the string TAG-NAME is empty" @@ -519,47 +514,47 @@ ;;;--------------------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)) - (client-id (htcomponent-client-id htcomponent))) + (static-id (getf (htcomponent-attributes htcomponent) :static-id)) + (client-id (htcomponent-client-id htcomponent))) (setf (slot-value htcomponent 'page) page) (unless client-id (if static-id - (setf (htcomponent-client-id htcomponent) static-id) - (setf (htcomponent-client-id htcomponent) (generate-id id)))))) + (setf (htcomponent-client-id htcomponent) static-id) + (setf (htcomponent-client-id htcomponent) (generate-id id)))))) (defmethod page-request-parameters ((page page)) (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) - (let ((parameters (append (post-parameters) (get-parameters))) - (pparameters (make-hash-table :test 'equal))) - (loop for kv in parameters - do (setf (gethash (string-upcase (car kv)) pparameters) - (append (gethash (string-upcase (car kv)) pparameters) - (list (cdr kv))))) - (setf (slot-value page 'request-parameters) pparameters)) - (slot-value page 'request-parameters))) + (let ((parameters (append (post-parameters) (get-parameters))) + (pparameters (make-hash-table :test 'equal))) + (loop for kv in parameters + do (setf (gethash (string-upcase (car kv)) pparameters) + (append (gethash (string-upcase (car kv)) pparameters) + (list (cdr kv))))) + (setf (slot-value page 'request-parameters) pparameters)) + (slot-value page 'request-parameters))) (defmethod page-req-parameter ((page page) name &optional as-list) (let ((parameters (page-request-parameters page)) - (retval)) + (retval)) (when parameters (setf retval (gethash (string-upcase name) parameters)) (if (or (null retval) as-list) - retval - (first retval))))) + retval + (first retval))))) (defmethod page-format ((page page) str &rest rest) (let ((jsonp (page-json-id-list page)) - (writer (page-writer page))) + (writer (page-writer page))) (if (null jsonp) - (apply #'format writer str rest) - (apply #'format writer (list - (regex-replace-all "\"" - (regex-replace-all "\\\\\"" - (regex-replace-all "\\n" - (apply #'format nil str rest) - "\\n") - "\\\\\\\"") - "\\\"")))))) + (apply #'format writer str rest) + (apply #'format writer (list + (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + (apply #'format nil str rest) + "\\n") + "\\\\\\\"") + "\\\"")))))) (defmethod page-format-raw ((page page) str &rest rest) (let ((writer (page-writer page))) @@ -577,107 +572,107 @@ (defmethod page-render-headings ((page page)) (let* ((writer (page-writer page)) - (jsonp (page-json-id-list page)) - (encoding (handler-case (format nil "~a" (stream-external-format writer)) - (error () (format nil "~a" *default-encoding*)))) - (xml-p (page-xmloutput page)) - (content-type (page-doc-type page))) + (jsonp (page-json-id-list page)) + (encoding (handler-case (format nil "~a" (stream-external-format writer)) + (error () (format nil "~a" *default-encoding*)))) + (xml-p (page-xmloutput page)) + (content-type (page-doc-type page))) (when (null jsonp) (when xml-p - (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) (when content-type - (page-format-raw page "~a~%" content-type))))) + (page-format-raw page "~a~%" content-type))))) (defun json-validation-errors () "Composes the error part for the json reply" (let ((validation-errors (aux-request-value :validation-errors))) (if validation-errors - (strings-to-jsarray - (loop for component-exceptions in validation-errors - collect (format "{~a:~a}"(car component-exceptions) - (strings-to-jsarray (loop for message in (cdr component-exceptions) - collect (prin1-to-string message)))))) - "null"))) + (strings-to-jsarray + (loop for component-exceptions in validation-errors + collect (format "{~a:~a}"(car component-exceptions) + (strings-to-jsarray (loop for message in (cdr component-exceptions) + collect (prin1-to-string message)))))) + "null"))) (defmethod page-render ((page page)) (let ((body (page-content page)) - (jsonp (page-json-id-list page))) + (jsonp (page-json-id-list page))) (setf (hunchentoot:content-type) (page-content-type page)) (if (null body) - (format nil "null body for page ~a~%" (type-of page)) - (progn - (setf (current-page) page) - (page-init page) - (when (page-req-parameter page *rewind-parameter*) - (htcomponent-rewind body page)) - (page-init page) - (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! - (page-render-headings page) - (page-init page) - (when jsonp - (page-format-raw page "{components:{")) - (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! - (when jsonp - (page-format-raw page "},classInjections:\"") - (setf (page-can-print page) t) - (dolist (injection (page-init-injections page)) - (when injection - (htcomponent-render injection page))) - (page-format-raw page "\",instanceInjections:\"") - (let ((init-scripts (htbody-init-scripts-tag page))) - (when init-scripts - (htcomponent-render init-scripts page))) - (page-format-raw page "\",errors:") - (page-format-raw page (json-validation-errors)) - (page-format-raw page "}")))))) + (format nil "null body for page ~a~%" (type-of page)) + (progn + (setf (current-page) page) + (page-init page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind body page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page "{components:{")) + (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! + (when jsonp + (page-format-raw page "},classInjections:\"") + (setf (page-can-print page) t) + (dolist (injection (page-init-injections page)) + (when injection + (htcomponent-render injection page))) + (page-format-raw page "\",instanceInjections:\"") + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) + (page-format-raw page "\",errors:") + (page-format-raw page (json-validation-errors)) + (page-format-raw page "}")))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) (dolist (current-js (reverse (page-instance-initscripts page))) (setf js-body (format nil "~a~%~a~%" js-body current-js))) (if (string= "" js-body) - js-body - (format nil "~a" js-body)))) + js-body + (format nil "~a" js-body)))) (defmethod page-print-tabulation ((page page)) (let ((jsonp (page-json-id-list page)) - (tabulator (page-tabulator page)) - (indent-p (page-indent page))) + (tabulator (page-tabulator page)) + (indent-p (page-indent page))) (when (and (<= 0 tabulator) indent-p (null jsonp)) (page-format-raw page "~a" - (make-string tabulator :initial-element #\tab))))) + (make-string tabulator :initial-element #\tab))))) (defmethod page-newline ((page page)) (let ((jsonp (page-json-id-list page)) - (indent-p (page-indent page))) + (indent-p (page-indent page))) (when (and indent-p (null jsonp)) (page-format-raw page "~%")))) (defmethod page-init-injections ((page page)) - (let ((tag-list) - (class-init-scripts "")) - (dolist (script (reverse (page-class-initscripts page))) - (setf class-init-scripts (format nil "~a~%~a" - class-init-scripts - script))) - (unless (string= "" class-init-scripts) - (let ((current-js (script> :type "text/javascript"))) - (setf (htcomponent-body current-js) class-init-scripts) - (push current-js tag-list))) - (dolist (js-file (page-script-files page)) - (if (typep js-file 'htcomponent) - (push js-file tag-list) - (let ((current-js (script> :type "text/javascript" :src ""))) - (setf (getf (htcomponent-attributes current-js) :src) js-file) - (push current-js tag-list)))) - (dolist (css-file (page-stylesheet-files page)) - (if (typep css-file 'htcomponent) - (push css-file tag-list) - (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) - (setf (getf (htcomponent-attributes current-css) :href) css-file) - (push current-css tag-list)))) + (let ((tag-list) + (class-init-scripts "")) + (dolist (script (reverse (page-class-initscripts page))) + (setf class-init-scripts (format nil "~a~%~a" + class-init-scripts + script))) + (unless (string= "" class-init-scripts) + (let ((current-js (script> :type "text/javascript"))) + (setf (htcomponent-body current-js) class-init-scripts) + (push current-js tag-list))) + (dolist (js-file (page-script-files page)) + (if (typep js-file 'htcomponent) + (push js-file tag-list) + (let ((current-js (script> :type "text/javascript" :src ""))) + (setf (getf (htcomponent-attributes current-js) :src) js-file) + (push current-js tag-list)))) + (dolist (css-file (page-stylesheet-files page)) + (if (typep css-file 'htcomponent) + (push css-file tag-list) + (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) + (setf (getf (htcomponent-attributes current-css) :href) css-file) + (push current-css tag-list)))) - tag-list)) + tag-list)) (defmethod page-current-component ((page page)) (car (page-components-stack page))) @@ -690,28 +685,28 @@ ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (htcomponent-client-id htcomponent)) - (page (htcomponent-page htcomponent)) - (print-status (page-can-print page)) - (render-p (member id (page-json-id-list page) :test #'string=))) + (page (htcomponent-page htcomponent)) + (print-status (page-can-print page)) + (render-p (member id (page-json-id-list page) :test #'string=))) (or print-status render-p))) (defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (member id jsonp :test #'string-equal)) (when (> (page-json-component-count page) 0) - (page-format page ",")) + (page-format page ",")) (page-format-raw page "~a:\"" id) (incf (page-json-component-count page))))) (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (member id jsonp :test #'string-equal)) (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) @@ -746,22 +741,22 @@ (setf (page-can-print page) (htcomponent-can-print htcomponent))) (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) + (htcomponent-prerender tag page))) (when (null previous-print-status) (setf (page-can-print page) nil)))) (defmethod htcomponent-render ((htcomponent htcomponent) (page page)) (let ((body-list (htcomponent-body htcomponent)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print htcomponent)) (htcomponent-json-print-start-component htcomponent)) (dolist (child-tag body-list) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (null previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htcomponent)))) @@ -774,66 +769,66 @@ (when (htcomponent-attributes tag) (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn - (assert (keywordp k)) - (when (functionp v) - (setf v (funcall v))) - (when (and v (string-not-equal v "")) - (page-format page " ~a=\"~a\"" - (string-downcase (if (eq k :static-id) - "id" - (symbol-name k))) - (let ((s (if (eq k :id) - (prin1-to-string (htcomponent-client-id tag)) - (prin1-to-string v)))) ;escapes double quotes - (subseq s 1 (1- (length s)))))))))) + (assert (keywordp k)) + (when (functionp v) + (setf v (funcall v))) + (when (and v (string-not-equal v "")) + (page-format page " ~a=\"~a\"" + (string-downcase (if (eq k :static-id) + "id" + (symbol-name k))) + (let ((s (if (eq k :id) + (prin1-to-string (htcomponent-client-id tag)) + (prin1-to-string v)))) ;escapes double quotes + (subseq s 1 (1- (length s)))))))))) (defmethod tag-render-starttag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (emptyp (htcomponent-empty tag)) - (xml-p (page-xmloutput page))) + (emptyp (htcomponent-empty tag)) + (xml-p (page-xmloutput page))) (setf (page-lasttag page) tagname) (page-newline page) (page-print-tabulation page) (page-format page "<~a" tagname) (tag-render-attributes tag page) (if (null emptyp) - (progn - (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) - (page-format page ">") - (page-format page "/>"))))) + (progn + (page-format page ">") + (incf (page-tabulator page))) + (if (null xml-p) + (page-format page ">") + (page-format page "/>"))))) (defmethod tag-render-endtag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (previous-tagname (page-lasttag page)) - (emptyp (htcomponent-empty tag))) + (previous-tagname (page-lasttag page)) + (emptyp (htcomponent-empty tag))) (when (null emptyp) - (progn - (decf (page-tabulator page)) - (if (string= tagname previous-tagname) - (progn - (page-format page "</~a>" tagname)) - (progn - (page-newline page) - (page-print-tabulation page) - (page-format page "</~a>" tagname))))) + (progn + (decf (page-tabulator page)) + (if (string= tagname previous-tagname) + (progn + (page-format page "</~a>" tagname)) + (progn + (page-newline page) + (page-print-tabulation page) + (page-format page "</~a>" tagname))))) (setf (page-lasttag page) nil))) (defmethod htcomponent-render ((tag tag) (page page)) (let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print tag)) (htcomponent-json-print-start-component tag)) (when (or (page-can-print page) previous-print-status) (tag-render-starttag tag page)) (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (or (page-can-print page) previous-print-status) (tag-render-endtag tag page)) (unless previous-print-status @@ -844,18 +839,18 @@ (defmethod htcomponent-render ((hthead hthead) (page page)) (when (null (page-json-id-list page)) (let ((body-list (htcomponent-body hthead)) - (injections (page-init-injections page))) + (injections (page-init-injections page))) (tag-render-starttag hthead page) (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (dolist (injection injections) - (when injection - (htcomponent-render injection page))) + (when injection + (htcomponent-render injection page))) (tag-render-endtag hthead page)))) ;;;========= HTSTRING =================================== @@ -865,35 +860,35 @@ (defmethod htcomponent-render ((htstring htstring) (page page)) (let ((body (htcomponent-body htstring)) - (jsonp (not (null (page-json-id-list page)))) - (print-p (page-can-print page))) + (jsonp (not (null (page-json-id-list page)))) + (print-p (page-can-print page))) (when (and print-p body) (when (functionp body) - (setf body (funcall body))) + (setf body (funcall body))) (when jsonp - (setf body (regex-replace-all "\"" - (regex-replace-all "\\\\\"" - (regex-replace-all "\\n" - body - "\\n") - "\\\\\\\"") - "\\\""))) + (setf body (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + body + "\\n") + "\\\\\\\"") + "\\\""))) (if (htstring-raw htstring) - (page-format-raw page body) - (loop for ch across body - do (case ch - ((#\<) (page-format-raw page "<")) - ((#\>) (page-format-raw page ">")) - ((#\&) (page-format-raw page "&")) - (t (page-format-raw page "~a" ch)))))))) + (page-format-raw page body) + (loop for ch across body + do (case ch + ((#\<) (page-format-raw page "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch)))))))) ;;;========= HTSCRIPT =================================== (defmethod htcomponent-prerender((htscript htscript) (page page))) (defmethod htcomponent-render ((htscript htscript) (page page)) (let ((xml-p (page-xmloutput page)) - (body (htcomponent-body htscript)) - (previous-print-status (page-can-print page))) + (body (htcomponent-body htscript)) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print htscript)) (htcomponent-json-print-start-component htscript)) @@ -902,21 +897,21 @@ (when (page-can-print page) (tag-render-starttag htscript page) (when (and (null (getf (htcomponent-attributes htscript) :src)) - (not (null (htcomponent-body htscript)))) - (if (null xml-p) - (page-format page "~%//<!--~%") - (page-format page "~%//<[CDATA[~%")) - (unless (listp body) - (setf body (list body))) - (dolist (element body) - (when element - (cond - ((stringp element) (htcomponent-render ($> element) page)) - ((functionp element) (htcomponent-render ($> (funcall element)) page)) - (t (htcomponent-render element page))))) - (if (null xml-p) - (page-format page "~%//-->") - (page-format page "~%//]]>"))) + (not (null (htcomponent-body htscript)))) + (if (null xml-p) + (page-format page "~%//<!--~%") + (page-format page "~%//<[CDATA[~%")) + (unless (listp body) + (setf body (list body))) + (dolist (element body) + (when element + (cond + ((stringp element) (htcomponent-render ($> element) page)) + ((functionp element) (htcomponent-render ($> (funcall element)) page)) + (t (htcomponent-render element page))))) + (if (null xml-p) + (page-format page "~%//-->") + (page-format page "~%//]]>"))) (setf (page-lasttag page) nil) (tag-render-endtag htscript page)) (when (null previous-print-status) @@ -932,9 +927,9 @@ (htcomponent-json-print-start-component htlink)) (when (page-can-print page) (unless (getf (htcomponent-attributes htlink) :type) - (append '(:type "text/css") (htcomponent-attributes htlink))) + (append '(:type "text/css") (htcomponent-attributes htlink))) (unless (getf (htcomponent-attributes htlink) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes htlink))) + (append '(:rel "styleshhet") (htcomponent-attributes htlink))) (tag-render-starttag htlink page) (tag-render-endtag htlink page)) (when (null previous-print-status) @@ -944,109 +939,105 @@ ;;;========= HTBODY =================================== (defmethod htcomponent-render ((htbody htbody) (page page)) (let ((body-list (htcomponent-body htbody)) - (previous-print-status (page-can-print page))) - (when (or (page-can-print page) previous-print-status) + (previous-print-status (page-can-print page))) + (when (or (page-can-print page) previous-print-status) (setf (page-can-print page) (htcomponent-can-print htbody)) (htcomponent-json-print-start-component htbody)) (when (page-can-print page) (tag-render-starttag htbody page)) (dolist (child-tag body-list) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (page-can-print page) (htcomponent-render (htbody-init-scripts-tag page) page) (tag-render-endtag htbody page)) (when (or (page-can-print page) previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htbody)))) - + (defmethod htbody-init-scripts-tag ((page page)) (let ((js (script> :type "text/javascript")) - (js-start-directive (if (msie-p) - "window.attachEvent\('onload', function\(e) {" - "document.addEventListener\('DOMContentLoaded', function\(e) {")) - (js-end-directive (if (msie-p) - "});" - "}, false);")) - (page-body-init-scripts (page-body-init-scripts page))) + (js-start-directive (if (msie-p) + "window.attachEvent\('onload', function\(e) {" + "document.addEventListener\('DOMContentLoaded', function\(e) {")) + (js-end-directive (if (msie-p) + "});" + "}, false);")) + (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts - (if (listp page-body-init-scripts) - (append (list js-start-directive) - page-body-init-scripts - (list js-end-directive)) - (list js-start-directive page-body-init-scripts js-end-directive)))) + (htcomponent-body js) (when page-body-init-scripts + (if (listp page-body-init-scripts) + (append (list js-start-directive) + page-body-init-scripts + (list js-end-directive)) + (list js-start-directive page-body-init-scripts js-end-directive)))) js)) ;;;========= WCOMPONENT =================================== (defclass wcomponent (htcomponent) ((reserved-parameters :initarg :reserved-parameters - :accessor wcomponent-reserved-parameters - :type cons - :documentation "Parameters that may not be used in the constructor function") - (informal-parameters :initarg :informal-parameters - :accessor wcomponent-informal-parameters - :type cons - :documentation "Informal parameters are parameters optional for the component") + :accessor wcomponent-reserved-parameters + :type cons + :documentation "Parameters that may not be used in the constructor function") + (informal-parameters :initform () + :accessor wcomponent-informal-parameters + :type cons + :documentation "Informal parameters are parameters optional for the component") (allow-informal-parameters :initarg :allow-informal-parameters - :reader wcomponent-allow-informal-parametersp - :allocation :class - :documentation "Determines if the component accepts informal parameters")) - (:default-initargs :informal-parameters nil - :reserved-parameters nil + :reader wcomponent-allow-informal-parametersp + :allocation :class + :documentation "Determines if the component accepts informal parameters")) + (:default-initargs :reserved-parameters nil :allow-informal-parameters t) (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) -(defmethod wcomponent-informal-parameters ((wcomponent wcomponent))) - (defun slot-initarg-p (initarg class-precedence-list) "Returns nil if a slot with that initarg isn't found into the list of classes passed" (loop for class in class-precedence-list - do (let* ((direct-slots (closer-mop:class-direct-slots class)) - (result (loop for slot in direct-slots - do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) - (return initarg))))) - (when result - (return result))))) + do (let* ((direct-slots (closer-mop:class-direct-slots class)) + (result (loop for slot in direct-slots + do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) + (return initarg))))) + (when result + (return result))))) (defmethod initialize-instance :after ((instance wcomponent) &rest rest) (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) - (informal-parameters (loop for (k v) on rest by #'cddr - for result = () - do (unless (slot-initarg-p k class-precedence-list) - (push v result) - (push k result)) - finally (return result)))) + (informal-parameters (loop for (k v) on rest by #'cddr + for result = () + do (unless (slot-initarg-p k class-precedence-list) + (push v result) + (push k result)) + finally (return result)))) (setf (slot-value instance 'informal-parameters) informal-parameters))) (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)) - (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) - do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) - (return (closer-mop:slot-definition-name slot-definition)))))) + (new-value (if (eq slot-initarg :id) (generate-id value) value)) + (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) + do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) + (return (closer-mop:slot-definition-name slot-definition)))))) (if (find initarg (wcomponent-reserved-parameters wcomponent)) - (error (format nil "Parameter ~a is reserved" initarg)) - (if slot-name - (setf (slot-value wcomponent slot-name) new-value) - (if (null (wcomponent-allow-informal-parametersp wcomponent)) - (error (format nil - "Component ~a doesn't accept informal parameters" - slot-initarg)) - (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) - - + (error (format nil "Parameter ~a is reserved" initarg)) + (if slot-name + (setf (slot-value wcomponent slot-name) new-value) + (if (null (wcomponent-allow-informal-parametersp wcomponent)) + (error (format nil + "Component ~a doesn't accept informal parameters" + slot-initarg)) + (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) + (defun make-component (name parameters content) "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." (let ((instance (make-instance name)) - (static-id (getf parameters :static-id))) + (static-id (getf parameters :static-id))) (when static-id - (remf parameters :id)) + (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) (setf (htcomponent-body instance) content) @@ -1063,9 +1054,9 @@ (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) - (htcomponent-rewind template page)) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) (wcomponent-after-rewind wcomponent page))) (defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) @@ -1074,23 +1065,23 @@ (defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) (wcomponent-before-prerender wcomponent page) (let ((previous-print-status (page-can-print page)) - (template (wcomponent-template wcomponent))) + (template (wcomponent-template wcomponent))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print wcomponent))) (when (page-can-print page) (dolist (script (htcomponent-script-files wcomponent)) - (pushnew script (page-script-files page) :test #'equal)) + (pushnew script (page-script-files page) :test #'equal)) (dolist (css (htcomponent-stylesheet-files wcomponent)) - (pushnew css (page-stylesheet-files page) :test #'equal)) + (pushnew css (page-stylesheet-files page) :test #'equal)) (dolist (js (htcomponent-class-initscripts wcomponent)) - (pushnew js (page-class-initscripts page) :test #'equal)) + (pushnew js (page-class-initscripts page) :test #'equal)) (when (htcomponent-instance-initscript wcomponent) - (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) + (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) (if (listp template) - (dolist (tag template) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (htcomponent-prerender template page)) + (dolist (tag template) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) (when (null previous-print-status) (setf (page-can-print page) nil))) (wcomponent-after-prerender wcomponent page)) @@ -1100,19 +1091,19 @@ (defmethod htcomponent-render ((wcomponent wcomponent) (page page)) (let ((template (wcomponent-template wcomponent)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print wcomponent)) (htcomponent-json-print-start-component wcomponent)) (wcomponent-before-render wcomponent page) (unless (listp template) (setf template (list template))) - (dolist (child-tag template) + (dolist (child-tag template) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (wcomponent-after-render wcomponent page) (when (null previous-print-status) (setf (page-can-print page) nil) @@ -1127,12 +1118,12 @@ (defmethod message-dispatch ((i18n-aware i18n-aware) key locale) (let ((dispatcher (message-dispatcher i18n-aware)) - (result)) + (result)) (when dispatcher (progn - (setf result (message-dispatch dispatcher key locale)) - (when (and (null result) (> (length locale) 2)) - (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) + (setf result (message-dispatch dispatcher key locale)) + (when (and (null result) (> (length locale) 2)) + (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) result)) (defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value)