Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-forms.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; w3-forms.el,v --- Emacs-w3 forms parsing code for new display engine
2 ;; Author: wmperry
3 ;; Created: 1996/06/06 14:14:34
4 ;; Version: 1.51
5 ;; Keywords: faces, help, comm, data, languages
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;;
12 ;;; 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 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; 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 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; FORMS processing for html 2.0/3.0
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile
31 (require 'w3-draw))
32
33 (require 'widget)
34
35 (if (featurep 'mule) (fset 'string-width 'length))
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
43 ;; A form entry area is a vector
44 ;; [ type name default-value value maxlength options widget]
45 ;; Where:
46 ;; type = symbol defining what type of form entry area it is
47 ;; (ie: file, radio)
48 ;; name = the name of the form element
49 ;; default-value = the value this started out with
50
51 (defsubst w3-form-element-type (obj) (aref obj 0))
52 (defsubst w3-form-element-name (obj) (aref obj 1))
53 (defsubst w3-form-element-default-value (obj) (aref obj 2))
54 (defsubst w3-form-element-value (obj) (aref obj 3))
55 (defsubst w3-form-element-size (obj) (aref obj 4))
56 (defsubst w3-form-element-maxlength (obj) (aref obj 5))
57 (defsubst w3-form-element-options (obj) (aref obj 6))
58 (defsubst w3-form-element-action (obj) (aref obj 7))
59 (defsubst w3-form-element-widget (obj) (aref obj 8))
60
61 (defsubst w3-form-element-set-type (obj val) (aset obj 0 val))
62 (defsubst w3-form-element-set-name (obj val) (aset obj 1 val))
63 (defsubst w3-form-element-set-default-value (obj val) (aset obj 2 val))
64 (defsubst w3-form-element-set-value (obj val) (aset obj 3 val))
65 (defsubst w3-form-element-set-size (obj val) (aset obj 4 val))
66 (defsubst w3-form-element-set-maxlength (obj val) (aset obj 5 val))
67 (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))
69 (defsubst w3-form-element-set-widget (obj val) (aset obj 8 val))
70
71 ;; The main function - this adds a single widget to the form
72 (defun w3-form-add-element (&rest args)
73 (let* ((widget nil)
74 (buffer-read-only nil)
75 (inhibit-read-only t)
76 (widget-creation-function nil)
77 (action (nth 6 args))
78 (node (assoc action w3-form-elements))
79 (name (or (nth 1 args)
80 (if (memq (nth 0 args) '(submit reset))
81 nil
82 (symbol-name (nth 0 args)))))
83 (val (vector (nth 0 args) ; type
84 name ; name
85 (nth 5 args) ; default
86 (nth 2 args) ; value
87 (nth 3 args) ; size
88 (nth 4 args) ; maxlength
89 (nth 7 args) ; options
90 action
91 nil)) ; widget
92 )
93 (setq widget-creation-function (or (get (car args)
94 'w3-widget-creation-function)
95 'w3-form-default-widget-creator)
96 widget (funcall widget-creation-function val
97 (cdr (nth 10 args))))
98 (if node
99 (setcdr node (cons val (cdr node)))
100 (setq w3-form-elements (cons (cons action (list val)) w3-form-elements)))
101 (if (not widget)
102 nil
103 (w3-form-element-set-widget val widget)
104 (widget-put widget 'w3-form-data val))))
105
106 ;; These properties tell the add-element function how to actually create
107 ;; each type of widget.
108 (put 'checkbox 'w3-widget-creation-function 'w3-form-create-checkbox)
109 (put 'multiline 'w3-widget-creation-function 'w3-form-create-multiline)
110 (put 'radio 'w3-widget-creation-function 'w3-form-create-radio-button)
111 (put 'reset 'w3-widget-creation-function 'w3-form-create-submit-button)
112 (put 'submit 'w3-widget-creation-function 'w3-form-create-submit-button)
113 (put 'hidden 'w3-widget-creation-function 'ignore)
114 (put 'file 'w3-widget-creation-function 'w3-form-create-file-browser)
115 (put 'option 'w3-widget-creation-function 'w3-form-create-option-list)
116 (put 'keygen 'w3-widget-creation-function 'w3-form-create-keygen-list)
117 (put 'button 'w3-widget-creation-function 'w3-form-create-button)
118 (put 'image 'w3-widget-creation-function 'w3-form-create-image)
119
120 (defun w3-form-create-checkbox (el face)
121 (widget-create 'checkbox :value-face face
122 (and (w3-form-element-default-value el) t)))
123
124 (defun w3-form-create-radio-button (el face)
125 (let* ((name (w3-form-element-name el))
126 (formobj (cdr (assoc name w3-form-radio-elements)))
127 (widget nil)
128 )
129 (if formobj
130 (progn
131 (setq widget (w3-form-element-widget formobj))
132 (widget-radio-add-item widget (list 'item :format "%t" :tag ""))
133 nil)
134 (setq widget (widget-create 'radio (list 'item :format "%t" :tag ""))
135 w3-form-radio-elements (cons (cons name el)
136 w3-form-radio-elements))
137 widget)))
138
139 (defun w3-form-create-button (el face)
140 ;; This handles dealing with the bogus Netscape 'button' input type
141 ;; that lots of places have been using to slap javascript shit onto
142 (let ((val (w3-form-element-value el)))
143 (if (or (not val) (string= val ""))
144 (setq val "Push Me"))
145 (widget-create 'push :notify 'ignore :button-face face val)))
146
147 (defun w3-form-create-image (el face)
148 (let ((widget (widget-create 'push
149 :notify 'w3-form-submit/reset-callback
150 :value "Form-Image")))
151 widget))
152
153 (defun w3-form-create-submit-button (el face)
154 (let ((val (w3-form-element-value el)))
155 (if (or (not val) (string= val ""))
156 (setq val (if (eq (w3-form-element-type el) 'submit)
157 "Submit"
158 "Reset")))
159 (widget-create 'push :notify 'w3-form-submit/reset-callback
160 :button-face face val)))
161
162 (defun w3-form-create-file-browser (el face)
163 (widget-create 'file :value-face face :value (w3-form-element-value el)))
164
165
166 (defvar w3-form-valid-key-sizes
167 '(
168 ("1024 (Premium)" . 1024)
169 ("896 (Regular)" . 896)
170 ("768 (Unleaded)" . 768)
171 ("512 (Low Grade)" . 512)
172 ("508 (Woos)" . 508)
173 ("256 (Test Grade)" . 256)
174 )
175 "An assoc list of available key sizes and meaningful descriptions.")
176
177 (defun w3-form-create-keygen-list (el face)
178 (let ((tmp w3-form-valid-key-sizes)
179 (longest 0)
180 (options nil))
181 (while tmp
182 (if (> (length (caar tmp)) longest)
183 (setq longest (length (caar tmp))))
184 (setq options (cons (list 'choice-item :tag (caar tmp)
185 :value (cdar tmp)) options)
186 tmp (cdr tmp)))
187 (apply 'widget-create 'choice :value 1024
188 :tag "Key Length"
189 :size (1+ longest)
190 :value-face face
191 options)))
192
193 (defun w3-form-create-option-list (el face)
194 (let ((widget (apply 'widget-create 'choice :value (w3-form-element-value el)
195 :tag "Choose"
196 :size (w3-form-element-size el)
197 :value-face face
198 (mapcar
199 (function
200 (lambda (x)
201 (list 'choice-item :format "%[%t%]"
202 :tag (car x) :value (cdr x))))
203 (reverse (w3-form-element-options el))))))
204 (widget-value-set widget (cdr-safe (assoc (w3-form-element-value el)
205 (w3-form-element-options el))))
206 (goto-char (point-max))
207 (skip-chars-backward "\r\n")
208 (delete-region (point) (point-max))
209 widget))
210
211 ;(defun w3-form-create-multiline (el face)
212 ; ;; FIX THIS! - need to padd out with newlines or something...
213 ; (widget-create 'field :value-face face (w3-form-element-value el)))
214
215 (defun w3-form-create-multiline (el face)
216 (widget-create 'push :notify 'w3-do-text-entry "Multiline text area"))
217
218 (defun w3-form-default-widget-creator (el face)
219 (widget-create 'link
220 :notify 'w3-form-default-button-callback
221 :size (w3-form-element-size el)
222 :tag (w3-truncate-string (w3-form-element-value el)
223 (w3-form-element-size el) ?_)
224 :value-face face
225 (w3-form-element-value el)))
226
227 (defun w3-form-default-button-callback (widget &rest ignore)
228 (let* ((obj (widget-get widget 'w3-form-data))
229 (typ (w3-form-element-type obj))
230 (def (widget-value widget))
231 (val nil)
232 )
233 (case typ
234 (password
235 (setq val (funcall url-passwd-entry-func "Password: " def))
236 (widget-put widget :tag (w3-truncate-string
237 (make-string (length val) ?*)
238 (w3-form-element-size obj) ?_)))
239 (otherwise
240 (setq val (read-string
241 (concat (capitalize (symbol-name typ)) ": ") def))
242 (widget-put widget :tag (w3-truncate-string
243 val (w3-form-element-size obj) ?_))))
244 (widget-value-set widget val))
245 (apply 'w3-form-possibly-submit widget ignore))
246
247 (defun w3-truncate-string (str len &optional pad)
248 "Truncate string STR so that string-width of STR is not greater than LEN.
249 If width of the truncated string is less than LEN, and if a character PAD is
250 defined, add padding end of it."
251 (if (featurep 'mule)
252 (let ((cl (string-to-char-list str)) (n 0) (sw 0))
253 (if (<= (string-width str) len) str
254 (while (<= (setq sw (+ (char-width (nth n cl)) sw)) len)
255 (setq n (1+ n)))
256 (string-match (make-string n ?.) str)
257 (setq str (substring str 0 (match-end 0))))
258 (if pad (concat str (make-string (- len (string-width str)) pad)) str))
259 (concat (if (> (length str) len) (substring str 0 len) str)
260 (if (or (null pad) (> (length str) len))
261 ""
262 (make-string (- len (length str)) pad)))))
263
264 (defun w3-form-possibly-submit (widget &rest ignore)
265 (let* ((formobj (widget-get widget 'w3-form-data))
266 (ident (w3-form-element-action formobj))
267 (widgets (w3-all-widgets ident))
268 (text-fields 0)
269 (text-p nil))
270 ;;
271 ;; Gack. Netscape auto-submits forms of one text field
272 ;; here we go through the list of widgets in this form and
273 ;; determine which are not submit/reset/button inputs.
274 ;; If the # == 1, then submit the form.
275 ;;
276 (while widgets
277 (setq text-fields (+
278 text-fields
279 (case (w3-form-element-type (car widgets))
280 ((submit reset image button)
281 0)
282 (text
283 (setq text-p t)
284 1)
285 (otherwise
286 1)))
287 widgets (cdr widgets)))
288 (if (and (= text-fields 1) text-p)
289 (w3-submit-form ident))))
290
291 (defun w3-form-submit/reset-callback (widget &rest ignore)
292 (let* ((formobj (widget-get widget 'w3-form-data))
293 (w3-submit-button formobj))
294 (case (w3-form-element-type formobj)
295 (submit (w3-submit-form (w3-form-element-action formobj)))
296 (reset (w3-revert-form (w3-form-element-action formobj)))
297 (image (w3-submit-form (w3-form-element-action formobj)))
298 (otherwise
299 (error
300 "Impossible widget type %s triggered w3-form-submit/reset-callback"
301 (w3-form-element-type formobj))))))
302
303 (defun w3-do-text-entry (widget &rest ignore)
304 (let* ((data (list widget (current-buffer)))
305 (formobj (widget-get widget 'w3-form-data))
306 (buff (get-buffer-create (format "Form Entry: %s"
307 (w3-form-element-name formobj)))))
308 (switch-to-buffer-other-window buff)
309 (indented-text-mode)
310 (erase-buffer)
311 (if (w3-form-element-value formobj)
312 (insert (w3-form-element-value formobj)))
313 (setq w3-current-last-buffer data)
314 (message "Press C-c C-c when finished with text entry.")
315 (local-set-key "\C-c\C-c" 'w3-finish-text-entry)))
316
317 (defun w3-finish-text-entry ()
318 (interactive)
319 (if w3-current-last-buffer
320 (let* ((widget (nth 0 w3-current-last-buffer))
321 (formobj (widget-get widget 'w3-form-data))
322 (buff (nth 1 w3-current-last-buffer))
323 (valu (buffer-string))
324 (inhibit-read-only t)
325 )
326 (local-set-key "\C-c\C-c" 'undefined)
327 (kill-buffer (current-buffer))
328 (condition-case ()
329 (delete-window)
330 (error nil))
331 (if (not (and buff (bufferp buff) (buffer-name buff)))
332 (message "Could not find the form buffer for this text!")
333 (switch-to-buffer buff)
334 (w3-form-element-set-value formobj valu)))))
335
336 (defsubst w3-all-widgets (actn)
337 ;; Return a list of data entry widgets in form number ACTN
338 (cdr-safe (assoc actn w3-form-elements)))
339
340 (defun w3-revert-form (actn)
341 (save-excursion
342 (let* ((formobjs (w3-all-widgets actn))
343 (inhibit-read-only t)
344 deft type widget formobj)
345 (while formobjs
346 (setq formobj (car formobjs)
347 widget (w3-form-element-widget formobj)
348 formobjs (cdr formobjs)
349 deft (w3-form-element-default-value formobj)
350 type (w3-form-element-type formobj))
351 (case type
352 ((submit reset image) nil)
353 (radio
354 ;; Ack - how!?
355 )
356 (checkbox
357 (if deft
358 (widget-value-set widget t)
359 (widget-value-set widget nil)))
360 (file
361 (widget-value-set widget deft))
362 (otherwise
363 (widget-value-set widget deft)))))))
364
365 (defun w3-form-encode-helper (formobjs)
366 (let (
367 (submit-button-data w3-submit-button)
368 formobj result widget temp type)
369 (while formobjs
370 (setq formobj (car formobjs)
371 type (w3-form-element-type formobj)
372 widget (w3-form-element-widget formobj)
373 formobjs (cdr formobjs)
374 temp (case type
375 (reset nil)
376 (image
377 (if (and (eq submit-button-data formobj)
378 (w3-form-element-name formobj))
379 (setq result (append
380 (list
381 (cons
382 (concat (w3-form-element-name formobj)
383 ".x") "0")
384 (cons
385 (concat (w3-form-element-name formobj)
386 ".y") "0"))
387 result)))
388 nil)
389 (submit
390 (if (and (eq submit-button-data formobj)
391 (w3-form-element-name formobj))
392 (cons (w3-form-element-name formobj)
393 (w3-form-element-value formobj))))
394 (radio
395 ;; this is probably broken
396 (let ((x (widget-radio-chosen widget)))
397 (if (or (not x)
398 (not (eq x (w3-form-element-widget formobj))))
399 nil
400 (cons (w3-form-element-name formobj)
401 (w3-form-element-value formobj)))))
402 (checkbox
403 (if (widget-value widget)
404 (cons (w3-form-element-name formobj)
405 (w3-form-element-value formobj))))
406 (file
407 (let ((dat nil)
408 (fname (widget-value widget)))
409 (save-excursion
410 (set-buffer (get-buffer-create " *w3-temp*"))
411 (erase-buffer)
412 (setq dat
413 (condition-case ()
414 (insert-file-contents-literally fname)
415 (error (concat "Error accessing " fname))))
416 (cons (w3-form-element-name formobj) dat))))
417 (option
418 (cons (w3-form-element-name formobj)
419 (widget-value widget)))
420 (keygen
421 (cons (w3-form-element-name formobj)
422 (format "Should create a %d bit RSA key"
423 (widget-value widget))))
424 ((multiline hidden)
425 (cons (w3-form-element-name formobj)
426 (w3-form-element-value formobj)))
427 (otherwise
428 (cons (w3-form-element-name formobj)
429 (widget-value widget)))))
430 (if temp
431 (setq result (cons temp result))))
432 result))
433
434 (defun w3-form-encode-make-mime-part (id data separator)
435 (concat separator "\nContent-id: " id
436 "\nContent-length: " (length data)
437 "\n\n" data))
438
439 (defun w3-form-encode-multipart/x-www-form-data (formobjs)
440 ;; Create a multipart form submission.
441 ;; Returns a cons of two strings. Car is the separator used.
442 ;; cdr is the body of the MIME message."
443 (let ((separator "---some-separator-for-www-form-data"))
444 (cons separator
445 (mapconcat
446 (function
447 (lambda (formobj)
448 (w3-form-encode-make-mime-part (car formobj) (cdr formobj)
449 separator)))
450 (w3-form-encode-helper formobjs)
451 "\n"))))
452
453 (fset 'w3-form-encode-multipart/form-data
454 'w3-form-encode-multipart/x-www-form-data)
455 (fset 'w3-form-encode- 'w3-form-encode-application/x-www-form-urlencoded)
456
457 (defun w3-next-widget (pos)
458 (let* ((next (cond ((get-text-property pos 'button)
459 (next-single-property-change pos 'button))
460 ((get-text-property pos 'field)
461 (next-single-property-change pos 'field))
462 (t pos)))
463 (button (next-single-property-change next 'button))
464 (field (next-single-property-change next 'field)))
465 (setq next
466 (cond
467 ((and button field) (min button field))
468 (button button)
469 (field field)
470 (t nil)))
471 (and next
472 (or (get-text-property next 'button)
473 (get-text-property next 'field)))))
474
475 (defun w3-form-encode (result &optional enctype)
476 "Create a string suitably encoded for a URL request."
477 (let ((func (intern (concat "w3-form-encode-" enctype))))
478 (if (fboundp func) (funcall func result))))
479
480 (defun w3-form-encode-text/plain (result)
481 (let ((query ""))
482 (setq query
483 (mapconcat
484 (function
485 (lambda (widget)
486 (let ((nam (car widget))
487 (val (cdr widget)))
488 (if (string-match "\n" nam)
489 (setq nam (mapconcat
490 (function
491 (lambda (x)
492 (if (= x ?\n) "," (char-to-string x))))
493 nam "")))
494 (concat nam " " val))))
495 (w3-form-encode-helper result) "\n"))
496 query))
497
498 (defun w3-form-encode-application/x-gopher-query (result)
499 (concat "\t" (nth 5 (car result))))
500
501 (defconst w3-xwfu-acceptable-chars
502 (list
503 ?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
504 ?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
505 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
506 ?_;; BOGUS! This is for #!%#@!ing netscape compatibility
507 )
508 "A list of characters that we do not have to escape in the media type
509 application/x-www/form-urlencoded")
510
511 (defun w3-form-encode-xwfu (chunk)
512 "Escape characters in a string for application/x-www-form-urlencoded.
513 Blasphemous crap because someone didn't think %20 was good enough for encoding
514 spaces. Die Die Die."
515 (if (and (featurep 'mule) chunk)
516 (setq chunk (code-convert-string
517 chunk *internal* url-mule-retrieval-coding-system)))
518 (mapconcat
519 (function
520 (lambda (char)
521 (cond
522 ((= char ? ) "+")
523 ((memq char w3-xwfu-acceptable-chars) (char-to-string char))
524 (t (format "%%%02x" char)))))
525 chunk ""))
526
527 (defun w3-form-encode-application/x-www-form-urlencoded (result)
528 (mapconcat
529 (function
530 (lambda (data)
531 (concat (w3-form-encode-xwfu (car data)) "="
532 (w3-form-encode-xwfu (cdr data)))))
533 (w3-form-encode-helper result) "&"))
534
535 (defun w3-form-encode-application/x-w3-isindex (result)
536 (let* ((info (w3-form-encode-helper result))
537 (query (cdr-safe (assoc "isindex" info))))
538 (if query
539 (url-hexify-string query)
540 "")))
541
542 (defun w3-form-encode-application/gopher-ask-block (result)
543 (let ((query ""))
544 ;;; gopher+ will expect all the checkboxes/etc, even if they are
545 ;;; not turned on. Should still ignore RADIO boxes that are not
546 ;;; active though.
547 (while result
548 (if (and (not (and (string= (nth 2 (car result)) "RADIO")
549 (not (nth 6 (car result)))))
550 (not (member (nth 2 (car result)) '("SUBMIT" "RESET"))))
551 (setq query (format "%s\r\n%s" query (nth 5 (car result)))))
552 (setq result (cdr result)))
553 (concat query "\r\n.\r\n")))
554
555 (defun w3-submit-form (ident)
556 ;; Submit form entry fields matching ACTN as their action identifier.
557 (let* ((result (w3-all-widgets ident))
558 (enctype (cdr (assq 'enctype ident)))
559 (query (w3-form-encode result enctype))
560 (themeth (upcase (or (cdr (assq 'method ident)) "get")))
561 (theurl (cdr (assq 'action ident))))
562 (if (and (string= "GET" themeth)
563 (string-match "\\([^\\?]*\\)\\?" theurl))
564 (setq theurl (url-match theurl 1)))
565 (cond
566 ((or (string= "POST" themeth)
567 (string= "PUT" themeth))
568 (if (consp query)
569 (setq enctype (concat enctype "; separator=\""
570 (substring (car query) 3 nil)
571 "\"")
572 query (cdr query)))
573 (let ((url-request-method themeth)
574 (url-request-data query)
575 (url-request-extra-headers
576 (cons (cons "Content-type" enctype) url-request-extra-headers)))
577 (w3-fetch theurl)))
578 ((string= "GET" themeth)
579 (let ((theurl (concat theurl "?" query)))
580 (w3-fetch theurl)))
581 (t
582 (w3-warn 'html (format "Unknown submit method: %s" themeth))
583 (let ((theurl (concat theurl "?" query)))
584 (w3-fetch theurl))))))
585
586 (provide 'w3-forms)