Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 114:8619ce7e4c50 r20-1b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b9
author cvs
date Mon, 13 Aug 2007 09:21:54 +0200
parents a145efe76779
children 9f59509498e1
comparison
equal deleted inserted replaced
113:2ec2fe4a4c89 114:8619ce7e4c50
1 ;;; url-cookie.el --- Netscape Cookie support 1 ;;; url-cookie.el --- Netscape Cookie support
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/02/18 23:34:20 3 ;; Created: 1997/03/19 00:42:23
4 ;; Version: 1.11 4 ;; Version: 1.14
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.
266 "\\|") 266 "\\|")
267 "\\)$") 267 "\\)$")
268 "A regular expression of top-level domains that only require two matching 268 "A regular expression of top-level domains that only require two matching
269 '.'s in the domain name in order to set a cookie.") 269 '.'s in the domain name in order to set a cookie.")
270 270
271 (defvar url-cookie-trusted-urls nil
272 "*A list of regular expressions matching URLs to always accept cookies from.")
273
274 (defvar url-cookie-untrusted-urls nil
275 "*A list of regular expressions matching URLs to never accept cookies from.")
276
271 (defun url-cookie-host-can-set-p (host domain) 277 (defun url-cookie-host-can-set-p (host domain)
272 (let ((numdots 0) 278 (let ((numdots 0)
273 (tmp domain) 279 (tmp domain)
274 (last nil) 280 (last nil)
275 (case-fold-search t) 281 (case-fold-search t)
296 (case-fold-search t) 302 (case-fold-search t)
297 (secure (and (assoc* "secure" args :test 'url-header-comparison) t)) 303 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
298 (domain (or (cdr-safe (assoc* "domain" args :test 304 (domain (or (cdr-safe (assoc* "domain" args :test
299 'url-header-comparison)) 305 'url-header-comparison))
300 (url-host url-current-object))) 306 (url-host url-current-object)))
307 (current-url (url-view-url t))
308 (trusted url-cookie-trusted-urls)
309 (untrusted url-cookie-untrusted-urls)
301 (expires (cdr-safe (assoc* "expires" args :test 310 (expires (cdr-safe (assoc* "expires" args :test
302 'url-header-comparison))) 311 'url-header-comparison)))
303 (path (or (cdr-safe (assoc* "path" args :test 312 (path (or (cdr-safe (assoc* "path" args :test
304 'url-header-comparison)) 313 'url-header-comparison))
305 (file-name-directory 314 (file-name-directory
322 (setq expires (concat (url-match expires 1) " " 331 (setq expires (concat (url-match expires 1) " "
323 (url-match expires 2) " " 332 (url-match expires 2) " "
324 (url-match expires 3) " " 333 (url-match expires 3) " "
325 (url-match expires 4) " [" 334 (url-match expires 4) " ["
326 (url-match expires 5) "]"))) 335 (url-match expires 5) "]")))
336 (while (consp trusted)
337 (if (string-match (car trusted) current-url)
338 (setq trusted (- (match-end 0) (match-beginning 0)))
339 (pop trusted)))
340 (while (consp untrusted)
341 (if (string-match (car untrusted) current-url)
342 (setq untrusted (- (match-end 0) (match-beginning 0)))
343 (pop untrusted)))
344 (if (and trusted untrusted)
345 ;; Choose the more specific match
346 (if (> trusted untrusted)
347 (setq untrusted nil)
348 (setq trusted nil)))
327 (cond 349 (cond
350 (untrusted
351 ;; The site was explicity marked as untrusted by the user
352 nil)
328 ((and (listp url-privacy-level) (memq 'cookies url-privacy-level)) 353 ((and (listp url-privacy-level) (memq 'cookies url-privacy-level))
329 ;; user never wants cookies 354 ;; user never wants cookies
330 nil) 355 nil)
331 ((and url-cookie-confirmation 356 ((and url-cookie-confirmation
332 (not (funcall url-confirmation-func 357 (not trusted)
333 (format "Allow %s to set a cookie? " 358 (save-window-excursion
334 (url-host url-current-object))))) 359 (with-output-to-temp-buffer "*Cookie Warning*"
360 (mapcar
361 (function
362 (lambda (x)
363 (princ (format "%s - %s" (car x) (cdr x))))) rest))
364 (prog1
365 (not (funcall url-confirmation-func
366 (format "Allow %s to set these cookies? "
367 (url-host url-current-object))))
368 (if (get-buffer "*Cookie Warning*")
369 (kill-buffer "*Cookie Warning*")))))
335 ;; user wants to be asked, and declined. 370 ;; user wants to be asked, and declined.
336 nil) 371 nil)
337 ((url-cookie-host-can-set-p (url-host url-current-object) domain) 372 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
338 ;; Cookie is accepted by the user, and passes our security checks 373 ;; Cookie is accepted by the user, and passes our security checks
339 (let ((cur nil)) 374 (let ((cur nil))