Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents 9ee227acff29
children 441bb1e64a06
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; url-cookie.el --- Netscape Cookie support 1 ;;; url-cookie.el --- Netscape Cookie support
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/10/09 19:00:59 3 ;; Created: 1997/01/26 00:40:23
4 ;; Version: 1.5 4 ;; Version: 1.10
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 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply. 11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;; 12 ;;;
13 ;;; 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
14 ;;; 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
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 28
29 (require 'timezone) 29 (require 'timezone)
30 (require 'cl) 30 (require 'cl)
31 31
32 (let ((keywords 32 (eval-and-compile
33 '(:name :value :expires :path :domain :test :secure))) 33 (let ((keywords
34 (while keywords 34 '(:name :value :expires :path :domain :test :secure)))
35 (or (boundp (car keywords)) 35 (while keywords
36 (set (car keywords) (car keywords))) 36 (or (boundp (car keywords))
37 (setq keywords (cdr keywords)))) 37 (set (car keywords) (car keywords)))
38 (setq keywords (cdr keywords)))))
38 39
39 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the 40 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
40 ;; 'open standard' defining this crap. 41 ;; 'open standard' defining this crap.
41 ;; 42 ;;
42 ;; A cookie is stored internally as a vector of 7 slots 43 ;; A cookie is stored internally as a vector of 7 slots
65 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args)) 66 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
66 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args)) 67 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))
67 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args)) 68 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
68 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args)) 69 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
69 retval)) 70 retval))
70
71 (defvar url-cookie-storage nil "Where cookies are stored.")
72 (defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
73 (defvar url-cookie-file nil "*Where cookies are stored on disk.")
74 71
75 (defun url-cookie-p (obj) 72 (defun url-cookie-p (obj)
76 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie))) 73 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
77 74
78 (defun url-cookie-parse-file (&optional fname) 75 (defun url-cookie-parse-file (&optional fname)
108 nil 105 nil
109 (setcdr cur new-cookies) 106 (setcdr cur new-cookies)
110 (setq new (cons cur new)))) 107 (setq new (cons cur new))))
111 (set var new))) 108 (set var new)))
112 109
110 ;;###autoload
113 (defun url-cookie-write-file (&optional fname) 111 (defun url-cookie-write-file (&optional fname)
114 (setq fname (or fname url-cookie-file)) 112 (setq fname (or fname url-cookie-file))
115 (url-cookie-clean-up) 113 (url-cookie-clean-up)
116 (url-cookie-clean-up t) 114 (url-cookie-clean-up t)
117 (save-excursion 115 (save-excursion
206 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2))) 204 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
207 (* 60 (string-to-int (aref exp-time 1))) 205 (* 60 (string-to-int (aref exp-time 1)))
208 (* 1 (string-to-int (aref exp-time 0)))))) 206 (* 1 (string-to-int (aref exp-time 0))))))
209 (> (- cur-norm exp-norm) 1)))))) 207 (> (- cur-norm exp-norm) 1))))))
210 208
209 ;;###autoload
211 (defun url-cookie-retrieve (host path &optional secure) 210 (defun url-cookie-retrieve (host path &optional secure)
212 "Retrieves all the netscape-style cookies for a specified HOST and PATH" 211 "Retrieves all the netscape-style cookies for a specified HOST and PATH"
213 (let ((storage (if secure 212 (let ((storage (if secure
214 (append url-cookie-secure-storage url-cookie-storage) 213 (append url-cookie-secure-storage url-cookie-storage)
215 url-cookie-storage)) 214 url-cookie-storage))
233 (if (and (string-match path-regexp path) 232 (if (and (string-match path-regexp path)
234 (not (url-cookie-expired-p cur))) 233 (not (url-cookie-expired-p cur)))
235 (setq retval (cons cur retval)))))) 234 (setq retval (cons cur retval))))))
236 retval)) 235 retval))
237 236
237 ;;###autolaod
238 (defun url-cookie-generate-header-lines (host path secure) 238 (defun url-cookie-generate-header-lines (host path secure)
239 (let* ((cookies (url-cookie-retrieve host path secure)) 239 (let* ((cookies (url-cookie-retrieve host path secure))
240 (retval nil) 240 (retval nil)
241 (cur nil) 241 (cur nil)
242 (chunk nil)) 242 (chunk nil))
288 (string-match (concat (regexp-quote domain) "$") host))))) 288 (string-match (concat (regexp-quote domain) "$") host)))))
289 289
290 (defun url-header-comparison (x y) 290 (defun url-header-comparison (x y)
291 (string= (downcase x) (downcase y))) 291 (string= (downcase x) (downcase y)))
292 292
293 ;;###autoload
293 (defun url-cookie-handle-set-cookie (str) 294 (defun url-cookie-handle-set-cookie (str)
294 (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
295 (case-fold-search t) 296 (case-fold-search t)
296 (secure (and (assoc* "secure" args :test 'url-header-comparison) t)) 297 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
297 (domain (or (cdr-safe (assoc* "domain" args :test 298 (domain (or (cdr-safe (assoc* "domain" args :test
332 url-current-server)))) 333 url-current-server))))
333 ;; user wants to be asked, and declined. 334 ;; user wants to be asked, and declined.
334 nil) 335 nil)
335 ((url-cookie-host-can-set-p url-current-server domain) 336 ((url-cookie-host-can-set-p url-current-server domain)
336 ;; Cookie is accepted by the user, and passes our security checks 337 ;; Cookie is accepted by the user, and passes our security checks
337 (while rest 338 (let ((cur nil))
338 (url-cookie-store (car (car rest)) (cdr (car rest)) 339 (while rest
339 expires domain path secure) 340 (setq cur (pop rest))
340 (setq rest (cdr rest)))) 341 ;; Oh gross, this is for microsoft & netscape.
342 ;; Fuck them fuck them fuchk them fuck them.
343 (if (string-match "^\\([^=]+\\)=\\(.*\\)" (cdr cur))
344 (setq rest (cons (cons (match-string 1 (cdr cur))
345 (match-string 2 (cdr cur))) rest)
346 cur (cons (car cur) "")))
347 (url-cookie-store (car cur) (cdr cur)
348 expires domain path secure))))
341 (t 349 (t
342 (url-warn 'url (format 350 (url-warn 'url (format
343 (concat "%s tried to set a cookie for domain %s\n" 351 (concat "%s tried to set a cookie for domain %s\n"
344 "Permission denied - cookie rejected.\n" 352 "Permission denied - cookie rejected.\n"
345 "Set-Cookie: %s") 353 "Set-Cookie: %s")