Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 26:441bb1e64a06 r19-15b96

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b96
author cvs
date Mon, 13 Aug 2007 08:51:32 +0200
parents 0293115a14e9
children 1a767b41a199
comparison
equal deleted inserted replaced
25:383a494979f8 26:441bb1e64a06
1 ;;; url-cookie.el --- Netscape Cookie support 1 ;;; url-cookie.el --- Netscape Cookie support
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/26 00:40:23 3 ;; Created: 1997/02/18 23:34:20
4 ;; Version: 1.10 4 ;; Version: 1.11
5 ;; Keywords: comm, data, processes, hypermedia 5 ;; Keywords: comm, data, processes, hypermedia
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, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
295 (let* ((args (mm-parse-args str nil t)) ; Don't downcase names 295 (let* ((args (mm-parse-args str nil t)) ; Don't downcase names
296 (case-fold-search t) 296 (case-fold-search t)
297 (secure (and (assoc* "secure" args :test 'url-header-comparison) t)) 297 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
298 (domain (or (cdr-safe (assoc* "domain" args :test 298 (domain (or (cdr-safe (assoc* "domain" args :test
299 'url-header-comparison)) 299 'url-header-comparison))
300 url-current-server)) 300 (url-host url-current-object)))
301 (expires (cdr-safe (assoc* "expires" args :test 301 (expires (cdr-safe (assoc* "expires" args :test
302 'url-header-comparison))) 302 'url-header-comparison)))
303 (path (or (cdr-safe (assoc* "path" args :test 303 (path (or (cdr-safe (assoc* "path" args :test
304 'url-header-comparison)) 304 'url-header-comparison))
305 (file-name-directory url-current-file))) 305 (file-name-directory
306 (url-filename url-current-object))))
306 (rest nil)) 307 (rest nil))
307 (while args 308 (while args
308 (if (not (member (downcase (car (car args))) 309 (if (not (member (downcase (car (car args)))
309 '("secure" "domain" "expires" "path"))) 310 '("secure" "domain" "expires" "path")))
310 (setq rest (cons (car args) rest))) 311 (setq rest (cons (car args) rest)))
328 ;; user never wants cookies 329 ;; user never wants cookies
329 nil) 330 nil)
330 ((and url-cookie-confirmation 331 ((and url-cookie-confirmation
331 (not (funcall url-confirmation-func 332 (not (funcall url-confirmation-func
332 (format "Allow %s to set a cookie? " 333 (format "Allow %s to set a cookie? "
333 url-current-server)))) 334 (url-host url-current-object)))))
334 ;; user wants to be asked, and declined. 335 ;; user wants to be asked, and declined.
335 nil) 336 nil)
336 ((url-cookie-host-can-set-p url-current-server domain) 337 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
337 ;; Cookie is accepted by the user, and passes our security checks 338 ;; Cookie is accepted by the user, and passes our security checks
338 (let ((cur nil)) 339 (let ((cur nil))
339 (while rest 340 (while rest
340 (setq cur (pop rest)) 341 (setq cur (pop rest))
341 ;; Oh gross, this is for microsoft & netscape. 342 ;; Oh gross, this is for microsoft & netscape.
349 (t 350 (t
350 (url-warn 'url (format 351 (url-warn 'url (format
351 (concat "%s tried to set a cookie for domain %s\n" 352 (concat "%s tried to set a cookie for domain %s\n"
352 "Permission denied - cookie rejected.\n" 353 "Permission denied - cookie rejected.\n"
353 "Set-Cookie: %s") 354 "Set-Cookie: %s")
354 url-current-server domain str)))))) 355 (url-host url-current-object) domain str))))))
355 356
356 (provide 'url-cookie) 357 (provide 'url-cookie)