Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-forms.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents ac2d302a0011
children 0293115a14e9
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;; w3-forms.el --- Emacs-w3 forms parsing code for new display engine 1 ;;; w3-forms.el --- Emacs-w3 forms parsing code for new display engine
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/08/10 16:14:08 3 ;; Created: 1997/01/02 20:20:29
4 ;; Version: 1.14 4 ;; Version: 1.32
5 ;; Keywords: faces, help, comm, data, languages 5 ;; Keywords: faces, help, comm, data, languages
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
9 ;;; 10 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply. 11 ;;; This file is part of GNU Emacs.
11 ;;; 12 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by 14 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option) 15 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version. 16 ;;; any later version.
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details. 21 ;;; GNU General Public License for more details.
21 ;;; 22 ;;;
22 ;;; You should have received a copy of the GNU General Public License 23 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to 24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 28
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; FORMS processing for html 2.0/3.0 30 ;;; FORMS processing for html 2.0/3.0
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile 32 (eval-and-compile
31 (require 'w3-draw)) 33 (require 'w3-display)
32 34 (require 'widget))
33 (require 'widget) 35
34 36 (require 'w3-vars)
35 (if (featurep 'mule) (fset 'string-width 'length)) 37 (require 'mule-sysdp)
36
37 ;; These are things in later versions of the widget package that I don't
38 ;; have yet.
39 (defun widget-at (pt)
40 (or (get-text-property pt 'button)
41 (get-text-property pt 'field)))
42 38
43 ;; A form entry area is a vector 39 ;; A form entry area is a vector
44 ;; [ type name default-value value maxlength options widget] 40 ;; [ type name default-value value maxlength options widget]
45 ;; Where: 41 ;; Where:
46 ;; type = symbol defining what type of form entry area it is 42 ;; type = symbol defining what type of form entry area it is
67 (defsubst w3-form-element-set-options (obj val) (aset obj 6 val)) 63 (defsubst w3-form-element-set-options (obj val) (aset obj 6 val))
68 (defsubst w3-form-element-set-action (obj val) (aset obj 7 val)) 64 (defsubst w3-form-element-set-action (obj val) (aset obj 7 val))
69 (defsubst w3-form-element-set-widget (obj val) (aset obj 8 val)) 65 (defsubst w3-form-element-set-widget (obj val) (aset obj 8 val))
70 66
71 ;; The main function - this adds a single widget to the form 67 ;; The main function - this adds a single widget to the form
72 (defun w3-form-add-element (&rest args) 68 (defun w3-form-add-element (type name value size maxlength default
69 action options number id checked
70 face)
71 (let* ((name (or name (case type
72 ((submit reset) nil)
73 (otherwise (symbol-name type)))))
74 (el (vector type
75 name
76 default
77 value
78 size
79 maxlength
80 options
81 action nil))
82 (size (if size
83 (+ 2 size)
84 (case type
85 ((checkbox radio) 3)
86 ((reset submit)
87 (+ 2 (length (or value (symbol-name type)))))
88 (multiline 21)
89 (hidden nil)
90 (otherwise 22))))
91 )
92 (if size
93 (set-text-properties (point)
94 (progn (insert-char ?T size) (point))
95 (list 'w3-form-info el
96 'start-open t
97 'end-open t
98 'rear-nonsticky t)))))
99
100 (defun w3-form-resurrect-widgets ()
101 (let ((st (point-min))
102 info nd node action)
103 (while st
104 (if (setq info (get-text-property st 'w3-form-info))
105 (progn
106 (setq nd (next-single-property-change st 'w3-form-info)
107 action (w3-form-element-action info)
108 node (assoc action w3-form-elements))
109 (goto-char st)
110 (delete-region st nd)
111 (if (not (w3-form-element-size info))
112 (w3-form-element-set-size info 20))
113 (if node
114 (setcdr node (cons info (cdr node)))
115 (setq w3-form-elements (cons (cons action (list info))
116 w3-form-elements)))
117 (w3-form-add-element-internal info)
118 (setq st (next-single-property-change st 'w3-form-info)))
119 (setq st (next-single-property-change st 'w3-form-info))))))
120
121 (defun w3-form-add-element-internal (el)
73 (let* ((widget nil) 122 (let* ((widget nil)
74 (buffer-read-only nil) 123 (buffer-read-only nil)
75 (inhibit-read-only t) 124 (inhibit-read-only t)
76 (widget-creation-function nil) 125 (widget-creation-function nil))
77 (action (cons (cons 'form-number (w3-get-state :formnum)) 126 (setq widget-creation-function (or (get (w3-form-element-type el)
78 (nth 6 args)))
79 (node (assoc action w3-form-elements))
80 (name (or (nth 1 args)
81 (if (memq (nth 0 args) '(submit reset))
82 nil
83 (symbol-name (nth 0 args)))))
84 (val (vector (nth 0 args) ; type
85 name ; name
86 (nth 5 args) ; default
87 (nth 2 args) ; value
88 (nth 3 args) ; size
89 (nth 4 args) ; maxlength
90 (nth 7 args) ; options
91 action
92 nil)) ; widget
93 )
94 (setq widget-creation-function (or (get (car args)
95 'w3-widget-creation-function) 127 'w3-widget-creation-function)
96 'w3-form-default-widget-creator) 128 'w3-form-default-widget-creator)
97 widget (funcall widget-creation-function val 129 widget (funcall widget-creation-function el nil))
98 (cdr (nth 10 args))))
99 (if node
100 (setcdr node (cons val (cdr node)))
101 (setq w3-form-elements (cons (cons action (list val)) w3-form-elements)))
102 (if (not widget) 130 (if (not widget)
103 nil 131 nil
104 (w3-form-element-set-widget val widget) 132 (w3-form-element-set-widget el widget)
105 (widget-put widget 'w3-form-data val)))) 133 (widget-put widget 'w3-form-data el))))
106 134
107 ;; These properties tell the add-element function how to actually create 135 ;; These properties tell the add-element function how to actually create
108 ;; each type of widget. 136 ;; each type of widget.
109 (put 'checkbox 'w3-widget-creation-function 'w3-form-create-checkbox) 137 (put 'checkbox 'w3-widget-creation-function 'w3-form-create-checkbox)
110 (put 'multiline 'w3-widget-creation-function 'w3-form-create-multiline) 138 (put 'multiline 'w3-widget-creation-function 'w3-form-create-multiline)
136 :tag "" 164 :tag ""
137 :value (w3-form-element-value el))) 165 :value (w3-form-element-value el)))
138 (if (w3-form-element-default-value el) 166 (if (w3-form-element-default-value el)
139 (widget-value-set widget (w3-form-element-value el))) 167 (widget-value-set widget (w3-form-element-value el)))
140 nil) 168 nil)
141 (setq widget (widget-create 'radio 169 (setq widget (widget-create 'radio-button-choice
142 :value (w3-form-element-value el) 170 :value (w3-form-element-value el)
143 (list 'item 171 (list 'item
144 :format "%t" 172 :format "%t"
145 :tag "" 173 :tag ""
146 :value (w3-form-element-value el))) 174 :value (w3-form-element-value el)))
152 ;; This handles dealing with the bogus Netscape 'button' input type 180 ;; This handles dealing with the bogus Netscape 'button' input type
153 ;; that lots of places have been using to slap javascript shit onto 181 ;; that lots of places have been using to slap javascript shit onto
154 (let ((val (w3-form-element-value el))) 182 (let ((val (w3-form-element-value el)))
155 (if (or (not val) (string= val "")) 183 (if (or (not val) (string= val ""))
156 (setq val "Push Me")) 184 (setq val "Push Me"))
157 (widget-create 'push :notify 'ignore :button-face face val))) 185 (widget-create 'push-button :notify 'ignore :button-face face val)))
158 186
159 (defun w3-form-create-image (el face) 187 (defun w3-form-create-image (el face)
160 (let ((widget (widget-create 'push 188 (let ((widget (widget-create 'push-button
161 :notify 'w3-form-submit/reset-callback 189 :notify 'w3-form-submit/reset-callback
162 :value "Form-Image"))) 190 :value "Form-Image")))
163 widget)) 191 widget))
164 192
165 (defun w3-form-create-submit-button (el face) 193 (defun w3-form-create-submit-button (el face)
166 (let ((val (w3-form-element-value el))) 194 (let ((val (w3-form-element-value el)))
167 (if (or (not val) (string= val "")) 195 (if (or (not val) (string= val ""))
168 (setq val (if (eq (w3-form-element-type el) 'submit) 196 (setq val (if (eq (w3-form-element-type el) 'submit)
169 "Submit" 197 "Submit"
170 "Reset"))) 198 "Reset")))
171 (widget-create 'push :notify 'w3-form-submit/reset-callback 199 (widget-create 'push-button
200 :notify 'w3-form-submit/reset-callback
172 :button-face face val))) 201 :button-face face val)))
173 202
174 (defun w3-form-create-file-browser (el face) 203 (defun w3-form-create-file-browser (el face)
175 (widget-create 'file :value-face face :value (w3-form-element-value el))) 204 (widget-create 'file :value-face face :value (w3-form-element-value el)))
176 205
193 (if (> (length (caar tmp)) longest) 222 (if (> (length (caar tmp)) longest)
194 (setq longest (length (caar tmp)))) 223 (setq longest (length (caar tmp))))
195 (setq options (cons (list 'choice-item :tag (caar tmp) 224 (setq options (cons (list 'choice-item :tag (caar tmp)
196 :value (cdar tmp)) options) 225 :value (cdar tmp)) options)
197 tmp (cdr tmp))) 226 tmp (cdr tmp)))
198 (apply 'widget-create 'choice :value 1024 227 (apply 'widget-create 'menu-choice
228 :value 1024
229 :ignore-case t
199 :tag "Key Length" 230 :tag "Key Length"
200 :size (1+ longest) 231 :size (1+ longest)
201 :value-face face 232 :value-face face
202 options))) 233 options)))
203 234
204 (defun w3-form-create-option-list (el face) 235 (defun w3-form-create-option-list (el face)
205 (let ((widget (apply 'widget-create 'choice :value (w3-form-element-value el) 236 (let ((widget (apply 'widget-create 'menu-choice
237 :value (w3-form-element-value el)
238 :ignore-case t
206 :tag "Choose" 239 :tag "Choose"
207 :format "%v" 240 :format "%v"
208 :size (w3-form-element-size el) 241 :size (w3-form-element-size el)
209 :value-face face 242 :value-face face
210 (mapcar 243 (mapcar
211 (function 244 (function
212 (lambda (x) 245 (lambda (x)
213 (list 'choice-item :format "%[%t%]" 246 (list 'choice-item :format "%[%t%]"
214 :tag (car x) :value (car x)))) 247 :tag (car x) :value (car x))))
215 (reverse (w3-form-element-options el)))))) 248 (w3-form-element-options el)))))
216 (widget-value-set widget (w3-form-element-value el)) 249 (widget-value-set widget (w3-form-element-value el))
217 widget)) 250 widget))
218 251
219 ;(defun w3-form-create-multiline (el face) 252 ;(defun w3-form-create-multiline (el face)
220 ; ;; FIX THIS! - need to padd out with newlines or something... 253 ; ;; FIX THIS! - need to padd out with newlines or something...
221 ; (widget-create 'field :value-face face (w3-form-element-value el))) 254 ; (widget-create 'field :value-face face (w3-form-element-value el)))
222 255
223 (defun w3-form-create-multiline (el face) 256 (defun w3-form-create-multiline (el face)
224 (widget-create 'push :notify 'w3-do-text-entry "Multiline text area")) 257 (widget-create 'push-button :notify 'w3-do-text-entry "Multiline text area"))
225 258
226 (defun w3-form-default-widget-creator (el face) 259 (defun w3-form-default-widget-creator (el face)
227 (widget-create 'link 260 (widget-create 'link
228 :notify 'w3-form-default-button-callback 261 :notify 'w3-form-default-button-callback
229 :size (w3-form-element-size el) 262 :size (w3-form-element-size el)
230 :tag (w3-truncate-string (w3-form-element-value el) 263 :tag (mule-truncate-string (w3-form-element-value el)
231 (w3-form-element-size el) ?_) 264 (w3-form-element-size el) ?_)
232 :value-face face 265 :value-face face
233 (w3-form-element-value el))) 266 (w3-form-element-value el)))
234 267
235 (defun w3-form-default-button-callback (widget &rest ignore) 268 (defun w3-form-default-button-callback (widget &rest ignore)
236 (let* ((obj (widget-get widget 'w3-form-data)) 269 (let* ((obj (widget-get widget 'w3-form-data))
239 (val nil) 272 (val nil)
240 ) 273 )
241 (case typ 274 (case typ
242 (password 275 (password
243 (setq val (funcall url-passwd-entry-func "Password: " def)) 276 (setq val (funcall url-passwd-entry-func "Password: " def))
244 (widget-put widget :tag (w3-truncate-string 277 (widget-put widget :tag (mule-truncate-string
245 (make-string (length val) ?*) 278 (make-string (length val) ?*)
246 (w3-form-element-size obj) ?_))) 279 (w3-form-element-size obj) ?_)))
247 (otherwise 280 (otherwise
248 (setq val (read-string 281 (setq val (read-string
249 (concat (capitalize (symbol-name typ)) ": ") def)) 282 (concat (capitalize (symbol-name typ)) ": ") def))
250 (widget-put widget :tag (w3-truncate-string 283 (widget-put widget :tag (mule-truncate-string
251 val (w3-form-element-size obj) ?_)))) 284 val (w3-form-element-size obj) ?_))))
252 (widget-value-set widget val)) 285 (widget-value-set widget val))
253 (apply 'w3-form-possibly-submit widget ignore)) 286 (apply 'w3-form-possibly-submit widget ignore))
254
255 (defun w3-truncate-string (str len &optional pad)
256 "Truncate string STR so that string-width of STR is not greater than LEN.
257 If width of the truncated string is less than LEN, and if a character PAD is
258 defined, add padding end of it."
259 (if (featurep 'mule)
260 (let ((cl (string-to-char-list str)) (n 0) (sw 0))
261 (if (<= (string-width str) len) str
262 (while (<= (setq sw (+ (char-width (nth n cl)) sw)) len)
263 (setq n (1+ n)))
264 (string-match (make-string n ?.) str)
265 (setq str (substring str 0 (match-end 0))))
266 (if pad (concat str (make-string (- len (string-width str)) pad)) str))
267 (concat (if (> (length str) len) (substring str 0 len) str)
268 (if (or (null pad) (> (length str) len))
269 ""
270 (make-string (- len (length str)) pad)))))
271 287
272 (defun w3-form-possibly-submit (widget &rest ignore) 288 (defun w3-form-possibly-submit (widget &rest ignore)
273 (let* ((formobj (widget-get widget 'w3-form-data)) 289 (let* ((formobj (widget-get widget 'w3-form-data))
274 (ident (w3-form-element-action formobj)) 290 (ident (w3-form-element-action formobj))
275 (widgets (w3-all-widgets ident)) 291 (widgets (w3-all-widgets ident))
472 (let* ((next (cond ((get-text-property pos 'button) 488 (let* ((next (cond ((get-text-property pos 'button)
473 (next-single-property-change pos 'button)) 489 (next-single-property-change pos 'button))
474 ((get-text-property pos 'field) 490 ((get-text-property pos 'field)
475 (next-single-property-change pos 'field)) 491 (next-single-property-change pos 'field))
476 (t pos))) 492 (t pos)))
477 (button (next-single-property-change next 'button)) 493 (button (and next (next-single-property-change next 'button)))
478 (field (next-single-property-change next 'field))) 494 (field (and next (next-single-property-change next 'field))))
479 (setq next 495 (setq next
480 (cond 496 (cond
481 ((and button field) (min button field)) 497 ((and button field) (min button field))
482 (button button) 498 (button button)
483 (field field) 499 (field field)
516 (cdr (car (w3-form-encode-helper result)))) 532 (cdr (car (w3-form-encode-helper result))))
517 533
518 (defun w3-form-encode-application/x-gopher-query (result) 534 (defun w3-form-encode-application/x-gopher-query (result)
519 (concat "\t" (cdr (car (w3-form-encode-helper result))))) 535 (concat "\t" (cdr (car (w3-form-encode-helper result)))))
520 536
521 (defconst w3-xwfu-acceptable-chars
522 (list
523 ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
524 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
525 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
526 ?_ ;; BOGUS! This is for #!%#@!ing netscape compatibility
527 ?. ;; BOGUS! This is for #!%#@!ing netscape compatibility
528 )
529 "A list of characters that we do not have to escape in the media type
530 application/x-www-form-urlencoded")
531
532 (defun w3-form-encode-xwfu (chunk) 537 (defun w3-form-encode-xwfu (chunk)
533 "Escape characters in a string for application/x-www-form-urlencoded. 538 "Escape characters in a string for application/x-www-form-urlencoded.
534 Blasphemous crap because someone didn't think %20 was good enough for encoding 539 Blasphemous crap because someone didn't think %20 was good enough for encoding
535 spaces. Die Die Die." 540 spaces. Die Die Die."
536 (if (and (featurep 'mule) chunk)
537 (setq chunk (if w3-running-xemacs
538 (decode-coding-string
539 chunk url-mule-retrieval-coding-system)
540 (code-convert-string
541 chunk *internal* url-mule-retrieval-coding-system))))
542 (mapconcat 541 (mapconcat
543 (function 542 (function
544 (lambda (char) 543 (lambda (char)
545 (cond 544 (cond
546 ((= char ? ) "+") 545 ((= char ? ) "+")
547 ((memq char w3-xwfu-acceptable-chars) (char-to-string char)) 546 ((memq char url-unreserved-chars) (char-to-string char))
548 (t (upcase (format "%%%02x" char)))))) 547 (t (upcase (format "%%%02x" char))))))
549 chunk "")) 548 (mule-encode-string chunk) ""))
550 549
551 (defun w3-form-encode-application/x-www-form-urlencoded (result) 550 (defun w3-form-encode-application/x-www-form-urlencoded (result)
552 (mapconcat 551 (mapconcat
553 (function 552 (function
554 (lambda (data) 553 (lambda (data)
577 (concat query "\r\n.\r\n"))) 576 (concat query "\r\n.\r\n")))
578 577
579 (defun w3-submit-form (ident) 578 (defun w3-submit-form (ident)
580 ;; Submit form entry fields matching ACTN as their action identifier. 579 ;; Submit form entry fields matching ACTN as their action identifier.
581 (let* ((result (w3-all-widgets ident)) 580 (let* ((result (w3-all-widgets ident))
582 (enctype (cdr (assq 'enctype ident))) 581 (enctype (or (cdr (assq 'enctype ident))
582 "application/x-www-form-urlencoded"))
583 (query (w3-form-encode result enctype)) 583 (query (w3-form-encode result enctype))
584 (themeth (upcase (or (cdr (assq 'method ident)) "get"))) 584 (themeth (upcase (or (cdr (assq 'method ident)) "get")))
585 (theurl (cdr (assq 'action ident)))) 585 (theurl (cdr (assq 'action ident))))
586 (if (and (string= "GET" themeth) 586 (if (and (string= "GET" themeth)
587 (string-match "\\([^\\?]*\\)\\?" theurl)) 587 (string-match "\\([^\\?]*\\)\\?" theurl))