├── docs ├── news.txt ├── history.txt ├── iebugs.txt ├── js-backend-abstraction.txt ├── goals.txt └── announcements │ ├── template.txt │ └── 083.txt ├── scripts ├── weblocks-core │ ├── pub │ └── weblocks.asd ├── weblocks-scripts.lisp ├── build-core.lisp ├── build-core.cronjob ├── new-app-templates │ ├── init-session.lisp │ ├── stores.lisp │ ├── {APPNAME}.asd │ └── {APPNAME}.lisp └── gen-doc.lisp ├── pub ├── images │ ├── reset.png │ ├── progress.gif │ ├── menu │ │ ├── arrow.png │ │ ├── top_left.png │ │ ├── top_right.png │ │ ├── bottom_left.png │ │ ├── bottom_right.png │ │ ├── selected_arrow.png │ │ ├── top_background.png │ │ └── bottom_background.png │ ├── dialog │ │ ├── close.gif │ │ ├── question.png │ │ └── information.png │ ├── header │ │ ├── logo.png │ │ ├── top_left.png │ │ ├── background.png │ │ ├── bottom_left.png │ │ ├── top_right.png │ │ └── bottom_right.png │ ├── page │ │ ├── top_left.png │ │ ├── background.png │ │ ├── hor_border.png │ │ ├── top_right.png │ │ ├── bottom_left.png │ │ ├── bottom_right.png │ │ └── hor_border_bottom.png │ ├── widget │ │ ├── arrow.png │ │ ├── top_left.png │ │ ├── bottom_left.png │ │ ├── flash │ │ │ ├── flag.png │ │ │ ├── top_left.png │ │ │ ├── top_right.png │ │ │ ├── bottom_left.png │ │ │ ├── bottom_right.png │ │ │ ├── top_background.png │ │ │ └── bottom_background.png │ │ ├── top_right.png │ │ ├── bottom_right.png │ │ ├── table_border_top.png │ │ ├── top_background.png │ │ ├── bottom_background.png │ │ ├── datagrid │ │ │ ├── up_arrow.png │ │ │ ├── down_arrow.png │ │ │ ├── sort_bg_asc.png │ │ │ └── sort_bg_desc.png │ │ ├── datalist │ │ │ ├── up_arrow.png │ │ │ ├── down_arrow.png │ │ │ ├── up_arrow_link.png │ │ │ └── down_arrow_link.png │ │ └── dataseq │ │ │ └── flash │ │ │ ├── bottom_left.png │ │ │ └── bottom_right.png │ ├── horizontal_line.png │ ├── footer │ │ ├── valid-css.png │ │ └── valid-xhtml11.png │ └── weblocks-alien-small.png └── stylesheets │ ├── isearch.css │ ├── suggest.css │ ├── debug-toolbar.css │ ├── error-page.css │ ├── datagrid.css │ ├── table.css │ ├── flash.css │ ├── pagination.css │ ├── menu.css │ ├── navigation.css │ └── dialog.css ├── test ├── debug-mode.lisp ├── request-hooks.lisp ├── test-code │ ├── utils.lisp │ └── query-actions.lisp ├── uri-tokens.lisp ├── views │ ├── formview │ │ ├── helpers.lisp │ │ ├── scaffold.lisp │ │ └── test-template.lisp │ ├── view │ │ ├── compiler.lisp │ │ ├── view.lisp │ │ └── scaffold.lisp │ ├── types │ │ ├── presentations │ │ │ ├── textarea.lisp │ │ │ ├── paragraph.lisp │ │ │ ├── image.lisp │ │ │ ├── date.lisp │ │ │ ├── choices.lisp │ │ │ ├── url.lisp │ │ │ ├── radio.lisp │ │ │ ├── excerpt.lisp │ │ │ └── dropdown.lisp │ │ ├── member.lisp │ │ └── password.lisp │ ├── sequence-view.lisp │ ├── tableview │ │ └── test-template.lisp │ └── dataview │ │ └── test-template.lisp ├── snippets │ └── html-utils-helper.lisp ├── control-flow │ └── workflow.lisp ├── widgets │ ├── widget │ │ └── widget-mop.lisp │ ├── data-editor.lisp │ ├── listedit.lisp │ ├── datagrid │ │ └── sort.lisp │ ├── login.lisp │ ├── navigation.lisp │ ├── dataedit │ │ └── delete-action.lisp │ ├── composite.lisp │ ├── selector.lisp │ └── pagination-utils.lisp ├── utils-test │ └── runtime-class.lisp ├── server.lisp ├── blocks │ ├── form.lisp │ └── suggest.lisp ├── weblocks.lisp ├── actions.lisp └── request-handler-utils.lisp ├── contrib ├── s11001001 │ ├── package.lisp │ ├── weblocks-s11.asd │ ├── dataedit.lisp │ └── presentations.lisp ├── yarek │ ├── package.lisp │ ├── examples │ │ ├── employer-employee │ │ │ ├── rundemo.lisp │ │ │ ├── README │ │ │ ├── src │ │ │ │ ├── model │ │ │ │ │ ├── address.lisp │ │ │ │ │ ├── employee.lisp │ │ │ │ │ └── person.lisp │ │ │ │ ├── sandbox.lisp │ │ │ │ ├── init-session.lisp │ │ │ │ └── layout.lisp │ │ │ ├── employer-employee.lisp │ │ │ ├── conf │ │ │ │ └── stores.lisp │ │ │ └── employer-employee.asd │ │ └── weblocks-demo-popover │ │ │ ├── rundemo.lisp │ │ │ ├── README │ │ │ ├── src │ │ │ ├── model │ │ │ │ ├── address.lisp │ │ │ │ ├── company.lisp │ │ │ │ ├── employee.lisp │ │ │ │ └── person.lisp │ │ │ ├── snippets.lisp │ │ │ ├── sandbox.lisp │ │ │ └── init-session.lisp │ │ │ ├── weblocks-demo-popover.lisp │ │ │ ├── conf │ │ │ └── stores.lisp │ │ │ └── weblocks-demo-popover.asd │ └── weblocks-yarek.asd ├── jwr │ └── yui │ │ └── weblocks-yui.asd ├── lpolzer │ ├── gauge.lisp │ ├── yui │ │ ├── yui-panel.lisp │ │ ├── yui-resize.lisp │ │ └── example.lisp │ ├── html-template.lisp │ ├── integer-range.lisp │ └── request-parameter-for-presentation.diff ├── nunb │ ├── functioncall.lisp │ ├── templates-crufty │ │ ├── html-template.lisp │ │ └── template-utils.lisp │ └── poncy.lisp └── jfremlin │ └── rrd-router-graph.lisp ├── README.md ├── src ├── control-flow │ └── workflow.lisp ├── views │ ├── formview │ │ ├── helpers.lisp │ │ └── scaffold.lisp │ ├── types │ │ ├── presentations │ │ │ ├── hidden.lisp │ │ │ ├── html.lisp │ │ │ ├── paragraph.lisp │ │ │ ├── excerpt.lisp │ │ │ ├── textarea.lisp │ │ │ ├── dropdown.lisp │ │ │ ├── url.lisp │ │ │ ├── widget.lisp │ │ │ ├── image.lisp │ │ │ └── date.lisp │ │ ├── member.lisp │ │ └── password.lisp │ └── view │ │ └── presentation.lisp ├── utils │ ├── i18n.lisp │ ├── repl.lisp │ ├── runtime-class.lisp │ └── timing.lisp ├── widgets │ ├── composite.lisp │ ├── widget │ │ ├── string-widget.lisp │ │ ├── funcall-widget.lisp │ │ └── uri-parameters-mixin.lisp │ ├── dataseq │ │ └── operations-action.lisp │ ├── template-block.lisp │ ├── breadcrumbs.lisp │ └── datagrid │ │ └── sort.lisp ├── application-mop.lisp ├── log-actions.lisp ├── util.lisp ├── package.lisp ├── acceptor.lisp └── widget-translation.lisp ├── weblocks-scripts.asd ├── run-tests.ros ├── .travis.yml └── weblocks-util.asd /docs/news.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /scripts/weblocks-core/pub: -------------------------------------------------------------------------------- 1 | ../../pub -------------------------------------------------------------------------------- /scripts/weblocks-core/weblocks.asd: -------------------------------------------------------------------------------- 1 | ../../weblocks.asd -------------------------------------------------------------------------------- /pub/images/reset.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/reset.png -------------------------------------------------------------------------------- /pub/images/progress.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/progress.gif -------------------------------------------------------------------------------- /pub/images/menu/arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/arrow.png -------------------------------------------------------------------------------- /scripts/weblocks-scripts.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:weblocks-scripts 3 | (:use :cl :cl-fad)) 4 | 5 | -------------------------------------------------------------------------------- /pub/images/dialog/close.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/dialog/close.gif -------------------------------------------------------------------------------- /pub/images/header/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/logo.png -------------------------------------------------------------------------------- /pub/images/menu/top_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/top_left.png -------------------------------------------------------------------------------- /pub/images/page/top_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/top_left.png -------------------------------------------------------------------------------- /pub/images/widget/arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/arrow.png -------------------------------------------------------------------------------- /pub/images/dialog/question.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/dialog/question.png -------------------------------------------------------------------------------- /pub/images/header/top_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/top_left.png -------------------------------------------------------------------------------- /pub/images/horizontal_line.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/horizontal_line.png -------------------------------------------------------------------------------- /pub/images/menu/top_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/top_right.png -------------------------------------------------------------------------------- /pub/images/page/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/background.png -------------------------------------------------------------------------------- /pub/images/page/hor_border.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/hor_border.png -------------------------------------------------------------------------------- /pub/images/page/top_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/top_right.png -------------------------------------------------------------------------------- /pub/images/widget/top_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/top_left.png -------------------------------------------------------------------------------- /test/debug-mode.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package weblocks-test) 3 | 4 | ; All tests were deprecated, waiting for new 5 | -------------------------------------------------------------------------------- /pub/images/dialog/information.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/dialog/information.png -------------------------------------------------------------------------------- /pub/images/footer/valid-css.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/footer/valid-css.png -------------------------------------------------------------------------------- /pub/images/header/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/background.png -------------------------------------------------------------------------------- /pub/images/header/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/bottom_left.png -------------------------------------------------------------------------------- /pub/images/header/top_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/top_right.png -------------------------------------------------------------------------------- /pub/images/menu/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/bottom_left.png -------------------------------------------------------------------------------- /pub/images/menu/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/bottom_right.png -------------------------------------------------------------------------------- /pub/images/page/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/bottom_left.png -------------------------------------------------------------------------------- /pub/images/page/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/bottom_right.png -------------------------------------------------------------------------------- /pub/images/widget/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/bottom_left.png -------------------------------------------------------------------------------- /pub/images/widget/flash/flag.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/flag.png -------------------------------------------------------------------------------- /pub/images/widget/top_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/top_right.png -------------------------------------------------------------------------------- /pub/images/footer/valid-xhtml11.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/footer/valid-xhtml11.png -------------------------------------------------------------------------------- /pub/images/header/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/header/bottom_right.png -------------------------------------------------------------------------------- /pub/images/menu/selected_arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/selected_arrow.png -------------------------------------------------------------------------------- /pub/images/menu/top_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/top_background.png -------------------------------------------------------------------------------- /pub/images/weblocks-alien-small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/weblocks-alien-small.png -------------------------------------------------------------------------------- /pub/images/widget/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/bottom_right.png -------------------------------------------------------------------------------- /pub/stylesheets/isearch.css: -------------------------------------------------------------------------------- 1 | 2 | .isearch input.submit 3 | { 4 | margin-right: 0; 5 | margin-left: 0.5em; 6 | } 7 | -------------------------------------------------------------------------------- /pub/images/menu/bottom_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/menu/bottom_background.png -------------------------------------------------------------------------------- /pub/images/page/hor_border_bottom.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/page/hor_border_bottom.png -------------------------------------------------------------------------------- /pub/images/widget/flash/top_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/top_left.png -------------------------------------------------------------------------------- /pub/images/widget/flash/top_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/top_right.png -------------------------------------------------------------------------------- /pub/images/widget/table_border_top.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/table_border_top.png -------------------------------------------------------------------------------- /pub/images/widget/top_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/top_background.png -------------------------------------------------------------------------------- /pub/images/widget/bottom_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/bottom_background.png -------------------------------------------------------------------------------- /pub/images/widget/datagrid/up_arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datagrid/up_arrow.png -------------------------------------------------------------------------------- /pub/images/widget/datalist/up_arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datalist/up_arrow.png -------------------------------------------------------------------------------- /pub/images/widget/flash/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/bottom_left.png -------------------------------------------------------------------------------- /pub/images/widget/flash/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/bottom_right.png -------------------------------------------------------------------------------- /pub/images/widget/datagrid/down_arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datagrid/down_arrow.png -------------------------------------------------------------------------------- /pub/images/widget/datagrid/sort_bg_asc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datagrid/sort_bg_asc.png -------------------------------------------------------------------------------- /pub/images/widget/datagrid/sort_bg_desc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datagrid/sort_bg_desc.png -------------------------------------------------------------------------------- /pub/images/widget/datalist/down_arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datalist/down_arrow.png -------------------------------------------------------------------------------- /pub/images/widget/flash/top_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/top_background.png -------------------------------------------------------------------------------- /pub/images/widget/datalist/up_arrow_link.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datalist/up_arrow_link.png -------------------------------------------------------------------------------- /pub/images/widget/flash/bottom_background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/flash/bottom_background.png -------------------------------------------------------------------------------- /pub/images/widget/datalist/down_arrow_link.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/datalist/down_arrow_link.png -------------------------------------------------------------------------------- /pub/images/widget/dataseq/flash/bottom_left.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/dataseq/flash/bottom_left.png -------------------------------------------------------------------------------- /pub/images/widget/dataseq/flash/bottom_right.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/weblocks/HEAD/pub/images/widget/dataseq/flash/bottom_right.png -------------------------------------------------------------------------------- /scripts/build-core.lisp: -------------------------------------------------------------------------------- 1 | (dolist (sys '(weblocks weblocks-demo)) 2 | (asdf:oos 'asdf:load-op sys)) 3 | (use-package :weblocks) 4 | (use-package :cl-who) 5 | (save-lisp-and-die #p"weblocks.sbclcore") 6 | -------------------------------------------------------------------------------- /docs/history.txt: -------------------------------------------------------------------------------- 1 | state management: 2 | 3 | * the state of specific widget slots should be bookmarkable 4 | as long as it is easily serializable. 5 | 6 | * continuation state need not be bookmarkable. 7 | -------------------------------------------------------------------------------- /contrib/s11001001/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; package.lisp: My package of Weblocks extensions. 2 | 3 | (defpackage #:weblocks-s11 4 | (:use #:cl #:weblocks)) 5 | 6 | (in-package #:weblocks-s11) 7 | 8 | ;;; package.lisp ends here 9 | -------------------------------------------------------------------------------- /contrib/yarek/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; package.lisp: Yarek's package of Weblocks extensions. 2 | 3 | (defpackage #:weblocks-yarek 4 | (:use #:cl #:weblocks)) 5 | 6 | (in-package #:weblocks-yarek) 7 | 8 | ;;; package.lisp ends here 9 | -------------------------------------------------------------------------------- /test/request-hooks.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test session-request-hooks 5 | (deftest session-request-hooks-1 6 | (with-request :get nil 7 | (null (weblocks::session-request-hooks))) 8 | nil) 9 | 10 | -------------------------------------------------------------------------------- /scripts/build-core.cronjob: -------------------------------------------------------------------------------- 1 | # MIN HOUR DAY MONTH DAYOFWEEK COMMAND 2 | 0 4 * * * cd /home/sky/www/weblocks-dev/scripts/weblocks-core/ && sbcl --load ../build-core.lisp && tar vcj --dereference --exclude=\*.asd -f ../weblocks-core-`date "+%Y-%m-%d"`.tar.bz2 ../weblocks-core 3 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/rundemo.lisp: -------------------------------------------------------------------------------- 1 | ;(push #p"/usr/lib/sbcl/site/cl-weblocks/" asdf:*central-registry*) 2 | (push #p"/path/to/the/demo/root/dir/employer-employee/" asdf:*central-registry*) 3 | (asdf:operate 'asdf:load-op :employer-employee) 4 | (employer-employee:start-employer-employee :debug t) 5 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/rundemo.lisp: -------------------------------------------------------------------------------- 1 | ;(push #p"/usr/lib/sbcl/site/cl-weblocks/" asdf:*central-registry*) 2 | (push #p"/path/to/the/demo/root/dir/weblocks-demo-popover/" asdf:*central-registry*) 3 | (asdf:operate 'asdf:load-op :weblocks-demo-popover) 4 | (weblocks-demo-popover:start-weblocks-demo-popover :debug t) 5 | -------------------------------------------------------------------------------- /scripts/new-app-templates/init-session.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :{APPNAME}) 3 | 4 | ;; Define callback function to initialize new sessions 5 | (defun init-user-session (root) 6 | (setf (widget-children root) 7 | (list (lambda (&rest args) 8 | (with-html 9 | (:strong "Happy Hacking!")))))) 10 | 11 | -------------------------------------------------------------------------------- /scripts/new-app-templates/stores.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :{APPNAME}) 3 | 4 | ;;; Multiple stores may be defined. The last defined store will be the 5 | ;;; default. 6 | (defstore *{APPNAME}-store* :prevalence 7 | (merge-pathnames (make-pathname :directory '(:relative "data")) 8 | (asdf-system-directory :{APPNAME}))) 9 | 10 | -------------------------------------------------------------------------------- /docs/iebugs.txt: -------------------------------------------------------------------------------- 1 | 2 | - Quirks mode - anything before doctype/incorrect doctype 3 | - Incorrect overflow issue (set overflow to hidden) 4 | - min-width doesn't work (use dynamic properties) 5 | (to do: .table min-width) 6 | - border-spacing doesn't work (replace with border-collapse?) 7 | - Not declaring a width along with negative margins causes extremely weird rendering bugs 8 | -------------------------------------------------------------------------------- /test/test-code/utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;; unfortunate that `ensure-same' doesn't accept lambda expr 5 | (defun set-equal-equal (a b) 6 | (set-equal a b :test #'equal)) 7 | 8 | (defun set-equal-uri= (a b) 9 | (set-equal a b :test #'puri:uri=)) 10 | 11 | (defun remove-all-methods (gf) 12 | (mapc (f_ (remove-method gf _)) (copy-list (generic-function-methods gf)))) 13 | -------------------------------------------------------------------------------- /pub/stylesheets/suggest.css: -------------------------------------------------------------------------------- 1 | 2 | div.suggest 3 | { 4 | border: solid 1px; 5 | background-color: #F6FBFD; 6 | } 7 | 8 | div.suggest ul 9 | { 10 | margin: 0; 11 | padding: 0; 12 | } 13 | 14 | div.suggest ul li 15 | { 16 | list-style-type: none; 17 | margin: 0; 18 | padding: 2px; 19 | display: block; 20 | } 21 | 22 | div.suggest ul li.selected 23 | { 24 | background-color: #D8EAF8; 25 | } 26 | -------------------------------------------------------------------------------- /test/uri-tokens.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftestsuite uri-tokens-suite (weblocks-suite) nil) 5 | 6 | (addtest init-uri-tokens 7 | (let ((tokens (make-instance 'uri-tokens :tokens '("foo"))) 8 | (*lift-equality-test* (curry-after #'tree-equal :test #'equalp))) 9 | (ensure-same (consumed-tokens tokens) nil) 10 | (ensure-same (remaining-tokens tokens) '("foo")))) 11 | 12 | -------------------------------------------------------------------------------- /test/views/formview/helpers.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test make-slot-writer 5 | (deftest make-slot-writer-1 6 | (let ((obj (copy-template *joe*))) 7 | (funcall 8 | (make-slot-writer 'name (lambda (value) 9 | (declare (ignore value)) 10 | "foo")) 11 | "bak" obj) 12 | (first-name obj)) 13 | "foo") 14 | 15 | -------------------------------------------------------------------------------- /docs/js-backend-abstraction.txt: -------------------------------------------------------------------------------- 1 | === Design: 2 | 3 | (define-javascript-backend NAME ROOT FILES) 4 | 5 | FILES are relative to ROOT, which in turn is relative to the 6 | static files path. 7 | 8 | 9 | === Files that need to be ported: 10 | weblocks.js 11 | weblocks-debug.js 12 | dialog.js 13 | datagrid.js 14 | hard-coded js in src/ 15 | 16 | 17 | === Initial portable API: 18 | AJAX requests 19 | Effects (simple) 20 | 21 | History (later) 22 | -------------------------------------------------------------------------------- /contrib/jwr/yui/weblocks-yui.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:weblocks-yui-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :weblocks-yui-asd) 6 | 7 | (defsystem weblocks-yui 8 | :name "weblocks-yui" 9 | :version "0.0.1" 10 | :maintainer "" 11 | :author "Jan Rychter" 12 | :licence "" 13 | :description "YUI integration for weblocks" 14 | :depends-on (:weblocks) 15 | :components ((:file "yui"))) 16 | 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Weblocks 2 | ======== 3 | 4 | [![Build Status](https://travis-ci.org/skypher/weblocks.svg?branch=master)](https://travis-ci.org/skypher/weblocks) 5 | 6 | Weblocks is an advanced web framework written in Common Lisp. 7 | 8 | [Offical Weblocks site](http://weblocks-framework.info) 9 | 10 | Currently your web application should depend on :weblocks and :weblocks-prototype-js packages to work. 11 | [Weblocks PrototypeJs backend](http://github.com/html/weblocks-prototype-js) 12 | -------------------------------------------------------------------------------- /test/snippets/html-utils-helper.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; utilities for easier testing 5 | (defun link-action-template (action name &key (uri "/foo/bar") id class) 6 | `(:a :id ,id 7 | :class ,class 8 | :href ,(format nil "~A?action=~A" uri action) 9 | :onclick ,(format nil "initiateAction(\"~A\", ~ 10 | \"weblocks-session=1%3ATEST\"); ~ 11 | return false;" action) 12 | ,name)) 13 | 14 | -------------------------------------------------------------------------------- /test/control-flow/workflow.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test with-flow 5 | (deftest with-flow-1 6 | (with-request :get nil 7 | (let* ((w1 (make-instance 'composite)) 8 | (w2 (make-instance 'composite)) 9 | (c1 (make-instance 'composite :widgets w1))) 10 | (with-flow w1 11 | (yield w2)) 12 | (values (eq (car (composite-widgets c1)) w2) 13 | (progn (answer w2) 14 | (null (composite-widgets w1)))))) 15 | t t) 16 | 17 | -------------------------------------------------------------------------------- /test/widgets/widget/widget-mop.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test direct-slot-definition-class for widget 5 | (deftest direct-slot-definition-class-widget-1 6 | (class-name (direct-slot-definition-class (find-class 'widget))) 7 | weblocks::widget-direct-slot-definition) 8 | 9 | ;;; test effective-slot-definition-class for widget 10 | (deftest effective-slot-definition-class-widget-1 11 | (class-name (effective-slot-definition-class (find-class 'widget))) 12 | weblocks::widget-effective-slot-definition) 13 | -------------------------------------------------------------------------------- /src/control-flow/workflow.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(with-flow yield)) 5 | 6 | (defmacro with-flow (widget &body body) 7 | "Eases the burden of creating flows. Instead of using 'do-widget' in 8 | the body, one can use 'yield', which will expand into appropriate 9 | 'do-widget' code." 10 | (let ((w (gensym))) 11 | `(let ((,w ,widget)) 12 | (declare (ignorable ,w)) 13 | (macrolet ((yield (target) 14 | `(do-widget ,',w ,target))) 15 | (with-call/cc 16 | ,@body))))) 17 | 18 | -------------------------------------------------------------------------------- /src/views/formview/helpers.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(make-slot-writer)) 5 | 6 | (defun make-slot-writer (slot-name slot-reader) 7 | "Returns a function that accepts a value and object and stores the 8 | value transformed by 'slot-reader' in the object's 'slot-name'. This 9 | is useful when declaring writers in the UI that should record the 10 | object ID instead of the object itself." 11 | (lambda (value obj) 12 | (setf (slot-value obj slot-name) 13 | (when value 14 | (funcall slot-reader value))))) 15 | 16 | -------------------------------------------------------------------------------- /contrib/yarek/weblocks-yarek.asd: -------------------------------------------------------------------------------- 1 | ;;; weblocks-yarek.asd: Another ASDF system definition. 2 | 3 | (in-package #:cl-user) 4 | 5 | (asdf:defsystem "weblocks-yarek" 6 | :description "Yarek Kowalik's extensions to Weblocks." 7 | :version "0.1" 8 | :author "Yarek Kowalik " 9 | :licence "LLGPL" 10 | :depends-on ("weblocks") 11 | :components ((:file "package") 12 | (:module widgets 13 | :components ((:file "popover-gridedit")) 14 | :depends-on ("package")))) 15 | 16 | ;;; weblocks-yarek.asd ends here 17 | -------------------------------------------------------------------------------- /test/views/view/compiler.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test view-argument-quoting-strategy 5 | (deftest view-argument-quoting-strategy-1 6 | (view-argument-quoting-strategy 'some-arg) 7 | :none) 8 | 9 | ;;; Test quote-property-list-arguments 10 | (deftest quote-property-list-arguments-1 11 | (weblocks::quote-property-list-arguments '(:a 1 :b 2 :c 3)) 12 | (:a 1 :b 2 :c 3)) 13 | 14 | (deftest quote-property-list-arguments-2 15 | (weblocks::quote-property-list-arguments '(:a 1 :initform foo :b 2)) 16 | (:a 1 :initform 'foo :b 2)) 17 | 18 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/README: -------------------------------------------------------------------------------- 1 | To run, you'll need to modify the paths in rundemo.lisp to match 2 | your system, then just run that (i.e. "sbcl --load rundemo.lisp") or 3 | whatever. Note that you'll get the REPL back with very little 4 | feedback; this means the server is running on port 8080. 5 | 6 | To see the demo be persistent across different runs of the server, 7 | comment out every reference to the sandbox store, and in cases where 8 | simply commenting them out won't work (i.e. (find-persistent-objects 9 | (sandbox-store) ...)) replace (sandbox-store) with 10 | *prevalence-store* 11 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/README: -------------------------------------------------------------------------------- 1 | To run, you'll need to modify the paths in rundemo.lisp to match 2 | your system, then just run that (i.e. "sbcl --load rundemo.lisp") or 3 | whatever. Note that you'll get the REPL back with very little 4 | feedback; this means the server is running on port 8080. 5 | 6 | To see the demo be persistent across different runs of the server, 7 | comment out every reference to the sandbox store, and in cases where 8 | simply commenting them out won't work (i.e. (find-persistent-objects 9 | (sandbox-store) ...)) replace (sandbox-store) with 10 | *prevalence-store* 11 | -------------------------------------------------------------------------------- /src/utils/i18n.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks-util) 2 | 3 | ; i18n utils 4 | 5 | (wexport '(*translation-function* translate default-translation-function) 6 | '(t util)) 7 | 8 | (defvar *translation-function* 'default-translation-function) 9 | 10 | (defun translate (string &rest scope) 11 | "Translates given string by calling *translation-function* 12 | with string and 'scope'. 13 | 'scope' is a set of function key arguments which can be 14 | :accusative-form-p 15 | :genitive-form-p 16 | :items-count 17 | :preceding-count" 18 | (apply *translation-function* (list* string scope))) 19 | -------------------------------------------------------------------------------- /test/views/types/presentations/textarea.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test textarea-presentation render-view-field-value 5 | (deftest-html textarea-presentation-render-view-field-value-1 6 | (render-view-field-value "Hello World!" 7 | (make-instance 'textarea-presentation) 8 | (make-instance 'form-view-field 9 | :slot-name 'foo) 10 | (make-instance 'form-view) 11 | nil *joe*) 12 | (:textarea :name "foo" :rows "10" :cols "50" "Hello World!")) 13 | 14 | -------------------------------------------------------------------------------- /contrib/s11001001/weblocks-s11.asd: -------------------------------------------------------------------------------- 1 | ;;; weblocks-s11.asd: Another ASDF system definition. 2 | 3 | (in-package #:cl-user) 4 | 5 | (asdf:defsystem "weblocks-s11" 6 | :description "Stephen Compall's extensions to Weblocks." 7 | :version "0.1" 8 | :author "Stephen Compall " 9 | :licence "LLGPL" 10 | :depends-on ("arnesi" "weblocks") 11 | :components ((:file "package") 12 | (:file "dataedit" :depends-on ("package")) 13 | (:file "persist-children" :depends-on ("package")) 14 | (:file "presentations" :depends-on ("package")))) 15 | 16 | ;;; weblocks-s11.asd ends here 17 | -------------------------------------------------------------------------------- /docs/goals.txt: -------------------------------------------------------------------------------- 1 | 2 | A modern web framework must have: 3 | 1. A simple, persistent and temporary model layer - elephant 4 | 2. A set of flexible, customizable generic renderers 5 | 3. A set of flexible, extensible widgets (do rendering, maintain UI state, etc.) 6 | 4. Good looks out of the box 7 | 5. Architectural guidance (how to create widgets, where to put them, widget interaction, callbacks, etc.) 8 | ?6. Support for natural modal coding 9 | ?7. Support for maintaining/reloading/versioning UI state 10 | 11 | Options: 12 | - A thread per session 13 | - Rebuild widgets (ala ASP.NET), use some sort of monadic/cps code for modal code 14 | -------------------------------------------------------------------------------- /test/utils-test/runtime-class.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftest make-class-1 5 | (let ((obj (make-instance (make-class '(foo bar baz))))) 6 | (values (slot-value obj 'foo) 7 | (slot-value obj 'bar) 8 | (slot-value obj 'baz))) 9 | nil nil nil) 10 | 11 | (deftest make-class-2 12 | (let ((obj (make-instance (make-class '(foo bar baz))))) 13 | (setf (slot-value obj 'foo) 1 14 | (slot-value obj 'bar) 2 15 | (slot-value obj 'baz) 3) 16 | (values (slot-value obj 'foo) 17 | (slot-value obj 'bar) 18 | (slot-value obj 'baz))) 19 | 1 2 3) 20 | 21 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/model/address.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;;; Address 5 | (defclass address () 6 | ((street :initform nil 7 | :accessor address-street 8 | :initarg :street) 9 | (city :initform nil 10 | :accessor address-city 11 | :initarg :city) 12 | (state :initform nil 13 | :accessor address-state 14 | :type (or us-state null) 15 | :initarg :state))) 16 | 17 | ;;; Form View 18 | (defview address-form-view (:type form 19 | :inherit-from '(:scaffold address) 20 | :persistp nil)) 21 | 22 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/model/address.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Address 5 | (defclass address () 6 | ((street :initform nil 7 | :accessor address-street 8 | :initarg :street) 9 | (city :initform nil 10 | :accessor address-city 11 | :initarg :city) 12 | (state :initform nil 13 | :accessor address-state 14 | :type (or us-state null) 15 | :initarg :state))) 16 | 17 | ;;; Form View 18 | (defview address-form-view (:type form 19 | :inherit-from '(:scaffold address) 20 | :persistp nil)) 21 | 22 | -------------------------------------------------------------------------------- /test/widgets/data-editor.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weblocks-test) 3 | 4 | (deftestsuite widgets/data-editor-suite (weblocks-suite) 5 | ()) 6 | 7 | (addtest reinterpret-dataform-in-data-accessor 8 | (let* ((obj (make-instance 'employee)) 9 | (wij (make-instance 'dataform :data obj))) 10 | (dolist (d (list (dataform-data wij) 11 | (progn (change-class wij 'data-editor) 12 | (dataform-data wij)))) 13 | (ensure-same d obj)))) 14 | 15 | (addtest dataform-i18n-1 16 | (ensure-alist-has-keys 17 | (widget-translation-table 18 | (make-instance 'dataform :data *joe*)) 19 | (list :close-link-title :modify-link-title))) 20 | -------------------------------------------------------------------------------- /scripts/new-app-templates/{APPNAME}.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:{APPNAME}-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :{APPNAME}-asd) 6 | 7 | (defsystem {APPNAME} 8 | :name "{APPNAME}" 9 | :version "0.0.1" 10 | :maintainer "" 11 | :author "" 12 | :licence "" 13 | :description "{APPNAME}" 14 | :depends-on (:weblocks :weblocks-jquery-js) 15 | :components ((:file "{APPNAME}") 16 | (:module conf 17 | :components ((:file "stores")) 18 | :depends-on ("{APPNAME}")) 19 | (:module src 20 | :components ((:file "init-session")) 21 | :depends-on ("{APPNAME}" conf)))) 22 | 23 | -------------------------------------------------------------------------------- /test/views/types/member.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test member typespec->view-field-presentation 5 | (deftest member-typespec->view-field-presentation-1 6 | (object-class-name 7 | (cadr 8 | (multiple-value-list 9 | (typespec->view-field-presentation (make-instance 'form-scaffold) 10 | 'member nil)))) 11 | radio-presentation) 12 | 13 | ;;; Test member typespec->form-view-field-parser 14 | (deftest member-typespec->form-view-field-parser-1 15 | (object-class-name 16 | (cadr 17 | (multiple-value-list 18 | (typespec->form-view-field-parser (make-instance 'form-scaffold) 19 | 'member nil)))) 20 | keyword-parser) 21 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/employer-employee.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:employer-employee 3 | (:use :cl :weblocks :metatilities :weblocks-yarek) 4 | (:documentation 5 | "A web application based on Weblocks.")) 6 | 7 | (in-package :employer-employee) 8 | 9 | (export '(start-employer-employee stop-employer-employee)) 10 | 11 | (defun start-employer-employee (&rest args) 12 | "Starts the application by calling 'start-weblocks' with appropriate 13 | arguments." 14 | (apply #'start-weblocks args)) 15 | 16 | (defun stop-employer-employee () 17 | "Stops the application by calling 'stop-weblocks'." 18 | (stop-weblocks)) 19 | 20 | ;;; A sandbox store macro 21 | (defmacro sandbox-store () 22 | "Access to a sandbox store in the session." 23 | `(hunchentoot:session-value 'sandbox-store)) 24 | 25 | -------------------------------------------------------------------------------- /src/widgets/composite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; COMPATIBILITY INTERFACE 3 | ;;;; 4 | ;;;; do not use in new code! 5 | ;;;; 6 | 7 | (in-package :weblocks) 8 | 9 | (export '(composite composite-widgets root-composite)) 10 | 11 | (defwidget composite (widget) 12 | ()) 13 | 14 | (defmethod initialize-instance :around ((obj composite) &rest initargs &key widgets &allow-other-keys) 15 | (remf initargs :widgets) 16 | (apply #'call-next-method obj :children widgets initargs)) 17 | 18 | (defmethod composite-widgets (comp) (widget-children comp)) 19 | 20 | (defmethod (setf composite-widgets) (value comp) 21 | (setf (widget-children comp) value)) 22 | 23 | (defmacro root-composite () 24 | "Expands to code that can be used as a place to access to the root 25 | composite." 26 | `(webapp-session-value 'root-widget)) 27 | 28 | -------------------------------------------------------------------------------- /weblocks-scripts.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:weblocks-scripts-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :weblocks-scripts-asd) 6 | 7 | (defsystem weblocks-scripts 8 | :name "weblocks-scripts" 9 | :version "0.0.2" 10 | :maintainer "Olexiy Zamkoviy, Scott L. Burson" 11 | :author "Slava Akhmechet" 12 | :licence "LLGPL" 13 | :description "A set of scripts for weblocks framework." 14 | :depends-on ("cl-fad" "cl-ppcre") 15 | :components ((:module scripts 16 | :components ( 17 | (:file "weblocks-scripts") 18 | (:file "gen-doc" 19 | :depends-on ("weblocks-scripts")) 20 | (:file "make-new-app" 21 | :depends-on ("weblocks-scripts")))))) 22 | 23 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/model/employee.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;;; Employee 5 | (defclass employee (person) 6 | ((company-id 7 | :accessor employee-company-id 8 | :initarg :company-id 9 | :type integer) 10 | 11 | (contract :accessor employee-contract 12 | :initarg :contract))) 13 | 14 | ;;; Table View 15 | (defview employee-table-view (:type table :inherit-from 'person-table-view)) 16 | 17 | ;;; Data View 18 | (defview employee-data-view (:type data :inherit-from 'person-data-view) 19 | contract) 20 | 21 | ;;; Form View 22 | (defview employee-form-view (:type form :inherit-from 'person-form-view) 23 | (contract :present-as (radio :choices '(:full-time :part-time :consultant :intern)) 24 | :parse-as keyword)) 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/weblocks-demo-popover.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:weblocks-demo-popover 3 | (:use :cl :weblocks :metatilities :weblocks-yarek) 4 | (:documentation 5 | "A web application based on Weblocks.")) 6 | 7 | (in-package :weblocks-demo-popover) 8 | 9 | (export '(start-weblocks-demo-popover stop-weblocks-demo-popover)) 10 | 11 | (defun start-weblocks-demo-popover (&rest args) 12 | "Starts the application by calling 'start-weblocks' with appropriate 13 | arguments." 14 | (apply #'start-weblocks args)) 15 | 16 | (defun stop-weblocks-demo-popover () 17 | "Stops the application by calling 'stop-weblocks'." 18 | (stop-weblocks)) 19 | 20 | ;;; A sandbox store macro 21 | (defmacro sandbox-store () 22 | "Access to a sandbox store in the session." 23 | `(hunchentoot:session-value 'sandbox-store)) 24 | 25 | -------------------------------------------------------------------------------- /src/utils/repl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(sessions in-session pt)) 5 | 6 | (declaim (special *weblocks-server*)) 7 | 8 | (defun sessions () 9 | (hunchentoot:session-db *weblocks-server*)) 10 | 11 | (defun in-session (&optional sid) 12 | "Enter a session context. If SID is supplied the session with 13 | this id will be selected. Otherwise the first session (likely 14 | the one started most recently) will be selected" 15 | (setf hunchentoot:*session* 16 | (if sid 17 | (cdr (assoc sid (sessions))) 18 | (cdar (sessions))))) 19 | 20 | (defun pt (&optional (stream t)) 21 | "Print the current session's widget tree" 22 | (walk-widget-tree (root-widget) 23 | (lambda (w d) 24 | (loop repeat d do (format stream " ")) 25 | (format stream "~S~%" w)))) 26 | -------------------------------------------------------------------------------- /test/views/sequence-view.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftest-html render-object-view-impl-empty-sequence-1 5 | (render-object-view-impl nil (make-instance 'sequence-view) nil) 6 | (:div :class "view sequence empty" 7 | (:div :class "extra-top-1" "") 8 | (:div :class "extra-top-2" "") 9 | (:div :class "extra-top-3" "") 10 | (:p :class "user-message" (:span :class "message" "No information available.")) 11 | (:div :class "extra-bottom-1" "") 12 | (:div :class "extra-bottom-2" "") 13 | (:div :class "extra-bottom-3" ""))) 14 | 15 | (addtest sequence-view-i18n-1 16 | (ensure-alist-has-keys 17 | (widget-translation-table (make-instance 'sequence-view)) 18 | (list :empty-message))) 19 | 20 | -------------------------------------------------------------------------------- /contrib/lpolzer/gauge.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(gauge gauge-value gauge-maximum)) 5 | 6 | 7 | (defwidget gauge (widget) 8 | ((value :type real :accessor gauge-value :initarg :value :initform 0) 9 | (maximum :type real :accessor gauge-maximum :initarg :maximum :initform 1))) 10 | 11 | 12 | (defmethod with-widget-header ((widget gauge) body-fn &rest args &key 13 | prewidget-body-fn postwidget-body-fn &allow-other-keys) 14 | (apply body-fn widget args)) 15 | 16 | 17 | (defmethod render-widget-body ((gauge gauge) &rest args) 18 | (declare (ignore args)) 19 | (let ((percentage (round (* (gauge-value gauge) 100) 20 | (gauge-maximum gauge)) )) 21 | (with-html 22 | (:div :class "widget gauge" 23 | :style (format nil "width:~,0D%" percentage))))) 24 | 25 | -------------------------------------------------------------------------------- /test/views/tableview/test-template.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; utilities for easier testing 5 | (defun table-header-template (headers rows &key summary pretable posttable 6 | (table-class "employee")) 7 | `(:div :class ,(format nil "view table ~A" table-class) 8 | (:div :class "extra-top-1" "") 9 | (:div :class "extra-top-2" "") 10 | (:div :class "extra-top-3" "") 11 | ,@pretable 12 | (:table :summary ,summary 13 | (:thead 14 | (:tr 15 | ,@headers)) 16 | (:tbody 17 | ,@rows)) 18 | ,@posttable 19 | (:div :class "extra-bottom-1" "") 20 | (:div :class "extra-bottom-2" "") 21 | (:div :class "extra-bottom-3" ""))) 22 | -------------------------------------------------------------------------------- /src/utils/runtime-class.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (wexport '(make-class) '(t util)) 5 | 6 | (defun make-class (slots &optional (class-name (gensym))) 7 | "Makes an anonymous class with a number of slots. 8 | 'slots' - a list of symbols to be used as slot names." 9 | (ensure-class class-name 10 | :direct-superclasses (list (find-class 'standard-object)) 11 | :direct-slots (mapcar (lambda (slot) 12 | (list :name slot 13 | :readers nil 14 | :writers nil 15 | :initargs nil 16 | :initform nil 17 | :initfunction (constantly nil))) 18 | slots))) 19 | 20 | -------------------------------------------------------------------------------- /contrib/nunb/functioncall.lisp: -------------------------------------------------------------------------------- 1 | (in-package :app) 2 | 3 | (defclass functioncall-presentation (text-presentation) 4 | ((function :accessor get-function :initarg :function))) 5 | 6 | (defmethod render-view-field-value (value (presentation functioncall-presentation) 7 | field view widget obj &rest args 8 | &key highlight &allow-other-keys) 9 | (declare (ignore args highlight)) 10 | (if (null value) 11 | (call-next-method) 12 | (with-html 13 | (:span :class "text" 14 | (str (funcall (get-function presentation) 15 | value)))))) 16 | 17 | 18 | (defmethod print-view-field-value ((value standard-object) (p functioncall-presentation) field view widget obj &rest args) 19 | (declare (ignore obj view field args)) 20 | (format nil " ~A" (funcall (get-function p) value))) 21 | 22 | 23 | -------------------------------------------------------------------------------- /pub/stylesheets/debug-toolbar.css: -------------------------------------------------------------------------------- 1 | 2 | .debug-toolbar 3 | { 4 | background-color: #d0d0d0; 5 | border-top: #f5f5f5 1px solid; 6 | 7 | width: 100%; 8 | text-align: left; 9 | } 10 | 11 | /* 'position: fixed' for all modern browsers */ 12 | body > .debug-toolbar 13 | { 14 | position: fixed; 15 | left: 0; 16 | bottom: 0; 17 | } 18 | 19 | /* IE 6 specific fix for lack of 'position: fixed' implementation */ 20 | * html .debug-toolbar 21 | { 22 | position: absolute; 23 | /* in case JS is turned off */ 24 | left: 0; 25 | /* in case JS is on */ 26 | left: expression((documentElement.scrollLeft) + 'px'); 27 | top: expression((documentElement.scrollTop 28 | + (documentElement.clientHeight - this.clientHeight - 1)) 29 | + 'px'); 30 | width: expression((document.documentElement.clientWidth) + 'px'); 31 | } 32 | 33 | .debug-toolbar img 34 | { 35 | border: none; 36 | } 37 | -------------------------------------------------------------------------------- /test/views/formview/scaffold.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test form scaffold generate-scaffold-view 5 | (deftest form-scaffold-generate-scaffold-view-1 6 | (object-class-name 7 | (generate-scaffold-view (make-instance 'form-scaffold) 8 | (find-class 'employee))) 9 | form-view) 10 | 11 | ;;; Test form scaffold generate-scaffold-view 12 | (deftest form-scaffold-generate-scaffold-view-field-1 13 | (object-class-name 14 | (generate-scaffold-view-field (make-instance 'form-scaffold) 15 | (find-class 'employee) 16 | (find-slot-dsd 'employee 'name))) 17 | form-view-field) 18 | 19 | ;;; Test typespec->form-view-field-parser 20 | (deftest typespec->form-view-field-parser-1 21 | (typespec->form-view-field-parser (make-instance 'form-scaffold) 22 | 'foobar nil) 23 | nil) 24 | 25 | -------------------------------------------------------------------------------- /src/views/types/presentations/hidden.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | (in-package :weblocks) 4 | 5 | (export '(hidden hidden-presentation)) 6 | 7 | ;;; hidden presentation 8 | (defclass hidden-presentation (input-presentation) 9 | () 10 | (:documentation "A presentation that outputs no HTML")) 11 | 12 | (defmethod render-view-field ((field form-view-field) 13 | (view form-view) 14 | widget 15 | (presentation hidden-presentation) 16 | value obj &rest args) 17 | (declare (ignore field view widget presentation value obj args))) 18 | 19 | (defmethod render-view-field ((field data-view-field) 20 | (view data-view) 21 | widget 22 | (presentation hidden-presentation) 23 | value obj &rest args) 24 | (declare (ignore field view widget presentation value obj args))) 25 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/conf/stores.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;;; Multiple stores may be defined. The last defined store will be the 5 | ;;; default. In the case of weblocks demo static store configuration 6 | ;;; isn't used - we dynamically create stores for each session because 7 | ;;; we need to sandbox users. We only create static configurations to 8 | ;;; load appropriate store code during application startup. 9 | 10 | ;;; Memory store 11 | (defstore *scratch-store* :memory) 12 | 13 | ;;; Prevalence store... 14 | (defstore *prevalence-store* :prevalence 15 | (merge-pathnames (make-pathname :directory '(:relative "data")) 16 | (asdf-system-directory :employer-employee))) 17 | 18 | ;;; CLSQL store 19 | ;; (defstore *sql-store* :clsql '("localhost" "test" "username" "password") 20 | ;; :database-type :mysql) 21 | 22 | ;;; Cascade delete should be turned off for prevalence store 23 | (setf *default-cascade-delete-mixins-p* nil) 24 | 25 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/conf/stores.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Multiple stores may be defined. The last defined store will be the 5 | ;;; default. In the case of weblocks demo static store configuration 6 | ;;; isn't used - we dynamically create stores for each session because 7 | ;;; we need to sandbox users. We only create static configurations to 8 | ;;; load appropriate store code during application startup. 9 | 10 | ;;; Memory store 11 | (defstore *scratch-store* :memory) 12 | 13 | ;;; Prevalence store... 14 | (defstore *prevalence-store* :prevalence 15 | (merge-pathnames (make-pathname :directory '(:relative "data")) 16 | (asdf-system-directory :weblocks-demo-popover))) 17 | 18 | ;;; CLSQL store 19 | ;; (defstore *sql-store* :clsql '("localhost" "test" "username" "password") 20 | ;; :database-type :mysql) 21 | 22 | ;;; Cascade delete should be turned off for prevalence store 23 | (setf *default-cascade-delete-mixins-p* nil) 24 | 25 | -------------------------------------------------------------------------------- /src/views/types/member.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | ;;; Scaffolding magic 5 | (defmethod typespec->view-field-presentation ((scaffold form-scaffold) 6 | (typespec (eql 'member)) args) 7 | (values t (make-instance 'radio-presentation 8 | :choices (if (every (lambda (arg) 9 | (or (symbolp arg) 10 | (stringp arg))) args) 11 | args 12 | (mapcar (curry #'format nil "~A") 13 | args))))) 14 | 15 | (defmethod typespec->form-view-field-parser ((scaffold form-scaffold) 16 | (typespec (eql 'member)) args) 17 | (cond 18 | ((every #'keywordp args) (values t (make-instance 'keyword-parser))) 19 | ((every #'symbolp args) (values t (make-instance 'symbol-parser))) 20 | (t nil))) 21 | 22 | -------------------------------------------------------------------------------- /test/views/types/password.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test password render-view-field-value 5 | (deftest-html password-render-view-field-value-1 6 | (let ((*presentation-dom-id* 0)) 7 | (render-view-field-value "foo" (make-instance 'password-presentation) 8 | (make-instance 'form-view-field 9 | :slot-name 'password) 10 | (find-view '(form employee)) 11 | nil *joe*)) 12 | (:input :type "password" :name "password" :id "0" :maxlength "12" :class "password")) 13 | 14 | ;;; Test password print-view-field-value 15 | (deftest password-print-view-field-value-1 16 | (print-view-field-value "foo" (make-instance 'password-presentation) 17 | (make-instance 'form-view-field 18 | :slot-name 'password) 19 | (find-view '(form employee)) 20 | nil *joe*) 21 | "*******") 22 | 23 | -------------------------------------------------------------------------------- /src/application-mop.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(webapp-class)) 5 | 6 | (defclass webapp-class (standard-class) 7 | ((home-package 8 | :accessor webapp-class-home-package :initform *package* 9 | :documentation "The current package when I was defined.") 10 | (default-store-name 11 | :accessor webapp-default-store-name :initform nil 12 | :documentation "If non-nil, the name of the `*default-store*' 13 | bound during request handlers.")) 14 | (:documentation "The class of all webapp classes.")) 15 | 16 | (defmethod validate-superclass ((self webapp-class) (super standard-class)) 17 | (typep (class-name (class-of super)) 18 | '(member standard-class webapp-class))) 19 | 20 | (defmethod shared-initialize :after 21 | ((self webapp-class) slots &key autostart &allow-other-keys) 22 | (declare (ignore slots)) 23 | (let ((name (class-name self))) 24 | (pushnew name (symbol-value '*registered-webapps*)) 25 | (when autostart 26 | (pushnew name (symbol-value '*autostarting-webapps*))))) 27 | 28 | -------------------------------------------------------------------------------- /src/views/types/presentations/html.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weblocks) 2 | 3 | (export '(html-presentation)) 4 | 5 | (defclass html-presentation (text-presentation) 6 | () 7 | (:documentation "A presentation that simply renders its value as-is, 8 | without any escaping, allowing for HTML inclusion.")) 9 | 10 | (defun html-presentation-field-value-wt (&key value) 11 | (with-html-to-string 12 | (:span :class "value" 13 | (str value)))) 14 | 15 | (deftemplate :html-presentation-field-value-wt #'html-presentation-field-value-wt) 16 | 17 | (defmethod render-view-field-value (value (presentation html-presentation) 18 | field view widget obj &rest args 19 | &key &allow-other-keys) 20 | (let ((printed-value (apply #'print-view-field-value value presentation field view widget obj args))) 21 | (render-wt 22 | :html-presentation-field-value-wt 23 | (list :field field :view view :widget widget :object obj :presentation presentation) 24 | :value printed-value))) 25 | -------------------------------------------------------------------------------- /src/views/view/presentation.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(presentation)) 5 | 6 | (eval-when (:compile-toplevel :load-toplevel :execute) 7 | (defmethod view-argument-quoting-strategy ((arg-name (eql :present-as))) 8 | :list) 9 | 10 | (setf (gethash :present-as *custom-view-field-argument-compilers*) 11 | (lambda (slot-name presentation) 12 | (let ((presentation (ensure-list presentation))) 13 | `(setf (view-field-presentation ,slot-name) 14 | (funcall #'make-instance (presentation-class-name ',(car presentation)) 15 | ,@(quote-property-list-arguments 16 | (cdr presentation)))))))) 17 | 18 | (defclass presentation () 19 | () 20 | (:documentation "Base class for all presentations. Exists in order 21 | to help manage CSS and JavaScript dependencies for presentations.")) 22 | 23 | ;; by default presentations have no dependencies, so the primary method 24 | ;; returns nil 25 | (defmethod dependencies append ((obj presentation)) 26 | ()) 27 | -------------------------------------------------------------------------------- /test/views/dataview/test-template.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; utilities for easier testing 5 | (defun data-header-template (action body &key (data-class-name "employee") preslots 6 | (postslots `((:div :class "submit" 7 | ,(link-action-template action "Modify" 8 | :class "modify"))))) 9 | `(:div :class ,(format nil "view data ~(~A~)" data-class-name) 10 | (:div :class "extra-top-1" "") 11 | (:div :class "extra-top-2" "") 12 | (:div :class "extra-top-3" "") 13 | (:h1 (:span :class "action" "Viewing: ") 14 | (:span :class "object" ,(humanize-name data-class-name))) 15 | ,@preslots 16 | (:ul ,@body) 17 | ,@postslots 18 | (:div :class "extra-bottom-1" "") 19 | (:div :class "extra-bottom-2" "") 20 | (:div :class "extra-bottom-3" ""))) 21 | 22 | -------------------------------------------------------------------------------- /src/widgets/widget/string-widget.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(string-widget string-widget-content string-widget-escape-p)) 5 | 6 | (defwidget string-widget () 7 | ((content :type string 8 | :accessor string-widget-content 9 | :initarg :content) 10 | (escape-p :type boolean 11 | :accessor string-widget-escape-p 12 | :initarg :escape-p 13 | :initform t 14 | :documentation "Whether to escape the output 15 | for HTML."))) 16 | 17 | (defmethod render-widget-body ((widget string-widget) &rest args &key id class &allow-other-keys) 18 | (declare (ignore args)) 19 | (let ((content (if (string-widget-escape-p widget) 20 | (escape-string (string-widget-content widget)) 21 | (string-widget-content widget)))) 22 | (with-html 23 | (:p :id id :class class (str content))))) 24 | 25 | (defmethod make-widget ((obj string)) 26 | "Create a widget from a string." 27 | (make-instance 'string-widget :content obj)) 28 | 29 | -------------------------------------------------------------------------------- /test/views/types/presentations/paragraph.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test paragraph-presentation render-view-field-value 5 | (deftest-html paragraph-presentation-paragraph-presentation-1 6 | (render-view-field-value "Hello World!" 7 | (make-instance 'paragraph-presentation) 8 | (make-instance 'data-view-field 9 | :slot-name 'foo) 10 | (make-instance 'data-view) 11 | nil *joe*) 12 | (:p :class "value text" "Hello World!")) 13 | 14 | (deftest-html paragraph-presentation-paragraph-presentation-2 15 | (render-view-field-value (format nil "Hello~%World!") 16 | (make-instance 'paragraph-presentation) 17 | (make-instance 'data-view-field 18 | :slot-name 'foo) 19 | (make-instance 'data-view) 20 | nil *joe*) 21 | (:p :class "value text" "Hello
World!")) 22 | 23 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/model/company.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; All companies 5 | (defun all-companies (&optional arg) 6 | "Accepts an argument (passed by dropdown choices) and returns all 7 | available companies." 8 | (declare (ignore arg)) 9 | (find-persistent-objects (sandbox-store) 'company 10 | :order-by (cons 'name :asc))) 11 | 12 | ;;; Company 13 | (defclass company () 14 | ((id :accessor company-id) 15 | (name :accessor company-name 16 | :initarg :name 17 | :type string) 18 | (industry :initform nil 19 | :accessor company-industry 20 | :initarg :industry) 21 | (non-profit :initform nil 22 | :accessor company-non-profit-p 23 | :initarg :non-profit-p 24 | :type boolean))) 25 | 26 | ;;; Table View 27 | (defview company-table-view (:type table :inherit-from '(:scaffold company)) 28 | (id :hidep t)) 29 | 30 | ;;; Form View 31 | (defview company-form-view (:type form :inherit-from '(:scaffold company)) 32 | (id :hidep t)) 33 | 34 | -------------------------------------------------------------------------------- /run-tests.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros dynamic-space-size=4096 -Q -- $0 "$@" 5 | |# 6 | (progn ;;init forms 7 | (ros:ensure-asdf) 8 | 9 | (handler-case (ql:quickload :weblocks-test) 10 | (error (c) 11 | (format t "~%Unable to load :WEBLOCKS-TEST~%Error was: ~a~2%" 12 | c) 13 | (uiop:quit 3)))) 14 | 15 | 16 | (defpackage :ros.script.run-tests.3700466499 17 | (:use :cl)) 18 | (in-package :ros.script.run-tests.3700466499) 19 | 20 | 21 | (defun main (&rest argv) 22 | (declare (ignorable argv)) 23 | 24 | (format t "~%WEBLOCKS-TEST's location: ~a~2%" 25 | (ql:where-is-system :weblocks-test)) 26 | 27 | (ignore-errors 28 | (let ((result (weblocks-test:test-weblocks))) 29 | 30 | (if (lift:errors result) 31 | (progn (format t "~3&There were some errors in tests.~%") 32 | (uiop:quit 1)) 33 | (progn (format t "~3&Success.~%") 34 | (uiop:quit 0))))) 35 | 36 | (format t "~3&There were some errors from test framework.~%") 37 | (uiop:quit 2)) 38 | 39 | ;;; vim: set ft=lisp lisp: 40 | -------------------------------------------------------------------------------- /test/views/view/view.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test entity-class-name 5 | (deftest entity-class-name-1 6 | (entity-class-name 'data '#:-view) 7 | data-view) 8 | 9 | (deftest entity-class-name-2 10 | (entity-class-name 'form '#:-scaffold) 11 | form-scaffold) 12 | 13 | (deftest entity-class-name-3 14 | (multiple-value-bind (res err) 15 | (ignore-errors 16 | (entity-class-name 'doesnt '#:-exist)) 17 | (declare (ignore err)) 18 | res) 19 | nil) 20 | 21 | ;;; Test view-class-name 22 | (deftest view-class-name-1 23 | (view-class-name 'data) 24 | data-view) 25 | 26 | ;;; Test view-default-field-type 27 | (deftest view-default-field-type-1 28 | (view-default-field-type 'form nil) 29 | form) 30 | 31 | (deftest view-default-field-type-2 32 | (view-default-field-type 'form 'data) 33 | data) 34 | 35 | ;;; Test view-field-class-name 36 | (deftest view-field-class-name-1 37 | (view-field-class-name 'data) 38 | data-view-field) 39 | 40 | ;;; Test presentation-class-name 41 | (deftest presentation-class-name-1 42 | (presentation-class-name 'input) 43 | input-presentation) 44 | 45 | -------------------------------------------------------------------------------- /test/views/types/presentations/image.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test image-presentation render-view-field-value 5 | (deftest-html image-presentation-1 6 | (render-view-field-value "www.hello.com" 7 | (make-instance 'image-presentation) 8 | (make-instance 'data-view-field 9 | :slot-name 'foo) 10 | (make-instance 'data-view) 11 | nil *joe*) 12 | (:div 13 | (:img :src "www.hello.com"))) 14 | 15 | (deftest-html image-presentation-2 16 | (render-view-field-value "www.hello.com" 17 | (make-instance 'image-presentation 18 | :alt "foo" 19 | :title "bar") 20 | (make-instance 'data-view-field 21 | :slot-name 'foo) 22 | (make-instance 'data-view) 23 | nil *joe*) 24 | (:div 25 | (:img :src "www.hello.com" :alt "foo" :title "bar"))) 26 | 27 | -------------------------------------------------------------------------------- /test/widgets/listedit.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftest-html render-widget-body-listedit-1 5 | (with-request :get nil 6 | (persist-object *default-store* *joe*) 7 | (let ((list (make-instance 'listedit :data-class 'employee 8 | :allow-sorting-p nil 9 | :allow-drilldown-p nil 10 | :allow-operations-p nil 11 | :allow-pagination-p nil))) 12 | (render-widget-body list))) 13 | (htm 14 | (:div :class "data-mining-bar" 15 | (:span :class "total-items" "(Total of 1 Employee)")) 16 | (:div :class "widget flash" :id "id-123" "") 17 | (:div :class "datalist-body" 18 | (:ol 19 | (:li 20 | #.(data-header-template 21 | nil 22 | '((:li :class "name" (:span :class "label text" "Name: ") 23 | (:span :class "value" "Joe")) 24 | (:li :class "manager" (:span :class "label text" "Manager: ") 25 | (:span :class "value" "Jim"))) 26 | :postslots nil)))))) 27 | 28 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/snippets.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Header 5 | (defun render-header (&rest args) 6 | (declare (ignore args)) 7 | "This function renders the page header." 8 | (with-html 9 | (:div :class "header" 10 | (with-extra-tags)))) 11 | 12 | ;;; Footer 13 | (defmethod render-page-body :after ((app weblocks-demo-popover) rendered-html) 14 | (with-html 15 | (:div :class "footer" 16 | (:p :id "system-info" 17 | "Running on " 18 | (str (concatenate 'string (server-type) " " (server-version))) 19 | " (" (str (concatenate 'string (lisp-implementation-type) " " 20 | (lisp-implementation-version))) ")") 21 | (:p :id "contact-info" 22 | "Contact me with any questions or comments at " 23 | (:a :href "mailto:coffeemug@gmail.com" "coffeemug@gmail.com") ".") 24 | (:img :src "/pub/images/footer/valid-xhtml11.png" :alt "This site has valid XHTML 1.1.") 25 | (:img :src "/pub/images/footer/valid-css.png" :alt "This site has valid CSS.")))) 26 | 27 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/sandbox.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;;; Custom copying from stores to sandbox users 5 | (defun init-sandbox-store () 6 | "Copies the fixtures from the disk store to a sandbox store (to 7 | ensure users have their own non-peristant sandboxes)." 8 | (let ((sandbox-store (open-store :memory)) 9 | (fixtures-store (open-store :prevalence 10 | (merge-pathnames (make-pathname :directory '(:relative "data")) 11 | (asdf-system-directory :employer-employee))))) 12 | (unwind-protect 13 | (progn 14 | (persist-objects sandbox-store (find-persistent-objects fixtures-store 'employee)) 15 | (persist-objects sandbox-store (find-persistent-objects fixtures-store 'company)) 16 | (setf (sandbox-store) sandbox-store)) 17 | (close-store fixtures-store)))) 18 | 19 | ;;; Instances of our model should be obtained from the sandbox store 20 | (defmethod class-store ((class-name (eql 'employee))) 21 | *prevalence-store*) 22 | 23 | (defmethod class-store ((class-name (eql 'company))) 24 | *prevalence-store*) 25 | 26 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/sandbox.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Custom copying from stores to sandbox users 5 | (defun init-sandbox-store () 6 | "Copies the fixtures from the disk store to a sandbox store (to 7 | ensure users have their own non-peristant sandboxes)." 8 | (let ((sandbox-store (open-store :memory)) 9 | (fixtures-store (open-store :prevalence 10 | (merge-pathnames (make-pathname :directory '(:relative "data")) 11 | (asdf-system-directory :weblocks-demo-popover))))) 12 | (unwind-protect 13 | (progn 14 | (persist-objects sandbox-store (find-persistent-objects fixtures-store 'employee)) 15 | (persist-objects sandbox-store (find-persistent-objects fixtures-store 'company)) 16 | (setf (sandbox-store) sandbox-store)) 17 | (close-store fixtures-store)))) 18 | 19 | ;;; Instances of our model should be obtained from the sandbox store 20 | (defmethod class-store ((class-name (eql 'employee))) 21 | (sandbox-store)) 22 | 23 | (defmethod class-store ((class-name (eql 'company))) 24 | (sandbox-store)) 25 | 26 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/model/person.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;;; Person 5 | (defclass person () 6 | ((id :accessor person-id) 7 | (first-name :accessor person-first-name 8 | :initarg :first-name) 9 | (last-name :accessor person-last-name 10 | :initarg :last-name 11 | :type string) 12 | (age :accessor person-age 13 | :initarg :age 14 | :type (or null integer)) 15 | (address :initform (make-instance 'address) 16 | :accessor person-address 17 | :initarg :address))) 18 | 19 | ;;; Table View 20 | (defview person-table-view (:type table :inherit-from '(:scaffold person)) 21 | (id :hidep t) 22 | (address :type mixin 23 | :view '(table address)) 24 | (street :hidep t) 25 | (city :hidep t)) 26 | 27 | ;;; Data View 28 | (defview person-data-view (:type data :inherit-from '(:scaffold person)) 29 | (id :hidep t) 30 | (address :type mixin 31 | :view '(data address))) 32 | 33 | ;;; Form View 34 | (defview person-form-view (:type form :inherit-from '(:scaffold person)) 35 | (id :hidep t) 36 | (address :type mixin 37 | :view 'address-form-view)) 38 | 39 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/model/employee.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Employee 5 | (defclass employee (person) 6 | ((company :accessor employee-company 7 | :initarg :company 8 | :type company) 9 | (contract :accessor employee-contract 10 | :initarg :contract))) 11 | 12 | ;;; Table View 13 | (defview employee-table-view (:type table :inherit-from 'person-table-view) 14 | (company :reader (compose #'company-name #'employee-company))) 15 | 16 | ;;; Data View 17 | (defview employee-data-view (:type data :inherit-from 'person-data-view) 18 | (company :reader (compose #'company-name #'employee-company)) 19 | contract) 20 | 21 | ;;; Form View 22 | (defview employee-form-view (:type form :inherit-from 'person-form-view) 23 | (company :present-as (dropdown :choices #'all-companies 24 | :label-key #'company-name) 25 | :parse-as (object-id :class-name 'company) 26 | :reader (compose #'object-id #'employee-company) 27 | :requiredp t) 28 | (contract :present-as (radio :choices '(:full-time :part-time :consultant :intern)) 29 | :parse-as keyword)) 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/model/person.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;;; Person 5 | (defclass person () 6 | ((id :accessor person-id) 7 | (first-name :accessor person-first-name 8 | :initarg :first-name) 9 | (last-name :accessor person-last-name 10 | :initarg :last-name 11 | :type string) 12 | (age :accessor person-age 13 | :initarg :age 14 | :type (or null integer)) 15 | (address :initform (make-instance 'address) 16 | :accessor person-address 17 | :initarg :address))) 18 | 19 | ;;; Table View 20 | (defview person-table-view (:type table :inherit-from '(:scaffold person)) 21 | (id :hidep t) 22 | (address :type mixin 23 | :view '(table address)) 24 | (street :hidep t) 25 | (city :hidep t)) 26 | 27 | ;;; Data View 28 | (defview person-data-view (:type data :inherit-from '(:scaffold person)) 29 | (id :hidep t) 30 | (address :type mixin 31 | :view '(data address))) 32 | 33 | ;;; Form View 34 | (defview person-form-view (:type form :inherit-from '(:scaffold person)) 35 | (id :hidep t) 36 | (address :type mixin 37 | :view 'address-form-view)) 38 | 39 | -------------------------------------------------------------------------------- /test/views/types/presentations/date.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weblocks-test) 2 | 3 | (deftestsuite views/types/presentations/date-suite (weblocks-suite) 4 | ()) 5 | 6 | (defclass some-dates () 7 | ((x :initform (encode-universal-time 0 0 12 10 1 1984)) 8 | (y :initform (encode-universal-time 0 0 12 3 4 1983)) 9 | (z :initform (encode-universal-time 0 0 12 1 12 1966)))) 10 | 11 | (defview some-dates (:inherit-from '(:scaffold some-dates)) 12 | (x :present-as date) 13 | (y :present-as (date :format "%m/%d/%Y")) 14 | (z :present-as (date :format "%A, %B %d, %Y"))) 15 | 16 | (addtest print-dates 17 | (ensure-html-output 18 | (render-object-view (make-instance 'some-dates) (find-view 'some-dates)) 19 | #.(data-header-template 20 | nil '((:li :class "x" 21 | (:span :class "label date" "X: ") 22 | (:span :class "value" "1984-01-10")) 23 | (:li :class "y" 24 | (:span :class "label date" "Y: ") 25 | (:span :class "value" "04/03/1983")) 26 | (:li :class "z" 27 | (:span :class "label date" "Z: ") 28 | (:span :class "value" "Thursday, December 01, 1966"))) 29 | :data-class-name 'some-dates :postslots '()))) 30 | -------------------------------------------------------------------------------- /src/widgets/widget/funcall-widget.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(funcall-widget funcall-widget-fun-designator)) 5 | 6 | (defwidget funcall-widget () 7 | ((fun-designator :type (or symbol function) 8 | :accessor funcall-widget-fun-designator 9 | :initarg :fun-designator))) 10 | 11 | (defmethod render-widget-body ((widget funcall-widget) &rest args) 12 | (when (widget-continuation widget) 13 | (setf args (cons (widget-continuation widget) args))) 14 | (let ((fun-designator (funcall-widget-fun-designator widget))) 15 | (etypecase fun-designator 16 | (symbol 17 | (if (fboundp fun-designator) 18 | (apply fun-designator args) 19 | (error "Cannot render ~A as widget. Symbol not bound to a function." 20 | fun-designator))) 21 | (function 22 | (apply fun-designator args))))) 23 | 24 | (defmethod make-widget ((obj symbol)) 25 | "Create a widget from a symbol denoting a function." 26 | (make-instance 'funcall-widget :fun-designator obj)) 27 | 28 | (defmethod make-widget ((obj function)) 29 | "Create a widget from a function object." 30 | (make-instance 'funcall-widget :fun-designator obj)) 31 | 32 | -------------------------------------------------------------------------------- /contrib/lpolzer/yui/yui-panel.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(yui-panel panel-on-close panel-on-end-drag)) 5 | 6 | (defwidget yui-panel (yui-widget) 7 | ((on-close :type function :accessor panel-on-close :initarg :on-close :initform (constantly t)) 8 | (on-end-drag :type function :accessor panel-on-end-drag :initarg :on-end-drag :initform (constantly t))) 9 | (:default-initargs :modules '("dragdrop" "container") :class-name |:YAHOO.widget.:Panel|)) 10 | 11 | (defmethod render-widget-body ((widget yui-panel) &rest args) 12 | (declare (ignore args)) 13 | (send-script 14 | (ps* `(with-lazy-loaded-modules (,(yui-modules widget) ,@(yui-loader-args widget)) 15 | (setf (global-variable ,(yui-widget-variable widget)) 16 | (new (,(yui-class-name widget) ,(yui-target-id widget) 17 | (keywords-to-object ,(yui-component-config widget))))) 18 | ((@ (global-variable ,(yui-widget-variable widget)) render)) 19 | ;(console.log ,(format nil "rendered yui widget ~A." (yui-widget-variable widget))) 20 | )))) 21 | 22 | (defmethod with-widget-header ((widget yui-panel) body-fn &rest args) 23 | (apply body-fn widget args)) 24 | 25 | -------------------------------------------------------------------------------- /scripts/new-app-templates/{APPNAME}.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:{APPNAME} 3 | (:use :cl :weblocks 4 | :f-underscore :anaphora) 5 | (:import-from :hunchentoot #:header-in 6 | #:set-cookie #:set-cookie* #:cookie-in 7 | #:user-agent #:referer) 8 | (:documentation 9 | "A web application based on Weblocks.")) 10 | 11 | (in-package :{APPNAME}) 12 | 13 | (export '(start-{APPNAME} stop-{APPNAME})) 14 | 15 | ;; A macro that generates a class or this webapp 16 | 17 | (defwebapp {APPNAME} 18 | :prefix "/" 19 | :description "{APPNAME}: A new application" 20 | :init-user-session '{APPNAME}::init-user-session 21 | :autostart nil ;; have to start the app manually 22 | :ignore-default-dependencies nil ;; accept the defaults 23 | :js-backend :jquery 24 | :debug t 25 | ) 26 | 27 | ;; Top level start & stop scripts 28 | 29 | (defun start-{APPNAME} (&rest args) 30 | "Starts the application by calling 'start-weblocks' with appropriate 31 | arguments." 32 | (apply #'start-weblocks args) 33 | (start-webapp '{APPNAME})) 34 | 35 | (defun stop-{APPNAME} () 36 | "Stops the application by calling 'stop-weblocks'." 37 | (stop-webapp '{APPNAME}) 38 | (stop-weblocks)) 39 | 40 | -------------------------------------------------------------------------------- /src/log-actions.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(log-ui-action log-link log-form)) 5 | 6 | (defvar *rendered-actions*) 7 | (setf (documentation '*rendered-actions* 'variable) 8 | "A list of actions rendered during the request.") 9 | 10 | ;; Logging UI action elements for easy querying in tests 11 | (defun log-ui-action (type name action &key id class) 12 | "If called during an active unit test, logs the UI action to the 13 | test's temporary database so that it can be queried during the unit 14 | test's verification process. If no active unit test is present, does 15 | nothing." 16 | (declare (special *rendered-actions*)) 17 | (when (boundp '*rendered-actions*) 18 | (push (list (cons :type type) 19 | (cons :name name) 20 | (cons :id id) 21 | (cons :class class) 22 | (cons :action action)) 23 | *rendered-actions*))) 24 | 25 | (defun log-link (name action &key id class) 26 | "Wrapper around log-ui-action for links." 27 | (log-ui-action :link name action :id id :class class)) 28 | 29 | (defun log-form (action &key id class) 30 | "Wrapper around log-ui-action for forms." 31 | (log-ui-action :form nil action :id id :class class)) 32 | 33 | -------------------------------------------------------------------------------- /src/views/types/presentations/paragraph.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(paragraph paragraph-presentation)) 5 | 6 | (defclass paragraph-presentation (text-presentation) 7 | () 8 | (:documentation "Presents a large amount of text as an HTML 9 | paragraph.")) 10 | 11 | (defmethod render-view-field-value (value (presentation paragraph-presentation) 12 | field view widget obj &rest args 13 | &key highlight &allow-other-keys) 14 | (if (null value) 15 | (call-next-method) 16 | (let* ((item (apply #'print-view-field-value value presentation field view widget obj args)) 17 | (lit-item (if highlight 18 | (highlight-regex-matches item highlight presentation) 19 | (escape-for-html item)))) 20 | (with-html 21 | (:p :class "value text" 22 | (str (apply #'concatenate 'string 23 | (intersperse (tokenize-string lit-item 24 | :delimiter #\Newline 25 | :include-empties? t) 26 | "
")))))))) 27 | 28 | -------------------------------------------------------------------------------- /test/server.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftestsuite server-suite (weblocks-suite) 5 | ()) 6 | 7 | ;;; test session-name-string-pair 8 | (deftest session-name-string-pair-1 9 | (let ((*rewrite-for-session-urls* nil)) 10 | (declare (special *rewrite-for-session-urls*)) 11 | (weblocks::session-name-string-pair)) 12 | "") 13 | 14 | (deftest session-name-string-pair-2 15 | (with-request :post nil 16 | (let ((*rewrite-for-session-urls* t)) 17 | (declare (special *rewrite-for-session-urls*)) 18 | (setf (slot-value *request* 'hunchentoot::cookies-in) 19 | (cons `(,(session-cookie-name *acceptor*) . "foo") (slot-value *request* 'hunchentoot::cookies-in))) 20 | (weblocks::session-name-string-pair))) 21 | "") 22 | 23 | (deftest session-name-string-pair-3 24 | (with-request :post nil 25 | (let ((*rewrite-for-session-urls* t)) 26 | (declare (special *rewrite-for-session-urls*)) 27 | (weblocks::session-name-string-pair))) 28 | "weblocks-session=1%3ATEST") 29 | 30 | (addtest compute-public-files-path-suffix-convert 31 | (ensure-same (last (pathname-directory 32 | (compute-public-files-path :weblocks "tmp/what")) 2) 33 | '("tmp" "what"))) 34 | -------------------------------------------------------------------------------- /contrib/lpolzer/html-template.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(html-template with-widget-header render-widget-body)) 5 | 6 | 7 | (defwidget html-template (widget) 8 | ((tp :accessor tp :initform nil) 9 | (src :type string :accessor src :initarg :src :initform nil) 10 | (file :type pathname :accessor file :initarg :file :initform nil) 11 | (vars :type list :accessor vars :initarg :vars :initform nil)) 12 | (:documentation "Models a HTML-TEMPLATE from a file.")) 13 | 14 | (defmethod initialize-instance :after ((obj html-template) &rest args) 15 | (unless (or (file obj) (src obj) 16 | (error "You need to specify either a template file (initarg :FILE) or a template 17 | string (initarg :SRC) when creating a HTML-TEMPLATE widget."))) 18 | (setf (tp obj) (html-template:create-template-printer (or (src obj) 19 | (pathname (file obj)))))) 20 | 21 | (defmethod with-widget-header ((widget html-template) body-fn &rest args) 22 | (apply body-fn widget args)) 23 | 24 | (defmethod render-widget-body ((widget html-template) &rest args) 25 | (html-template:fill-and-print-template (tp widget) (vars widget) 26 | :stream *weblocks-output-stream*)) 27 | 28 | -------------------------------------------------------------------------------- /contrib/nunb/templates-crufty/html-template.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cm) 3 | 4 | (export '(html-template with-widget-header render-widget-body)) 5 | 6 | 7 | (defwidget html-template (widget) 8 | ((tp :accessor tp :initform nil) 9 | (src :type string :accessor src :initarg :src :initform nil) 10 | (file :type pathname :accessor file :initarg :file :initform nil) 11 | (vars :type list :accessor vars :initarg :vars :initform nil)) 12 | (:documentation "Models a HTML-TEMPLATE from a file.")) 13 | 14 | (defmethod initialize-instance :after ((obj html-template) &rest args) 15 | (unless (or (file obj) (src obj) 16 | (error "You need to specify either a template file (initarg :FILE) or a template 17 | string (initarg :SRC) when creating a HTML-TEMPLATE widget."))) 18 | (setf (tp obj) (html-template:create-template-printer (or (src obj) 19 | (pathname (file obj)))))) 20 | 21 | (defmethod with-widget-header ((widget html-template) body-fn &rest args) 22 | (apply body-fn widget args)) 23 | 24 | (defmethod render-widget-body ((widget html-template) &rest args) 25 | (html-template:fill-and-print-template (tp widget) (vars widget) 26 | :stream *weblocks-output-stream*)) 27 | 28 | -------------------------------------------------------------------------------- /test/views/types/presentations/choices.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test presentation-choices-default-label-key 5 | (deftest presentation-choices-default-label-key-1 6 | (presentation-choices-default-label-key 'foo) 7 | "Foo") 8 | 9 | (deftest presentation-choices-default-label-key-2 10 | (presentation-choices-default-label-key *joe*) 11 | "Employee") 12 | 13 | ;;; Test presentation-choices-default-value-key 14 | (deftest presentation-choices-default-value-key-1 15 | (presentation-choices-default-value-key 'foo) 16 | "foo") 17 | 18 | (deftest presentation-choices-default-value-key-2 19 | (presentation-choices-default-value-key *joe*) 20 | "1") 21 | 22 | ;;; Test obtain-presentation-choices 23 | (deftest obtain-presentation-choices-1 24 | (obtain-presentation-choices (make-instance 'choices-presentation-mixin 25 | :choices (list (cons 1 2) 26 | (cons 3 4))) 27 | *joe*) 28 | (("1" . "2") ("3" . "4"))) 29 | 30 | (deftest obtain-presentation-choices-2 31 | (obtain-presentation-choices (make-instance 'choices-presentation-mixin 32 | :choices (list *joe* *bob*)) 33 | *joe*) 34 | (("Employee" . "1") ("Employee" . "2"))) 35 | 36 | -------------------------------------------------------------------------------- /src/widgets/dataseq/operations-action.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | ;;; This function processes actions that perform operations on dataseq 5 | ;;; items. It's in a separate file because there is an issue with 6 | ;;; CMUCL and compiling this function transformed through 7 | ;;; CL-CONT. CMUCL interpreter, however, works. We'll just add this to 8 | ;;; ASDF for all implementations except CMUCL, and for CMUCL this file 9 | ;;; will be loaded without compilation. 10 | (defun/cc dataseq-operations-action (obj &rest args) 11 | (declare (ignore args)) 12 | (dataseq-clear-selection obj) 13 | (let ((id)) 14 | (loop for i in (request-parameters) 15 | when (string-starts-with (car i) "item-") 16 | do 17 | (setf id (substring (car i) 5)) 18 | (setf id (if (ppcre:scan "^\\d+$" id) (parse-integer id) id)) 19 | (dataseq-select-item obj id))) 20 | (loop for i in (append 21 | (dataseq-item-ops obj) 22 | (dataseq-common-ops obj)) 23 | when (member (attributize-name (car i)) (request-parameters) 24 | :key (compose #'attributize-name #'car) 25 | :test #'string-equal) 26 | do (funcall (cdr i) obj (dataseq-selection obj))) 27 | (dataseq-clear-selection obj)) 28 | 29 | -------------------------------------------------------------------------------- /pub/stylesheets/error-page.css: -------------------------------------------------------------------------------- 1 | a { 2 | color:#c37; 3 | text-decoration:none; 4 | } 5 | 6 | body { 7 | background-color:#ecf8d7; 8 | width:80%; 9 | max-width:800pt; 10 | margin:auto; 11 | margin-top:4em; 12 | margin-bottom:1em; 13 | font-size:120%; 14 | } 15 | 16 | h1,h2,h3,h4,h5,h6 { 17 | color:#435781; 18 | font-family:sans-serif; 19 | padding-bottom:2mm; 20 | border-bottom:1px solid gray; 21 | } 22 | 23 | h1 img { 24 | vertical-align:text-bottom; 25 | margin-right:0.4ex; 26 | float:right; 27 | } 28 | 29 | h1 { 30 | border-bottom:5px solid #ac2415; 31 | } 32 | 33 | h2 { 34 | margin-top:10mm; 35 | padding:0; 36 | padding-top:1.5mm; 37 | padding-bottom:1mm; 38 | border-bottom:2px solid #ac2415; 39 | } 40 | 41 | tr { 42 | padding-top:10px; 43 | } 44 | 45 | th, td { 46 | padding:5px; 47 | text-align:left; 48 | } 49 | 50 | td { 51 | vertical-align:top; 52 | } 53 | 54 | tr.odd td { 55 | background-color:#eaebc7; 56 | } 57 | 58 | tr.even td { 59 | background-color:#f2ecc5; 60 | } 61 | 62 | 63 | td.frame-number { 64 | text-align:right; 65 | 66 | font-size:1.5em; 67 | font-family:serif; 68 | 69 | color:#555; 70 | } 71 | 72 | td.frame-call { 73 | font-family:monospace; 74 | } 75 | 76 | td.frame-args { 77 | font-family:monospace; 78 | max-width:500px; 79 | } 80 | 81 | .footer { 82 | font-style:italic; 83 | } 84 | 85 | .footer address { 86 | display:inline; 87 | font-style:inherit; 88 | } 89 | 90 | -------------------------------------------------------------------------------- /scripts/gen-doc.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-scripts) 3 | 4 | (export '(document-weblocks)) 5 | 6 | (defun compute-documentation-path () 7 | "Computes the directory where generated documentation should 8 | reside." 9 | (asdf:system-relative-pathname "weblocks" "docs/gen/")) 10 | 11 | (defun document-package (package &key (system package) (ignore-errors-p t)) 12 | (flet ((load-system (s) (if ignore-errors-p 13 | (ignore-errors (asdf:load-system s)) 14 | (asdf:load-system s)))) 15 | (let (errorp) 16 | (unless (find-package package) 17 | (setf errorp (not (load-system system)))) 18 | (unless errorp 19 | (document-package/tinaa package))))) 20 | 21 | (defun document-package/tinaa (package) 22 | ;; dynamically invoke 'document-system' (since reader has no access to tinaa) 23 | (funcall (symbol-function (find-symbol (symbol-name '#:document-system) (find-package 'tinaa))) 24 | 'package package 25 | (compute-documentation-path) 26 | :show-parts-without-documentation? t)) 27 | 28 | (defun document-weblocks () 29 | ; lazily load necessary systems 30 | (unless (find-package :tinaa) 31 | (asdf:operate 'asdf:load-op 'tinaa)) 32 | (document-package :weblocks :ignore-errors-p nil) 33 | (document-package :weblocks-prevalence) 34 | (document-package :weblocks-elephant) 35 | (document-package :weblocks-memory) 36 | (document-package :weblocks-clsql)) 37 | 38 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:weblocks-util 2 | (:use :cl :metabang.utilities :anaphora :hunchentoot :c2mop :f-underscore) 3 | (:shadowing-import-from :c2mop #:defclass #:defgeneric #:defmethod 4 | #:standard-generic-function #:ensure-generic-function 5 | #:standard-class #:typep #:subtypep #:standard-method) 6 | (:shadow #:slot-value-by-path) 7 | (:documentation "General Lisp utilities traditionally exported 8 | with Weblocks.")) 9 | 10 | (in-package :weblocks-util) 11 | 12 | (defun wexport (symbols-designator &optional (package-specs t)) 13 | "Export SYMBOLS-DESIGNATOR from PACKAGE-SPECS. Over `export', 14 | PACKAGE-SPECS can be a list of packages, and the name designators 15 | therein are interpreted by prepending \"WEBLOCKS-\". In the latter 16 | case, the symbols will be imported first if need be." 17 | (dolist (pkg (ensure-list package-specs)) 18 | (multiple-value-bind (pkg import-first?) 19 | (typecase pkg 20 | (boolean '#:weblocks-util) 21 | (symbol (values (concatenate 'string (symbol-name '#:weblocks-) 22 | (symbol-name pkg)) 23 | t)) 24 | (string (values (concatenate 'string (symbol-name '#:weblocks-util-) pkg) 25 | t)) 26 | (otherwise pkg)) 27 | (when import-first? 28 | (import symbols-designator pkg)) 29 | (export symbols-designator pkg)))) 30 | -------------------------------------------------------------------------------- /contrib/lpolzer/yui/yui-resize.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(yui-resize resize-proxy-resize-p resize-panel)) 5 | 6 | (defwidget yui-resize (yui-widget) 7 | ((panel :type (or symbol nil) :accessor resize-panel :initarg :panel :initform nil)) 8 | (:default-initargs :modules '("resize") :class-name |:YAHOO.util.:Resize|)) 9 | 10 | (defmethod with-widget-header ((widget yui-resize) body-fn &rest args) 11 | (apply body-fn widget args)) 12 | 13 | (defmethod render-widget-body ((widget yui-resize) &rest args) 14 | (declare (ignore args)) 15 | (if (resize-panel widget) 16 | (progn 17 | (send-script 18 | (ps* `(with-lazy-loaded-modules (,(yui-modules widget) ,@(yui-loader-args widget)) 19 | ;(|:YAHOO.util.:Event.:addListener| (global-variable ,(resize-panel widget)) "init" 20 | (|:YAHOO.util.:Event.:onAvailable| ,(format nil "~A_c" (yui-target-id widget)) ; fragile hack 21 | (lambda (obj) 22 | (setf ,(yui-widget-variable widget) 23 | (new (,(yui-class-name widget) ,(yui-target-id widget) 24 | (keywords-to-object ,(yui-component-config widget))))) 25 | 26 | (init-yui-resize ,(yui-widget-variable widget) ,(resize-panel widget)) 27 | #+OFF(console.log ,(format nil "rendered yui widget ~A." (yui-widget-variable widget))))))))) 28 | (call-next-method))) 29 | 30 | -------------------------------------------------------------------------------- /src/widgets/widget/uri-parameters-mixin.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(uri-parameters-mixin uri-parameters-slotmap)) 5 | 6 | (defclass uri-parameters-mixin () 7 | ()) 8 | 9 | (defgeneric uri-parameters-slotmap (w) 10 | (:documentation "Returns an alist of (slotname . param-name)") 11 | (:method (w) (declare (ignore w)) nil)) 12 | 13 | (defgeneric uri-parameter-values (w) 14 | (:documentation "Returns an alist of (param-name . slot-value)") 15 | (:method (w) (declare (ignore w)) nil) 16 | (:method ((w uri-parameters-mixin)) 17 | (loop for (sname . pname) in (uri-parameters-slotmap w) 18 | when (slot-boundp w sname) 19 | collect (cons pname (slot-value w sname))))) 20 | 21 | (defun maybe-generate-parameter-slot-map-fn (class slot-defs) 22 | "When a slot contains " 23 | (awhen (get-parameter-slot-map slot-defs) 24 | (with-gensyms (widget) 25 | `(defmethod uri-parameters-slotmap ((,widget ,class)) 26 | ',it)))) 27 | 28 | (defun uri-parameter-def-p (slot-defs) 29 | (member :uri-parameter (flatten slot-defs))) 30 | 31 | (defun get-parameter-slot-map (slot-defs) 32 | (remove-if #'null 33 | (mapcar (lambda (slot-def) 34 | (awhen (member :uri-parameter slot-def) 35 | (cons (first slot-def) 36 | (as-string (cadr it))))) 37 | slot-defs))) 38 | 39 | (defun as-string (obj) 40 | (etypecase obj 41 | (symbol (string-downcase (symbol-name obj))) 42 | (string obj))) 43 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/src/init-session.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-demo-popover) 3 | 4 | ;; Define our application 5 | (defwebapp weblocks-demo-popover 6 | :description "A web application based on Weblocks" 7 | :init-user-session 'init-user-session 8 | :dependencies 9 | '((:stylesheet "suggest"))) 10 | 11 | ;; ;; Application dependencies 12 | ;; (setf *application-public-dependencies* 13 | ;; (append (public-files-relative-paths 14 | ;; '(:stylesheet . "suggest")) 15 | ;; *application-public-dependencies*)) 16 | 17 | ;; Define callback function to initialize new sessions. The function 18 | ;; initializes a sandbox store for the new user and sets up a 19 | ;; continuation flow. It then renders the initial page. 20 | ;; 21 | ;; After the initial page answers, INIT-USER-SESSION sets 22 | ;; RENDER-HEADER as a prefix for the main composite so that header is 23 | ;; seen on all pages (similar behavior could be accomplished by 24 | ;; placing this function into the layout made by MAKE-MAIN-PAGE, but 25 | ;; this would prevent the header from being displayed in some cases 26 | ;; like dialogs invoked with JavaScript turned off). 27 | ;; 28 | ;; The control is then passed to main page. The main page is never 29 | ;; expected to answer. 30 | (defun init-user-session (comp) 31 | (init-sandbox-store) 32 | (with-flow comp 33 | (yield #'initial-page) 34 | (setf (widget-prefix-fn comp) #'render-header) 35 | (yield (make-main-page)))) 36 | 37 | -------------------------------------------------------------------------------- /pub/stylesheets/datagrid.css: -------------------------------------------------------------------------------- 1 | /* Body */ 2 | .datagrid 3 | { 4 | margin-bottom: 1em; 5 | position: relative; 6 | _height: 1%; /* IE 6 fix */ 7 | } 8 | 9 | /* Sorting */ 10 | 11 | .sort-asc span a 12 | { 13 | background: url(/weblocks-common/pub/images/widget/datagrid/up_arrow.png) no-repeat right center; 14 | } 15 | 16 | 17 | .sort-desc span a 18 | { 19 | background: url(/weblocks-common/pub/images/widget/datagrid/down_arrow.png) no-repeat right center; 20 | } 21 | 22 | .sort-asc span a, .sort-desc span a, 23 | .sort-asc span, .sort-desc span 24 | { 25 | display: block; 26 | text-decoration: underline; 27 | } 28 | 29 | /* Selecting */ 30 | p.datagrid-select-bar 31 | { 32 | padding: 0; 33 | margin: 0; 34 | font-size: x-small; 35 | position: absolute; 36 | bottom: 0; 37 | left: 0; 38 | } 39 | 40 | p.datagrid-select-bar strong 41 | { 42 | color: gray; 43 | font-family: Garamond, New York, serif; 44 | font-weight: normal; 45 | } 46 | 47 | .datagrid form .select 48 | { 49 | text-align: right; 50 | width: 1em; 51 | } 52 | 53 | .datagrid table tbody tr.drilled-down td.select input 54 | { 55 | visibility: hidden; 56 | } 57 | 58 | .datagrid table tbody tr.drilled-down td.select div 59 | { 60 | background: url(/weblocks-common/pub/images/widget/arrow.png) no-repeat center center; 61 | } 62 | 63 | 64 | /* We need to adjust margins to properly style pagination and item 65 | operations */ 66 | .datagrid .datagrid-body .view.table 67 | { 68 | margin-bottom: 0; 69 | } 70 | 71 | .datagrid table { 72 | width: 100%; 73 | height: 100%; 74 | } 75 | -------------------------------------------------------------------------------- /contrib/s11001001/dataedit.lisp: -------------------------------------------------------------------------------- 1 | ;;; dataedit.lisp: Helpers for extending `dataedit'. 2 | 3 | (in-package #:weblocks-s11) 4 | 5 | (export '(dataedit-editor-initargs)) 6 | 7 | (defun dataedit-editor-initargs (dataedit &optional (item nil item?)) 8 | "Answer initargs appropriate for passing to a `data-editor' to talk 9 | back to DATAEDIT when appropriate. If ITEM, this is a form for an 10 | existing instance." 11 | (list :data (if item? 12 | item 13 | (make-instance (dataseq-data-form-class dataedit))) 14 | :class-store (dataseq-class-store dataedit) 15 | :on-success (lambda (obj) 16 | (unless item? 17 | (safe-funcall (dataedit-on-add-item dataedit) dataedit obj)) 18 | (flash-message (dataseq-flash dataedit) 19 | (format nil (if item? "Modified ~A." "Added ~A.") 20 | (humanize-name (dataseq-data-class dataedit)))) 21 | (dataedit-reset-state dataedit) 22 | (when item? 23 | (mark-dirty dataedit))) 24 | :on-close (lambda (obj) 25 | (declare (ignore obj)) 26 | (dataedit-reset-state dataedit)) 27 | :on-cancel (lambda (obj) 28 | (declare (ignore obj)) 29 | (dataedit-reset-state dataedit) 30 | (unless item? 31 | (throw 'annihilate-dataform nil))))) 32 | 33 | ;;; dataedit.lisp ends here 34 | -------------------------------------------------------------------------------- /test/blocks/form.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test with-form-html macro 5 | (deftest-html with-form-html-1 6 | (with-request :get nil 7 | (with-html-form (:get "abc123") 8 | (:div "test1") 9 | (:div "test2"))) 10 | (:form 11 | :action "" 12 | :method "get" 13 | :onsubmit "initiateFormAction(\"abc123\", $(this), \"weblocks-session=1%3Atest\"); return false;" 14 | (:div :class "extra-top-1" " ") 15 | (:div :class "extra-top-2" " ") 16 | (:div :class "extra-top-3" " ") 17 | (:fieldset 18 | (:div "test1") 19 | (:div "test2") 20 | (:input :name "action" :type "hidden" :value "abc123")) 21 | (:div :class "extra-bottom-1" " ") 22 | (:div :class "extra-bottom-2" " ") 23 | (:div :class "extra-bottom-3" " "))) 24 | 25 | (deftest-html with-form-html-2 26 | (with-request :get nil 27 | (with-html-form (:get "abc123" :id "some-id" :class "some-class") 28 | (:div "test"))) 29 | (:form 30 | :id "some-id" 31 | :class "some-class" 32 | :action "" 33 | :method "get" 34 | :onsubmit "initiateFormAction(\"abc123\", $(this), \"weblocks-session=1%3Atest\"); return false;" 35 | (:div :class "extra-top-1" " ") 36 | (:div :class "extra-top-2" " ") 37 | (:div :class "extra-top-3" " ") 38 | (:fieldset 39 | (:div "test") 40 | (:input :name "action" :type "hidden" :value "abc123")) 41 | (:div :class "extra-bottom-1" " ") 42 | (:div :class "extra-bottom-2" " ") 43 | (:div :class "extra-bottom-3" " "))) 44 | -------------------------------------------------------------------------------- /contrib/nunb/poncy.lisp: -------------------------------------------------------------------------------- 1 | (in-package :app) 2 | 3 | (defwidget poncy (composite) 4 | ((width :accessor poncy-width :initarg :width) 5 | (title :accessor poncy-title :initarg :title))) 6 | 7 | (defmethod render-widget-body ((obj poncy) &rest args) 8 | (with-html (:div :style "margin: 0 auto; text-align:center;" 9 | (render-image (my-tab-image "tabs" (poncy-title obj) (poncy-width obj)))) 10 | (:div :style 11 | (dolist (b (composite-widgets obj)) 12 | (render-widget-body b))))) 13 | 14 | 15 | #+OLD(defun make-text-tab (width file text) 16 | (let* ((y 13)) 17 | (with-canvas (:width width :height (* 2 y)) 18 | (let ((font (get-font "/tmp/font.ttf")) 19 | (step (/ pi 7))) 20 | (set-font font 12)) 21 | (let ((x width) (2y (* 2 y))) 22 | (set-rgba-fill 0.3 0.3 0.3 0.3) 23 | (rounded-rectangle 0 0 x 2y 10 10 ) 24 | (set-gradient-fill 2 2y 25 | 0.4 0.4 0.4 0.8 26 | 2 y 27 | 0 0 0 0.2) 28 | (set-gradient-fill 2 y 29 | 0.4 0.4 0.4 0.9 30 | 2 0 31 | 0 0 0 0.2) 32 | 33 | ;(clip-path) 34 | ;(rectangle 0 0 x y) 35 | (clip-path) 36 | (centered-circle-path 2 2 10) 37 | (centered-circle-path x 2 10) 38 | (fill-path) 39 | (rgba-fill 255 255 255 1.0) 40 | (vecto::translate (/ x 2) 8) 41 | (draw-centered-string 0 0 text) 42 | (fill-path) 43 | (save-png file))))) 44 | -------------------------------------------------------------------------------- /pub/stylesheets/table.css: -------------------------------------------------------------------------------- 1 | 2 | .table 3 | { 4 | min-width: 42em; 5 | } 6 | 7 | .table table 8 | { 9 | width: 100%; 10 | } 11 | 12 | .table table thead tr th 13 | { 14 | text-align: left; 15 | } 16 | 17 | .table table thead tr th, .table table tbody tr td 18 | { 19 | padding-left: 0.5em; 20 | } 21 | 22 | .table table tbody tr td strong 23 | { 24 | background: #fe4631; 25 | color: white; 26 | font-weight: normal; 27 | } 28 | 29 | .view table tbody tr td 30 | { 31 | border-bottom: 1px solid #dbeac1; 32 | padding-top: 1px; 33 | background-image: url(/weblocks-common/pub/images/widget/table_border_top.png); 34 | background-repeat: repeat-x; 35 | background-position: top; 36 | } 37 | 38 | /* Hover on table */ 39 | .table table tbody tr:hover, 40 | .datagrid table tbody tr.drilled-down, 41 | .table table tr.hover 42 | { 43 | background: #dbeac1; 44 | } 45 | 46 | /* IE specific border behavior (no support for border-spacing) */ 47 | .table table 48 | { 49 | border-collapse: collapse; 50 | } 51 | 52 | /* Border behavior for other browsers (can't use border-collapse 53 | because of incosistent behavior between Opera, Mozilla, IE, and 54 | Safari). Note, comment is necessary to hide from IE7. */ 55 | .table >/**/table 56 | { 57 | border-spacing: 0; 58 | border-collapse: separate; 59 | } 60 | 61 | /* Safari and WebKit specific caption fix */ 62 | html[xmlns*=""] body:last-child .table table caption 63 | { 64 | width: 100%; 65 | } 66 | 67 | @media all and (min-width: 0px) 68 | { 69 | body:not(:root:root) .table table caption 70 | { 71 | width: 100%; 72 | } 73 | } 74 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:weblocks-cont 2 | (:documentation "Operators for continuation-based web development 3 | with Weblocks.")) 4 | 5 | (defpackage #:weblocks 6 | (:use :cl :c2mop :metabang.utilities :hunchentoot :cl-who :json :optima :cont :parenscript 7 | :anaphora :f-underscore :trivial-timeout 8 | :weblocks-stores 9 | :weblocks-util) 10 | (:shadowing-import-from :c2mop #:defclass #:defgeneric #:defmethod 11 | #:standard-generic-function #:ensure-generic-function 12 | #:standard-class #:typep #:subtypep #:standard-method) 13 | (:shadowing-import-from :cl-who #:str) 14 | (:shadowing-import-from :f-underscore #:f #:_) 15 | (:shadowing-import-from :optima #:match) 16 | (:shadowing-import-from :metabang.utilities #:with-array #:size #:bind) 17 | (:shadowing-import-from :json #:prototype) 18 | (:shadowing-import-from :weblocks-util #:find-all) 19 | (:shadow #:redirect #:reset-sessions #:errors #:create-regex-dispatcher #:create-prefix-dispatcher #:create-folder-dispatcher-and-handler #:create-static-file-dispatcher-and-handler) 20 | (:export #:defstore #:asdf-system-directory #:id #:persist-object) 21 | (:documentation 22 | "Weblocks is a Common Lisp framework that eases the pain of web 23 | application development. It achieves its goals by standardizing on 24 | various libraries, providing flexible and extensible generic views, 25 | and exposing a unique widget-based approach to maintaining UI 26 | state.")) 27 | 28 | ;; the following are export-only; see `wexport' 29 | 30 | 31 | -------------------------------------------------------------------------------- /docs/announcements/template.txt: -------------------------------------------------------------------------------- 1 | Weblocks released 2 | =========================== 3 | 4 | Weblocks is an advanced web framework written in Common Lisp. 5 | 6 | It is designed to make Agile web application development as 7 | effective and simple as possible. 8 | 9 | Weblocks uses powerful Lisp features like multiple dispatch, the 10 | metaobject protocol, lexical closures, keyword arguments, and macros 11 | to build abstractions that make web development easy, intuitive, and 12 | free of boilerplate. In addition, control flow is easily expressed 13 | using continuations. 14 | 15 | Things that are hard or mundane in other frameworks become easy and 16 | fun in Weblocks. 17 | 18 | 19 | AUDIENCE 20 | 21 | People who want to get their real-life web programming done 22 | as effectively as possible. 23 | 24 | Weblocks is not only targeted at old hands but also at 25 | newcomers to Lisp and Lisp web programming. 26 | 27 | It offers a helpful community and code that prevents you 28 | from shooting yourself too easily in the foot. 29 | 30 | 31 | CHANGES IN 32 | 33 | 34 | 35 | 36 | MORE INFORMATION 37 | 38 | Platforms: 39 | Well-tested on SBCL and Clozure. 40 | Partially tested on CMUCL, Lispworks, AllegroCL, and OpenMCL. 41 | 42 | Official site (with detailed installation guide): 43 | http://weblocks.viridian-project.de/ 44 | 45 | Demo: 46 | http://weblocks.viridian-project.de/weblocks-demo 47 | 48 | 49 | CONTRIBUTORS 50 | 51 | This release has been made possible by 52 | 53 | 55 | 56 | -------------------------------------------------------------------------------- /pub/stylesheets/flash.css: -------------------------------------------------------------------------------- 1 | 2 | .flash .view 3 | { 4 | width: 100%; 5 | /* background: #f8e9d8 url(/weblocks-common/pub/images/widget/flash/top_background.png) repeat-x;*/ 6 | } 7 | 8 | .flash .view .extra-top-1 9 | { 10 | /* background: url(/weblocks-common/pub/images/widget/flash/top_left.png) no-repeat top left;*/ 11 | } 12 | 13 | .flash .view .extra-top-2 14 | { 15 | /* background: url(/weblocks-common/pub/images/widget/flash/top_right.png) no-repeat top right;*/ 16 | border-bottom-color: #ead8c2; 17 | } 18 | 19 | .flash .view ul.messages p 20 | { 21 | padding: 0; 22 | margin: 0; 23 | } 24 | 25 | .flash .view ul.messages 26 | { 27 | border-left-color: #ead8c2; 28 | border-right-color: #ead8c2; 29 | } 30 | 31 | .flash .view ul.messages li 32 | { 33 | padding-left: 32px; 34 | min-height: 16px; 35 | border-top-color: #fef9f6; 36 | border-bottom-color: #ead8c2; 37 | list-style-image: none; 38 | /* background: url(/weblocks-common/pub/images/widget/flash/flag.png) no-repeat top left;*/ 39 | } 40 | 41 | /* Fake min-height for IE 6 */ 42 | * html .flash .view ul.messages li 43 | { 44 | height: 16px; 45 | } 46 | 47 | .flash .view .extra-bottom-1 48 | { 49 | /* background: url(/weblocks-common/pub/images/widget/flash/bottom_background.png) repeat-x top;*/ 50 | border-top-color: #fef9f6; 51 | } 52 | 53 | .flash .view .extra-bottom-2 54 | { 55 | /* background: url(/weblocks-common/pub/images/widget/flash/bottom_left.png) no-repeat top left;*/ 56 | } 57 | 58 | .flash .view .extra-bottom-3 59 | { 60 | /* background: url(/weblocks-common/pub/images/widget/flash/bottom_right.png) no-repeat top right;*/ 61 | } 62 | 63 | -------------------------------------------------------------------------------- /test/test-code/query-actions.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (export '(find-ui-actions find-ui-link find-ui-form)) 5 | 6 | ;; Querying UI elements 7 | (defun find-ui-actions (type &key name id class (test #'equalp)) 8 | "If called during an active unit test, looks for the action in the 9 | unit test database and returns the action (if found), or nil. If no 10 | active unit test is present, signals an error." 11 | (declare (special weblocks::*rendered-actions*)) 12 | (unless (boundp 'weblocks::*rendered-actions*) 13 | (error "FIND-UI-ACTION can only be called during an active unit test.")) 14 | ;; Return elements that match the query 15 | (flet ((prop-match (action prop val &optional (test #'equalp)) 16 | (funcall test val (cdr (assoc prop action))))) 17 | (loop 18 | for action in weblocks::*rendered-actions* 19 | when (and (prop-match action :type type) 20 | (or (null name) (prop-match action :name name test)) 21 | (or (null id) (prop-match action :id id test)) 22 | (or (null class) (prop-match action :class class test))) 23 | collect (cdr (assoc :action action))))) 24 | 25 | (defun find-ui-link (&key name id class (test #'equalp)) 26 | "A wrapper for find-ui-actions for links. Returns the first link in 27 | the list, if any." 28 | (car (find-ui-actions :link :name name :id id :class class :test test))) 29 | 30 | (defun find-ui-form (&key id class (test #'equalp)) 31 | "A wrapper for find-ui-action for forms. Returns the first form in 32 | the list, if any." 33 | (car (find-ui-actions :form :id id :class class :test test))) 34 | 35 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:~/nginx/sbin:$PATH 7 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 8 | matrix: 9 | - LISP=sbcl 10 | # unable to find libssl.so, I tried hard, but it doesn't see it 11 | - LISP=allegro 12 | # fails with mmap: Invalid argument 13 | # ensure_space: Failed to validate 0 bytes at 0x58100000 14 | - LISP=cmucl 15 | # fails on weblocks-test loading 16 | - LISP=ccl 17 | # shows error there is no package with name "UIOP" 18 | - LISP=clisp 19 | # it shows success but actually fails with tracebacks 20 | - LISP=abcl 21 | # compile error on loading yaclml-20150709-git 22 | - LISP=ecl 23 | 24 | matrix: 25 | allow_failures: 26 | - env: LISP=allegro 27 | - env: LISP=cmucl 28 | - env: LISP=ccl 29 | - env: LISP=clisp 30 | - env: LISP=abcl 31 | - env: LISP=ecl 32 | 33 | addons: 34 | apt: 35 | packages: 36 | - libtidy-dev 37 | - libc6-i386 38 | - openjdk-7-jre 39 | 40 | install: 41 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/master/scripts/install-for-ci.sh | sh 42 | 43 | cache: 44 | directories: 45 | - $HOME/.roswell 46 | - $HOME/.config/common-lisp 47 | 48 | before_script: 49 | - env 50 | - cat /proc/meminfo 51 | - ros --version 52 | - ros config 53 | - ros -e '(princ (lisp-implementation-type)) 54 | (terpri) 55 | (princ (lisp-implementation-version)) 56 | (terpri) 57 | (princ *features*) 58 | (terpri) 59 | (uiop:quit 0)' 60 | 61 | script: 62 | - ./run-tests.ros 63 | -------------------------------------------------------------------------------- /contrib/lpolzer/integer-range.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks) 2 | 3 | (export '(integer-range-presentation integer-range-parser)) 4 | 5 | (defclass integer-range-presentation (text-presentation input-presentation) 6 | () (:documentation "A presentation for integer ranges.")) 7 | 8 | (defmethod render-view-field-value (value (presentation integer-range-presentation) 9 | (field form-view-field) (view form-view) 10 | widget obj &rest args 11 | &key intermediate-values &allow-other-keys) 12 | (declare (ignore args)) 13 | (multiple-value-bind (intermediate-value intermediate-value-p) 14 | (form-field-intermediate-value field intermediate-values) 15 | (let* ((value (if intermediate-value-p intermediate-value value)) 16 | (value (if (consp value) value (cons value value)))) 17 | (render-input-field "text" (view-field-slot-name field) 18 | (format nil "~D-~D" (car value) (cdr value)))))) 19 | 20 | (defclass integer-range-parser (text-parser) 21 | ()) 22 | 23 | (defmethod parse-view-field-value ((parser integer-range-parser) value obj 24 | (view form-view) (field form-view-field) &rest args) 25 | (declare (ignore args)) 26 | (let* ((parsed-value (cl-ppcre:split "-" value)) 27 | (min (parse-integer (car parsed-value))) 28 | (max (parse-integer (car (metatilities:ensure-list (cdr parsed-value))))) 29 | (present-p (and min max)) 30 | (valid-p (and present-p (cl-ppcre:scan "[0-9]+-[0-9]+|[0-9]+" value) 31 | (<= min max)))) 32 | (values valid-p present-p (cons min max)))) 33 | 34 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/init-session.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | ;; Define our application 5 | (defwebapp employer-employee 6 | :description "A web application based on Weblocks" 7 | :init-user-session 'init-user-session 8 | :dependencies 9 | '((:stylesheet "suggest"))) 10 | 11 | ;; ;; Application dependencies 12 | ;; (setf *application-public-dependencies* 13 | ;; (append (public-files-relative-paths 14 | ;; '(:stylesheet . "suggest")) 15 | ;; *application-public-dependencies*)) 16 | 17 | ;; Define callback function to initialize new sessions. The function 18 | ;; initializes a sandbox store for the new user and sets up a 19 | ;; continuation flow. It then renders the initial page. 20 | ;; 21 | ;; After the initial page answers, INIT-USER-SESSION sets 22 | ;; RENDER-HEADER as a prefix for the main composite so that header is 23 | ;; seen on all pages (similar behavior could be accomplished by 24 | ;; placing this function into the layout made by MAKE-MAIN-PAGE, but 25 | ;; this would prevent the header from being displayed in some cases 26 | ;; like dialogs invoked with JavaScript turned off). 27 | ;; 28 | ;; The control is then passed to main page. The main page is never 29 | ;; expected to answer. 30 | (defun init-user-session (comp) 31 | (init-slime-debugging) 32 | (init-sandbox-store) 33 | (setf (composite-widgets comp) 34 | (list (make-main-page)))) 35 | 36 | ;; Define callback function to initialize new sessions 37 | (defun init-slime-debugging () 38 | "Don't catch errors and redirect debugger to slime. Works great !" 39 | (setf hunchentoot:*catch-errors-p* nil) 40 | (setf *debugger-hook* 'swank:swank-debugger-hook)) 41 | -------------------------------------------------------------------------------- /src/widgets/template-block.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks) 2 | 3 | (export '(template-block 4 | template-block-source 5 | template-block-vars 6 | recreate-template-printer 7 | render-template 8 | *always-recreate-template-printer*)) 9 | 10 | (defparameter *always-recreate-template-printer* t) 11 | 12 | (defwidget template-block () 13 | ((template-printer :accessor template-printer-of :initform nil 14 | :affects-dirty-status-p nil) 15 | (source :accessor template-block-source :initarg :source :initform nil) 16 | (vars :type list :accessor template-block-vars :initarg :vars :initform nil)) 17 | (:documentation "A block of HTML taken from 'source', which is processed by 18 | HTML-TEMPLATE using 'vars'.")) 19 | 20 | (defmethod recreate-template-printer ((obj template-block)) 21 | (when (template-block-source obj) 22 | (setf (template-printer-of obj) 23 | (html-template:create-template-printer (template-block-source obj))))) 24 | 25 | (defmethod ensure-printer-exists ((obj template-block)) 26 | (handler-bind ((warning #'muffle-warning)) 27 | (if *always-recreate-template-printer* 28 | (recreate-template-printer obj) 29 | (or (template-printer-of obj) (recreate-template-printer obj))))) 30 | 31 | (defmethod render-template ((obj template-block)) 32 | (ensure-printer-exists obj) 33 | (html-template:fill-and-print-template (template-printer-of obj) 34 | (template-block-vars obj) 35 | :stream *weblocks-output-stream*)) 36 | 37 | (defmethod render-widget-body ((widget template-block) &rest args) 38 | (declare (ignore args)) 39 | (render-template widget)) 40 | 41 | -------------------------------------------------------------------------------- /src/views/formview/scaffold.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(form-scaffold typespec->form-view-field-parser)) 5 | 6 | (defclass form-scaffold (scaffold) 7 | () 8 | (:documentation "Form scaffold.")) 9 | 10 | (defmethod generate-scaffold-view ((scaffold form-scaffold) object-class) 11 | (make-instance (scaffold-view-type scaffold) 12 | :inherit-from nil 13 | :fields (mapcar 14 | (curry #'generate-scaffold-view-field scaffold object-class) 15 | (weblocks-stores:class-visible-slots object-class :readablep t :writablep t)))) 16 | 17 | (defmethod generate-scaffold-view-field ((scaffold form-scaffold) 18 | object-class dsd) 19 | (let ((slot-type (slot-definition-type dsd))) 20 | (apply #'make-instance (scaffold-view-field-type scaffold) 21 | :slot-name (slot-definition-name dsd) 22 | :label (humanize-name (slot-definition-name dsd)) 23 | :requiredp (and slot-type (not (typep nil slot-type))) 24 | (append 25 | (extract-view-property-from-type :present-as #'typespec->view-field-presentation 26 | scaffold dsd) 27 | (extract-view-property-from-type :parse-as #'typespec->form-view-field-parser 28 | scaffold dsd))))) 29 | 30 | ;;; Type introspection protocol 31 | (defgeneric typespec->form-view-field-parser (scaffold typespec args) 32 | (:documentation "Converts a typespec to a parser argument. See 33 | 'typespec->view-field-presentation' for more information.") 34 | (:method ((scaffold form-scaffold) typespec args) 35 | (declare (ignore typespec args)) 36 | nil)) 37 | 38 | -------------------------------------------------------------------------------- /test/weblocks.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftestsuite .weblocks-suite (weblocks-suite) 5 | ()) 6 | 7 | (addtest wexport 8 | (labels ((pkg-name (suffix) 9 | (format nil "~A~A" (symbol-name '#:weblocks-temp-) suffix)) 10 | (used? (suffix) 11 | (find-package (pkg-name suffix))) 12 | (sym-exported? (pkg sym) 13 | (eq :external (nth-value 1 (find-symbol (symbol-name sym) pkg)))) 14 | (wexport (&rest args) 15 | (apply #'weblocks::wexport args))) 16 | (let* ((pkg (make-package (pkg-name (loop for n from 0 to 420 17 | unless (used? n) 18 | return n)))) 19 | (suffix (subseq (package-name pkg) 9))) 20 | (unwind-protect 21 | (progn 22 | (wexport 'a1 suffix) 23 | (ensure (sym-exported? pkg 'a1)) 24 | (wexport '(b2 c3) (list (make-symbol suffix))) 25 | (ensure (sym-exported? pkg 'b2)) 26 | (ensure (sym-exported? pkg 'c3))) 27 | (delete-package pkg))))) 28 | 29 | ;;; testing root-composite 30 | (deftest root-composite-1 31 | (with-request :get nil 32 | (root-composite)) 33 | nil nil) 34 | 35 | (deftest root-composite-2 36 | (with-request :get nil 37 | (setf (root-composite) 'foobar) 38 | (multiple-value-bind (res present-p) 39 | (root-composite) 40 | (values res (not (null present-p))))) 41 | foobar t) 42 | 43 | (addtest with-javascript-1 44 | (set-sensible-suite) 45 | (ensure-same 46 | (with-output-to-string (*weblocks-output-stream*) 47 | (with-javascript 48 | "foo~A" "bar")) 49 | (with-javascript-to-string "foo~A" "bar"))) 50 | 51 | -------------------------------------------------------------------------------- /test/widgets/datagrid/sort.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test datagrid-render-view-field-header-sort 5 | (deftest-html datagrid-render-view-field-header-sort-1 6 | (with-request :get nil 7 | (let* ((view (defview () (:type table :inherit-from '(:scaffold employee)))) 8 | (field-info (car (get-object-view-fields *joe* view))) 9 | (field (field-info-field field-info)) 10 | (grid (make-instance 'datagrid :data-class 'employee 11 | :view view 12 | :sort '(name . :asc))) 13 | (presentation (view-field-presentation field)) 14 | (value (first-name *joe*))) 15 | (render-view-field-header field view grid presentation value *joe* 16 | :field-info field-info))) 17 | (:th :class "name sort-asc" 18 | (:span :class "label" #.(link-action-template "abc123" "Name")))) 19 | 20 | (deftest-html datagrid-render-view-field-header-sort-2 21 | (with-request :get nil 22 | (let* ((view (defview () (:type table :inherit-from '(:scaffold employee)))) 23 | (field-info (car (get-object-view-fields *joe* view))) 24 | (field (field-info-field field-info)) 25 | (grid (make-instance 'datagrid :data-class 'employee 26 | :view view 27 | :sort '(manager . :asc))) 28 | (presentation (view-field-presentation field)) 29 | (value (first-name *joe*))) 30 | (render-view-field-header field view grid presentation value *joe* 31 | :field-info field-info))) 32 | (:th :class "name" 33 | (:span :class "label" #.(link-action-template "abc123" "Name")))) 34 | 35 | -------------------------------------------------------------------------------- /test/widgets/login.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test authenticatedp 5 | (deftest authenticatedp-1 6 | (with-request :get nil 7 | (authenticatedp)) 8 | nil) 9 | 10 | (deftest authenticatedp-2 11 | (with-request :get nil 12 | (setf (webapp-session-value *authentication-key*) 123) 13 | (authenticatedp)) 14 | 123) 15 | 16 | ;;; test logout 17 | (deftest logout-1 18 | (with-request :get nil 19 | (setf (session-value *authentication-key*) 123) 20 | (logout) 21 | (authenticatedp)) 22 | nil) 23 | 24 | ;;; test hash-password 25 | (deftest hash-password-1 26 | (let ((test1 (hash-password "test1")) 27 | (test2 (hash-password "test2"))) 28 | (or (equalp test1 "test1") 29 | (equalp test2 "test2") 30 | (equalp test1 test2))) 31 | nil) 32 | 33 | ;;; test login flow 34 | (deftest login-1 35 | (with-request :get nil 36 | (let ((*weblocks-output-stream* (make-string-output-stream)) 37 | (login (make-instance 'login 38 | :on-login (lambda (w o) 39 | (declare (ignore w)) 40 | (slot-value o 'email))))) 41 | (declare (special *weblocks-output-stream*)) 42 | (render-widget-body login) 43 | (do-request `(("submit" . "Login") 44 | ("email" . "Foo") 45 | ("password" . "Bar") 46 | (,weblocks::*action-string* . "abc123"))) 47 | (authenticatedp))) 48 | "Foo") 49 | 50 | -------------------------------------------------------------------------------- /test/views/types/presentations/url.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test url-presentation render-view-field-value 5 | (deftest-html url-presentation-1 6 | (render-view-field-value "www.hello.com" 7 | (make-instance 'url-presentation) 8 | (make-instance 'data-view-field 9 | :slot-name 'foo) 10 | (make-instance 'data-view) 11 | nil *joe*) 12 | (:a :href "www.hello.com" :onclick "stopPropagation(event);" "www.hello.com")) 13 | 14 | (deftest-html url-presentation-2 15 | (render-view-field-value "www.hello.com" 16 | (make-instance 'url-presentation 17 | :body "Foo") 18 | (make-instance 'data-view-field 19 | :slot-name 'foo) 20 | (make-instance 'data-view) 21 | nil *joe*) 22 | (:a :href "www.hello.com" :onclick "stopPropagation(event);" "Foo")) 23 | 24 | (deftest-html url-presentation-3 25 | (render-view-field-value "www.hello.com" 26 | (make-instance 'url-presentation 27 | :body (lambda (&rest args) 28 | (declare (ignore args)) 29 | (with-html "Bar"))) 30 | (make-instance 'data-view-field 31 | :slot-name 'foo) 32 | (make-instance 'data-view) 33 | nil *joe*) 34 | (:a :href "www.hello.com" :onclick "stopPropagation(event);" "Bar")) 35 | -------------------------------------------------------------------------------- /test/widgets/navigation.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftestsuite widgets/navigation-suite (weblocks-suite) nil) 5 | 6 | (defun make-test-nav () 7 | (let ((widget (make-instance 'widget))) 8 | (make-navigation "Test navigation" (list "Default Item" widget "") 9 | (list "Item One" widget "one") 10 | (list "Item Two" widget "two")))) 11 | 12 | (addtest navigation-pane-name-for-token 13 | (let ((nav (make-test-nav))) 14 | (ensure-same (weblocks::navigation-pane-name-for-token nav "one") "Item One") 15 | (ensure-same (weblocks::navigation-pane-name-for-token nav "ONE") "Item One") 16 | (ensure-same (weblocks::navigation-pane-name-for-token nav nil) "Default Item"))) 17 | 18 | (addtest navigation-menu-items 19 | (let ((nav (make-test-nav)) 20 | (*lift-equality-test* (curry-after #'tree-equal :test #'equal))) 21 | (ensure-same (navigation-menu-items nav) 22 | '(("Default Item" . "") 23 | ("Item One" . "one") 24 | ("Item Two" . "two"))))) 25 | 26 | (addtest navigation-hidden-panes-1 27 | (let ((nav (make-test-nav)) 28 | (*lift-equality-test* (curry-after #'tree-equal :test #'equal))) 29 | (setf (navigation-hidden-panes nav) (list "one")) 30 | (ensure-same (navigation-menu-items nav) 31 | '(("Default Item" . "") 32 | ("Item Two" . "two"))))) 33 | 34 | (addtest navigation-hidden-panes-2 35 | (let ((nav (make-test-nav)) 36 | (*lift-equality-test* (curry-after #'tree-equal :test #'equal))) 37 | (setf (navigation-hidden-panes nav) (list nil)) 38 | (ensure-same (navigation-menu-items nav) 39 | '(("Item One" . "one") 40 | ("Item Two" . "two"))))) 41 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/src/layout.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :employer-employee) 3 | 4 | (defun make-main-page () 5 | "Lays out the main page. It consists of a FLASH widget for showing 6 | initial message, and a NAVIGATION widget with panes that hold 7 | employees page and companies page." 8 | (make-instance 'composite :widgets 9 | (list 10 | (make-navigation 'main-menu 11 | 'companies (make-companies-page))))) 12 | 13 | (defun make-companies-page () 14 | "Lays out the widgets for the comppanies page." 15 | (make-instance 'composite :widgets 16 | (list 17 | (make-instance 'company-gridedit 18 | :name 'company-grid 19 | :view 'company-table-view 20 | :item-data-view 'company-data-view 21 | :item-form-view 'company-form-view 22 | :drilldown-type :view 23 | :data-class 'company 24 | 25 | :on-query #'company-list-on-query 26 | 27 | :employee-list-data-class 'employee 28 | :employee-list-form-view 'employee-form-view 29 | :employee-list-view 'employee-table-view 30 | :employee-list-on-add-employee #'company-employee-list-on-add-employee 31 | :employee-list-on-query #'company-employee-list-on-query 32 | )))) 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /contrib/yarek/examples/weblocks-demo-popover/weblocks-demo-popover.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:weblocks-demo-popover-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :weblocks-demo-popover-asd) 6 | 7 | (defsystem weblocks-demo-popover 8 | :name "weblocks-demo-popover" 9 | :version "0.1" 10 | :author "Yarek Kowalik, Slava Akhmechet" 11 | :licence "Public Domain" 12 | :description "weblocks-demo" 13 | :depends-on (:weblocks :metatilities :weblocks-yarek) 14 | :components ((:file "weblocks-demo-popover") 15 | (:module conf 16 | :components ((:file "stores")) 17 | :depends-on ("weblocks-demo-popover")) 18 | (:module src 19 | :components ((:file "layout" 20 | :depends-on (model)) 21 | (:file "snippets" 22 | :depends-on ("init-session")) 23 | (:file "sandbox" 24 | :depends-on (model)) 25 | (:file "init-session" 26 | :depends-on ("layout" "sandbox")) 27 | (:module model 28 | :components ((:file "company") 29 | (:file "address") 30 | (:file "person" 31 | :depends-on ("address")) 32 | (:file "employee" 33 | :depends-on ("person" "company"))))) 34 | :depends-on ("weblocks-demo-popover" conf)))) 35 | 36 | -------------------------------------------------------------------------------- /weblocks-util.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:weblocks-util-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :weblocks-util-asd) 6 | 7 | (defsystem weblocks-util 8 | :name "weblocks-util" 9 | :version "0.1.1" 10 | :maintainer "Olexiy Zamkoviy, Scott L. Burson" 11 | :author "Slava Akhmechet" 12 | :licence "LLGPL" 13 | :description "Utilities for weblocks" 14 | :depends-on (:closer-mop 15 | :hunchentoot 16 | :puri 17 | :cl-json 18 | :cl-who 19 | :parenscript 20 | :cl-fad 21 | :optima 22 | :cl-cont 23 | :metatilities 24 | :cl-ppcre 25 | :anaphora 26 | :f-underscore 27 | :bordeaux-threads 28 | :salza2 29 | :html-template 30 | :trivial-timeout 31 | :trivial-backtrace 32 | :parse-number 33 | :pretty-function 34 | :ironclad) 35 | :components 36 | ((:module src 37 | :components ( 38 | (:file "util") 39 | (:module utils 40 | :components 41 | ((:file "misc") 42 | (:file "clos") 43 | ;(:file "runtime-class") 44 | ;(:file "string") 45 | (:file "list") 46 | ;(:file "uri") 47 | ;(:file "html") 48 | ;(:file "javascript") 49 | ;(:file "isearch" :depends-on ("html")) 50 | ;(:file "menu" :depends-on ("html")) 51 | ;(:file "suggest") 52 | ;(:file "timing") 53 | ;(:file "repl") 54 | (:file "i18n") 55 | (:file "templates" :depends-on ("html-parts")) 56 | (:file "html-parts")) 57 | :depends-on ("util")))))) 58 | -------------------------------------------------------------------------------- /pub/stylesheets/pagination.css: -------------------------------------------------------------------------------- 1 | 2 | .pagination .current-page, 3 | .pagination .total-pages 4 | { 5 | font-weight: bolder; 6 | font-size: small; 7 | } 8 | 9 | .pagination .page-info 10 | { 11 | margin-top: 4px; 12 | } 13 | 14 | .pagination .viewing-label 15 | { 16 | display: none; 17 | } 18 | 19 | .pagination form fieldset 20 | { 21 | vertical-align: middle; 22 | } 23 | 24 | .pagination form, 25 | .pagination fieldset 26 | { 27 | display: inline; 28 | border: none; 29 | margin: 0; 30 | padding: 0; 31 | } 32 | 33 | .pagination fieldset 34 | { 35 | margin-left: 0.75em; 36 | } 37 | 38 | .pagination form fieldset input.page-number 39 | { 40 | width: 2em; 41 | margin-right: 0.5em; 42 | } 43 | 44 | /* We need to increate input width on Safari */ 45 | html[xmlns*=""] body:last-child .pagination form fieldset input.page-number 46 | { 47 | width: 2.5em; 48 | } 49 | 50 | .pagination form fieldset input.item-not-validated 51 | { 52 | border: solid 1px red; 53 | } 54 | 55 | .pagination div.extra-top-1, 56 | .pagination div.extra-top-2, 57 | .pagination div.extra-top-3, 58 | .pagination div.extra-bottom-1, 59 | .pagination div.extra-bottom-2, 60 | .pagination div.extra-bottom-3 61 | { 62 | display: none; 63 | } 64 | 65 | .pagination form label span 66 | { 67 | color: gray; 68 | } 69 | 70 | /* Fix the vertical alignment issue for IE 6 */ 71 | * html .pagination form label span 72 | { 73 | display: inline-block; 74 | padding-bottom: 3px; 75 | } 76 | 77 | /* Fix the vertical alignment issue for IE 7 */ 78 | *:first-child+html .pagination form label span 79 | { 80 | display: inline-block; 81 | padding-bottom: 3px; 82 | } 83 | 84 | /* Normalize alignment for all modern browsers (without IE 7) */ 85 | html>/**/body .pagination .page-info, 86 | html>/**/body .pagination a 87 | { 88 | vertical-align: middle; 89 | } 90 | 91 | .pagination .total-items 92 | { 93 | display: block; 94 | } 95 | 96 | -------------------------------------------------------------------------------- /src/widgets/breadcrumbs.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(breadcrumbs)) 5 | 6 | (defwidget breadcrumbs () 7 | () 8 | (:documentation "A (misnamed) breadcrumbs widget, showing the current 9 | position within the site's navigation system. Example: 'Home > Events 10 | > Latest Event'. Its render-widget-body method walks the widget tree, 11 | finds navigation widgets and learns about their selections.")) 12 | 13 | (defmethod render-widget-body ((obj breadcrumbs) &rest args) 14 | (declare (ignore args)) 15 | (let (crumbs) 16 | (walk-widget-tree 17 | (root-widget) 18 | (lambda (obj depth) 19 | (declare (ignore depth)) 20 | ;; we only process objects that eat URI tokens, we need to know them, unfortunately 21 | (cond 22 | ((subclassp (class-of obj) 'navigation) 23 | (unless crumbs 24 | (push (navigation-pane-name-for-token obj nil) crumbs)) 25 | (push-end (make-webapp-uri (selector-base-uri obj)) crumbs) 26 | (push-end (navigation-pane-name-for-token obj (static-selector-current-pane obj)) crumbs)) 27 | ((equal (class-of obj) (find-class 'on-demand-selector)) 28 | (let ((name (car (last (car (on-demand-selector-cache obj)))))) 29 | (when name 30 | (push-end (make-webapp-uri (selector-base-uri obj)) crumbs) 31 | ;; hopefully one of our children defined a page-title method... 32 | (push-end (or (first (remove nil (mapcar #'page-title (widget-children obj)))) 33 | (humanize-name name)) 34 | crumbs))))))) 35 | (with-html 36 | (:ul 37 | (loop for item on crumbs by #'cddr 38 | do (progn 39 | (if (second item) 40 | (htm (:li (:a :href (second item) (str (first item))))) 41 | (htm (:li (str (first item))))))))))) 42 | 43 | 44 | -------------------------------------------------------------------------------- /test/views/types/presentations/radio.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test radio-presentation render-view-field-value 5 | (deftest-html radio-presentation-render-view-field-value-1 6 | (render-view-field-value nil 7 | (make-instance 'radio-presentation 8 | :choices (list *joe* *bob*)) 9 | (make-instance 'form-view-field 10 | :slot-name 'foo) 11 | (make-instance 'form-view) 12 | nil *joe*) 13 | (htm 14 | (:label :class "radio first" 15 | (:input :name "foo" :type "radio" :class "radio" 16 | :value "1") 17 | (:span "Employee ")) 18 | (:label :class "radio last" 19 | (:input :name "foo" :type "radio" :class "radio" 20 | :value "2") 21 | (:span "Employee ")))) 22 | 23 | (deftest-html radio-presentation-render-view-field-value-2 24 | (render-view-field-value 4 25 | (make-instance 'radio-presentation 26 | :choices (list (cons 1 2) 27 | (cons 3 4))) 28 | (make-instance 'form-view-field 29 | :slot-name 'foo) 30 | (make-instance 'form-view) 31 | nil *joe*) 32 | (htm 33 | (:label :class "radio first" 34 | (:input :name "foo" :type "radio" :class "radio" 35 | :value "2") 36 | (:span "1 ")) 37 | (:label :class "radio last" 38 | (:input :name "foo" :type "radio" :class "radio" 39 | :value "4" 40 | :checked "checked") 41 | (:span "3 ")))) 42 | 43 | -------------------------------------------------------------------------------- /contrib/nunb/templates-crufty/template-utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm) 2 | 3 | (defparameter *template-temporary-validation-errors* nil) 4 | (defparameter *template-temporary-intermediate-values* nil) 5 | (defparameter *out-of-band-template-vars* nil) 6 | 7 | ;============ utils 8 | (defmacro string+ (&rest args) 9 | `(concatenate 'string ,@args)) 10 | 11 | (defun fill-template-widget (name &key (language "it") assoc assoc2) 12 | (declare (special *out-of-band-template-vars*)) 13 | (setf html-template:*string-modifier* #'CL:IDENTITY) 14 | ;(warn (format nil "filltemplatewidget norml ~A" assoc)) 15 | (warn (format nil "filltemplatewidget oob ~A" assoc2)) 16 | 17 | (let ((filename (merge-pathnames (make-pathname :directory '(:relative "templates") :name name :type language ) 18 | *public-files-path*))) 19 | (make-instance 'html-template :file filename :vars (append assoc assoc2)))) 20 | 21 | (defun make-main-page-employee () 22 | (with-html (:p "You are an employee"))) 23 | 24 | ; from template-form-view.lisp put this into utils -- same as weblocks alist->plist, but converts clos object to obj-class-name 25 | (defun my-alist->plist (alist) 26 | "Converts an alist to plist." 27 | (let ((keyword-package (find-package :keyword))) 28 | (loop for i in alist 29 | collect (if (symbolp (car i)) 30 | (intern (symbol-name (car i)) keyword-package) 31 | "DONTCARE") 32 | collect (cdr i)))) 33 | 34 | ;; (if (symbolp (car i)) 35 | ;; (intern (symbol-name (car i)) keyword-package) 36 | ;; (intern (string-upcase (car i)) keyword-package)) 37 | 38 | ; was to be used in conjunction with (clos->string (car i)) 39 | ; in the original alist->plist above (in place of string-upcase (car i)) 40 | (defun clos->string (some) 41 | (ecase (class-of some) 42 | (:templform-view-field (view-field-name some)))) 43 | -------------------------------------------------------------------------------- /test/widgets/dataedit/delete-action.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; testing dataedit-delete-items 5 | (deftest dataedit-delete-items-flow-1 6 | (with-request :get nil 7 | (persist-objects *default-store* (list *joe* *bob*)) 8 | (make-request-ajax) 9 | (let ((grid (make-instance 'gridedit 10 | :data-class 'employee 11 | :allow-pagination-p nil))) 12 | (dataedit-delete-items-flow grid (cons :none (list (object-id *joe*)))) 13 | (do-request `(("yes" . "Yes") 14 | (,weblocks::*action-string* . "abc123"))) 15 | (mapcar #'first-name (dataseq-data grid)))) 16 | ("Bob")) 17 | 18 | (deftest dataedit-delete-items-flow-2 19 | (with-request :get nil 20 | (persist-objects *default-store* (list *joe* *bob*)) 21 | (make-request-ajax) 22 | (let ((grid (make-instance 'gridedit 23 | :data-class 'employee 24 | :allow-pagination-p nil))) 25 | (dataedit-delete-items-flow grid (cons :none (list (object-id *joe*) (object-id *bob*)))) 26 | (do-request `(("yes" . "Yes") 27 | (,weblocks::*action-string* . "abc123"))) 28 | (mapcar #'first-name (dataseq-data grid)))) 29 | nil) 30 | 31 | (deftest dataedit-delete-items-flow-3 32 | (with-request :get nil 33 | (persist-objects *default-store* (list *joe* *bob*)) 34 | (make-request-ajax) 35 | (let ((grid (make-instance 'gridedit 36 | :data-class 'employee 37 | :allow-pagination-p nil))) 38 | (dataedit-delete-items-flow grid (cons :none (list (object-id *joe*)))) 39 | (do-request `(("yes" . "Yes") 40 | (,weblocks::*action-string* . "abc123"))) 41 | (not (null (widget-dirty-p grid))))) 42 | t) 43 | 44 | -------------------------------------------------------------------------------- /contrib/s11001001/presentations.lisp: -------------------------------------------------------------------------------- 1 | ;;; presentations.lisp: Additional presentations. 2 | 3 | (in-package #:weblocks-s11) 4 | 5 | (export '(us-cents us-cents-input us-cents-presentation 6 | us-cents-input-presentation us-cents-parser)) 7 | 8 | (arnesi:enable-sharp-l-syntax) 9 | 10 | ;;;; Money represented in US dollars and stored as #cents 11 | 12 | (defclass us-cents-printer () 13 | () 14 | (:documentation "Mixin for data and form; see 15 | `us-cents-presentation' and `us-cents-input-presentation'.")) 16 | 17 | (defclass us-cents-presentation (us-cents-printer text-presentation) 18 | () 19 | (:documentation "Present a count of US cents as a pretty US dollar 20 | amount.")) 21 | 22 | (defclass us-cents-input-presentation (us-cents-printer input-presentation) 23 | () 24 | (:documentation "The counterpart to `us-cents-presentation' for 25 | forms.")) 26 | 27 | (defclass us-cents-parser (text-parser) 28 | () 29 | (:documentation "Parse a US dollar amount and answer the # of US cents.")) 30 | 31 | (defmethod print-view-field-value 32 | (value (self us-cents-printer) field view widget obj &rest args) 33 | (declare (ignore field view widget obj args)) 34 | (multiple-value-bind (dollars cents) (truncate value 100) 35 | (format nil "$~:D.~2,'0D" dollars cents))) 36 | 37 | (defmethod weblocks:parse-view-field-value 38 | ((parser us-cents-parser) value obj view field &rest args) 39 | (declare (ignore obj view field args)) 40 | (let* ((present? (text-input-present-p value)) 41 | (float-start 42 | (and present? 43 | (position-if #L(or (char<= #\0 !1 #\9) (char= #\. !1)) value))) 44 | (float 45 | (and float-start 46 | (ignore-errors (arnesi:parse-float value :start float-start))))) 47 | (values (or (not present?) float) present? 48 | (and float (round (* 100 float)))))) 49 | 50 | ;;; presentations.lisp ends here 51 | -------------------------------------------------------------------------------- /test/widgets/composite.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test suite for composite widgets 5 | (deftestsuite composite-suite (weblocks-suite) 6 | ()) 7 | 8 | ;;; test setting composite widget to single widget on init 9 | (addtest init-composite-single 10 | (ensure-same (composite-widgets (make-instance 'composite :widgets "foo")) 11 | (list "foo"))) 12 | 13 | ;;; test proper setting of widget parent on adding to composite 14 | (addtest composite-add-widget-parent 15 | (let* ((w (make-instance 'composite)) 16 | (c (make-instance 'composite :widgets w))) 17 | (ensure-same (widget-parent w) c))) 18 | 19 | ;;; widget can be in multiple composites; it's up to the user to ensure 20 | ;;; proper parentship 21 | (addtest composite-add-widget-multiple 22 | (let ((w (make-instance 'composite))) 23 | (make-instance 'composite :widgets w) 24 | (make-instance 'composite :widgets w))) 25 | 26 | ;;; Make sure parents are switched properly 27 | #+(or) ; disabled for now -- see comment to (SETF WIDGET-CHILDREN) 28 | (addtest composite-add-widget-parent-switching 29 | (let* ((w1 (make-instance 'composite)) 30 | (w2 (make-instance 'composite)) 31 | (c (make-instance 'composite :widgets w1))) 32 | (ensure (widget-parent w1)) 33 | (ensure-null (widget-parent w2)) 34 | (setf (composite-widgets c) w2) 35 | (ensure-null (widget-parent w1)) 36 | (ensure (widget-parent w2)))) 37 | 38 | ;;; testing render for composite widget 39 | (addtest render-composite 40 | (let (a-rendered 41 | b-rendered 42 | (comp (make-instance 'composite))) 43 | (push-end (lambda () 44 | (setf a-rendered t)) 45 | (composite-widgets comp)) 46 | (push-end (lambda () 47 | (setf b-rendered t)) 48 | (composite-widgets comp)) 49 | (render-widget comp) 50 | (ensure a-rendered) 51 | (ensure b-rendered))) 52 | 53 | -------------------------------------------------------------------------------- /pub/stylesheets/menu.css: -------------------------------------------------------------------------------- 1 | 2 | .menu 3 | { 4 | width: 15em; 5 | /* background: #d8eaf8 url(/weblocks-common/pub/images/menu/top_background.png) repeat-x;*/ 6 | } 7 | 8 | .menu h1 9 | { 10 | background: #d8eaf8; 11 | } 12 | 13 | .menu .extra-top-1 14 | { 15 | /* background: url(/weblocks-common/pub/images/menu/top_left.png) no-repeat top left;*/ 16 | } 17 | 18 | .menu .extra-top-2 19 | { 20 | /* background: url(/weblocks-common/pub/images/menu/top_right.png) no-repeat top right;*/ 21 | border-bottom-color: #bfd9ec; 22 | } 23 | 24 | .empty-menu 25 | { 26 | padding-left: 0.5em; 27 | } 28 | 29 | .selected-item 30 | { 31 | color: #606060; 32 | background-color: #bfd9ec; 33 | } 34 | 35 | .menu ul li 36 | { 37 | padding-left: 0; 38 | } 39 | 40 | .menu ul li.selected-item 41 | { 42 | padding-left: 0.5em; 43 | } 44 | 45 | .menu ul li.selected-item span.label 46 | { 47 | /* background: url(/weblocks-common/pub/images/menu/arrow.png) no-repeat center left;*/ 48 | padding-left: 1em; 49 | } 50 | 51 | .menu h1, .view .empty-menu, .menu ul li 52 | { 53 | border-top-color: #f6fbfd; 54 | border-bottom-color: #bfd9ec; 55 | } 56 | 57 | .menu h1, .menu .empty-menu, .menu ul 58 | { 59 | border-left-color: #bfd9ec; 60 | border-right-color: #bfd9ec; 61 | } 62 | 63 | .menu .extra-bottom-1 64 | { 65 | /* background: url(/weblocks-common/pub/images/menu/bottom_background.png) repeat-x top;*/ 66 | border-top-color: #f6fbfd; 67 | } 68 | 69 | .menu .extra-bottom-2 70 | { 71 | /* background: url(/weblocks-common/pub/images/menu/bottom_left.png) no-repeat top left;*/ 72 | } 73 | 74 | .menu .extra-bottom-3 75 | { 76 | /* background: url(/weblocks-common/pub/images/menu/bottom_right.png) no-repeat top right;*/ 77 | } 78 | 79 | .menu a 80 | { 81 | display: block; 82 | } 83 | 84 | /* IE 6 and 7 hover hack */ 85 | *:first-child+html {} * html {} .menu a 86 | { 87 | height: 1%; 88 | } 89 | 90 | .menu a:hover 91 | { 92 | background-color: #bfd9ec; 93 | } 94 | 95 | -------------------------------------------------------------------------------- /contrib/yarek/examples/employer-employee/employer-employee.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | (defpackage #:employer-employee-asd 3 | (:use :cl :asdf)) 4 | 5 | (in-package :employer-employee-asd) 6 | 7 | (defsystem employer-employee 8 | :name "employer-employee" 9 | :version "0.1" 10 | :author "Yarek Kowalik" 11 | :licence "Public Domain" 12 | :description "weblocks-demo" 13 | :depends-on (:weblocks :metatilities :weblocks-yarek) 14 | :components ((:file "employer-employee") 15 | (:module conf 16 | :components ((:file "stores")) 17 | :depends-on ("employer-employee")) 18 | (:module src 19 | :components ((:file "layout" 20 | :depends-on (model widgets)) 21 | (:file "sandbox" 22 | :depends-on (model)) 23 | (:file "init-session" 24 | :depends-on ("layout" "sandbox")) 25 | (:module model 26 | :components ((:file "company") 27 | (:file "address") 28 | (:file "person" 29 | :depends-on ("address")) 30 | (:file "employee" 31 | :depends-on ("person" "company")))) 32 | (:module widgets 33 | :components ((:file "company-gridedit" 34 | :depends-on ("company-presenter")) 35 | (:file "company-presenter")))) 36 | :depends-on ("employer-employee" conf)))) 37 | 38 | -------------------------------------------------------------------------------- /pub/stylesheets/navigation.css: -------------------------------------------------------------------------------- 1 | 2 | .menu 3 | { 4 | width: 15em; 5 | /* background: #d8eaf8 url(/weblocks-common/pub/images/widget/menu/top_background.png) repeat-x;*/ 6 | } 7 | 8 | .menu h1 9 | { 10 | background: #d8eaf8; 11 | } 12 | 13 | .menu .extra-top-1 14 | { 15 | /* background: url(/weblocks-common/pub/images/widget/menu/top_left.png) no-repeat top left;*/ 16 | } 17 | 18 | .menu .extra-top-2 19 | { 20 | /* background: url(/weblocks-common/pub/images/widget/menu/top_right.png) no-repeat top right;*/ 21 | border-bottom-color: #bfd9ec; 22 | } 23 | 24 | .empty-navigation 25 | { 26 | padding-left: 0.5em; 27 | } 28 | 29 | .selected-item 30 | { 31 | color: #606060; 32 | background-color: #bfd9ec; 33 | } 34 | 35 | .menu ul li 36 | { 37 | padding-left: 0; 38 | } 39 | 40 | .menu ul li.selected-item 41 | { 42 | padding-left: 0.5em; 43 | } 44 | 45 | .menu ul li.selected-item span 46 | { 47 | /* background: url(/weblocks-common/pub/images/widget/menu/arrow.png) no-repeat center left;*/ 48 | padding-left: 1em; 49 | } 50 | 51 | .menu h1, .view .empty-navigation, .menu ul li 52 | { 53 | border-top-color: #f6fbfd; 54 | border-bottom-color: #bfd9ec; 55 | } 56 | 57 | .menu h1, .menu .empty-navigation, .menu ul 58 | { 59 | border-left-color: #bfd9ec; 60 | border-right-color: #bfd9ec; 61 | } 62 | 63 | .menu .extra-bottom-1 64 | { 65 | /* background: url(/weblocks-common/pub/images/widget/menu/bottom_background.png) repeat-x top;*/ 66 | border-top-color: #f6fbfd; 67 | } 68 | 69 | .menu .extra-bottom-2 70 | { 71 | /* background: url(/weblocks-common/pub/images/widget/menu/bottom_left.png) no-repeat top left;*/ 72 | } 73 | 74 | .menu .extra-bottom-3 75 | { 76 | /* background: url(/weblocks-common/pub/images/widget/menu/bottom_right.png) no-repeat top right;*/ 77 | } 78 | 79 | .menu a 80 | { 81 | display: block; 82 | } 83 | 84 | /* IE 6 and 7 hover hack */ 85 | *:first-child+html {} * html {} .menu a 86 | { 87 | height: 1%; 88 | } 89 | 90 | .menu a:hover 91 | { 92 | background-color: #bfd9ec; 93 | } 94 | 95 | -------------------------------------------------------------------------------- /src/utils/timing.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (wexport '(*enable-timings* 5 | *timing-report-fn* 6 | timing) 7 | '(t util)) 8 | 9 | (defvar *enable-timings* nil) 10 | 11 | (defvar *timing-report-fn* (lambda (name real cpu) 12 | (format t "time spent for ~S (real/cpu): ~F/~F~%" 13 | name real cpu))) 14 | 15 | (defun report-timing (name real cpu) 16 | (funcall *timing-report-fn* name real cpu)) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel :execute) 19 | (defvar *timing-level* 0)) 20 | (declaim (fixnum *timing-level*)) 21 | 22 | (defmethod on-timing-start (level name)) 23 | (defmethod on-timing-end (level name)) 24 | 25 | (defmacro timing (name &body body) 26 | (with-gensyms (start/real start/cpu 27 | end/real end/cpu 28 | spent/real spent/cpu) 29 | `(let ((thunk (lambda () ,@body))) 30 | (if *enable-timings* 31 | (let ((,start/real (get-internal-real-time)) 32 | (,start/cpu (get-internal-run-time))) 33 | (declare (optimize (speed 3)(safety 3)) 34 | ((integer 0) ,start/real ,start/cpu)) 35 | (incf *timing-level*) 36 | (on-timing-start *timing-level* ,name) 37 | (prog1 38 | (funcall thunk) 39 | (let* ((,end/real (get-internal-real-time)) 40 | (,end/cpu (get-internal-run-time)) 41 | (,spent/real (/ (- ,end/real ,start/real) 42 | internal-time-units-per-second)) 43 | 44 | (,spent/cpu (/ (- ,end/cpu ,start/cpu) 45 | internal-time-units-per-second))) 46 | (declare ((integer 0) ,end/real ,end/cpu) 47 | ((rational 0) ,spent/real ,spent/cpu)) 48 | (report-timing ,name ,spent/real ,spent/cpu) 49 | (on-timing-end *timing-level* ,name) 50 | (decf *timing-level*)))) 51 | (funcall thunk))))) 52 | -------------------------------------------------------------------------------- /src/widgets/datagrid/sort.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | ;;; Support sorting by clicking on headers 5 | (defmethod render-view-field-header ((field table-view-field) 6 | (view table-view) 7 | (widget datagrid) presentation value obj 8 | &rest args &key field-info 9 | &allow-other-keys) 10 | (declare (ignore args)) 11 | (if (dataseq-field-sortable-p widget field) 12 | (let* ((slot-name (view-field-slot-name field)) 13 | (slot-path (get-field-info-sort-path field-info)) 14 | (th-class (when (equalp slot-path (dataseq-sort-path widget)) 15 | (concatenate 'string " sort-" 16 | (attributize-name (string (dataseq-sort-direction widget)))))) 17 | (sort-dir (dataseq-sort-direction widget))) 18 | (render-wt 19 | :table-view-field-header-wt 20 | (list :view view :field field :widget widget :presentation presentation :object obj) 21 | :row-class (concatenate 'string 22 | (if field-info 23 | (attributize-view-field-name field-info) 24 | (attributize-name slot-name)) 25 | th-class) 26 | :label (capture-weblocks-output 27 | (render-link 28 | (make-action 29 | (lambda (&rest args) 30 | (declare (ignore args)) 31 | (let ((new-dir :asc)) 32 | (when (equalp (dataseq-sort-path widget) slot-path) 33 | (setf new-dir (negate-sort-direction sort-dir))) 34 | (setf (dataseq-sort widget) (cons slot-path new-dir))) 35 | ;; we also need to clear the selection 36 | (dataseq-clear-selection widget))) 37 | (view-field-label field))))) 38 | (call-next-method))) 39 | 40 | -------------------------------------------------------------------------------- /test/views/types/presentations/excerpt.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test excerpt-presentation render-view-field-value 5 | (deftest-html excerpt-presentation-render-view-field-value-1 6 | (render-view-field-value "Hello World!" 7 | (make-instance 'excerpt-presentation) 8 | (make-instance 'data-view-field 9 | :slot-name 'foo) 10 | (make-instance 'data-view) 11 | nil *joe*) 12 | (:span :class "value" "Hello World!")) 13 | 14 | (deftest-html excerpt-presentation-render-view-field-value-2 15 | (render-view-field-value "Hello World! Hello World! Hello World! Hello World!" 16 | (make-instance 'excerpt-presentation) 17 | (make-instance 'data-view-field 18 | :slot-name 'foo) 19 | (make-instance 'data-view) 20 | nil *joe*) 21 | (:span :class "value" "Hello World! He" 22 | (:span :class "ellipsis" "..."))) 23 | 24 | ;;; Test excerpt-presentation print-view-field-value 25 | (deftest excerpt-presentation-print-view-field-value-1 26 | (print-view-field-value "Hello World!" 27 | (make-instance 'excerpt-presentation) 28 | (make-instance 'data-view-field 29 | :slot-name 'foo) 30 | (make-instance 'data-view) 31 | nil *joe*) 32 | "Hello World!") 33 | 34 | (deftest excerpt-presentation-print-view-field-value-2 35 | (print-view-field-value "Hello World! Hello World! Hello World! Hello World!" 36 | (make-instance 'excerpt-presentation) 37 | (make-instance 'data-view-field 38 | :slot-name 'foo) 39 | (make-instance 'data-view) 40 | nil *joe*) 41 | "Hello World! He") 42 | 43 | -------------------------------------------------------------------------------- /src/views/types/password.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package weblocks) 3 | 4 | (export '(*max-password-length* password password-presentation)) 5 | 6 | (defparameter *max-password-length* 12 7 | "Default maximum for the length of the password field") 8 | 9 | (defclass password-presentation (text-presentation input-presentation) 10 | ((max-length :initform *max-password-length*)) 11 | (:documentation "A presentation for passwords.")) 12 | 13 | (defmethod render-view-field-value (value (presentation password-presentation) 14 | (field form-view-field) (view form-view) 15 | widget obj &key field-info &allow-other-keys) 16 | (declare (ignore args) 17 | (special *presentation-dom-id*)) 18 | (render-password (if field-info 19 | (attributize-view-field-name field-info) 20 | (attributize-name (view-field-slot-name field))) 21 | nil 22 | :maxlength (input-presentation-max-length presentation) 23 | :size (input-presentation-size presentation) 24 | :id *presentation-dom-id*)) 25 | 26 | (defmethod render-view-field-value ((value null) (presentation password-presentation) 27 | (field form-view-field) (view form-view) 28 | widget obj &key field-info &allow-other-keys) 29 | (declare (ignore args) 30 | (special *presentation-dom-id*)) 31 | (render-password (if field-info 32 | (attributize-view-field-name field-info) 33 | (attributize-name (view-field-slot-name field))) 34 | nil 35 | :maxlength (input-presentation-max-length presentation) 36 | :size (input-presentation-size presentation) 37 | :id *presentation-dom-id*)) 38 | 39 | (defmethod print-view-field-value (value (presentation password-presentation) 40 | field view widget obj &rest args) 41 | (declare (ignore presentation obj view field args)) 42 | (format nil "*******")) 43 | 44 | -------------------------------------------------------------------------------- /test/views/types/presentations/dropdown.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test dropdown-presentation render-view-field-value 5 | (deftest-html dropdown-presentation-render-view-field-value-1 6 | (render-view-field-value nil 7 | (make-instance 'dropdown-presentation 8 | :choices (list *joe* *bob*)) 9 | (make-instance 'form-view-field 10 | :slot-name 'foo) 11 | (make-instance 'form-view) 12 | nil *joe*) 13 | (:select :name "foo" 14 | (:option :value "" "[Select Foo]") 15 | (:option :value "1" "Employee") 16 | (:option :value "2" "Employee"))) 17 | 18 | (deftest-html dropdown-presentation-render-view-field-value-2 19 | (render-view-field-value (object-id *bob*) 20 | (make-instance 'dropdown-presentation 21 | :choices (list *joe* *bob*)) 22 | (make-instance 'form-view-field 23 | :slot-name 'foo) 24 | (make-instance 'form-view) 25 | nil *joe*) 26 | (:select :name "foo" 27 | (:option :value "" "[Select None]") 28 | (:option :value "1" "Employee") 29 | (:option :value "2" :selected "selected" "Employee"))) 30 | 31 | (deftest-html dropdown-presentation-render-view-field-value-3 32 | (render-view-field-value (object-id *bob*) 33 | (make-instance 'dropdown-presentation 34 | :choices (list *joe* *bob*)) 35 | (make-instance 'form-view-field 36 | :slot-name 'foo 37 | :requiredp t) 38 | (make-instance 'form-view) 39 | nil *joe*) 40 | (:select :name "foo" 41 | (:option :value "1" "Employee") 42 | (:option :value "2" :selected "selected" "Employee"))) 43 | 44 | -------------------------------------------------------------------------------- /src/views/types/presentations/excerpt.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(*text-data-cutoff-threshold* excerpt excerpt-presentation 5 | excerpt-presentation-cutoff-threshold)) 6 | 7 | (defparameter *text-data-cutoff-threshold* 15 8 | "In the excerpt mode, the number of characters to be rendered 9 | before the text is cut off and an ellipsis is inserted.") 10 | 11 | (defclass excerpt-presentation (text-presentation) 12 | ((cutoff-threshold :initform *text-data-cutoff-threshold* 13 | :accessor excerpt-presentation-cutoff-threshold 14 | :initarg :cutoff-threshold 15 | :documentation "Number of characters before the 16 | text is cut off.")) 17 | (:documentation "Presents a large amount of text as an HTML 18 | paragraph.")) 19 | 20 | (defmethod render-view-field-value (value (presentation excerpt-presentation) 21 | field view widget obj &rest args 22 | &key highlight &allow-other-keys) 23 | (if (null value) 24 | (call-next-method) 25 | (let* ((orig-item (apply #'print-view-field-value 26 | value (make-instance 'text-presentation) field view widget obj args)) 27 | (item (apply #'print-view-field-value value presentation field view widget obj args)) 28 | (lit-item (if highlight 29 | (highlight-regex-matches item highlight presentation) 30 | (escape-for-html item)))) 31 | (with-html 32 | (:span :class "value" 33 | (str lit-item) 34 | (unless (<= (length orig-item) 35 | (excerpt-presentation-cutoff-threshold presentation)) 36 | (htm (:span :class "ellipsis" "...")))))))) 37 | 38 | (defmethod print-view-field-value (value (presentation excerpt-presentation) 39 | field view widget obj &rest args) 40 | (declare (ignore obj view field args)) 41 | (let ((threshold (excerpt-presentation-cutoff-threshold presentation)) 42 | (item (call-next-method))) 43 | (if (<= (length item) threshold) 44 | item 45 | (subseq item 0 threshold)))) 46 | 47 | -------------------------------------------------------------------------------- /test/views/formview/test-template.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; utilities for easier testing 5 | (defun form-header-template (action body &key (method "get") (title-action "Modifying: ") preslots 6 | (postslots `((:div :class "submit" 7 | (:input :name "submit" :type "submit" :class "submit" 8 | :value "Submit" 9 | :onclick "disableIrrelevantButtons(this);") 10 | (:input :name "cancel" :type "submit" 11 | :class "submit cancel" :value "Cancel" 12 | :onclick "disableIrrelevantButtons(this);")))) 13 | (uri "/foo/bar") enctype (use-ajax-p t) 14 | (data-class-name "employee") 15 | form-id) 16 | `(:form :id ,form-id 17 | :class ,(format nil "view form ~A" data-class-name) 18 | :action ,uri :method ,method :enctype ,enctype 19 | ,@(when use-ajax-p 20 | `(:onsubmit ,(format nil "initiateFormAction(\"~A\", ~ 21 | $(this), ~ 22 | \"weblocks-session=1%3ATEST\"); ~ 23 | return false;" 24 | (or action "")))) 25 | (:div :class "extra-top-1" "") 26 | (:div :class "extra-top-2" "") 27 | (:div :class "extra-top-3" "") 28 | (:fieldset 29 | (:h1 (:span :class "action" (str ,title-action)) 30 | (:span :class "object" ,(humanize-name data-class-name))) 31 | ,@preslots 32 | (:ul ,@body) 33 | ,@postslots 34 | (:input :name "action" :type "hidden" :value ,action)) 35 | (:div :class "extra-bottom-1" "") 36 | (:div :class "extra-bottom-2" "") 37 | (:div :class "extra-bottom-3" ""))) 38 | 39 | -------------------------------------------------------------------------------- /src/views/types/presentations/textarea.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(*textarea-rows* *textarea-cols* *max-textarea-input-length* 5 | textarea textarea-presentation textarea-presentation-rows 6 | textarea-presentation-cols)) 7 | 8 | ;;; some defaults 9 | (defparameter *textarea-rows* 10 10 | "Default number of rows rendered in textarea") 11 | 12 | (defparameter *textarea-cols* 50 13 | "Default number of columns rendered in textarea") 14 | 15 | (defparameter *max-textarea-input-length* 200 16 | "Maximum number of characters that can be entered before the server complains.") 17 | 18 | ;;; textarea 19 | (defclass textarea-presentation (input-presentation) 20 | ((max-length :initform *max-textarea-input-length*) 21 | (rows :initform *textarea-rows* 22 | :accessor textarea-presentation-rows 23 | :initarg :rows 24 | :documentation "Number of rows in the text area.") 25 | (cols :initform *textarea-cols* 26 | :accessor textarea-presentation-cols 27 | :initarg :cols 28 | :documentation "Number of columns in the text area.")) 29 | (:documentation "Present values in a text area HTML control.")) 30 | 31 | (defmethod render-view-field-value (value (presentation textarea-presentation) 32 | (field form-view-field) (view form-view) widget obj 33 | &rest args &key intermediate-values field-info &allow-other-keys) 34 | (declare (special *presentation-dom-id*)) 35 | (multiple-value-bind (intermediate-value intermediate-value-p) 36 | (form-field-intermediate-value field intermediate-values) 37 | (render-textarea (if field-info 38 | (attributize-view-field-name field-info) 39 | (attributize-name (view-field-slot-name field))) 40 | (if intermediate-value-p 41 | intermediate-value 42 | (apply #'print-view-field-value value presentation 43 | field view widget obj args)) 44 | (textarea-presentation-rows presentation) 45 | (textarea-presentation-cols presentation) 46 | :disabledp (form-view-field-disabled-p field obj) 47 | :id *presentation-dom-id*))) 48 | -------------------------------------------------------------------------------- /test/widgets/selector.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (deftestsuite widgets/static-selector-suite (weblocks-suite) nil) 5 | 6 | (addtest static-selector-select-pane-1 7 | (let* ((widget (make-instance 'widget)) 8 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 9 | (setf (selector-base-uri selector) "/") 10 | (let ((tokens (make-instance 'uri-tokens :tokens '("one")))) 11 | (ensure-same 12 | (get-widget-for-tokens selector tokens) 13 | widget)))) 14 | 15 | (addtest static-selector-select-pane-2 16 | (let* ((widget (make-instance 'widget)) 17 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 18 | (setf (selector-base-uri selector) "/") 19 | (let ((tokens (make-instance 'uri-tokens :tokens '("two")))) 20 | (ensure-same 21 | (get-widget-for-tokens selector tokens) 22 | nil)))) 23 | 24 | (addtest static-selector-update-children-base-uri 25 | (let* ((widget (make-instance 'widget)) 26 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 27 | (let ((*uri-tokens* (make-instance 'uri-tokens :tokens '("one")))) 28 | (update-children selector) 29 | (ensure-same (selector-base-uri selector) "/")))) 30 | 31 | (addtest static-selector-update-children-404 32 | (let* ((widget (make-instance 'widget)) 33 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 34 | (let ((*uri-tokens* (make-instance 'uri-tokens :tokens '("two")))) 35 | (ensure-condition 'http-not-found 36 | (update-children selector))))) 37 | 38 | (addtest static-selector-update-dependents 39 | (let* ((widget (make-instance 'widget)) 40 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 41 | (let ((*uri-tokens* (make-instance 'uri-tokens :tokens '("one")))) 42 | (update-children selector) 43 | (ensure-same (widget-children selector) (list widget))))) 44 | 45 | (addtest static-selector-current-pane 46 | (let* ((widget (make-instance 'widget)) 47 | (selector (make-instance 'static-selector :panes `(("one" . ,widget))))) 48 | (let ((*uri-tokens* (make-instance 'uri-tokens :tokens '("one")))) 49 | (update-children selector) 50 | (ensure-same (static-selector-current-pane selector) "one")))) 51 | 52 | -------------------------------------------------------------------------------- /src/views/types/presentations/dropdown.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(dropdown dropdown-presentation 5 | dropdown-presentation-welcome-name)) 6 | 7 | ;;; Dropdown 8 | (defclass dropdown-presentation (form-presentation choices-presentation-mixin) 9 | ((welcome-name :initarg :welcome-name 10 | :accessor dropdown-presentation-welcome-name 11 | :documentation "If bound, uses this value to 12 | present a welcome message in the form of [Select 13 | Welcome-Name] as the first choice. By default uses 14 | the view field label."))) 15 | 16 | (defmethod render-view-field-value (value (presentation dropdown-presentation) 17 | (field form-view-field) (view form-view) widget obj 18 | &rest args &key intermediate-values field-info &allow-other-keys) 19 | (declare (ignore args) 20 | (special *presentation-dom-id*)) 21 | (multiple-value-bind (intermediate-value intermediate-value-p) 22 | (form-field-intermediate-value field intermediate-values) 23 | (render-dropdown (if field-info 24 | (attributize-view-field-name field-info) 25 | (attributize-name (view-field-slot-name field))) 26 | (obtain-presentation-choices presentation obj) 27 | :welcome-name (if value 28 | (if (form-view-field-required-p field) 29 | nil "None") 30 | (if (slot-boundp presentation 'welcome-name) 31 | (dropdown-presentation-welcome-name presentation) 32 | (view-field-label field))) 33 | :selected-value (if intermediate-value-p 34 | intermediate-value 35 | (when value 36 | (princ-to-string 37 | (funcall 38 | (presentation-choices-value-key presentation) value)))) 39 | :disabledp (form-view-field-disabled-p field obj) 40 | :id *presentation-dom-id*))) 41 | -------------------------------------------------------------------------------- /contrib/lpolzer/request-parameter-for-presentation.diff: -------------------------------------------------------------------------------- 1 | diff -rN -u old-cl-weblocks/src/views/formview/request-deserialization.lisp new-cl-weblocks/src/views/formview/request-deserialization.lisp 2 | --- old-cl-weblocks/src/views/formview/request-deserialization.lisp 2008-06-17 11:37:50.192587184 +0200 3 | +++ new-cl-weblocks/src/views/formview/request-deserialization.lisp 2008-06-17 11:37:50.276564898 +0200 4 | @@ -2,7 +2,8 @@ 5 | (in-package :weblocks) 6 | 7 | (export '(update-object-view-from-request 8 | - request-parameters-for-object-view)) 9 | + request-parameters-for-object-view 10 | + request-parameter-for-presentation)) 11 | 12 | (defgeneric update-object-view-from-request (obj view &rest args 13 | &key class-store 14 | @@ -38,7 +39,8 @@ 15 | (let* ((field (field-info-field field-info)) 16 | (obj (field-info-object field-info)) 17 | (field-key (attributize-name (view-field-slot-name field))) 18 | - (field-value (request-parameter field-key))) 19 | + (field-value (request-parameter-for-presentation field-key 20 | + (view-field-presentation field)))) 21 | (when (typep (view-field-presentation field) 'form-presentation) 22 | (multiple-value-bind (parsedp presentp parsed-value) 23 | (apply #'parse-view-field-value (form-view-field-parser field) 24 | @@ -75,6 +77,7 @@ 25 | (find-slot-dsd (class-of obj) 26 | (view-field-slot-name field))))) 27 | (writer (when writer-name (fdefinition writer-name)))) 28 | + ;(format t "slot ~A => ~A~%" (view-field-slot-name field) value) 29 | (if writer 30 | (funcall writer value obj) 31 | (setf (slot-value obj (view-field-slot-name field)) 32 | @@ -141,7 +144,11 @@ 33 | (when (typep (view-field-presentation field) 'form-presentation) 34 | (let* ((slot-name (view-field-slot-name field)) 35 | (slot-key (attributize-name slot-name)) 36 | - (request-slot-value (request-parameter slot-key))) 37 | + (request-slot-value (request-parameter-for-presentation slot-key (view-field-presentation field)))) 38 | (cons field request-slot-value))))) 39 | (find-view view) nil args)) 40 | 41 | +(defmethod request-parameter-for-presentation (name presentation) 42 | + (declare (ignore presentation)) 43 | + (request-parameter name)) 44 | + 45 | -------------------------------------------------------------------------------- /src/views/types/presentations/url.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(url url-presentation url-presentation-body)) 5 | 6 | (defclass url-presentation (text-presentation) 7 | ((body :initform nil 8 | :initarg :body 9 | :accessor url-presentation-body 10 | :documentation "Body of the link. This can be a string or a 11 | function that accepts same parameters as 12 | 'render-view-field-value'. The function is expected to render 13 | the body into the usual output stream. Its return value is 14 | ignored.") 15 | (escape :initform t 16 | :initarg :escape 17 | :accessor url-presentation-escape 18 | :documentation "If true (the default), the URL will be HTML- 19 | escaped on output to the page.") 20 | (nofollow :initform nil 21 | :initarg :nofollow 22 | :accessor url-presentation-nofollow 23 | :documentation "If true, `rel=\"nofollow\" will be emitted to 24 | tell search engines that this is a user-entered link that 25 | should not be considered in ranking the target.")) 26 | (:documentation "Presents text as a URL. The link body is normally HTML- 27 | escaped; you can turn this off, if needed, by using `:escape nil', 28 | or circumvent it with a body function. The 'href' attribute is 29 | not escaped; be careful to validate it in advance.")) 30 | 31 | (defmethod render-view-field-value (value (presentation url-presentation) 32 | field view widget obj &rest args 33 | &key highlight &allow-other-keys) 34 | (declare (ignore highlight)) 35 | (if (null value) 36 | (call-next-method) 37 | (with-html 38 | (:a :href value 39 | :rel (and (url-presentation-nofollow presentation) "nofollow") 40 | :onclick "stopPropagation(event);" 41 | (flet ((out (x) 42 | (if (url-presentation-escape presentation) 43 | (esc x) 44 | (str x)))) 45 | (etypecase (url-presentation-body presentation) 46 | (string (out (url-presentation-body presentation))) 47 | (function (apply (url-presentation-body presentation) 48 | value presentation field view widget obj args)) 49 | (null (out value)))))))) 50 | 51 | -------------------------------------------------------------------------------- /test/widgets/pagination-utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; utilities for easier testing 5 | (defun pagination-goto-form-template (action &key (page-one-p nil) (validatedp t) (uri "/foo/bar")) 6 | `(:form :action ,uri :method "get" 7 | :onsubmit ,(format nil "initiateFormAction(\"~A\", ~ 8 | $(this), ~ 9 | \"weblocks-session=1%3ATEST\"); ~ 10 | return false;" 11 | (or action "")) 12 | (:div :class "extra-top-1" "") 13 | (:div :class "extra-top-2" "") 14 | (:div :class "extra-top-3" "") 15 | (:fieldset 16 | (:label (:span "Go to page: ") 17 | (:input :name "page-number" 18 | :class ,(concatenate 'string "page-number" 19 | (unless validatedp 20 | " item-not-validated")) 21 | :onfocus ,(format nil "~A~A" 22 | "$(this).removeClassName(\"item-not-validated\");" 23 | (if page-one-p 24 | "" 25 | "if(this.value == \"1\") { this.value = \"\"; }")) 26 | :onblur ,(unless page-one-p "if(this.value == \"\") { this.value = \"1\"; }") 27 | :value ,(unless page-one-p "1"))) 28 | (:input :name "go-to-page" :type "submit" :class "submit" 29 | :value "Go" :onclick "disableIrrelevantButtons(this);") 30 | (:input :name "action" :type "hidden" :value ,action)) 31 | (:div :class "extra-bottom-1" "") 32 | (:div :class "extra-bottom-2" "") 33 | (:div :class "extra-bottom-3" ""))) 34 | 35 | (defun pagination-page-info-template (current-page total-pages) 36 | `(:span :class "page-info" 37 | (:span :class "viewing-label" "Viewing ") 38 | (:span :class "page-label" "Page ") 39 | (:span :class "current-page" (:strong (str ,current-page))) 40 | (:span :class "of-label" " of ") 41 | (:span :class "total-pages" (str ,total-pages)))) 42 | -------------------------------------------------------------------------------- /src/views/types/presentations/widget.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks) 2 | 3 | (export '(widget-presentation get-widget-form-value-from-request)) 4 | 5 | (defclass widget-presentation (form-presentation) 6 | ((widget-init :initarg :widget-init :accessor widget-presentation-widget) 7 | (widget-set-value :initform nil :initarg :set-value) 8 | (current-widget :initform nil))) 9 | 10 | (defmethod render-view-field-value (value (presentation widget-presentation) field view widget obj &rest args &key intermediate-values field-info) 11 | (let ((attributized-slot-name (if field-info 12 | (attributize-view-field-name field-info) 13 | (attributize-name (view-field-slot-name field)))) 14 | (field-widget (setf 15 | (slot-value presentation 'current-widget) 16 | (or (get (view-field-slot-name field) widget) 17 | (let ((field-widget 18 | (funcall (slot-value presentation 'widget-init) 19 | :value value 20 | :presentation presentation 21 | :field field 22 | :view view 23 | :form widget 24 | :object obj))) 25 | (funcall (slot-value presentation 'widget-set-value) 26 | :value value 27 | :widget field-widget 28 | :type :init-value) 29 | (setf (get (view-field-slot-name field) widget) field-widget)))))) 30 | 31 | (render-widget field-widget))) 32 | 33 | (defmethod request-parameter-for-presentation (name (presentation widget-presentation)) 34 | (let ((value (get-widget-form-value-from-request (slot-value presentation 'current-widget)))) 35 | (funcall (slot-value presentation 'widget-set-value) 36 | :value value 37 | :widget (slot-value presentation 'current-widget) 38 | :type :set-value) 39 | value)) 40 | 41 | (defgeneric get-widget-form-value-from-request (widget) 42 | (:documentation "Should parse and return request value for widget. Used for widgets rendered inside of widget-presentation") 43 | (:method ((widget t)) 44 | nil)) 45 | 46 | -------------------------------------------------------------------------------- /test/actions.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; testing get-request-action-name 5 | (deftest get-request-action-name-1 6 | (with-request :get '(("action" . "blah")) 7 | (setf (slot-value *request* 'post-parameters) '(("action" . "blah1"))) 8 | (weblocks::get-request-action-name)) 9 | "blah") 10 | 11 | (deftest get-request-action-name-2 12 | (with-request :get nil 13 | (setf (slot-value *request* 'post-parameters) '(("action" . "blah"))) 14 | (weblocks::get-request-action-name)) 15 | "blah") 16 | 17 | ;;; testing make-action 18 | (deftest make-action/get-request-action-1 19 | (with-request :get nil 20 | (let ((action-name (make-action (lambda (&rest keys) 123)))) 21 | (do-request `(("action" . ,action-name))))) 22 | 123) 23 | 24 | (deftest make-action/get-request-action-2 25 | (with-request :post nil 26 | (let ((action-name (make-action (lambda (&rest keys) 123)))) 27 | (do-request `(("action" . ,action-name))))) 28 | 123) 29 | 30 | (deftest make-action/get-request-action-3 31 | (with-request :post nil 32 | (let ((action-name (make-action (lambda (&rest keys) 123)))) 33 | (setf (slot-value *request* 'get-parameters) `(("action" . ,action-name))) 34 | (weblocks::eval-action))) 35 | 123) 36 | 37 | ;;; test function-or-action->action 38 | (deftest function-or-action->action-1 39 | (with-request :get nil 40 | (multiple-value-bind (res err) 41 | (ignore-errors 42 | (weblocks::function-or-action->action "abc123")) 43 | (values res (not (null err))))) 44 | nil t) 45 | 46 | (deftest function-or-action->action-2 47 | (with-request :get nil 48 | (make-action #'identity "abc123") 49 | (weblocks::function-or-action->action "abc123")) 50 | "abc123") 51 | 52 | (deftest function-or-action->action-3 53 | (with-request :get nil 54 | (weblocks::function-or-action->action #'identity)) 55 | "abc123") 56 | 57 | ;;; testing make-action-url 58 | (deftest make-action-url-1 59 | (with-request :get nil 60 | (make-action-url "test-action")) 61 | "/foo/bar?action=test-action") 62 | 63 | ;;; test eval-action 64 | (deftest eval-action-1 65 | (with-request :get `(("name" . "Bob") 66 | ("cancel" . "Cancel") 67 | (,weblocks::*action-string* . "abc123")) 68 | (make-action (lambda (&key name cancel &allow-other-keys) 69 | (concatenate 'string name cancel))) 70 | (weblocks::eval-action)) 71 | "BobCancel") 72 | 73 | -------------------------------------------------------------------------------- /src/views/types/presentations/image.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(image image-presentation image-presentation-alt 5 | image-presentation-title image-presentation-width 6 | image-presentation-height image-presentation-url-default)) 7 | 8 | (defclass image-presentation (text-presentation) 9 | ((alt :initform nil 10 | :initarg :alt 11 | :accessor image-presentation-alt 12 | :documentation "Alternative text to be specified with the 13 | image.") 14 | (title :initform nil 15 | :initarg :title 16 | :accessor image-presentation-title 17 | :documentation "A title to be specified with the image.") 18 | (width :initform nil 19 | :initarg :width 20 | :accessor image-presentation-width 21 | :documentation "A width attribute of the image.") 22 | (height :initform nil 23 | :initarg :height 24 | :accessor image-presentation-height 25 | :documentation "A height attribute of the image.") 26 | (url-default :initform nil 27 | :initarg :url-default 28 | :accessor image-presentation-url-default 29 | :documentation "If specified, uses this URL to render 30 | a default image, if the value being rendered is 31 | null.")) 32 | (:documentation "Presents a url as an image.")) 33 | 34 | (defmethod render-view-field-value ((value null) (presentation image-presentation) 35 | field view widget obj &rest args 36 | &key highlight &allow-other-keys) 37 | (declare (ignore highlight)) 38 | (if (image-presentation-url-default presentation) 39 | (apply #'render-view-field-value (image-presentation-url-default presentation) 40 | presentation field view widget obj args) 41 | (call-next-method))) 42 | 43 | (defmethod render-view-field-value (value (presentation image-presentation) 44 | field view widget obj &rest args 45 | &key highlight &allow-other-keys) 46 | (declare (ignore args highlight)) 47 | (if (null value) 48 | (call-next-method) 49 | (with-html 50 | (:div 51 | (:img :src value 52 | :width (image-presentation-width presentation) 53 | :height (image-presentation-height presentation) 54 | :alt (image-presentation-alt presentation) 55 | :title (image-presentation-title presentation)))))) 56 | 57 | -------------------------------------------------------------------------------- /src/acceptor.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks) 3 | 4 | (export '(weblocks-acceptor 5 | weblocks-ssl-acceptor 6 | ssl-redirect-acceptor)) 7 | 8 | (defclass weblocks-acceptor (#.(if (find-class 'easy-acceptor nil) 9 | 'easy-acceptor 10 | 'acceptor)) 11 | ((session-cookie-name :type string :accessor session-cookie-name 12 | :initarg :session-cookie-name 13 | :initform (format nil "weblocks-~(~A~)" (gensym))))) 14 | 15 | (defmethod initialize-instance :after ((inst weblocks-acceptor) &rest initargs) 16 | "Set the session secret to prevent a Hunchentoot warning emitted upon 17 | starting the acceptor." 18 | (unless (boundp 'hunchentoot:*session-secret*) 19 | (hunchentoot:reset-session-secret))) 20 | 21 | (defmethod process-connection ((acceptor weblocks-acceptor) socket) 22 | ;; CCL uses predictable random states for new threads 23 | #+ccl(setf *random-state* (make-random-state t)) 24 | (let ((*print-readably* nil)) 25 | (call-next-method))) 26 | 27 | (defmethod acceptor-status-message :around ((acceptor weblocks-acceptor) (http-status-code (eql hunchentoot:+http-internal-server-error+)) &key &allow-other-keys) 28 | nil) 29 | 30 | (defmethod acceptor-status-message :around ((acceptor weblocks-acceptor) (http-status-code (eql hunchentoot:+http-not-found+)) &key &allow-other-keys) 31 | nil) 32 | 33 | ;;; To support both http: and https:, call START-WEBLOCKS twice, once with 34 | ;;; :ACCEPTOR-CLASS 'WEBLOCKS-SSL-ACCEPTOR, once using the default acceptor. 35 | ;;; To force https:, call START-WEBLOCKS with :ACCEPTOR-CLASS 'WEBLOCKS-SSL-ACCEPTOR, 36 | ;;; and also do 37 | ;;; 38 | ;;; (hunchentoot:start (make-instance 'ssl-redirect-acceptor)) 39 | ;;; 40 | 41 | (defclass weblocks-ssl-acceptor (weblocks-acceptor ssl-acceptor) 42 | ()) 43 | 44 | (defclass ssl-redirect-acceptor (acceptor) 45 | ((ssl-port :reader ssl-redirect-acceptor-ssl-port 46 | :initarg :ssl-port 47 | :initform 443 48 | :documentation 49 | "The port used by the SSL acceptor.")) 50 | (:documentation 51 | "A very simple acceptor for handling non-SSL requests and redirecting them 52 | to the SSL port.")) 53 | 54 | (defmethod acceptor-dispatch-request ((acceptor ssl-redirect-acceptor) request) 55 | (hunchentoot:redirect (request-uri* request) 56 | :protocol ':https 57 | :port (ssl-redirect-acceptor-ssl-port acceptor) 58 | :add-session-id nil)) 59 | 60 | -------------------------------------------------------------------------------- /docs/announcements/083.txt: -------------------------------------------------------------------------------- 1 | Weblocks 0.8.3 released 2 | ======================= 3 | 4 | Weblocks is an advanced web framework written in Common Lisp. 5 | 6 | It is designed to make Agile web application development as 7 | effective and simple as possible. 8 | 9 | 10 | WHY YET ANOTHER WEB FRAMEWORK? 11 | 12 | This is not your ordinary run-of-the-mill web framework in PHP, 13 | Python or Ruby. 14 | 15 | Weblocks uses powerful Lisp features like multiple dispatch, the 16 | metaobject protocol, lexical closures, keyword arguments, and macros 17 | to build abstractions that make web development easy, intuitive, and 18 | free of boilerplate. In addition, control flow is easily expressed 19 | using continuations. 20 | 21 | Things that are hard or mundane in other frameworks become easy and 22 | fun in Weblocks. A fine example of this are Weblocks' AJAX capabilities 23 | which relieves you from writing Javascript in a lot of situations. 24 | 25 | 26 | AUDIENCE 27 | 28 | People who want to get their real-life web programming done 29 | as effectively as possible. 30 | 31 | Weblocks is especially targeted at newcomers to Lisp 32 | and Lisp web programming. 33 | 34 | It offers a helpful community and code that prevents you 35 | from shooting yourself too easily in the foot. 36 | 37 | 38 | IS IT USABLE? CAN I SEE SOME DEMOS? 39 | 40 | Weblocks is well-tested and has proven its worth in daily usage. 41 | It is used by a community of developers all over the world. 42 | 43 | Public applications running Weblocks include 44 | 45 | * LAMsight https://www.lamsight.org/ 46 | * Aula Polska http://aulapolska.pl/ 47 | * Thanandar http://www.thanandar.de/ 48 | 49 | 50 | CHANGES IN 0.8.3 51 | 52 | * Greatly enhanced performance in the request handler 53 | * Support for request timeouts 54 | * Automatic bundling/versioning of static files 55 | * Rudimentary profiling 56 | * Fundamentally overhauled nav system 57 | * CLSQL demo fixed 58 | * Updated Simple Blog example 59 | * New HTML error handler 60 | * More flexible debugger configuration with additional restarts 61 | * The usual assortment of fixes and contrib/ additions 62 | 63 | 64 | MORE INFORMATION 65 | 66 | Platforms: 67 | Well-tested on SBCL and Clozure CL. 68 | Partially tested on CMUCL, Lispworks, AllegroCL, and OpenMCL. 69 | 70 | Official site (with detailed installation guide): 71 | http://weblocks-framework.info/ 72 | 73 | Demo: 74 | http://weblocks-framework.info/weblocks-demo 75 | 76 | 77 | CONTRIBUTORS 78 | 79 | This release has been made possible by Nandan Bagchee, Benjamin Collins, 80 | Stephen Compall, Chris Hallwright, Jan Rychter and yours truly. 81 | 82 | -------------------------------------------------------------------------------- /test/views/view/scaffold.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; Test scaffold-class-name 5 | (deftest scaffold-class-name-1 6 | (scaffold-class-name 'form) 7 | form-scaffold) 8 | 9 | ;;; Test scaffold-view-type 10 | (deftest scaffold-view-type-1 11 | (multiple-value-bind (res temp) 12 | (scaffold-view-type (make-instance 'form-scaffold)) 13 | res) 14 | form-view) 15 | 16 | ;;; Test scaffold-view-field-type 17 | (deftest scaffold-view-field-type-1 18 | (multiple-value-bind (res temp) 19 | (scaffold-view-field-type (make-instance 'form-scaffold)) 20 | res) 21 | form-view-field) 22 | 23 | ;;; Test class-visible-slots 24 | (deftest class-visible-slots-1 25 | (mapcar #'slot-definition-name (weblocks-stores:class-visible-slots 'employee)) 26 | (id name age address education manager veteran)) 27 | 28 | (deftest class-visible-slots-2 29 | (mapcar #'slot-definition-name (weblocks-stores:class-visible-slots 'employee :writablep t)) 30 | (name manager)) 31 | 32 | ;;; Test inspect-typespec 33 | (deftest inspect-typespec-1 34 | (inspect-typespec 'integer) 35 | integer nil) 36 | 37 | (deftest inspect-typespec-2 38 | (inspect-typespec '(or null integer)) 39 | integer nil) 40 | 41 | (deftest inspect-typespec-3 42 | (inspect-typespec '(integer 1 5)) 43 | integer (1 5)) 44 | 45 | ;;; Test extract-view-property-from-type 46 | (deftest extract-view-property-from-type-1 47 | (mapcar (lambda (value) 48 | (if (typep value 'standard-object) 49 | (class-name (class-of value)) 50 | value)) 51 | (extract-view-property-from-type :present-as #'typespec->form-view-field-parser 52 | (make-instance 'form-scaffold) 53 | (find-slot-dsd 'employee 'age))) 54 | (:present-as integer-parser)) 55 | 56 | ;;; Test typespec->view-field-presentation 57 | (deftest typespec->view-field-presentation-1 58 | (typespec->view-field-presentation 'foo 'bar nil) 59 | nil) 60 | 61 | ;;; Test default generate-scaffold-view 62 | (deftest generate-scaffold-view-1 63 | (object-class-name 64 | (generate-scaffold-view (make-instance 'data-scaffold) 65 | (find-class 'employee))) 66 | data-view) 67 | 68 | ;;; Test default generate-scaffold-view 69 | (deftest generate-scaffold-view-field-1 70 | (object-class-name 71 | (generate-scaffold-view-field (make-instance 'data-scaffold) 72 | (find-class 'employee) 73 | (find-slot-dsd 'employee 'name))) 74 | data-view-field) 75 | 76 | -------------------------------------------------------------------------------- /src/views/types/presentations/date.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weblocks) 2 | 3 | (export '(date-parser date-printing-mixin 4 | date-presentation date-entry-presentation)) 5 | 6 | (defconstant +seconds-per-day+ (* 24 60 60)) 7 | 8 | (defun date->utime (day month year hour minute) 9 | (encode-universal-time 0 minute hour day month year)) 10 | 11 | (defclass date-parser (parser) 12 | () 13 | (:default-initargs :error-message nil) 14 | (:documentation "")) 15 | 16 | ;; Note: this is a very simple parser -- it will try to match three 17 | ;; numbers separated by one of ./- and make them into a date assuming 18 | ;; it is in the format YYYY.MM.DD. If there is a HH:MM after the date, 19 | ;; it will get parsed as well. 20 | (defmethod parse-view-field-value ((parser date-parser) value obj 21 | (view form-view) (field form-view-field) &rest args) 22 | (declare (ignore args)) 23 | (if (text-input-present-p value) 24 | (multiple-value-bind (matched elements) 25 | (cl-ppcre:scan-to-strings "(\\d+)[\\-/\\.](\\d+)[\\-/\\.](\\d+)(\\s+(\\d+)[:\\.](\\d+))?" value) 26 | (when matched 27 | (let ((date (date->utime (parse-integer (aref elements 2) :junk-allowed t) 28 | (parse-integer (aref elements 1) :junk-allowed t) 29 | (parse-integer (aref elements 0) :junk-allowed t) 30 | (or (and (aref elements 4) (parse-integer (aref elements 4) :junk-allowed t)) 0) 31 | (or (and (aref elements 5) (parse-integer (aref elements 5) :junk-allowed t)) 0)))) 32 | (when date (values t t date))))) 33 | (values t (text-input-present-p value) value))) 34 | 35 | 36 | (defclass date-printing-mixin () 37 | ((format :accessor date-printing-format :initarg :format 38 | :initform "%Y-%m-%d" 39 | :documentation "`format-date' format string to use. Default 40 | is YYYY-MM-DD (ISO 8601 extended format).")) 41 | (:documentation "Show a universal time in a friendly 42 | `format-date'-generated form.")) 43 | 44 | (defmethod print-view-field-value (value (presentation date-printing-mixin) 45 | field view widget obj &rest args) 46 | (declare (ignore obj view field widget args)) 47 | (format-date (date-printing-format presentation) value)) 48 | 49 | (defclass date-presentation (text-presentation date-printing-mixin) 50 | () 51 | (:documentation "Simple date display")) 52 | 53 | (defclass date-entry-presentation (input-presentation date-printing-mixin) 54 | () 55 | (:documentation "Simple date entry")) 56 | 57 | 58 | -------------------------------------------------------------------------------- /src/widget-translation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks) 2 | 3 | (export '(widget-translate 4 | widget-dynamic-translate 5 | widget-translation-table)) 6 | 7 | (defgeneric widget-translation-table (obj &rest args) 8 | (:documentation "Widget translation table is an alist with all strings used in widget which should be translated. 9 | The idea of this table is to hold every string so we just translate this table to translate all widget strings. 10 | Some strings like messages or questions to user can be hard to locate for translation but 11 | when we put all widget translation strings in one place there is no need in location it will be easy to translate them. 12 | This function should return translation strings from widget and all its children. 13 | To use string from translation table see 'widget-translate'. 14 | To use some dynamic string which you want to put into translation table use 'widget-dynamic-translate'") 15 | (:method-combination append) 16 | (:method append (obj &rest args) 17 | (loop for (key . value) in (get 'dynamic-translation-table obj) 18 | collect (cons key (if (functionp value) 19 | (funcall value) 20 | value))))) 21 | 22 | (defmethod widget-translate (obj key &key items-count) 23 | "Returns string associated with key from widget translation table" 24 | (when items-count 25 | (setf key (concatenate-keywords key :- (number-form-type-with-locale (current-locale) items-count)))) 26 | (let ((translation-record (assoc key (widget-translation-table obj)))) 27 | (unless translation-record 28 | (warn "Translation missing for key ~A" key)) 29 | (if (functionp (cdr translation-record)) 30 | (funcall (cdr translation-record)) 31 | (cdr translation-record)))) 32 | 33 | (defmethod widget-dynamic-translate-impl (obj key value) 34 | "Updates widget dynamic translation table. When 'key' is already exists in table, replaces it." 35 | (let* ((table (get 'dynamic-translation-table obj)) 36 | (found-element (assoc key table))) 37 | 38 | (when found-element 39 | (setf table (remove found-element table))) 40 | 41 | (push (cons key value) table) 42 | 43 | (setf (get 'dynamic-translation-table obj) table) 44 | 45 | (if (functionp value) 46 | (funcall value) 47 | value))) 48 | 49 | (defmacro widget-dynamic-translate (obj key value) 50 | `(widget-dynamic-translate-impl ,obj ,key (f0 ,value))) 51 | 52 | -------------------------------------------------------------------------------- /test/blocks/suggest.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | ;;; test render-suggest 5 | (deftest-html render-suggest-1 6 | (render-suggest 'some-name '("a" "b" "c") :input-id 'i1 :choices-id 'c1) 7 | (htm 8 | (:select :id "I1" :name "some-name" 9 | (:option "a") 10 | (:option "b") 11 | (:option "c")) 12 | (:script :type "text/javascript" 13 | (fmt "~%// ~%")))) 16 | 17 | (deftest-html render-suggest-2 18 | (with-request :get nil 19 | (render-suggest 'some-name nil :fetch-fn (lambda (a) '("a" "b" "c")) :input-id 'i1 :choices-id 'c1)) 20 | (htm 21 | (:input :type "text" :id "I1" :name "some-name" :class "suggest") 22 | (:div :id "C1" :class "suggest" "") 23 | (:script :type "text/javascript" 24 | (fmt "~%// ~%")))) 27 | 28 | (deftest render-suggest-3 29 | (with-request :get nil 30 | (let ((*weblocks-output-stream* (make-string-output-stream))) 31 | (declare (special *weblocks-output-stream*)) 32 | (render-suggest 'some-name nil :fetch-fn (lambda (a) '("a" "b" "c")) :input-id 'i1 :choices-id 'c1)) 33 | (do-request `(("pure" . "true") (,weblocks::*action-string* . "abc123")))) 34 | "
  • a
  • b
  • c
") 35 | 36 | (deftest-html render-suggest-4 37 | (render-suggest 'some-name '("a" "b" "c") :input-id 'i1 :choices-id 'c1 :value "b") 38 | (htm 39 | (:select :id "I1" :name "some-name" 40 | (:option "a") 41 | (:option :selected "true" "b") 42 | (:option "c")) 43 | (:script :type "text/javascript" 44 | (fmt "~%// ~%")))) 47 | 48 | (deftest-html render-suggest-5 49 | (with-request :get nil 50 | (render-suggest 'some-name nil :fetch-fn (lambda (a) '("a" "b" "c")) :input-id 'i1 :choices-id 'c1 51 | :value "test")) 52 | (htm 53 | (:input :type "text" :id "I1" :name "some-name" :class "suggest" :value "test") 54 | (:div :id "C1" :class "suggest" "") 55 | (:script :type "text/javascript" 56 | (fmt "~%// ~%")))) 59 | 60 | ;;; test format-suggest-list 61 | (deftest format-suggest-list-1 62 | (weblocks::format-suggest-list '("a" "b" "c")) 63 | "
  • a
  • b
  • c
") 64 | -------------------------------------------------------------------------------- /contrib/jfremlin/rrd-router-graph.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defun graph-tmp-path () 3 | (merge-pathnames "tmp/" (compute-public-files-path :weblocks))) 4 | 5 | (defvar *graph-tmp-html-path* "/pub/tmp/") 6 | 7 | (defun clean-graph-tmp-path () 8 | (ensure-directories-exist (graph-tmp-path)) 9 | (loop for file in (directory (merge-pathnames "*" (graph-tmp-path))) 10 | do (when (> (- (get-universal-time) (file-write-date file)) 300) 11 | (delete-file file)))) 12 | 13 | (defun router-graph-show (k router) 14 | (let ((counter 0)) 15 | (flet ((gen-filename () 16 | (format nil "tmp-router-~D-~D.png" (random 100000) (incf counter)))) 17 | (clean-graph-tmp-path) 18 | (labels ((graph-router (router) 19 | (let ((graphs (netstatus.manager::sourcegroup-graphs router))) 20 | (when graphs 21 | (let ((files 22 | (loop for g in graphs collect (gen-filename)))) 23 | (loop for g in graphs 24 | for f in files 25 | do (netstatus.manager::generate-graph g router (merge-pathnames f (graph-tmp-path)))) 26 | (with-html 27 | (:h2 (str (netstatus.manager::title router)))) 28 | 29 | (loop for f in files 30 | for g in graphs do 31 | (with-html 32 | (:div 33 | (:h3 (str (netstatus.manager::graph-def-title g))) 34 | (:img :src (concatenate 'string (string *graph-tmp-html-path*) f))))) 35 | (typecase router 36 | (netstatus.manager::router 37 | (loop for if in (netstatus.manager::router-interfaces router) do 38 | (graph-router if))))))))) 39 | (graph-router router)))) 40 | 41 | (render-link 42 | (lambda(&rest args) 43 | (declare (ignore args)) 44 | (answer k)) "Back")) 45 | 46 | (defun router-graph (obj router) 47 | (declare (ignore obj)) 48 | (do-page 49 | (lambda(k)(router-graph-show k router)))) 50 | 51 | (defun make-routers-page () 52 | (make-instance 'composite :widgets 53 | (list 54 | (make-instance 'datagrid 55 | :on-drilldown '(graph . router-graph) 56 | :name 'routers-grid 57 | :data-class 'router 58 | :view 'router-table-view 59 | :item-data-view 'router-data-view 60 | :item-form-view 'router-form-view)))) 61 | 62 | -------------------------------------------------------------------------------- /test/request-handler-utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weblocks-test) 3 | 4 | (defun with-request-template (body &key 5 | (title "Hello") 6 | render-debug-toolbar-p widget-stylesheets) 7 | (format nil "~ 8 | ~%~ 10 | ~ 11 | ~ 12 | ~A~ 13 | ~ 14 | ~ 15 | ~ 16 | ~ 17 | ~A~ 18 | ~A~ 19 | ~ 20 | ~ 21 | ~ 22 | ~ 23 | ~ 24 | ~A~ 25 | ~ 26 | ~ 27 |
~ 28 |
~ 29 |
~ 30 |
~ 31 |
~ 32 | ~A~ 33 |
~ 34 |
~ 35 |
~ 36 |
~ 37 |
~ 38 | ~A~ 39 |
 
~ 40 | ~ 41 | " 42 | title 43 | (apply #'concatenate 44 | 'string 45 | (loop for i in widget-stylesheets 46 | collect (format 47 | nil 48 | "" i))) 49 | (if render-debug-toolbar-p (format nil "~ 50 | ") 51 | "") 52 | (if render-debug-toolbar-p (format nil "~ 53 | ") 54 | "") 55 | (format nil body) 56 | (if render-debug-toolbar-p (format nil "~ 57 |
~ 58 | ~ 59 | Reset Sessions~ 60 |
") 61 | ""))) 62 | -------------------------------------------------------------------------------- /contrib/lpolzer/yui/example.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defwidget buddy-manager-panel (yui-panel) () 3 | (:default-initargs :target-id "buddy-manager" 4 | :config '(:drag-only t :context (array "header-banner" "tr" "tr")) 5 | :loader-args '(:include-css-p nil))) 6 | 7 | (defwidget buddy-manager-resize (yui-resize) () 8 | (:default-initargs :target-id "buddy-manager" 9 | :config '(:handles (array "br") :auto-ratio false 10 | :status false :proxy false))) 11 | 12 | (defwidget buddy-manager (yui-tabview) 13 | ((proxy-resize-p :type boolean :accessor proxy-resize-p :initarg :proxy-resize-p :initform nil) 14 | (closable :type boolean :accessor closable :initarg :closable :initform nil) 15 | (draggable :type boolean :accessor draggable :initarg :draggable :initform nil) 16 | (resizable :type boolean :accessor resizable :initarg :resizable :initform nil)) 17 | (:default-initargs :name "buddy-manager" 18 | :tabs (list 19 | (cons #!"Friends" (make-instance 'buddy-list :buddies #'friends)) 20 | (cons #!"Foes" (make-instance 'buddy-list :buddies #'foes)) 21 | (cons #!"Clan" (make-instance 'buddy-list :buddies #'clan-buddies))) 22 | 23 | )) 24 | 25 | (defmethod render-widget-body ((widget buddy-manager) &rest args) 26 | (call-next-method) ; render tabview 27 | (let ((panel (intern (gen-id "yuiWidget"))) 28 | (resize (intern (gen-id "yuiWidget")))) 29 | (let ((panel (make-instance 'buddy-manager-panel :widget-variable panel))) 30 | (add-component-config panel :draggable (js-bool (draggable widget)) 31 | :closeable (js-bool (closable widget))) 32 | (render-widget panel)) 33 | (when (resizable widget) 34 | (render-widget (make-instance 'buddy-manager-resize 35 | :panel panel 36 | :widget-variable resize 37 | :target-id (attributize-name (widget-name widget)) 38 | #|:proxy-resize-p (proxy-resize-p widget)|#))))) 39 | 40 | (defun make-buddy-manager () 41 | (premium (:GOLD) 42 | (return-from make-buddy-manager (make-instance 'buddy-manager :closable t :draggable t 43 | :resizable t 44 | :proxy-resize (eq (+pref+ resize-mode) :proxy)))) 45 | (premium (:SILVER) 46 | (return-from make-buddy-manager (make-instance 'buddy-manager :closable t :draggable t))) 47 | (premium (:BRONZE) 48 | (return-from make-buddy-manager (make-instance 'buddy-manager))) 49 | nil) 50 | 51 | -------------------------------------------------------------------------------- /pub/stylesheets/dialog.css: -------------------------------------------------------------------------------- 1 | 2 | .graybox 3 | { 4 | position: fixed; 5 | top: 0; 6 | left: 0; 7 | bottom: 0; 8 | right: 0; 9 | background-color: black; 10 | z-index: 500; 11 | 12 | filter: alpha(opacity=30); 13 | -moz-opacity: 0.3; 14 | opacity: 0.3; 15 | } 16 | 17 | /* IE 6 specific fix for lack of 'position: fixed' implementation */ 18 | * html .graybox 19 | { 20 | position: absolute; 21 | left: expression(documentElement.scrollLeft + 'px'); 22 | top: expression(documentElement.scrollTop + 'px'); 23 | width: expression(document.documentElement.clientWidth + 'px'); 24 | height: expression(document.documentElement.clientHeight + 'px'); 25 | } 26 | 27 | .dialog 28 | { 29 | position: fixed; 30 | _position: absolute; /* Degrade to this in IE for now */ 31 | z-index: 725; 32 | min-width:200px; 33 | max-width: 50%; 34 | } 35 | 36 | .dialog-body 37 | { 38 | padding: 1em; 39 | _height: 1%; /* hasLayout */ 40 | background-color: white; 41 | border-bottom: 1px solid black; 42 | } 43 | 44 | /* Style choice dialog */ 45 | .choice .dialog-body, .modal .choice 46 | { 47 | background: white url(/weblocks-common/pub/images/dialog/question.png) no-repeat 0.5em center; 48 | } 49 | 50 | .dialog h2, .modal h2 51 | { 52 | padding: 0; 53 | margin: 0; 54 | text-align: left; 55 | } 56 | 57 | .dialog h1 span, .modal h1 span 58 | { 59 | background: url(/weblocks-common/pub/images/horizontal_line.png) repeat-x bottom; 60 | display: block; 61 | } 62 | 63 | .dialog h1 span 64 | { 65 | margin-left: 0.5em; 66 | margin-right: 0.5em; 67 | } 68 | 69 | .choice 70 | { 71 | text-align: center; 72 | } 73 | 74 | .choice form, .choice form fieldset, .choice p 75 | { 76 | border: none; 77 | margin: 0; 78 | padding: 0; 79 | } 80 | 81 | .choice p 82 | { 83 | margin-bottom: 1em; 84 | } 85 | 86 | .choice input 87 | { 88 | margin-left: 0.25em; 89 | margin-right: 0.25em; 90 | } 91 | 92 | /* Style information dialog */ 93 | .information .dialog-body, .modal .information 94 | { 95 | background-image: url(/weblocks-common/pub/images/dialog/information.png); 96 | } 97 | 98 | /* Modal interaction */ 99 | .modal 100 | { 101 | background: url(/weblocks-common/pub/images/horizontal_line.png) repeat-x bottom; 102 | padding-bottom: 2px; 103 | } 104 | 105 | .modal h1 106 | { 107 | border: none; 108 | margin: 0; 109 | } 110 | 111 | .modal .choice 112 | { 113 | min-height: 48px; 114 | _height: 48px; 115 | background-position: left center; 116 | padding-top: 1em; 117 | padding-bottom: 1em; 118 | } 119 | 120 | .title-bar { 121 | width: 100%; 122 | } 123 | 124 | .title-text-cell { 125 | background:white; 126 | border-top:1px solid black; 127 | border-left:1px solid black; 128 | border-right: 1px solid black; 129 | padding:0 5px; 130 | padding-top:3px; 131 | } 132 | --------------------------------------------------------------------------------