Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 9ee227acff29
children 364816949b59
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
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/16 22:34:30
4 ;; Version: 1.5 4 ;; Version: 1.9
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