- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2188 - in branches/trunk-reorg: datastore/src web/src xhtmlgen
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 12:25:24 -0400 (Thu, 04 Oct 2007) New Revision: 2188 Added: branches/trunk-reorg/web/src/packages.lisp branches/trunk-reorg/web/src/sysclasses/ branches/trunk-reorg/xhtmlgen/package.lisp Removed: branches/trunk-reorg/datastore/src/packages.lisp branches/trunk-reorg/datastore/src/sysclasses/ Log: checkpoint Deleted: branches/trunk-reorg/datastore/src/packages.lisp =================================================================== --- branches/trunk-reorg/datastore/src/packages.lisp 2007-10-04 16:20:09 UTC (rev 2187) +++ branches/trunk-reorg/datastore/src/packages.lisp 2007-10-04 16:25:24 UTC (rev 2188) @@ -1,464 +0,0 @@ -(in-package :cl-user) - -(defpackage :xhtml-generator - (:use :common-lisp) - (:export #:html - #:html-stream - #:*html-sink* - #:set-string-encoding)) - -(defpackage :bknr.sysparams - (:use :cl :cl-user :bknr.indices :bknr.datastore) - (:export #:sysparam - #:set-sysparam)) - -(defpackage :bknr.htmlize - (:use :cl :cl-user :bknr.utils) - (:export #:to-html - #:htmlize-file - #:htmlize-string - #:htmlize)) - -(defpackage :bknr.cron - (:use :cl :cl-user :bknr.utils :bknr.indices :bknr.datastore) - (:export #:make-cron-job - #:cron-job-with-name - #:start-cron)) - -(defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) - (:export #:xml-escape - #:*img-src-scanner* - #:*a-href-scanner* - #:*link-href-scanner* - #:replace-relative-links - #:make-absolute-url - - #:rss-to-xml - #:merge-feeds - - ;; channel - #:rss-channel - #:find-rss-channel - #:make-rss-channel - #:rss-channel-cleanup - #:rss-channel-about - #:rss-channel-title - #:rss-channel-link - #:rss-channel-desc - #:rss-channel-image - #:rss-channel-textinput - #:rss-channel-items - #:rss-channel-xml - - ;; image - #:rss-image - #:rss-image-about - #:rss-image-title - #:rss-image-url - #:rss-image-link - - ;; item - #:rss-item - #:rss-item-channel - #:rss-item-published - #:rss-item-pub-date - #:rss-item-title - #:rss-item-link - #:rss-item-description - #:rss-item-author - #:rss-item-category - #:rss-item-comments - #:rss-item-enclosure - #:rss-item-guid - #:rss-item-source - - ;; textinput - #:rss-textinput - #:rss-textinput-about - #:rss-textinput-title - #:rss-textinput-desc - #:rss-textinput-link - #:rss-textinput-name - - #:parse-rss091-feed - #:parse-rss10-feed - #:parse-rss20-feed - #:parse-atom-feed - - #:*base-url*)) - -(defpackage :bknr.events - (:use :cl - :xhtml-generator - :bknr.utils - :bknr.datastore - :cl-ppcre) - (:documentation "events framework, currently exports all defined symbols until refactoring") - (:export #:event - #:event-time - #:event-handler - #:event-argument - #:event-class-name - - #:make-event - #:find-events - #:all-events - - #:handle-event - #:generate-event-xml)) - -(defpackage :bknr.user - (:use :cl - :cl-user - :cl-interpol - :cl-ppcre - :md5 - :bknr.datastore - :bknr.indices - :bknr.utils - :bknr.events - :xhtml-generator) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:export #:user - - #:user-full-name - #:user-last-login - #:user-email - #:user-login - #:user-password - #:user-flags - #:user-preferences - #:user-subscriptions - #:user-editable-p - - ;; Export slot names so that derived classes can overload - ;; slots (e.g. to add XML impex attributes) - #:login - #:flags - #:email - #:full-name - #:last-login - #:password - #:preferences - #:subscriptions - #:mail-error - - #:find-user - #:user-with-email - #:admin-p - #:anonymous-p - - #:user-has-flag - #:user-add-flags - #:user-remove-flags - #:all-user-flags - #:define-user-flag - - #:user-reachable-by-mail-p - #:user-mail-error-p - #:verify-password - #:user-disabled - #:user-preferences - #:user-preference - #:set-user-preference - #:all-users - #:get-flag-users - #:make-user - #:delete-user - #:set-user-password - - #:set-user-last-login - - #:owned-object - #:owned-object-owners - #:store-objects-owned-by - - #:message-event)) - -(defpackage :bknr.web - (:use :cl - :cl-user - :cl-gd - :cl-interpol - :cl-ppcre - :net.aserve - :cxml-xmls - :xhtml-generator - :puri - :md5 - :js - :bknr.datastore - :bknr.indices - :bknr.impex - :bknr.utils - :bknr.xml - :bknr.events - :bknr.user) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) - (:export #:*req* - #:*ent* - #:*user* - #:session-variable - #:request-variable - #:with-query-params - #:define-bknr-tag - #:with-bknr-page - #:cmslink - - #:web-server-log-event-referer - #:web-server-log-event-url - #:web-server-log-event-user-agent - - #:web-visitor-event-host - #:web-visitor-event-session-id - #:web-visitor-event-user - - #:web-server-error-event - #:web-server-error-event-error - #:all-web-server-error-events - - #:;; web-utils - #:*upload-file-size-limit* - #:all-request-params - #:request-uploaded-files - #:request-uploaded-file - #:query-param - #:query-param-list - #:cookie-value - #:http-error - #:keywords-from-query-param-list - #:html-quote - #:parse-url - #:parse-uri - #:text-to-html - #:make-wiki-hrefs - #:html-link - #:html-edit-link - #:object-url - #:edit-object-url - #:xmls-emit - #:emit-html - #:make-self-reference-url - #:html-warn - #:redirect - #:redirect-uri - #:emit-html - #:error-404 - #:encode-urlencoded - #:submit-button - #:text-field - #:textarea-field - #:checkbox-field - #:select-box - #:date-field - #:parse-date-field - #:keyword-choose-dialog - #:navi-button - #:with-bknr-http-response - - #:upload - #:upload-name - #:upload-pathname - #:upload-size - #:upload-content-type - - #:bknr-url-path - - ;; templates - #:expand-template - #:get-template-var - #:with-template-vars - #:emit-template-node - #:user-error - #:find-template-pathname - #:initial-template-environment - #:with-tag-expanders - - #:*html-variables* - #:*template-dtd-catalog* - - ;; handlers - #:parse-handler-url - #:*website* - #:website - #:website-name - #:website-hosts - #:website-authorizer - #:website-show-page - #:website-show-error-page - #:website-handler-definitions - #:website-admin-navigation - #:website-navigation - #:website-menu - #:website-url - #:website-session-info - #:website-base-href - #:website-make-path - #:website-rss-feed-url - #:host - #:publish-site - #:publish-handler - - #:handle-object - #:handle-object-form - #:handle-form - #:object-handler-object-class - #:object-handler-get-object - - #:bknr-authorizer - #:find-user-from-request-parameters - #: - #:handle - #:object-handler - #:edit-object-handler - #:template-handler - #:page-handler - #:page-handler-prefix - #:page-handler-site - #:page-handler-url - #:authorized-p - #:admin-only-handler - #:prefix-handler - #:form-handler - #:login-handler - #:logout-handler - #:redirect-handler - #:directory-handler - #:file-handler - - #:keyword-handler - #:keywords-handler - - #:rss-handler - - #:define-bknr-webserver-module - - #:ensure-form-field - #:form-field-missing-condition - #:form-field-missing-condition-field - - #:handler-path - #:decoded-handler-path - - ;; misc tags xxx should be revised xxx - #:next-days-list - #:previous-days-list - #:reset-results - - ;; choice (html menus) - #:make-choice - #:choice-link - #:choice-title - #:choice-submenu - - ;; object-list-handler - #:object-list-handler - #:object-list-handler-get-objects - #:object-list-handler-title - #:object-list-handler-rss-link - #:object-list-handler-show-object-xml - #:object-date-list-handler - #:object-date-list-handler-grouped-objects - #:object-date-list-handler-date - - ;; xml-object-handler - #:xml-object-handler - #:xml-object-handler-show-object - #:xml-object-list-handler - #:xml-image-browser-handler - - ;; blob-handler - #:blob-handler - - ;; sessions - #:bknr-session - #:bknr-session-user - #:bknr-session-start-time - #:bknr-session-last-used - #:bknr-session-variables - - #:http-session - #:http-session-host - #:host-name - #:bknr-request-user - #:bknr-request - #:bknr-request-session - #:*session* - #:anonymous-session - - ;; site - #:*default-billboard* - #:*thumbnail-max-height* - #:*thumbnail-max-width* - #:*user-spool-directory-root* - - ;; import-handler - #:import-handler - #:import-handler-spool-dir - #:import-handler-spool-files - #:import-handler-import-files - #:import-handler-import-pathname)) - -(defpackage :bknr.images - (:use :cl - :cl-user - :cl-gd - :cl-interpol - :cl-ppcre - :net.aserve - :puri - :xhtml-generator - :bknr.rss - :bknr.web - :bknr.datastore - :bknr.indices - :bknr.utils - :bknr.user) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) - (:export #:imageproc - #:define-imageproc-handler - #:image-handler ; plain images only - #:imageproc-handler ; image with processing - - #:banner ; tag to display the site's banner image - #:user-image - #:user-images - - #:parse-color - #:get-keyword-store-images - #:get-keywords-intersection-store-images - - #:emit-image-to-browser - #:image-collection - #:image-keyword-choose-dialog - #:image-thumbnail-page - - #:store-image-with-name - - #:store-image - #:make-store-image - #:with-store-image - #:with-store-image* - #:with-store-image-from-id - #:image-type-keyword - - #:store-image-name - #:store-image-height - #:store-image-width - #:store-image-aspect-ratio - #:store-image-keywords - - #:emit-image-to-browser - - #:import-image)) - -(defpackage :bknr.site-menu - (:use :cl - :cl-user - :cxml - :bknr.web - :bknr.impex - :xhtml-generator)) Copied: branches/trunk-reorg/web/src/packages.lisp (from rev 2185, branches/trunk-reorg/datastore/src/packages.lisp) =================================================================== --- branches/trunk-reorg/datastore/src/packages.lisp 2007-10-04 16:18:54 UTC (rev 2185) +++ branches/trunk-reorg/web/src/packages.lisp 2007-10-04 16:25:24 UTC (rev 2188) @@ -0,0 +1,457 @@ +(in-package :cl-user) + +(defpackage :bknr.sysparams + (:use :cl :cl-user :bknr.indices :bknr.datastore) + (:export #:sysparam + #:set-sysparam)) + +(defpackage :bknr.htmlize + (:use :cl :cl-user :bknr.utils) + (:export #:to-html + #:htmlize-file + #:htmlize-string + #:htmlize)) + +(defpackage :bknr.cron + (:use :cl :cl-user :bknr.utils :bknr.indices :bknr.datastore) + (:export #:make-cron-job + #:cron-job-with-name + #:start-cron)) + +(defpackage :bknr.rss + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:export #:xml-escape + #:*img-src-scanner* + #:*a-href-scanner* + #:*link-href-scanner* + #:replace-relative-links + #:make-absolute-url + + #:rss-to-xml + #:merge-feeds + + ;; channel + #:rss-channel + #:find-rss-channel + #:make-rss-channel + #:rss-channel-cleanup + #:rss-channel-about + #:rss-channel-title + #:rss-channel-link + #:rss-channel-desc + #:rss-channel-image + #:rss-channel-textinput + #:rss-channel-items + #:rss-channel-xml + + ;; image + #:rss-image + #:rss-image-about + #:rss-image-title + #:rss-image-url + #:rss-image-link + + ;; item + #:rss-item + #:rss-item-channel + #:rss-item-published + #:rss-item-pub-date + #:rss-item-title + #:rss-item-link + #:rss-item-description + #:rss-item-author + #:rss-item-category + #:rss-item-comments + #:rss-item-enclosure + #:rss-item-guid + #:rss-item-source + + ;; textinput + #:rss-textinput + #:rss-textinput-about + #:rss-textinput-title + #:rss-textinput-desc + #:rss-textinput-link + #:rss-textinput-name + + #:parse-rss091-feed + #:parse-rss10-feed + #:parse-rss20-feed + #:parse-atom-feed + + #:*base-url*)) + +(defpackage :bknr.events + (:use :cl + :xhtml-generator + :bknr.utils + :bknr.datastore + :cl-ppcre) + (:documentation "events framework, currently exports all defined symbols until refactoring") + (:export #:event + #:event-time + #:event-handler + #:event-argument + #:event-class-name + + #:make-event + #:find-events + #:all-events + + #:handle-event + #:generate-event-xml)) + +(defpackage :bknr.user + (:use :cl + :cl-user + :cl-interpol + :cl-ppcre + :md5 + :bknr.datastore + :bknr.indices + :bknr.utils + :bknr.events + :xhtml-generator) + (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:export #:user + + #:user-full-name + #:user-last-login + #:user-email + #:user-login + #:user-password + #:user-flags + #:user-preferences + #:user-subscriptions + #:user-editable-p + + ;; Export slot names so that derived classes can overload + ;; slots (e.g. to add XML impex attributes) + #:login + #:flags + #:email + #:full-name + #:last-login + #:password + #:preferences + #:subscriptions + #:mail-error + + #:find-user + #:user-with-email + #:admin-p + #:anonymous-p + + #:user-has-flag + #:user-add-flags + #:user-remove-flags + #:all-user-flags + #:define-user-flag + + #:user-reachable-by-mail-p + #:user-mail-error-p + #:verify-password + #:user-disabled + #:user-preferences + #:user-preference + #:set-user-preference + #:all-users + #:get-flag-users + #:make-user + #:delete-user + #:set-user-password + + #:set-user-last-login + + #:owned-object + #:owned-object-owners + #:store-objects-owned-by + + #:message-event)) + +(defpackage :bknr.web + (:use :cl + :cl-user + :cl-gd + :cl-interpol + :cl-ppcre + :net.aserve + :cxml-xmls + :xhtml-generator + :puri + :md5 + :js + :bknr.datastore + :bknr.indices + :bknr.impex + :bknr.utils + :bknr.xml + :bknr.events + :bknr.user) + (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:import-from :net.html.generator #:*html-stream*) + (:export #:*req* + #:*ent* + #:*user* + #:session-variable + #:request-variable + #:with-query-params + #:define-bknr-tag + #:with-bknr-page + #:cmslink + + #:web-server-log-event-referer + #:web-server-log-event-url + #:web-server-log-event-user-agent + + #:web-visitor-event-host + #:web-visitor-event-session-id + #:web-visitor-event-user + + #:web-server-error-event + #:web-server-error-event-error + #:all-web-server-error-events + + #:;; web-utils + #:*upload-file-size-limit* + #:all-request-params + #:request-uploaded-files + #:request-uploaded-file + #:query-param + #:query-param-list + #:cookie-value + #:http-error + #:keywords-from-query-param-list + #:html-quote + #:parse-url + #:parse-uri + #:text-to-html + #:make-wiki-hrefs + #:html-link + #:html-edit-link + #:object-url + #:edit-object-url + #:xmls-emit + #:emit-html + #:make-self-reference-url + #:html-warn + #:redirect + #:redirect-uri + #:emit-html + #:error-404 + #:encode-urlencoded + #:submit-button + #:text-field + #:textarea-field + #:checkbox-field + #:select-box + #:date-field + #:parse-date-field + #:keyword-choose-dialog + #:navi-button + #:with-bknr-http-response + + #:upload + #:upload-name + #:upload-pathname + #:upload-size + #:upload-content-type + + #:bknr-url-path + + ;; templates + #:expand-template + #:get-template-var + #:with-template-vars + #:emit-template-node + #:user-error + #:find-template-pathname + #:initial-template-environment + #:with-tag-expanders + + #:*html-variables* + #:*template-dtd-catalog* + + ;; handlers + #:parse-handler-url + #:*website* + #:website + #:website-name + #:website-hosts + #:website-authorizer + #:website-show-page + #:website-show-error-page + #:website-handler-definitions + #:website-admin-navigation + #:website-navigation + #:website-menu + #:website-url + #:website-session-info + #:website-base-href + #:website-make-path + #:website-rss-feed-url + #:host + #:publish-site + #:publish-handler + + #:handle-object + #:handle-object-form + #:handle-form + #:object-handler-object-class + #:object-handler-get-object + + #:bknr-authorizer + #:find-user-from-request-parameters + #: + #:handle + #:object-handler + #:edit-object-handler + #:template-handler + #:page-handler + #:page-handler-prefix + #:page-handler-site + #:page-handler-url + #:authorized-p + #:admin-only-handler + #:prefix-handler + #:form-handler + #:login-handler + #:logout-handler + #:redirect-handler + #:directory-handler + #:file-handler + + #:keyword-handler + #:keywords-handler + + #:rss-handler + + #:define-bknr-webserver-module + + #:ensure-form-field + #:form-field-missing-condition + #:form-field-missing-condition-field + + #:handler-path + #:decoded-handler-path + + ;; misc tags xxx should be revised xxx + #:next-days-list + #:previous-days-list + #:reset-results + + ;; choice (html menus) + #:make-choice + #:choice-link + #:choice-title + #:choice-submenu + + ;; object-list-handler + #:object-list-handler + #:object-list-handler-get-objects + #:object-list-handler-title + #:object-list-handler-rss-link + #:object-list-handler-show-object-xml + #:object-date-list-handler + #:object-date-list-handler-grouped-objects + #:object-date-list-handler-date + + ;; xml-object-handler + #:xml-object-handler + #:xml-object-handler-show-object + #:xml-object-list-handler + #:xml-image-browser-handler + + ;; blob-handler + #:blob-handler + + ;; sessions + #:bknr-session + #:bknr-session-user + #:bknr-session-start-time + #:bknr-session-last-used + #:bknr-session-variables + + #:http-session + #:http-session-host + #:host-name + #:bknr-request-user + #:bknr-request + #:bknr-request-session + #:*session* + #:anonymous-session + + ;; site + #:*default-billboard* + #:*thumbnail-max-height* + #:*thumbnail-max-width* + #:*user-spool-directory-root* + + ;; import-handler + #:import-handler + #:import-handler-spool-dir + #:import-handler-spool-files + #:import-handler-import-files + #:import-handler-import-pathname)) + +(defpackage :bknr.images + (:use :cl + :cl-user + :cl-gd + :cl-interpol + :cl-ppcre + :net.aserve + :puri + :xhtml-generator + :bknr.rss + :bknr.web + :bknr.datastore + :bknr.indices + :bknr.utils + :bknr.user) + (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:import-from :net.html.generator #:*html-stream*) + (:export #:imageproc + #:define-imageproc-handler + #:image-handler ; plain images only + #:imageproc-handler ; image with processing + + #:banner ; tag to display the site's banner image + #:user-image + #:user-images + + #:parse-color + #:get-keyword-store-images + #:get-keywords-intersection-store-images + + #:emit-image-to-browser + #:image-collection + #:image-keyword-choose-dialog + #:image-thumbnail-page + + #:store-image-with-name + + #:store-image + #:make-store-image + #:with-store-image + #:with-store-image* + #:with-store-image-from-id + #:image-type-keyword + + #:store-image-name + #:store-image-height + #:store-image-width + #:store-image-aspect-ratio + #:store-image-keywords + + #:emit-image-to-browser + + #:import-image)) + +(defpackage :bknr.site-menu + (:use :cl + :cl-user + :cxml + :bknr.web + :bknr.impex + :xhtml-generator)) Copied: branches/trunk-reorg/web/src/sysclasses (from rev 2185, branches/trunk-reorg/datastore/src/sysclasses) Added: branches/trunk-reorg/xhtmlgen/package.lisp =================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp 2007-10-04 16:20:09 UTC (rev 2187) +++ branches/trunk-reorg/xhtmlgen/package.lisp 2007-10-04 16:25:24 UTC (rev 2188) @@ -0,0 +1,9 @@ +(in-package :cl-user) + +(defpackage :xhtml-generator + (:use :common-lisp) + (:export #:html + #:html-stream + #:*html-sink* + #:set-string-encoding)) +

1 0

[bknr-cvs] r2187 - in branches/trunk-reorg: datastore/src web/src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 12:20:09 -0400 (Thu, 04 Oct 2007) New Revision: 2187 Added: branches/trunk-reorg/web/src/bknr-web.asd Removed: branches/trunk-reorg/datastore/src/bknr-web.asd Log: checkpoint Deleted: branches/trunk-reorg/datastore/src/bknr-web.asd =================================================================== --- branches/trunk-reorg/datastore/src/bknr-web.asd 2007-10-04 16:19:28 UTC (rev 2186) +++ branches/trunk-reorg/datastore/src/bknr-web.asd 2007-10-04 16:20:09 UTC (rev 2187) @@ -1,133 +0,0 @@ -(in-package :cl-user) - -(defpackage :bknr.system - (:use :cl :asdf) - (:export :*bknr-directory*)) - -(in-package :bknr.system) - -(defparameter *bknr-directory* - (make-pathname :name nil :type nil :version nil - :defaults (parse-namestring *load-truename*))) - -(defsystem :bknr - :name "Baikonour - Base modules" - :author "Hans Huebner <hans(a)huebner.org>" - :author "Manuel Odendahl <manuel(a)bl0rg.net>" - :version "0" - :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" - :licence "BSD" - :description "Baikonour - Launchpad for LISP satellites - Base system" - - :depends-on (:cl-interpol - :cl-ppcre - :cl-gd - :aserve - ;:net.post-office - :md5 - :cxml - :unit-test - :bknr-utils - :bknr-xml - :puri - ;:stem - ;:mime - :klammerscript - :bknr-datastore - :bknr-data-impex - :kmrcl - :iconv - #+(not allegro) - :acl-compat) - - :components ((:file "packages") - - (:module "xhtmlgen" :components ((:file "xhtmlgen")) - :depends-on ("packages")) - - (:module "sysclasses" :components ((:file "event") - (:file "user" :depends-on ("event")) - (:file "cron") - (:file "sysparam")) - :depends-on ("xhtmlgen")) - - (:module "htmlize" :components ((:file "hyperspec") - (:file "htmlize" - :depends-on ("hyperspec"))) - :depends-on ("packages")) - - (:module "rss" :components ((:file "rss") - (:file "parse-xml") - (:file "parse-rss10" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss091" - :depends-on ("parse-xml" "rss")) - (:file "parse-atom" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss20" - :depends-on ("parse-xml" "rss"))) - :depends-on ("packages")) - - (:module "web" :components ((:file "site") - ;; data - (:file "host") - (:file "web-server-event" - :depends-on ("host")) - (:file "web-visitor" - :depends-on ("host")) - - ;; web stuff - (:file "tag-functions") - (:file "web-macros" - :depends-on ("site" - "tag-functions")) - (:file "sessions" - :depends-on ("web-macros" - "site")) - (:file "authorizer" - :depends-on ("sessions" - "host")) - (:file "web-utils" - :depends-on ("web-macros" - "sessions" - "site" - "handlers")) - (:file "menu" :depends-on ("web-macros")) - - ;; handlers - (:file "handlers" - :depends-on ("authorizer" - "web-macros" - "sessions" - "site")) - - (:file "templates" - :depends-on ("handlers")) - (:file "rss-handlers" - :depends-on ("handlers")) - - (:file "user-handlers" - :depends-on ("handlers")) - (:file "user-tags" - :depends-on ("handlers")) - - (:file "tags" - :depends-on ("handlers" - "templates" - "site" - "web-utils"))) - :depends-on ("sysclasses" "packages" "xhtmlgen" "rss")) - - (:module "images" :components ((:file "image") - - (:file "image-tags" :depends-on ("image")) - (:file "image-handlers" - :depends-on ("image-tags" "image")) - (:file "imageproc-handler" - :depends-on ("image-handlers")) - (:file "edit-image-handler" - :depends-on ("image-handlers")) - (:file "import-images-handler" - :depends-on ("image-tags" "image")) - (:file "session-image")) - :depends-on ("web")))) Copied: branches/trunk-reorg/web/src/bknr-web.asd (from rev 2185, branches/trunk-reorg/datastore/src/bknr-web.asd)

1 0

[bknr-cvs] r2186 - in branches/trunk-reorg: datastore web
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 12:19:28 -0400 (Thu, 04 Oct 2007) New Revision: 2186 Added: branches/trunk-reorg/web/etc/ Removed: branches/trunk-reorg/datastore/etc/ Log: checkpoint Copied: branches/trunk-reorg/web/etc (from rev 2185, branches/trunk-reorg/datastore/etc)

1 0

[bknr-cvs] r2185 - in branches/trunk-reorg: . datastore/experimental/xml-schema datastore/experimental/xml-schema/examples
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 12:18:54 -0400 (Thu, 04 Oct 2007) New Revision: 2185 Added: branches/trunk-reorg/datastore/ branches/trunk-reorg/web/ Removed: branches/trunk-reorg/bknr-web/ branches/trunk-reorg/bknr/ Modified: branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp Log: checkpoint Copied: branches/trunk-reorg/datastore (from rev 2184, branches/trunk-reorg/bknr) Modified: branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml =================================================================== --- branches/trunk-reorg/bknr/experimental/xml-schema/examples/test-schema.xml 2007-10-04 15:50:09 UTC (rev 2184) +++ branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml 2007-10-04 16:18:54 UTC (rev 2185) @@ -1,65 +1,65 @@ -<?xml version="1.0"?> -<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema"> - <xs:element name="name" type="xs:string"/> - <xs:element name="qualification" type="xs:string"/> - <xs:element name="born" type="xs:date"/> - <xs:element name="dead" type="xs:date"/> - <xs:element name="isbn" type="xs:string"/> - <xs:attribute name="id" type="xs:ID"/> - <xs:attribute name="available" type="xs:boolean"/> - <xs:attribute name="lang" type="xs:language"/> - - <xs:element name="title"> - <xs:complexType> - <xs:simpleContent> - <xs:extension base="xs:string"> - <xs:attribute ref="lang"/> - </xs:extension> - </xs:simpleContent> - </xs:complexType> - </xs:element> - - <xs:element name="library"> - <xs:complexType> - <xs:sequence> - <xs:element ref="book" maxOccurs="unbounded"/> - </xs:sequence> - </xs:complexType> - </xs:element> - - <xs:element name="author"> - <xs:complexType> - <xs:sequence> - <xs:element ref="name"/> - <xs:element ref="born"/> - <xs:element ref="dead" minOccurs="0"/> - </xs:sequence> - <xs:attribute ref="id"/> - </xs:complexType> - </xs:element> - - <xs:element name="book"> - <xs:complexType> - <xs:sequence> - <xs:element ref="isbn"/> - <xs:element ref="title"/> - <xs:element ref="author" minOccurs="0" maxOccurs="unbounded"/> - <xs:element ref="character" minOccurs="0" maxOccurs="unbounded"/> - </xs:sequence> - <xs:attribute ref="id"/> - <xs:attribute ref="available"/> - </xs:complexType> - </xs:element> - - <xs:element name="character"> - <xs:complexType> - <xs:sequence> - <xs:element ref="name"/> - <xs:element ref="born"/> - <xs:element ref="qualification"/> - </xs:sequence> - <xs:attribute ref="id"/> - </xs:complexType> - </xs:element> - +<?xml version="1.0"?> +<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema"> + <xs:element name="name" type="xs:string"/> + <xs:element name="qualification" type="xs:string"/> + <xs:element name="born" type="xs:date"/> + <xs:element name="dead" type="xs:date"/> + <xs:element name="isbn" type="xs:string"/> + <xs:attribute name="id" type="xs:ID"/> + <xs:attribute name="available" type="xs:boolean"/> + <xs:attribute name="lang" type="xs:language"/> + + <xs:element name="title"> + <xs:complexType> + <xs:simpleContent> + <xs:extension base="xs:string"> + <xs:attribute ref="lang"/> + </xs:extension> + </xs:simpleContent> + </xs:complexType> + </xs:element> + + <xs:element name="library"> + <xs:complexType> + <xs:sequence> + <xs:element ref="book" maxOccurs="unbounded"/> + </xs:sequence> + </xs:complexType> + </xs:element> + + <xs:element name="author"> + <xs:complexType> + <xs:sequence> + <xs:element ref="name"/> + <xs:element ref="born"/> + <xs:element ref="dead" minOccurs="0"/> + </xs:sequence> + <xs:attribute ref="id"/> + </xs:complexType> + </xs:element> + + <xs:element name="book"> + <xs:complexType> + <xs:sequence> + <xs:element ref="isbn"/> + <xs:element ref="title"/> + <xs:element ref="author" minOccurs="0" maxOccurs="unbounded"/> + <xs:element ref="character" minOccurs="0" maxOccurs="unbounded"/> + </xs:sequence> + <xs:attribute ref="id"/> + <xs:attribute ref="available"/> + </xs:complexType> + </xs:element> + + <xs:element name="character"> + <xs:complexType> + <xs:sequence> + <xs:element ref="name"/> + <xs:element ref="born"/> + <xs:element ref="qualification"/> + </xs:sequence> + <xs:attribute ref="id"/> + </xs:complexType> + </xs:element> + </xs:schema> \ No newline at end of file Modified: branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml =================================================================== --- branches/trunk-reorg/bknr/experimental/xml-schema/examples/test-schema2.xml 2007-10-04 15:50:09 UTC (rev 2184) +++ branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml 2007-10-04 16:18:54 UTC (rev 2185) @@ -1,47 +1,47 @@ -<?xml version="1.0"?> -<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema"> - <xs:element name="library"> - <xs:complexType> - <xs:sequence> - <xs:element name="book" maxOccurs="unbounded"> - <xs:complexType> - <xs:sequence> - <xs:element name="isbn" type="xs:integer"/> - <xs:element name="title"> - <xs:complexType> - <xs:simpleContent> - <xs:extension base="xs:string"> - <xs:attribute name="lang" type="xs:language"/> - </xs:extension> - </xs:simpleContent> - </xs:complexType> - </xs:element> - <xs:element name="author" minOccurs="0" maxOccurs="unbounded"> - <xs:complexType> - <xs:sequence> - <xs:element name="name" type="xs:string"/> - <xs:element name="born" type="xs:date"/> - <xs:element name="dead" type="xs:date"/> - </xs:sequence> - <xs:attribute name="id" type="xs:ID"/> - </xs:complexType> - </xs:element> - <xs:element name="character" minOccurs="0" maxOccurs="unbounded"> - <xs:complexType> - <xs:sequence> - <xs:element name="name" type="xs:string"/> - <xs:element name="born" type="xs:date"/> - <xs:element name="qualification" type="xs:string"/> - </xs:sequence> - <xs:attribute name="id" type="xs:ID"/> - </xs:complexType> - </xs:element> - </xs:sequence> - <xs:attribute name="id" type="xs:ID"/> - <xs:attribute name="available" type="xs:boolean"/> - </xs:complexType> - </xs:element> - </xs:sequence> - </xs:complexType> - </xs:element> -</xs:schema> +<?xml version="1.0"?> +<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema"> + <xs:element name="library"> + <xs:complexType> + <xs:sequence> + <xs:element name="book" maxOccurs="unbounded"> + <xs:complexType> + <xs:sequence> + <xs:element name="isbn" type="xs:integer"/> + <xs:element name="title"> + <xs:complexType> + <xs:simpleContent> + <xs:extension base="xs:string"> + <xs:attribute name="lang" type="xs:language"/> + </xs:extension> + </xs:simpleContent> + </xs:complexType> + </xs:element> + <xs:element name="author" minOccurs="0" maxOccurs="unbounded"> + <xs:complexType> + <xs:sequence> + <xs:element name="name" type="xs:string"/> + <xs:element name="born" type="xs:date"/> + <xs:element name="dead" type="xs:date"/> + </xs:sequence> + <xs:attribute name="id" type="xs:ID"/> + </xs:complexType> + </xs:element> + <xs:element name="character" minOccurs="0" maxOccurs="unbounded"> + <xs:complexType> + <xs:sequence> + <xs:element name="name" type="xs:string"/> + <xs:element name="born" type="xs:date"/> + <xs:element name="qualification" type="xs:string"/> + </xs:sequence> + <xs:attribute name="id" type="xs:ID"/> + </xs:complexType> + </xs:element> + </xs:sequence> + <xs:attribute name="id" type="xs:ID"/> + <xs:attribute name="available" type="xs:boolean"/> + </xs:complexType> + </xs:element> + </xs:sequence> + </xs:complexType> + </xs:element> +</xs:schema> Modified: branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp =================================================================== --- branches/trunk-reorg/bknr/experimental/xml-schema/xml-schema.lisp 2007-10-04 15:50:09 UTC (rev 2184) +++ branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp 2007-10-04 16:18:54 UTC (rev 2185) @@ -1,197 +1,197 @@ -(in-package :cl-user) - -;;; general helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro awhen (test-form &rest then-forms) - `(let ((it ,test-form)) - (when it ,@then-forms))) - -(defmacro aif (pred then-form &optional else-form) - `(let ((it ,pred)) (if it ,then-form ,else-form))) - -(defun string-null (string) - (string-equal string "")) - -(defconstant +whitespace-chars+ - '(#\Space #\Newline #\Tab #\Linefeed)) - -(defun whitespace-char-p (c) - (member c +whitespace-chars+)) - -(defun whitespace-p (c-or-s) - (cond ((stringp c-or-s) - (every #'whitespace-char-p c-or-s)) - ((characterp c-or-s) - (whitespace-char-p c-or-s)) - (t nil))) - -(defun make-keyword-from-string (string) - (if (keywordp string) - string - (nth-value 0 (intern (string-upcase - (substitute-if #\- #'(lambda (char) - (or (whitespace-char-p char) - (eql #\: char))) - string)) 'keyword)))) - - -;;; cxml helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun child-elements (node) - (coerce (remove-if-not #'dom:element-p (dom:child-nodes node)) 'list)) - -(defmacro with-attributes (attributes node &rest body) - `(let ,(loop for attr in attributes - when (symbolp attr) - collect `(,attr (dom:get-attribute ,node ,(string-downcase (symbol-name attr)))) - when (listp attr) - collect `(,(car attr) (dom:get-attribute ,node ,(cadr attr)))) - ,@(loop for attr in attributes - when (symbolp attr) - collect `(when (string-null ,attr) - (error ,(format nil "Attribute ~S is empty." - (string-downcase (symbol-name attr))))) - when (listp attr) - collect `(when (string-null ,(car attr)) - (error ,(format nil "Attribute ~S is empty." (cadr attr))))) - ,@body)) - - -;;; xml schema parser ;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; element and attribute environment - -(defvar *xml-schema-envs* nil - "This special variables holds the list of the current xml schema -element definition environments. Environments can be nested, the list -holds them in top to bottom order (the toplevel environment is first.") - -(defun get-xml-schema-ref (ref) - "Get the definition of REF from the current environment stack." - (dolist (env *xml-schema-envs*) - (awhen (gethash ref env) - (return it)))) - -(defun (setf get-xml-schema-ref) (newvalue ref) - "Set the definition of REF in the current environment." - (let ((env (first *xml-schema-envs*))) - (awhen (gethash ref env) - (error "There already is an XML Schema element named ~A: ~A." ref it)) - (setf (gethash ref env) newvalue))) - -;;; xml schema types - -(defgeneric parse-xs-type (type elt) - (:documentation "Parse ELT according to TYPE. TYPE can be a keyword -to identify base datatypes, or a class derived from XS-TYPE.")) - -(defmacro define-xs-type (name (elt) &rest body) - "Define a base XML Schema type, named by a keyword. For example, -\"xs:string\" is identified by :XS-STRING." - (let ((n (gensym))) - `(defmethod parse-xs-type (,(if (keywordp name) - `(,n (eql ,name)) - name) - ,elt) - ,@body))) - -(defmacro define-xs-type-error (name (elt) &rest body) - "Define the default error function called when ELT could not be -parsed as a value of type NAME." - `(define-xs-type ,name ((,elt t)) - ,@body)) - -;;; Einfach XML Schema typen, wie primitive Types, einfach Elements -;;; und Attributes werden direkt zu Lisp primitive geparst. - -(define-xs-type :xs-string ((elt dom-impl::text)) - (dom:node-value elt)) - -(define-xs-type :xs-string ((elt dom-impl::node)) - (let ((children (dom:child-nodes elt))) - (if (and (= (length children) 1) - (dom:text-node-p (aref children 0))) - (dom:node-value (aref children 0)) - ""))) - -(define-xs-type-error :xs-string (elt) - (error "~s could not be parsed as xs:string." elt)) - -(defclass xs-elt () - ((name :initarg :name :initform nil :reader xs-elt-name) - (type :initarg :type :initform nil :reader xs-elt-type))) - -(defun create-xs-elt (node) - (unless (= (length (dom:child-nodes node)) 0) - (error "~a is not a simple XML Scheme element node." node)) - (with-attributes (name type) node - (setf (get-xml-schema-ref name) - (make-instance 'xs-elt - :name name - :type (make-keyword-from-string type))))) - -(defclass xs-attribute (xs-elt) - ()) - -(defun create-xs-attribute (node) - (unless (= (length (dom:child-nodes node)) 0) - (error "~a is not an XML Scheme attribute node." node)) - (with-attributes (name type) node - (setf (get-xml-schema-ref name) - (make-instance 'xs-attribute - :name name - :type (make-keyword-from-string type))))) - -(define-xs-type (type xs-elt) (elt) - (parse-xs-type (xs-elt-type type) elt)) - - -(defclass xs-complex-type (xs-type) - ((attrs :initarg :attrs :reader xs-ctype-attrs) - (children :initarg :children :reader xs-ctype-children) - (content :initarg :content :reader xs-ctype-content))) - - -(defclass xs-element () - ((name :initarg :name :reader xs-type-name) - (type :initarg :type :reader xs-type-type))) - -(defun xs-attribute-p (node) - (string-equal (dom:node-name node) "xs:attribute")) - -(defun xs-element-p (node) - (string-equal (dom:node-name node) "xs:element")) - -(defun xs-simple-type-p (node) - (or (xs-attribute-p node) - (and (xs-element-p node) - (null (child-elements node))))) - -(defun xs-complex-type-p (node) - (let ((children (child-elements node))) - (and (xs-element-p node) - (not (null children)) - (let ((child (first children))) - (string-equal (dom:node-name node) - "xs:complexType"))))) - -(defun parse-schema-node (elt) - (cond ((xs-attribute-p elt) - (create-xs-attribute elt)) - ((xs-simple-type-p elt) - (create-xs-simple-type elt)) - #+nil - ((xs-complex-type-p elt) - (create-xs-complex-type elt)) - (t (error "Unknown top-level XML Schema node: ~A." (dom:node-name elt))))) - -(defun parse-schema-file (filename) - "Returns the toplevel XML schema environment." - (let* ((dom (cxml:parse-file filename (dom:make-dom-builder))) - (root (dom:document-element dom)) - (*xml-schema-envs* (list (make-hash-table)))) - (unless (string-equal (dom:node-name root) "xs:schema") - (error "Document is not an XML Schema document.")) - (dolist (elt (child-elements root)) - (parse-schema-node elt)) +(in-package :cl-user) + +;;; general helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro awhen (test-form &rest then-forms) + `(let ((it ,test-form)) + (when it ,@then-forms))) + +(defmacro aif (pred then-form &optional else-form) + `(let ((it ,pred)) (if it ,then-form ,else-form))) + +(defun string-null (string) + (string-equal string "")) + +(defconstant +whitespace-chars+ + '(#\Space #\Newline #\Tab #\Linefeed)) + +(defun whitespace-char-p (c) + (member c +whitespace-chars+)) + +(defun whitespace-p (c-or-s) + (cond ((stringp c-or-s) + (every #'whitespace-char-p c-or-s)) + ((characterp c-or-s) + (whitespace-char-p c-or-s)) + (t nil))) + +(defun make-keyword-from-string (string) + (if (keywordp string) + string + (nth-value 0 (intern (string-upcase + (substitute-if #\- #'(lambda (char) + (or (whitespace-char-p char) + (eql #\: char))) + string)) 'keyword)))) + + +;;; cxml helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun child-elements (node) + (coerce (remove-if-not #'dom:element-p (dom:child-nodes node)) 'list)) + +(defmacro with-attributes (attributes node &rest body) + `(let ,(loop for attr in attributes + when (symbolp attr) + collect `(,attr (dom:get-attribute ,node ,(string-downcase (symbol-name attr)))) + when (listp attr) + collect `(,(car attr) (dom:get-attribute ,node ,(cadr attr)))) + ,@(loop for attr in attributes + when (symbolp attr) + collect `(when (string-null ,attr) + (error ,(format nil "Attribute ~S is empty." + (string-downcase (symbol-name attr))))) + when (listp attr) + collect `(when (string-null ,(car attr)) + (error ,(format nil "Attribute ~S is empty." (cadr attr))))) + ,@body)) + + +;;; xml schema parser ;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; element and attribute environment + +(defvar *xml-schema-envs* nil + "This special variables holds the list of the current xml schema +element definition environments. Environments can be nested, the list +holds them in top to bottom order (the toplevel environment is first.") + +(defun get-xml-schema-ref (ref) + "Get the definition of REF from the current environment stack." + (dolist (env *xml-schema-envs*) + (awhen (gethash ref env) + (return it)))) + +(defun (setf get-xml-schema-ref) (newvalue ref) + "Set the definition of REF in the current environment." + (let ((env (first *xml-schema-envs*))) + (awhen (gethash ref env) + (error "There already is an XML Schema element named ~A: ~A." ref it)) + (setf (gethash ref env) newvalue))) + +;;; xml schema types + +(defgeneric parse-xs-type (type elt) + (:documentation "Parse ELT according to TYPE. TYPE can be a keyword +to identify base datatypes, or a class derived from XS-TYPE.")) + +(defmacro define-xs-type (name (elt) &rest body) + "Define a base XML Schema type, named by a keyword. For example, +\"xs:string\" is identified by :XS-STRING." + (let ((n (gensym))) + `(defmethod parse-xs-type (,(if (keywordp name) + `(,n (eql ,name)) + name) + ,elt) + ,@body))) + +(defmacro define-xs-type-error (name (elt) &rest body) + "Define the default error function called when ELT could not be +parsed as a value of type NAME." + `(define-xs-type ,name ((,elt t)) + ,@body)) + +;;; Einfach XML Schema typen, wie primitive Types, einfach Elements +;;; und Attributes werden direkt zu Lisp primitive geparst. + +(define-xs-type :xs-string ((elt dom-impl::text)) + (dom:node-value elt)) + +(define-xs-type :xs-string ((elt dom-impl::node)) + (let ((children (dom:child-nodes elt))) + (if (and (= (length children) 1) + (dom:text-node-p (aref children 0))) + (dom:node-value (aref children 0)) + ""))) + +(define-xs-type-error :xs-string (elt) + (error "~s could not be parsed as xs:string." elt)) + +(defclass xs-elt () + ((name :initarg :name :initform nil :reader xs-elt-name) + (type :initarg :type :initform nil :reader xs-elt-type))) + +(defun create-xs-elt (node) + (unless (= (length (dom:child-nodes node)) 0) + (error "~a is not a simple XML Scheme element node." node)) + (with-attributes (name type) node + (setf (get-xml-schema-ref name) + (make-instance 'xs-elt + :name name + :type (make-keyword-from-string type))))) + +(defclass xs-attribute (xs-elt) + ()) + +(defun create-xs-attribute (node) + (unless (= (length (dom:child-nodes node)) 0) + (error "~a is not an XML Scheme attribute node." node)) + (with-attributes (name type) node + (setf (get-xml-schema-ref name) + (make-instance 'xs-attribute + :name name + :type (make-keyword-from-string type))))) + +(define-xs-type (type xs-elt) (elt) + (parse-xs-type (xs-elt-type type) elt)) + + +(defclass xs-complex-type (xs-type) + ((attrs :initarg :attrs :reader xs-ctype-attrs) + (children :initarg :children :reader xs-ctype-children) + (content :initarg :content :reader xs-ctype-content))) + + +(defclass xs-element () + ((name :initarg :name :reader xs-type-name) + (type :initarg :type :reader xs-type-type))) + +(defun xs-attribute-p (node) + (string-equal (dom:node-name node) "xs:attribute")) + +(defun xs-element-p (node) + (string-equal (dom:node-name node) "xs:element")) + +(defun xs-simple-type-p (node) + (or (xs-attribute-p node) + (and (xs-element-p node) + (null (child-elements node))))) + +(defun xs-complex-type-p (node) + (let ((children (child-elements node))) + (and (xs-element-p node) + (not (null children)) + (let ((child (first children))) + (string-equal (dom:node-name node) + "xs:complexType"))))) + +(defun parse-schema-node (elt) + (cond ((xs-attribute-p elt) + (create-xs-attribute elt)) + ((xs-simple-type-p elt) + (create-xs-simple-type elt)) + #+nil + ((xs-complex-type-p elt) + (create-xs-complex-type elt)) + (t (error "Unknown top-level XML Schema node: ~A." (dom:node-name elt))))) + +(defun parse-schema-file (filename) + "Returns the toplevel XML schema environment." + (let* ((dom (cxml:parse-file filename (dom:make-dom-builder))) + (root (dom:document-element dom)) + (*xml-schema-envs* (list (make-hash-table)))) + (unless (string-equal (dom:node-name root) "xs:schema") + (error "Document is not an XML Schema document.")) + (dolist (elt (child-elements root)) + (parse-schema-node elt)) (pop *xml-schema-envs*))) \ No newline at end of file Copied: branches/trunk-reorg/web (from rev 2184, branches/trunk-reorg/bknr-web)

1 0

[bknr-cvs] r2184 - in branches/trunk-reorg: . bknr/experimental bknr-web bknr-web/src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:50:09 -0400 (Thu, 04 Oct 2007) New Revision: 2184 Added: branches/trunk-reorg/bknr-web/site/ branches/trunk-reorg/bknr-web/src/images/ branches/trunk-reorg/bknr/experimental/dump-core.lisp Removed: branches/trunk-reorg/bknr-web/images/ branches/trunk-reorg/bknr-web/src/xhtmlgen/ branches/trunk-reorg/site/ Log: More reorganization Added: branches/trunk-reorg/bknr/experimental/dump-core.lisp =================================================================== --- branches/trunk-reorg/bknr/experimental/dump-core.lisp 2007-10-04 15:45:02 UTC (rev 2183) +++ branches/trunk-reorg/bknr/experimental/dump-core.lisp 2007-10-04 15:50:09 UTC (rev 2184) @@ -0,0 +1,34 @@ +(in-package :bknr.datastore) + +(defun save-cmucl-clean-slime-debugger () + "Called in *after-save-initializations* because cores dumped +when slime is running has this bound. TODO" + (format t "~&clearing debugger hook (~A)" cl:*debugger-hook*) + (setf cl:*debugger-hook* nil)) + +(defun save-cmucl-close-fd-handlers () + (loop for handler in lisp::*descriptor-handlers* + when (> (lisp::handler-descriptor handler) 2) + do (SYSTEM:REMOVE-FD-HANDLER handler))) + +(defun save-cmucl-inits (corefilepath) + "called in the child process" + (save-cmucl-close-fd-handlers) + (mp::shutdown-multi-processing) + (when cl:*debugger-hook* + (warn "CHILD: setting debugger-hook to NIL") + (setf cl:*debugger-hook* nil) ; does not work! + (pushnew 'save-cmucl-clean-slime-debugger ext:*after-save-initializations*)) + (pushnew 'system::reinitialize-global-table ext:*after-save-initializations*) + (ext:save-lisp corefilepath) + (warn "CHILD: strangely survived. killing.") + (unix:unix-exit 1)) + +(defun snapshot-core (&optional (corefilepath "/tmp/bknr.core")) + (cond ((zerop (unix:unix-fork)) + (save-cmucl-inits corefilepath)) + (t (alien:alien-funcall + (alien:extern-alien "wait" + (alien:function alien:unsigned alien:unsigned)) + 0))) + (warn "PARENT saved")) Copied: branches/trunk-reorg/bknr-web/site (from rev 2182, branches/trunk-reorg/site) Copied: branches/trunk-reorg/bknr-web/src/images (from rev 2183, branches/trunk-reorg/bknr-web/images)

1 0

[bknr-cvs] r2183 - in branches/trunk-reorg: . bknr/src bknr-web bknr-web/src bknr-web/src/xhtmlgen
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:45:02 -0400 (Thu, 04 Oct 2007) New Revision: 2183 Added: branches/trunk-reorg/bknr-web/ branches/trunk-reorg/bknr-web/images/ branches/trunk-reorg/bknr-web/src/ branches/trunk-reorg/bknr-web/src/html-match/ branches/trunk-reorg/bknr-web/src/htmlize/ branches/trunk-reorg/bknr-web/src/rss/ branches/trunk-reorg/bknr-web/src/web/ branches/trunk-reorg/bknr-web/src/xhtmlgen/ branches/trunk-reorg/bknr/src/bknr-web.asd branches/trunk-reorg/xhtmlgen/ Removed: branches/trunk-reorg/bknr-web/src/xhtmlgen/xhtmlgen.lisp branches/trunk-reorg/bknr/src/bknr.asd branches/trunk-reorg/bknr/src/html-match/ branches/trunk-reorg/bknr/src/htmlize/ branches/trunk-reorg/bknr/src/images/ branches/trunk-reorg/bknr/src/js/ branches/trunk-reorg/bknr/src/rss/ branches/trunk-reorg/bknr/src/web/ branches/trunk-reorg/bknr/src/xhtmlgen/ Log: began reorganizing the source tree so that the store components are seperated from the web cruft. Copied: branches/trunk-reorg/bknr/src/bknr-web.asd (from rev 2181, trunk/bknr/src/bknr.asd) Deleted: branches/trunk-reorg/bknr/src/bknr.asd =================================================================== --- branches/trunk-reorg/bknr/src/bknr.asd 2007-10-04 15:39:18 UTC (rev 2182) +++ branches/trunk-reorg/bknr/src/bknr.asd 2007-10-04 15:45:02 UTC (rev 2183) @@ -1,133 +0,0 @@ -(in-package :cl-user) - -(defpackage :bknr.system - (:use :cl :asdf) - (:export :*bknr-directory*)) - -(in-package :bknr.system) - -(defparameter *bknr-directory* - (make-pathname :name nil :type nil :version nil - :defaults (parse-namestring *load-truename*))) - -(defsystem :bknr - :name "Baikonour - Base modules" - :author "Hans Huebner <hans(a)huebner.org>" - :author "Manuel Odendahl <manuel(a)bl0rg.net>" - :version "0" - :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" - :licence "BSD" - :description "Baikonour - Launchpad for LISP satellites - Base system" - - :depends-on (:cl-interpol - :cl-ppcre - :cl-gd - :aserve - ;:net.post-office - :md5 - :cxml - :unit-test - :bknr-utils - :bknr-xml - :puri - ;:stem - ;:mime - :klammerscript - :bknr-datastore - :bknr-data-impex - :kmrcl - :iconv - #+(not allegro) - :acl-compat) - - :components ((:file "packages") - - (:module "xhtmlgen" :components ((:file "xhtmlgen")) - :depends-on ("packages")) - - (:module "sysclasses" :components ((:file "event") - (:file "user" :depends-on ("event")) - (:file "cron") - (:file "sysparam")) - :depends-on ("xhtmlgen")) - - (:module "htmlize" :components ((:file "hyperspec") - (:file "htmlize" - :depends-on ("hyperspec"))) - :depends-on ("packages")) - - (:module "rss" :components ((:file "rss") - (:file "parse-xml") - (:file "parse-rss10" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss091" - :depends-on ("parse-xml" "rss")) - (:file "parse-atom" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss20" - :depends-on ("parse-xml" "rss"))) - :depends-on ("packages")) - - (:module "web" :components ((:file "site") - ;; data - (:file "host") - (:file "web-server-event" - :depends-on ("host")) - (:file "web-visitor" - :depends-on ("host")) - - ;; web stuff - (:file "tag-functions") - (:file "web-macros" - :depends-on ("site" - "tag-functions")) - (:file "sessions" - :depends-on ("web-macros" - "site")) - (:file "authorizer" - :depends-on ("sessions" - "host")) - (:file "web-utils" - :depends-on ("web-macros" - "sessions" - "site" - "handlers")) - (:file "menu" :depends-on ("web-macros")) - - ;; handlers - (:file "handlers" - :depends-on ("authorizer" - "web-macros" - "sessions" - "site")) - - (:file "templates" - :depends-on ("handlers")) - (:file "rss-handlers" - :depends-on ("handlers")) - - (:file "user-handlers" - :depends-on ("handlers")) - (:file "user-tags" - :depends-on ("handlers")) - - (:file "tags" - :depends-on ("handlers" - "templates" - "site" - "web-utils"))) - :depends-on ("sysclasses" "packages" "xhtmlgen" "rss")) - - (:module "images" :components ((:file "image") - - (:file "image-tags" :depends-on ("image")) - (:file "image-handlers" - :depends-on ("image-tags" "image")) - (:file "imageproc-handler" - :depends-on ("image-handlers")) - (:file "edit-image-handler" - :depends-on ("image-handlers")) - (:file "import-images-handler" - :depends-on ("image-tags" "image")) - (:file "session-image")) - :depends-on ("web")))) Copied: branches/trunk-reorg/bknr-web/images (from rev 2181, trunk/bknr/src/images) Copied: branches/trunk-reorg/bknr-web/src/html-match (from rev 2181, trunk/bknr/src/html-match) Copied: branches/trunk-reorg/bknr-web/src/htmlize (from rev 2181, trunk/bknr/src/htmlize) Copied: branches/trunk-reorg/bknr-web/src/rss (from rev 2181, trunk/bknr/src/rss) Copied: branches/trunk-reorg/bknr-web/src/web (from rev 2181, trunk/bknr/src/web) Copied: branches/trunk-reorg/bknr-web/src/xhtmlgen (from rev 2181, trunk/bknr/src/xhtmlgen) Deleted: branches/trunk-reorg/bknr-web/src/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/bknr/src/xhtmlgen/xhtmlgen.lisp 2007-10-04 15:27:54 UTC (rev 2181) +++ branches/trunk-reorg/bknr-web/src/xhtmlgen/xhtmlgen.lisp 2007-10-04 15:45:02 UTC (rev 2183) @@ -1,386 +0,0 @@ -;; xhtmlgen.lisp -;; This version by david(a)lichteblau.com for headcraft (http://headcraft.de/) -;; -;; Derived from htmlgen.cl: -;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA -;; -;; This code is free software; you can redistribute it and/or -;; modify it under the terms of the version 2.1 of -;; the GNU Lesser General Public License as published by -;; the Free Software Foundation, as clarified by the AllegroServe -;; prequel found in license-allegroserve.txt. -;; -;; This code is distributed in the hope that it will be useful, -;; but without any warranty; without even the implied warranty of -;; merchantability or fitness for a particular purpose. See the GNU -;; Lesser General Public License for more details. -;; -;; Version 2.1 of the GNU Lesser General Public License is in the file -;; license-lgpl.txt that was distributed with this file. -;; If it is not present, you can access it from -;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer -;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, -;; Suite 330, Boston, MA 02111-1307 USA - -(in-package :xhtml-generator) - -;; fixme -(defvar *html-sink*) - -;; html generation - -(defstruct (html-process (:type list) (:constructor - make-html-process (key macro special - name-attr - ))) - key ; keyword naming this tag - macro ; the macro to define this - special ; if true then call this to process the keyword and return - ; the macroexpansion - name-attr ; attribute symbols which can name this object for subst purposes - ) - - -(defparameter *html-process-table* - (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes - ) - -;; support for strings encoded in latin-1 or utf-8 on non-unicode lisps - -#-rune-is-character -(defun make-sink-for-utf8-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink stream :canonical nil :indentation 3) - #'cxml::utf8-string-to-rod)) - -#-rune-is-character -(defun make-sink-for-latin1-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink stream :canonical nil :indentation 3) - #'cxml::string-rod)) - -#-rune-is-character -(defvar *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings) - -#-rune-is-character -(defun make-sink-for-internal-strings (stream) - (funcall *make-sink-for-internal-strings-fn* stream)) - -#-rune-is-character -(defun set-string-encoding (encoding) - (ecase encoding - (:latin-1 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-latin1-strings)) - (:utf-8 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings)))) - -(defmacro html (&rest forms &environment env) - ;; just emit html to the current stream - `(let ((*html-sink* (if (boundp '*html-sink*) - *html-sink* - #+rune-is-character - (cxml:make-character-stream-sink net.html.generator:*html-stream* :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings net.html.generator:*html-stream*)))) - ,(process-html-forms forms env))) - -(defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* - #+rune-is-character - (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings ,stream))) - ,(process-html-forms forms env))) - -(defun get-process (form) - (let ((ent (gethash form *html-process-table*))) - (unless ent - (error "unknown html keyword ~s" form)) - ent)) - -(defun process-html-forms (forms env) - (let (res) - (flet ((do-ent (ent args argsp body) - ;; ent is an html-process object associated with the - ;; html tag we're processing - ;; args is the list of values after the tag in the form - ;; ((:tag &rest args) ....) - ;; argsp is true if this isn't a singleton tag (i.e. it has - ;; a body) .. (:tag ...) or ((:tag ...) ...) - ;; body is the body if any of the form - ;; - (let ((special (html-process-special ent))) - (push (if special - (funcall special ent args argsp body) - `(,(html-process-macro ent) - ,args - ,(process-html-forms body env))) - res)))) - (do* ((xforms forms (cdr xforms)) - (form (car xforms) (car xforms))) - ((null xforms)) - - (setq form (macroexpand form env)) - - (if (atom form) - (typecase form - (keyword (do-ent (get-process form) nil nil nil)) - (string (push `(sax:characters *html-sink* ,form) res)) - (t (push form res))) - (let ((first (car form))) - (cond - ((keywordp first) - ;; (:xxx . body) form - (do-ent (get-process (car form)) nil t (cdr form))) - ((and (consp first) (keywordp (car first))) - ;; ((:xxx args ) . body) - (do-ent (get-process (caar form)) (cdr first) t (cdr form))) - (t - (push form res))))))) - `(progn ,@(nreverse res)))) - -(defun html-body-key-form (string-code args body) - (unless (evenp (length args)) - (error "attribute list ~S isn't even" args)) - `(let ((.tagname. ,string-code)) - (sax:start-element *html-sink* nil nil .tagname. - (list - ,@(loop - for (name value) on args by #'cddr - collect - `(sax:make-attribute - :qname ,(etypecase name - ; fixme: all attribute names converted to lower case, this won't work - ; all the time. - (symbol (string-downcase (symbol-name name))) - (string name)) - :value (format nil "~A" ,value) - :specified-p t)))) - ,@body - (sax:end-element *html-sink* nil nil .tagname.))) - -(defun emit-without-quoting (str) - ;; das ist fuer WPDISPLAY - (let ((s (cxml::chained-handler *html-sink*))) - (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str))) - -(defun princ-http (val) - #+(or) - (warn "use of deprecated :PRINC (use :PRINC-SAFE instead?)") - (emit-without-quoting (princ-to-string val))) - -(defun prin1-http (val) - #+(or) - (warn "use of deprecated :PRIN1 (use :PRIN1-SAFE instead?)") - (emit-without-quoting (prin1-to-string val))) - -(defun princ-safe-http (val) - (sax:characters *html-sink* (princ-to-string val))) - -(defun prin1-safe-http (val) - (sax:characters *html-sink* (prin1-to-string val))) - - -;; -- defining how html tags are handled. -- -;; -;; most tags are handled in a standard way and the def-std-html -;; macro is used to define such tags -;; -;; Some tags need special treatment and def-special-html defines -;; how these are handled. The tags requiring special treatment -;; are the pseudo tags we added to control operations -;; in the html generator. -;; -;; -;; tags can be found in three ways: -;; :br - singleton, no attributes, no body -;; (:b "foo") - no attributes but with a body -;; ((:a href="foo") "balh") - attributes and body -;; - -(defmacro def-special-html (kwd fcn) - ;; kwd - the tag we're defining behavior for. - ;; fcn - function to compute the macroexpansion of a use of this - ;; tag. args to fcn are: - ;; ent - html-process object holding info on this tag - ;; args - list of attribute-values following tag - ;; argsp - true if there is a body in this use of the tag - ;; body - list of body forms. - `(setf (gethash ,kwd *html-process-table*) - (make-html-process ,kwd nil ,fcn nil))) - -(def-special-html :newline - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp)) - (when body - (error "can't have a body with :newline -- body is ~s" body)) - (emit-without-quoting (string #\newline)))) - -(def-special-html :princ - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(princ-http ,bod)) - body)))) - -(def-special-html :princ-safe - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(princ-safe-http ,bod)) - body)))) - -(def-special-html :prin1 - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(prin1-http ,bod)) - body)))) - -(def-special-html :prin1-safe - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(prin1-safe-http ,bod)) - body)))) - -(def-special-html :comment - #'(lambda (ent args argsp body) - (declare (ignore ent args argsp body)) - `(warn ":COMMENT in html macro not supported yet"))) - -(defmacro def-std-html (kwd name-attrs) - (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) - (string-code (string-downcase (string kwd)))) - `(progn (setf (gethash ,kwd *html-process-table*) - (make-html-process ,kwd - ',mac-name - nil - ',name-attrs)) - (defmacro ,mac-name (args &rest body) - (html-body-key-form ,string-code args body))))) - -(def-std-html :a nil) -(def-std-html :abbr nil) -(def-std-html :acronym nil) -(def-std-html :address nil) -(def-std-html :applet nil) -(def-std-html :area nil) - -(def-std-html :b nil) -(def-std-html :base nil) -(def-std-html :basefont nil) -(def-std-html :bdo nil) -(def-std-html :bgsound nil) -(def-std-html :big nil) -(def-std-html :blink nil) -(def-std-html :blockquote nil) -(def-std-html :body nil) -(def-std-html :br nil) -(def-std-html :button nil) - -(def-std-html :caption nil) -(def-std-html :center nil) -(def-std-html :cite nil) -(def-std-html :code nil) -(def-std-html :col nil) -(def-std-html :colgroup nil) - -(def-std-html :dd nil) -(def-std-html :del nil) -(def-std-html :dfn nil) -(def-std-html :dir nil) -(def-std-html :div nil) -(def-std-html :dl nil) -(def-std-html :dt nil) - -(def-std-html :em nil) -(def-std-html :embed nil) - -(def-std-html :fieldset nil) -(def-std-html :font nil) -(def-std-html :form :name) -(def-std-html :frame nil) -(def-std-html :frameset nil) - -(def-std-html :h1 nil) -(def-std-html :h2 nil) -(def-std-html :h3 nil) -(def-std-html :h4 nil) -(def-std-html :h5 nil) -(def-std-html :h6 nil) -(def-std-html :head nil) -(def-std-html :hr nil) -(def-std-html :html nil) - -(def-std-html :i nil) -(def-std-html :iframe nil) -(def-std-html :ilayer nil) -(def-std-html :img :id) -(def-std-html :input nil) -(def-std-html :ins nil) -(def-std-html :isindex nil) - -(def-std-html :kbd nil) -(def-std-html :keygen nil) - -(def-std-html :label nil) -(def-std-html :layer nil) -(def-std-html :legend nil) -(def-std-html :li nil) -(def-std-html :link nil) -(def-std-html :listing nil) - -(def-std-html :map nil) -(def-std-html :marquee nil) -(def-std-html :menu nil) -(def-std-html :meta nil) -(def-std-html :multicol nil) - -(def-std-html :nobr nil) -(def-std-html :noembed nil) -(def-std-html :noframes nil) -(def-std-html :noscript nil) - -(def-std-html :object nil) -(def-std-html :ol nil) -(def-std-html :optgroup nil) -(def-std-html :option nil) - -(def-std-html :p nil) -(def-std-html :param nil) -(def-std-html :plaintext nil) -(def-std-html :pre nil) - -(def-std-html :q nil) - -(def-std-html :s nil) -(def-std-html :samp nil) -(def-std-html :script nil) -(def-std-html :select nil) -(def-std-html :server nil) -(def-std-html :small nil) -(def-std-html :spacer nil) -(def-std-html :span :id) -(def-std-html :strike nil) -(def-std-html :strong nil) -(def-std-html :style nil) -(def-std-html :sub nil) -(def-std-html :sup nil) - -(def-std-html :table :name) -(def-std-html :tbody nil) -(def-std-html :td nil) -(def-std-html :textarea nil) -(def-std-html :tfoot nil) -(def-std-html :th nil) -(def-std-html :thead nil) -(def-std-html :title nil) -(def-std-html :tr nil) -(def-std-html :tt nil) - -(def-std-html :u nil) -(def-std-html :ul nil) - -(def-std-html :var nil) - -(def-std-html :wbr nil) - -(def-std-html :xmp nil) Copied: branches/trunk-reorg/xhtmlgen (from rev 2181, trunk/bknr/src/xhtmlgen)

1 0

[bknr-cvs] r2182 - branches
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:39:18 -0400 (Thu, 04 Oct 2007) New Revision: 2182 Added: branches/trunk-reorg/ Log: Create branch to reorganize directory structure. Copied: branches/trunk-reorg (from rev 2181, trunk)

1 0

[bknr-cvs] r2181 - branches/bos/projects/quickhoney/src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:27:54 -0400 (Thu, 04 Oct 2007) New Revision: 2181 Added: branches/bos/projects/quickhoney/src/todo-filme Log: save this file for later Added: branches/bos/projects/quickhoney/src/todo-filme =================================================================== --- branches/bos/projects/quickhoney/src/todo-filme 2007-10-04 07:41:40 UTC (rev 2180) +++ branches/bos/projects/quickhoney/src/todo-filme 2007-10-04 15:27:54 UTC (rev 2181) @@ -0,0 +1,17 @@ +Nachr�stung von Filmen in mehreren Formaten: + +in animation-handler: mime-type anhand blob-type setzen + +in upload-animation-handler: blob-type anhand uploaded-file-type setzen + +dazu: + +in web-utils.lisp mehr informationen �ber die hochgeladenen files abspeichern, insbesondere mime-type + + +Log: + +16. Juli 1h Einarbeitung, 4h Upload-Typen mitf�hren, Fehlermeldung bei +ung�ltigem Dateityp, nicht mehr ben�tigte Filme l�schen, Quicktime und +Shockwave anzeigen, getestet. Shockwave noch unklar wegen +Positionierung, IE geht noch nicht.

1 0

[bknr-cvs] r2180 - in trunk/bknr/src: . data indices sysclasses utils web xml-impex
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 03:41:40 -0400 (Thu, 04 Oct 2007) New Revision: 2180 Modified: trunk/bknr/src/bknr-impex.asd trunk/bknr/src/bknr-utils.asd trunk/bknr/src/bknr.asd trunk/bknr/src/data/object.lisp trunk/bknr/src/data/package.lisp trunk/bknr/src/data/txn.lisp trunk/bknr/src/indices/package.lisp trunk/bknr/src/packages.lisp trunk/bknr/src/sysclasses/user.lisp trunk/bknr/src/utils/acl-mp-compat.lisp trunk/bknr/src/utils/package.lisp trunk/bknr/src/utils/utils.lisp trunk/bknr/src/utils/xml.lisp trunk/bknr/src/web/user-handlers.lisp trunk/bknr/src/web/user-tags.lisp trunk/bknr/src/web/web-visitor.lisp trunk/bknr/src/xml-impex/package.lisp Log: Merge back changes that I committed to the bos branch recently. This includes the SBCL compatibility fixes as well as the CXML fix from Kamen. Modified: trunk/bknr/src/bknr-impex.asd =================================================================== --- trunk/bknr/src/bknr-impex.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr-impex.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-indices) + :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: trunk/bknr/src/bknr-utils.asd =================================================================== --- trunk/bknr/src/bknr-utils.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr-utils.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -17,7 +17,6 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cl-ppcre - :cxml :md5 #+(not allegro) :acl-compat @@ -37,7 +36,6 @@ (:file "base64" :depends-on ("utils")) (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) - (:file "xml" :depends-on ("utils")) (:file "date-calc") (:file "acl-mp-compat" :depends-on ("package")))))) Modified: trunk/bknr/src/bknr.asd =================================================================== --- trunk/bknr/src/bknr.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -28,6 +28,7 @@ :cxml :unit-test :bknr-utils + :bknr-xml :puri ;:stem ;:mime Modified: trunk/bknr/src/data/object.lisp =================================================================== --- trunk/bknr/src/data/object.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/object.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -607,6 +607,34 @@ :timestamp (get-universal-time) :args (mapcar #'store-object-id objects))))) +(defgeneric cascade-delete-p (object referencing-object) + (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted")) + +(defmethod cascade-delete-p (object referencing-object) + nil) + +(defun partition-list (list predicate) + "Return two list values, the first containing all elements from LIST +that satisfy PREDICATE, the second those that don't" + (let (do dont) + (dolist (element list) + (if (funcall predicate element) + (push element do) + (push element dont))) + (values do dont))) + +(defun cascading-delete-object (object) + "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by +the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible +to cascading deletes." + (multiple-value-bind (cascading-delete-refs + remaining-refs) + (partition-list (find-refs object) #'cascade-delete-p) + (when remaining-refs + (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" + object)) + (apply #'delete-objects object cascading-delete-refs))) + (deftransaction change-slot-values (object &rest slots-and-values) (when object (loop for (slot value) on slots-and-values by #'cddr @@ -655,4 +683,17 @@ (deftransaction store-object-set-keywords (object slot keywords) (setf (slot-value object slot) keywords)) +(defmethod find-refs ((object store-object)) + "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots." + (remove-if-not + (lambda (candidate) + (find-if (lambda (slotd) + (and (slot-boundp candidate (slot-definition-name slotd)) + (let ((slot-value (slot-value candidate (slot-definition-name slotd)))) + (or (eq object slot-value) + (and (listp slot-value) + (find object slot-value)))))) + (class-slots (class-of candidate)))) + (class-instances 'store-object))) + (pushnew :mop-store cl:*features*) Modified: trunk/bknr/src/data/package.lisp =================================================================== --- trunk/bknr/src/data/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -52,6 +52,8 @@ #:delete-object #:delete-objects + #:cascade-delete-p + #:cascading-delete-object #:initialize-persistent-instance #:initialize-transient-instance @@ -108,4 +110,6 @@ #:store-blob-root-tempdir #:store-object-subsystem - #:blob-subsystem)) + #:blob-subsystem + + #:find-refs)) Modified: trunk/bknr/src/data/txn.lisp =================================================================== --- trunk/bknr/src/data/txn.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/txn.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -43,11 +43,11 @@ () (:default-initargs :guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk)))) :log-guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk))))) (:documentation "Store in which every transaction and operation is protected by a giant lock.")) Modified: trunk/bknr/src/indices/package.lisp =================================================================== --- trunk/bknr/src/indices/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/indices/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -6,7 +6,6 @@ #+cmu :ext #+sbcl :sb-ext :cl-user - :cxml :bknr.utils :bknr.skip-list #+allegro :aclmop Modified: trunk/bknr/src/packages.lisp =================================================================== --- trunk/bknr/src/packages.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/packages.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -26,7 +26,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) (:export #:xml-escape #:*img-src-scanner* #:*a-href-scanner* @@ -130,6 +130,7 @@ #:user-flags #:user-preferences #:user-subscriptions + #:user-editable-p ;; Export slot names so that derived classes can overload ;; slots (e.g. to add XML impex attributes) @@ -152,6 +153,7 @@ #:user-add-flags #:user-remove-flags #:all-user-flags + #:define-user-flag #:user-reachable-by-mail-p #:user-mail-error-p @@ -163,6 +165,7 @@ #:all-users #:get-flag-users #:make-user + #:delete-user #:set-user-password #:set-user-last-login @@ -189,6 +192,7 @@ :bknr.indices :bknr.impex :bknr.utils + :bknr.xml :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) Modified: trunk/bknr/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -13,8 +13,7 @@ :index-values all-users) (flags :update :initform nil :index-type hash-list-index - :index-reader get-flag-users - :index-keys all-user-flags) + :index-reader get-flag-users) (email :update :initform "" :documentation "Email Address, must be unique") @@ -30,6 +29,15 @@ (defconstant +salt-length+ 8) +(defgeneric user-editable-p (user) + (:documentation "Return non-nil if the given user can be edited through the administration interface. The USER class +is frequently subclassed to implement special user accounts that are self-registered and that cannot be edited through +the standard user administration interface. It would be better if the ``real'' system users would live in a seperate base +class that would be editable and have the USER class be non-editable.")) + +(defmethod user-editable-p ((user user)) + t) + (defun make-salt () (coerce (loop for i from 1 upto +salt-length+ @@ -91,6 +99,14 @@ (defmethod user-has-flag ((user user) flag) (find flag (user-flags user))) +(defvar *user-flags* '(:admin)) + +(defun define-user-flag (keyword) + (pushnew keyword *user-flags*)) + +(defun all-user-flags () + (copy-list *user-flags*)) + (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) @@ -149,6 +165,14 @@ (set-user-password user password)) user)) +(defmethod cascade-delete-p ((user user) (event event)) + t) + +(defmethod delete-user ((user user)) + (when (eq user (find-user "anonymous")) + (error "Can't delete system user ``anonymous''")) + (cascading-delete-object user)) + (deftransaction set-user-full-name (user full-name) (setf (user-full-name user) full-name)) @@ -215,4 +239,4 @@ (defmethod as-xml ((event message-event)) (generate-event-xml event :from (message-event-from-name event) - :text (message-event-text event))) \ No newline at end of file + :text (message-event-text event))) Modified: trunk/bknr/src/utils/acl-mp-compat.lisp =================================================================== --- trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -18,3 +18,14 @@ #+cmu `(mp:with-lock-held (,lock) ,@body)) + +(defmacro mp-with-recursive-lock-held ((lock) &rest body) + #+allegro + `(mp:with-process-lock (,lock) + ,@body) + #+sbcl + `(sb-thread:with-recursive-lock (,lock) + ,@body) + #+cmu + `(mp:with-lock-held (,lock) + ,@body)) Modified: trunk/bknr/src/utils/package.lisp =================================================================== --- trunk/bknr/src/utils/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -4,7 +4,6 @@ (:use :cl :cl-ppcre :cl-interpol - :cxml-xmls :md5 #+cmu :extensions ; #+sbcl :sb-ext @@ -122,15 +121,6 @@ #:string-beginning-with-p #:string-delimited-by-p - ;; xml - #:node-children-nodes - #:find-child - #:find-children - #:node-string-body - #:node-attribute - #:node-child-string-body - #:node-to-html - ;; crypt-md5 #:crypt-md5 #:verify-md5-password @@ -147,6 +137,10 @@ ;; mp compatibility #:mp-make-lock #:mp-with-lock-held + #:mp-with-recursive-lock-held ;; class utils - #:class-subclasses)) + #:class-subclasses + + ;; norvig + #:find-all)) Modified: trunk/bknr/src/utils/utils.lisp =================================================================== --- trunk/bknr/src/utils/utils.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/utils.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -545,4 +545,15 @@ (format nil "~3,1F KB" (/ byte-count 1024))) (t (format nil "~A" byte-count)))) - \ No newline at end of file + +;;; from norvig +(defun find-all (item sequence &rest keyword-args + &key (test #'eql) test-not &allow-other-keys) + "Find all those elements of sequence that match item, + according to the keywords. Doesn't alter sequence." + (if test-not + (apply #'remove item sequence + :test-not (complement test-not) keyword-args) + (apply #'remove item sequence + :test (complement test) keyword-args))) + Modified: trunk/bknr/src/utils/xml.lisp =================================================================== --- trunk/bknr/src/utils/xml.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/xml.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -1,63 +0,0 @@ -(in-package :bknr.utils) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Modified: trunk/bknr/src/web/user-handlers.lisp =================================================================== --- trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -59,13 +59,21 @@ (defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) (with-bknr-page (req :title "Manage users") - #+(or) - (:ul (loop for user in (remove :registered (all-users) :key #'user-flags :test #'member) - do (html (:li ((:a :href (object-url user)) - (:princ-safe (user-login user))))))) - ((:form :method "POST") - (:h2 "Search for user") - "Login: " ((:input :type "text" :name "login" :size "20")) (submit-button "search" "search")) + ((:table :border "1") + (:tr (:th "Login") + (:th "Real name") + (:th "Privileges") + (:th "Last login")) + (dolist (user (sort (remove-if-not #'user-editable-p (all-users)) + #'string-lessp :key #'user-login)) + (html (:tr (:td ((:a :href (object-url user)) + (:princ-safe (user-login user)))) + (:td (:princ-safe (user-full-name user))) + (:td (:princ-safe (format nil "~{~A~^, ~}" (user-flags user)))) + (:td (:princ-safe (if (and (user-last-login user) + (plusp (user-last-login user))) + (format-date-time (user-last-login user)) + "<never logged in>"))))))) (:h2 "Create new user") (user-form))) @@ -90,25 +98,27 @@ (when password (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) + + (when (admin-p (bknr-request-user req)) + (let* ((all-flags (all-user-flags)) + (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (unset-flags (set-difference all-flags set-flags))) + (user-add-flags user set-flags) + (user-remove-flags user unset-flags))) + (call-next-method)) +(define-condition unauthorized-error (simple-error) + () + (:report "You are not authorized to perform this operation")) + (defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) + (unless (admin-p (bknr-request-user req)) + (error 'unauthorized-error)) (when user - (delete-object user)) + (delete-user user)) (redirect "/user" req)) -(defmethod handle-object-form ((handler user-handler) (action (eql :add-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-add-flags user flags))) - (call-next-method)) - -(defmethod handle-object-form ((handler user-handler) (action (eql :remove-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-remove-flags user flags))) - (call-next-method)) - (defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) (with-query-params (req login email full-name password password-repeat) (if (and password @@ -116,14 +126,14 @@ (error "please enter the same password twice") (if login (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) - (user (make-object 'user :login login - :email email - :full-name full-name - :password password - :flags flags))) + (user (make-user login + :email email + :full-name full-name + :password password + :flags flags))) (redirect (edit-object-url user) req)) (error "please enter a login"))))) (define-bknr-webserver-module user ("/user" user-handler) - ("/logout" logout-handler)) \ No newline at end of file + ("/logout" logout-handler)) Modified: trunk/bknr/src/web/user-tags.lisp =================================================================== --- trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -2,20 +2,15 @@ (enable-interpol-syntax) -(define-bknr-tag user-flag-choose-dialog (&key (size "4") (name "keyword") (create nil)) - (let ((size (or (parse-integer size :junk-allowed t) 1))) - (loop for i from 1 to size - do (html ((:div :class "keyword-choose") - (when (> size 1) - (html (:princ-safe i) ". ")) - (select-box name - (loop for flag in - (sort (all-user-flags) #'string<) - collect (list (string-downcase flag) flag))) - (when create - (html ((:input :type "text" :length "20" :name name))))))))) +(define-bknr-tag user-flag-choose-dialog (&key enabled) + (dolist (flag (sort (all-user-flags) #'string<)) + (html + ((:div :class "user-flag-choose") + (if (find flag enabled) + (html ((:input :type "checkbox" :name "flags" :value flag :checked "checked"))) + (html ((:input :type "checkbox" :name "flags" :value flag)))) + (:princ-safe flag))))) - (define-bknr-tag user-form (&key user-id) (let ((user (when user-id (store-object-with-id (if (numberp user-id) @@ -36,11 +31,7 @@ (:td (html (text-field "email" :value (user-email user))))) (when (admin-p *user*) (html (:tr (:td "flags") - (:td (dolist (flag (user-flags user)) - (html (:princ-safe flag) " ")))) - (:tr (:td "new flags") - (:td (user-flag-choose-dialog :create t - :size "2"))))) + (:td (user-flag-choose-dialog :enabled (user-flags user)))))) (:tr (:td "new password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat new password") @@ -48,9 +39,7 @@ (:tr ((:td :colspan "2") (submit-button "save" "save") (when (admin-p *user*) - (submit-button "add-flags" "add flags") - (submit-button "remove-flags" "remove flags") - (submit-button "delete" "delete"))))))) + (submit-button "delete" "delete" :confirm "Really delete this user account? The operation cannot be undone."))))))) (html ((:form :method "post") (:table (:tr (:td "login") @@ -60,7 +49,7 @@ (:tr (:td "email") (:td ((:input :type "text" :name "email" :size "40")))) (:tr (:td "flags") - (:td (user-flag-choose-dialog :create t :size "2"))) + (:td (user-flag-choose-dialog))) (:tr (:td "password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat password") Modified: trunk/bknr/src/web/web-visitor.lisp =================================================================== --- trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -16,12 +16,15 @@ (host-ip-address (web-visitor-event-host event)))) (defmethod print-object ((event web-visitor-event) stream) - (format stream "#<~a at ~a user ~a from ~a [~a]>" - (class-of event) (format-date-time (event-time event)) - (when (web-visitor-event-user event) - (user-login (web-visitor-event-user event))) - (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event))) + (print-unreadable-object (event stream :type t :identity t) + (format stream "at ~A user ~A" + (format-date-time (event-time event)) + (and (web-visitor-event-user event) + (user-login (web-visitor-event-user event)))) + (when (web-visitor-event-host event) + (format stream " from ~a [~a]" + (host-name (web-visitor-event-host event)) + (host-ip-address (web-visitor-event-host event)))))) event) #+(or) Modified: trunk/bknr/src/xml-impex/package.lisp =================================================================== --- trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -13,6 +13,7 @@ #+sbcl :sb-pcl :bknr.utils + :bknr.xml :bknr.indices) (:export #:xml-class

1 0

[bknr-cvs] r2179 - branches/bos/thirdparty/asdf
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 03:23:42 -0400 (Thu, 04 Oct 2007) New Revision: 2179 Modified: branches/bos/thirdparty/asdf/asdf.lisp Log: Update asdf to current cclan version. Modified: branches/bos/thirdparty/asdf/asdf.lisp =================================================================== --- branches/bos/thirdparty/asdf/asdf.lisp 2007-10-03 01:20:42 UTC (rev 2178) +++ branches/bos/thirdparty/asdf/asdf.lisp 2007-10-04 07:23:42 UTC (rev 2179) @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list(a)lists.sf.net>. But note first that the canonical @@ -13,7 +13,7 @@ ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; Copyright (c) 2001-2007 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -78,7 +78,10 @@ #:system-author #:system-maintainer #:system-license - + #:system-licence + #:system-source-file + #:system-relative-pathname + #:operation-on-warnings #:operation-on-failure @@ -90,24 +93,29 @@ #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors - + #:duplicate-names + #:retry #:accept ; restarts + #:preference-file-for-system/operation + #:load-preferences ) (:use :cl)) + #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.110 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -117,10 +125,14 @@ :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) + (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) +(defparameter +asdf-methods+ + '(perform explain output-files operation-done-p)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff @@ -156,6 +168,9 @@ (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) @@ -168,7 +183,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s (formatter "~@<erred while invoking ~A on ~A~@:>") + (format s "~@<erred while invoking ~A on ~A~@:>" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -199,9 +214,8 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s (formatter "~@<~A, required by ~A~@:>") - (call-next-method c nil) - (missing-required-by c))) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) @@ -209,9 +223,9 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s (formatter "~@<component ~S not found~ - ~@[ or does not match version ~A~]~ - ~@[ in ~A~]~@:>") + (format s "~@<component ~S not found~ + ~@[ or does not match version ~A~]~ + ~@[ in ~A~]~@:>" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -281,7 +295,8 @@ :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license))) ;;; version-satisfies @@ -326,8 +341,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error (formatter "~@<invalid component designator ~A~@:>") - name)))) + (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -356,6 +370,14 @@ (if (and file (probe-file file)) (return file))))))) +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) @@ -364,15 +386,18 @@ (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) - (let ((*package* (make-package (gensym (package-name #.*package*)) - :use '(:cl :asdf)))) - (format *verbose-out* - (formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%") - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. on-disk *package*) - (load on-disk))) + (load on-disk)) + (delete-package package)))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) @@ -380,8 +405,7 @@ (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) - (format *verbose-out* - (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) @@ -427,17 +451,20 @@ (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) - (let* ((*default-pathname-defaults* (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) - (if (slot-value component 'relative-pathname) - (merge-pathnames - (slot-value component 'relative-pathname) - name-type) - name-type))) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -537,8 +564,26 @@ (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -(defgeneric component-depends-on (operation component)) +(defgeneric component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defmethod component-depends-on ((op-spec symbol) (c component)) + (component-depends-on (make-instance op-spec) c)) + (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) (slot-value c 'in-order-to)))) @@ -567,26 +612,40 @@ (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) - (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ + operation ~S on component ~S as done.~@:>" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -676,16 +735,15 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - (formatter "~@<required method PERFORM not implemented~ - for operation ~A, component ~A~@:>") + "~@<required method PERFORM not implemented ~ + for operation ~A, component ~A~@:>" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) nil) (defmethod explain ((operation operation) (component component)) - (format *verbose-out* "~&;;; ~A on ~A~%" - operation component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) ;;; compile-op @@ -701,38 +759,39 @@ (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (get-universal-time)) + (load-preferences c operation)) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) + (compile-file source-file + :output-file output-file) ;(declare (ignore output)) (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (formatter "~@<COMPILE-FILE warned while ~ - performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (case (operation-on-warnings operation) + (:warn (warn + "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) (when failure-p - (case (operation-on-failure operation) - (:warn (warn - (formatter "~@<COMPILE-FILE failed while ~ - performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-failed :component c :operation operation)) - (:ignore nil))) + (case (operation-on-failure operation) + (:warn (warn + "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) (unless output - (error 'compile-error :component c :operation operation))))) + (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) - (list (compile-file-pathname (component-pathname c)))) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) (defmethod perform ((operation compile-op) (c static-file)) nil) @@ -740,10 +799,16 @@ (defmethod output-files ((operation compile-op) (c static-file)) nil) +(defmethod input-files ((op compile-op) (c static-file)) + nil) + + ;;; load-op -(defclass load-op (operation) ()) +(defclass basic-load-op (operation) ()) +(defclass load-op (basic-load-op) ()) + (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) @@ -761,7 +826,7 @@ ;;; load-source-op -(defclass load-source-op (operation) ()) +(defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (let ((source (component-pathname c))) @@ -796,46 +861,103 @@ (defmethod perform ((operation test-op) (c component)) nil) +(defgeneric load-preferences (system operation) + (:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded.")) + +(defgeneric preference-file-for-system/operation (system operation) + (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load.")) + +(defmethod load-preferences ((s t) (operation t)) + ;; do nothing + (values)) + +(defmethod load-preferences ((s system) (operation basic-load-op)) + (let* ((*package* (find-package :common-lisp)) + (file (probe-file (preference-file-for-system/operation s operation)))) + (when file + (when *verbose-out* + (format *verbose-out* + "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" + (component-name s) + (type-of operation) file)) + (load file)))) + +(defmethod preference-file-for-system/operation ((system t) (operation t)) + ;; cope with anything other than systems + (preference-file-for-system/operation (find-system system t) operation)) + +(defmethod preference-file-for-system/operation ((s system) (operation t)) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil + :defaults *default-pathname-defaults*))) + (merge-pathnames + (make-pathname :name (component-name s) + :type "lisp" + :directory '(:relative ".asdf")) + (truename (user-homedir-pathname))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defun operate (operation-class system &rest args) +(defvar *operate-docstring* + "Operate does three things: + +1. It creates an instance of `operation-class` using any keyword parameters +as initargs. +2. It finds the asdf-system specified by `system` (possibly loading +it from disk). +3. It then calls `traverse` with the operation and system as arguments + +The traverse operation is wrapped in `with-compilation-unit` and error +handling code. If a `version` argument is supplied, then operate also +ensures that the system found satisfies it using the `version-satisfies` +method.") + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) - (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s - (formatter "~@<Retry performing ~S on ~S.~@:>") - op component))) - (accept () - :report - (lambda (s) - (format s - (formatter "~@<Continue, treating ~S on ~S as ~ - having been successful.~@:>") - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + :original-initargs args + args)) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@<Retry performing ~S on ~S.~@:>" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@<Continue, treating ~S on ~S as ~ + having been successful.~@:>" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) -(defun oos (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) +(setf (documentation 'operate 'function) + *operate-docstring*) +(defun oos (operation-class system &rest args &key force (verbose t) version) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" + *operate-docstring*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax @@ -871,22 +993,30 @@ :module (coerce-name ',name) :pathname (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) + (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks *load-truename*))) *default-pathname-defaults*) ',component-options)))))) (defun class-for-type (parent type) - (let ((class (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.*package*)) nil))) + (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) + (load-time-value + (package-name :asdf))))) + (class (dolist (symbol (if (keywordp type) + extra-symbols + (cons type extra-symbols))) + (when (and symbol + (find-class symbol nil) + (subtypep symbol 'component)) + (return (find-class symbol)))))) (or class (and (eq type :file) (or (module-default-component-class parent) (find-class 'cl-source-file))) - (sysdef-error (formatter "~@<don't recognize component type ~A~@:>") - type)))) + (sysdef-error "~@<don't recognize component type ~A~@:>" type)))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -923,27 +1053,42 @@ (defvar *serial-depends-on*) (defun parse-component-form (parent options) + (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to ;; list ends &allow-other-keys) options - (check-component-input type name depends-on components in-order-to) + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) rest)) (ret (or (find-component parent name) (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) (when (boundp '*serial-depends-on*) (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) + (concatenate 'list *serial-depends-on* depends-on))) (apply #'reinitialize-instance ret :name (coerce-name name) @@ -961,7 +1106,19 @@ for c = (parse-component-form ret c-form) collect c if serial - do (push (component-name c) *serial-depends-on*))))) + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) (setf (slot-value ret 'in-order-to) (union-of-dependencies @@ -970,28 +1127,39 @@ (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) + (%remove-component-inline-methods ret rest) + ret))) -(defun check-component-input (type name depends-on components in-order-to) +(defun %remove-component-inline-methods (ret rest) + (loop for name in +asdf-methods+ + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods ret))) + ;; clear methods, then add the new ones + (setf (component-inline-methods ret) nil) + (loop for name in +asdf-methods+ + for v = (getf rest (intern (symbol-name name) :keyword)) + when v do + (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." type name components)) @@ -1018,14 +1186,15 @@ (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with -output to *verbose-out*. Returns the shell's exit code." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (format *verbose-out* "; $ ~A~%" command) #+sbcl - (sb-impl::process-exit-code + (sb-ext:process-exit-code (sb-ext:run-program - "/bin/sh" + #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) + #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) @@ -1053,8 +1222,9 @@ (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) - - #-(or openmcl clisp lispworks allegro scl cmu sbcl) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) @@ -1066,7 +1236,29 @@ (defun hyperdoc (name doc-type) (hyperdocumentation (symbol-package name) name doc-type)) +(defun system-source-file (system-name) + (let ((system (asdf:find-system system-name))) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system)))) +(defun system-source-directory (system-name) + (make-pathname :name nil + :type nil + :defaults (system-source-file system-name))) + +(defun system-relative-pathname (system pathname &key name type) + (let ((directory (pathname-directory pathname))) + (when (eq (car directory) :absolute) + (setf (car directory) :relative)) + (merge-pathnames + (make-pathname :name (or name (pathname-name pathname)) + :type (or type (pathname-type pathname)) + :directory directory) + (system-source-directory system)))) + + (pushnew :asdf *features*) #+sbcl @@ -1084,14 +1276,24 @@ (asdf:operate 'asdf:load-op name) t)))) - (pushnew - '(merge-pathnames "systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) + (defun contrib-sysdef-search (system) + (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (let* ((name (coerce-name system)) + (home (truename home)) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))))) (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) + '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew @@ -1099,6 +1301,8 @@ (user-homedir-pathname)) *central-registry*) - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) (provide 'asdf) +

1 0