UCW Source
(defclass login ()
((username :accessor login.username
:initform nil)
(password :accessor login.password
:initform nil)
(message :accessor login.message
:initform nil
:initarg :message
:documentation "A message which will be presented to
the user before the login box."))
(:documentation "Generic login (input username and password) component.
This component, which must be embedded in another component,
presents the user with a simple two fielded login form.
When the user attempts a login the action try-login is called,
try-login calls the generic function check-credentials passing it
the login component. If check-credentials returns true then the
login-successful action is called, otherwise the message slot of
the login component is set (to a generic \"bad username\"
message).
The default implementaion of login-successful simples answers t,
no defalut implementation of check-credentials is
provided. Developers should use sub-classes of login for which
all the required methods have been definined.")
(:metaclass standard-component-class))
(defmethod render-on ((res response) (l login))
(<:div :id "ucw-login"
(when (login.message l)
(<:div :id "ucw-login-message" (<:as-html (login.message l))))
(<ucw:form :action (try-login l)
(<:table
(<:tr (<:td :align "right" "Username")
(<:td :align "left" (<ucw:input :type "text"
:accessor (login.username l)
:size 10)))
(<:tr (<:td :align "right" "Password")
(<:td :align "left" (<ucw:input :type "password"
:accessor (login.password l)
:size 10)))
(<:tr (<:td :align "center" :colspan 2
(<:input :type "submit" :value "login")))))))
(defgeneric check-credentials (login)
(:documentation "Returns T if LOGIN is valid."))
(defaction login-successful ((l login))
(answer t))
(defaction try-login ((l login))
(if (check-credentials l)
(login-successful l)
(setf (login.message l) "Bad username/password.")))
(defclass error-message (simple-window-component)
((message :accessor message :initarg :message :initform "ERROR [no message specified]"))
(:documentation "Generic component for showing server side
error messages.")
(:metaclass standard-component-class))
(defmethod window-component.title ((err error-message))
(concatenate 'string "ERROR: " (message err)))
(defmethod render-on ((res response) (err error-message))
(<:h1 :style "color: #cc3333;" "ERROR")
(<:p :style "color: #cc3333;" (message err)))
(defclass error-component (error-message)
((condition :accessor error.condition :initarg :condition :initform nil)
(backtrace :accessor error.backtrace :initarg :backtrace))
(:documentation "Generic component for showing server side
error conditions. Unlike ERROR-MESSAGE this component also
attempts to display a backtrace.")
(:default-initargs
:place (make-place (context.window-component *context*))
:inline-javascript "
function toggle_display(id) {
var element = document.getElementById(id);
element.style.display = element.style.display == 'none' ? 'block' : 'none';
}")
(:metaclass standard-component-class))
(defmethod window-component.title ((err error-component))
(format nil "ERROR: ~S" (error.condition err)))
(defmethod render-on ((res response) (err error-component))
(<:h1 :style "text-align: center; width: 100%; color: #cc3333;" "ERROR")
(<:h2 :style "color: #ff0000;"
(<:tt
(inspect-anchor (frame.window-component (context.current-frame *context*))
(error.condition err)
(message err))))
(<:h2 :style "text-align: center; width: 100%; color: #cc3333;" "BACKTRACE")
(loop
for frame in (error.backtrace err)
for index upfrom 0
for div-id = (concatenate 'string "frame-" (princ-to-string index) "-details")
do (<:div
(<:p (<:button :onclick (concatenate 'string "toggle_display('" div-id "');") "[ + ]")
" "
(<:as-html
(let ((desc (backtrace-frame-description frame))
(max-length 50))
(if (stringp desc)
(if (< max-length (length desc))
(concatenate 'string (subseq desc 0 (min max-length (length desc))) "...")
desc)
desc))))
(<:div :style "display: none;" :id div-id
(<:table :border 1
(<:tr
(<:td :valign "top" "Description")
(<:td (<:as-html (backtrace-frame-description frame))))
(<:tr
(<:td :valign "top" "Locals")
(<:td
(if (backtrace-frame-locals frame)
(<:table
(<:tr
(<:th "Name")
(<:th "Value"))
(loop
with *print-level* = 4
with *print-length* = 4
with *print-circle* = t
for local in (backtrace-frame-locals frame)
do (<:tr
(<:td :valign "top"
(inspect-anchor (frame.window-component (context.current-frame *context*))
(getf local :name) #| "name" |# ))
(<:td :valign "top"
(inspect-anchor (frame.window-component (context.current-frame *context*))
(getf local :value) #| "value" |# )))))
(<:as-html "None."))))
(<:tr
(<:td :valign "top" "Source")
(<:td (<:as-html (backtrace-frame-source-location frame)))))))))
(defclass info-message ()
((message :initarg :message :accessor message)
(ok-text :initarg :ok-text :accessor ok-text :initform "Ok."))
(:documentation "Component for showing a message to the user.
If the OK-TEXT slot is non-NIL component will use that as the
text for a link which, when clicked, causes the component to
answer. It follows that if OK-TEXT is NIL this component will
never answer.")
(:metaclass standard-component-class))
(defmethod render-on ((res response) (m info-message))
(<:html
(<:body
(<:p (<:as-html (message m)))
(when (ok-text m)
(<:p (<ucw:a :action (answer-component m t) (<:as-html (ok-text m))))))))
(defclass option-dialog (template-component)
((message :accessor message :initarg :message)
(options :accessor options :initarg :options)
(confirm :accessor confirm :initarg :confirm :initform nil))
(:default-initargs :template-name "ucw/option-dialog.tal")
(:documentation "Component for querying the user.
The value of the slot MESSAGE is used as a general heading.
The OPTIONS slot must be an alist of (VALUE . LABEL). LABEL (a
string) will be used as the text of a link which, when clikced,
will answer VALUE.
If the CONFIRM slot is T the user will be presented with a second
OPTION-DIALOG asking the user if they are sure they want to
submit that value.")
(:metaclass standard-component-class))
(defmethod template-component-environment nconc ((dialog option-dialog))
(make-standard-environment
`((options . ,(mapcar (lambda (value-cons)
(tal-env 'text (cdr value-cons)
'value (car value-cons)))
(options dialog))))
dialog))
(defaction respond ((dialog option-dialog) value)
(if (confirm dialog)
(if (call 'option-dialog
:message (format nil "Are you sure you want to answer ~S to the question ~S?"
(cdr (assoc value (options dialog)))
(message dialog))
:options '((t . "Yes")
(nil . "No")))
(answer value)
;; repeat the question
nil)
(answer value)))
(defmacro option-dialog ((message-spec &rest message-args) &body options)
`(call 'option-dialog :message ,(if message-args
`(format nil ,message-spec ,@message-args)
message-spec)
:options (list ,@options)))
(defclass range-view (template-component)
((offset :initarg :offset
:accessor range-view.offset
:initform 0
:backtrack t
:documentation "Whcih of the windows we're currently looking at.")
(windows :reader range-view.windows :initform '())
(window-size :accessor range-view.window-size :initform 20 :initarg :window-size))
(:default-initargs :template-name "ucw/range-view.tal")
(:documentation "Component for showing the user a set of data one \"window\" at a time.
The data set is presented one \"window\" at a time with links to
the the first, previous, next and last window. Each window shows
at most WINDOW-SIZE elements of the data. The data is passed to
the range-view at instance creation time via the :DATA initarg.
The generic function RENDER-RANGE-VIEW-ITEM is used to render
each item of DATA.
In order to change the rendering of the single elements of a
range view developer's should create a sub class of RANGE-VIEW
and define their RENDER-RANGE-VIEW-ITEM methods on that.")
(:metaclass standard-component-class))
(defun partition-into-windows (data window-size)
(iterate
(with windows = '())
(with current-window = '())
(for index upfrom 1)
(for ele in data)
(push (cons index ele) current-window)
(when (zerop (mod index window-size))
(push (nreverse current-window) windows)
(setf current-window '()))
(finally (when current-window
(push (nreverse current-window) windows)))
(finally (return (nreverse windows)))))
(defmethod shared-initialize :after ((range range-view) slot-names
&key data window-size &allow-other-keys)
(declare (ignore slot-names))
(setf (slot-value range 'windows)
(partition-into-windows data window-size)))
(defmethod range-view.current-window ((range range-view))
(nth (range-view.offset range) (range-view.windows range)))
(defmethod template-component-environment nconc ((range range-view))
(let ((current-window (range-view.current-window range))
current-window-number)
(make-standard-environment
`((items . ,(mapcar (lambda (item-cons)
(tal-env 'index (car item-cons)
'item (cdr item-cons)))
current-window))
(windows . ,(loop
for page-number upfrom 1
for w in (range-view.windows range)
when (eq w current-window)
do (setf current-window-number page-number)
collect (tal-env 'num page-number 'selected (eq current-window w))))
(current-window-number . ,current-window-number)
(nextp . ,(range-view.have-next-p range))
(previousp . ,(range-view.have-previous-p range))
(num-windows . ,(length (range-view.windows range)))))))
(defmethod range-view.current-window-items ((range range-view))
(mapcar #'cdr (range-view.current-window range)))
(defmethod range-view.have-previous-p ((view range-view))
"Returns true if VIEW has a window before the current one."
(and (range-view.windows view)
(not (zerop (range-view.offset view)))))
(defmethod range-view.have-next-p ((view range-view))
"Returns true if VIEW has a window after the current one."
(with-slots (offset windows)
view
(and windows (< offset (1- (length windows))))))
(defgeneric render-range-view-item (response range-view item)
(:documentation "Render a single element of a range-view.")
(:method ((response response) (range-view range-view) (item t))
"Standard implementaion of RENDER-RANGE-VIEW-ITEM. Simply
applies ITEM to princ (via <:as-html)."
(declare (ignore response range-view))
(<:as-html item)))
(defaction scroll-start ((range range-view))
(setf (range-view.offset range) 0))
(defaction scroll-end ((range range-view))
(setf (range-view.offset range) (1- (length (range-view.windows range)))))
(defaction scroll-forward ((view range-view) &optional (n 1))
(with-slots (offset windows)
view
(incf offset n)
(when (<= (length windows) offset)
(scroll-end view))))
(defaction scroll-backward ((range range-view) &optional (n 1))
(with-slots (offset)
range
(decf offset n)
(when (minusp offset)
(setf offset 0))))
(defaction scroll-to-page ((range range-view) window-number)
(setf (range-view.offset range) window-number))
(defclass redirect-component (window-component)
((target :accessor target :initarg :target))
(:metaclass standard-component-class)
(:documentation "Send a client redirect.
This component, which must be used as a window-component,
redirects the client to the url specified in the target slot. A
302 (as opposed to 303) response code is sent to ensure
compatability with older browsers.
The redirect component never answers."))
(defmethod render-on ((res response) (redirect redirect-component))
(unless (eq redirect (context.window-component *context*))
(error "Redirect component can only be used as a root component."))
(setf (get-header res "Status") "302"
(get-header res "Location") (target redirect)))
(defclass tabbed-pane (template-component container)
()
(:default-initargs
:template-name "ucw/tabbed-pane.tal"
:label-test #'string=)
(:documentation "Component for providing the user with a standard \"tabbed pane\" GUI widget.")
(:metaclass standard-component-class))
(defmethod template-component-environment nconc ((tabbed-pane tabbed-pane))
(make-standard-environment
(list
(cons 'panes
(iterate
(with current = (container.current-component tabbed-pane))
(for (label . component) in (container.contents tabbed-pane))
(collect (tal-env 'pane-label label
'pane-component component
'selected (eql current component)))))
(cons 'selected-component (container.current-component tabbed-pane)))))
(defclass task-component (standard-component)
()
(:metaclass standard-component-class)
(:documentation "Call an action without user interaction.
This component, corresponds to a component with a single \"start\"
action that gets clicked automatically without any user interaction.
By using a task component, you can specify control flow using standard
components without needing a component with a link that starts up the
interaction."))
(defgeneric start (task)
(:documentation "action which gets called automatically when task-component
is active. Use defaction to define your own \"start\" action"))
(defmethod render-on ((res response) (task task-component))
(start task)
(let ((active-component (place (component.place task))))
(when (eq task active-component)
(error "No active component after calling task's start method"))
(render-on res active-component)))
(defclass ucw-inspector ()
((datum :accessor datum :initarg :datum :initform nil))
(:documentation "Component for inspecting random lisp values.
Based on SLIME's inspector.")
(:metaclass standard-component-class))
(defaction call-action ((inspector ucw-inspector) action)
"Call an inspector action."
(funcall action))
(defaction call-inspector ((component component) datum)
"Call an inspector for DATUM on the component COMPONENT."
(call 'ucw-inspector :datum datum))
(defun inspect-anchor (from datum &optional (string (write-to-string datum :circle t :pretty nil)))
(<ucw:a :action (call-inspector from datum) (<:as-html string)))
(defun inspect-anchor-string (from datum)
(with-output-to-string (*yaclml-stream*)
(inspect-anchor from datum)))
(defmethod render-on ((res response) (insp ucw-inspector))
(multiple-value-bind (title content)
(swank::inspect-for-emacs (slot-value insp 'datum) (swank::make-default-inspector))
(<:h2 (<:as-html title))
(dolist (part content)
(etypecase part
(null nil)
(string (<:as-html part))
(cons (swank::destructure-case part
((:newline) (<:br))
((:value obj &optional (str (prin1-to-string obj)))
(<ucw:a :action (call-inspector insp obj)
(<:as-html str)))
((:action text lambda)
(<ucw:a :action (call-action insp lambda)
(<:as-html text)))))))
(<:p (<ucw:a :action (ok insp)) "Ok.")))