macros.lisp 4.63 KB
Newer Older
1
;;
2
;; Copyright 2002-2011 Genworks International 
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

(in-package :gwl)


(defmacro with-all-servers ((server) &rest body)
  (let ((server-var (gensym)))
    `(dolist (,server-var (list *wserver* *ssl-server*))
       (when ,server-var
         (let ((,server ,server-var)) ,@body)))))

(define-object form-mixin ())


(define-lens (html-format form-mixin)()
  :output-functions
  ((:form 
    (slot-names &key (size-default 5)
                (sizes (make-list (length slot-names) :initial-element size-default))
                (prompts (mapcar #'(lambda(slot-name) (symbol-name slot-name)) slot-names))
                (cellpadding 0)
                (heading-color :yellow))
    (html 
     (:p
      ((:table :cellpadding cellpadding)
       (:tr ((:th :colspan 2)  "Dimensions"))
       (mapc #'(lambda(slot-name prompt size)
                 (html (:tr ((:td :bgcolor heading-color) (:princ (string-capitalize prompt)))
                            (:td ((:input :type :text :name (symbol-name slot-name) :size size 
                                          :value (or (the (evaluate slot-name)) ""))))))) slot-names prompts sizes)))
     (:p ((:input :type :submit :name :subbmit :value " OK ")))))))
    



(defmacro html-form (slot-names 
                     &key (size-default 5)
                          (sizes (make-list (length slot-names) :initial-element size-default))
                          (prompts (mapcar #'(lambda(slot-name) (symbol-name slot-name)) slot-names))
                          (cellpadding 0)
                          (heading-color :yellow))
  `(html 
    (:p
     ((:table :cellpadding ,cellpadding)
      (:tr ((:th :colspan 2)  "Dimensions"))
      ,@(mapcar #'(lambda(slot-name prompt size)
                    `(:tr ((:td :bgcolor ,heading-color) (:princ ,(string-capitalize prompt)))
                          (:td ((:input :type :text :name ,(symbol-name slot-name) :size ,size 
                                        :value (or (the ,slot-name) "")))))) slot-names prompts sizes)))
    (:p ((:input :type :submit :name :subbmit :value " OK ")))))


(defmacro with-html-form ((&key name multipart? enctype target requestor on-submit suppress-border? local-anchor cl-who?) 
                          &body body)
  
  "Enclose a body of code with a form.

FLAG -- fill in.


"
81
82

  
83
84
85
86
87
  
  (let ((%enctype% (gensym))
        (fixed-prefix (gensym)))
    `(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data")))
           (,fixed-prefix (the fixed-url-prefix)))
88

89
90
91
92
93
94
95
       (,@(if cl-who? '(with-html-output (*stream* nil :indent t)) 
            '(html 
              ;;html-stream *stream*
              
              ))
          ((:form :method :|post| 
                  
96
                  :action (string-append "" ;;(or ,fixed-prefix "")
97
98
99
100
101
102
103
104
105
106
107
108
                                 (format nil (if ,local-anchor (format nil "/answer#~a" ,local-anchor) "/answer")))
                  
                  :name ,(or name `(the root-path-string))
                  ,@(if cl-who? `(:enctype ,%enctype%) `(:if* ,%enctype% :enctype ,%enctype%))
                  ,@(if cl-who? `(:target ,target) `(:if* ,target :target ,target))
                  ,@(if cl-who? `(:on-submit ,on-submit) `(:if* ,on-submit :onsubmit ,on-submit))
                  ,@(if cl-who? `(:style ,(when suppress-border? "padding: 0; border: 0; margin: 0"))
                      `(:if* ,suppress-border? :style "padding: 0; border: 0; margin: 0")))
           
           ((:input :type :hidden :name :|requestor| :value ,(if (null requestor) `(the url-encoded-root-path)
                                                             `(the-object ,requestor url-encoded-root-path))))
           
109
110
111
           ((:input :type :hidden :name :|iid| :value (the instance-id)))

	   ,@body)))))
112
113
114
115
116
117