Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 102:a145efe76779 r20-1b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b3
author cvs
date Mon, 13 Aug 2007 09:15:49 +0200
parents 364816949b59
children 8619ce7e4c50
comparison
equal deleted inserted replaced
101:a0ec055d74dd 102:a145efe76779
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)