/[emacs]/emacs/lisp/url/url-cookie.el
ViewVC logotype

Diff of /emacs/lisp/url/url-cookie.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by rms, Thu Jun 23 21:28:07 2005 UTC revision 1.11 by rms, Tue Jun 28 00:47:07 2005 UTC
# Line 34  Line 34 
34  ;; 'open standard' defining this crap.  ;; 'open standard' defining this crap.
35  ;;  ;;
36  ;; A cookie is stored internally as a vector of 7 slots  ;; A cookie is stored internally as a vector of 7 slots
37  ;; [ 'cookie name value expires path domain secure ]  ;; [ cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
38    
39  (defsubst url-cookie-name    (cookie) (aref cookie 1))  (defsubst url-cookie-name    (cookie) (aref cookie 1))
40  (defsubst url-cookie-value   (cookie) (aref cookie 2))  (defsubst url-cookie-value   (cookie) (aref cookie 2))
41  (defsubst url-cookie-expires (cookie) (aref cookie 3))  (defsubst url-cookie-expires (cookie) (aref cookie 3))
42  (defsubst url-cookie-path    (cookie) (aref cookie 4))  (defsubst url-cookie-localpart    (cookie) (aref cookie 4))
43  (defsubst url-cookie-domain  (cookie) (aref cookie 5))  (defsubst url-cookie-domain  (cookie) (aref cookie 5))
44  (defsubst url-cookie-secure  (cookie) (aref cookie 6))  (defsubst url-cookie-secure  (cookie) (aref cookie 6))
45    
46  (defsubst url-cookie-set-name    (cookie val) (aset cookie 1 val))  (defsubst url-cookie-set-name    (cookie val) (aset cookie 1 val))
47  (defsubst url-cookie-set-value   (cookie val) (aset cookie 2 val))  (defsubst url-cookie-set-value   (cookie val) (aset cookie 2 val))
48  (defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))  (defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
49  (defsubst url-cookie-set-path    (cookie val) (aset cookie 4 val))  (defsubst url-cookie-set-localpart (cookie val) (aset cookie 4 val))
50  (defsubst url-cookie-set-domain  (cookie val) (aset cookie 5 val))  (defsubst url-cookie-set-domain  (cookie val) (aset cookie 5 val))
51  (defsubst url-cookie-set-secure  (cookie val) (aset cookie 6 val))  (defsubst url-cookie-set-secure  (cookie val) (aset cookie 6 val))
52  (defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))  (defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
53    
54  (defsubst url-cookie-create (&rest args)  (defsubst url-cookie-create (&rest args)
55      "Create a cookie vector object from keyword-value pairs ARGS.
56    The keywords allowed are
57      :name NAME
58      :value VALUE
59      :expires TIME
60      :localpart LOCALPAR
61      :domain DOMAIN
62      :secure ???
63    Could someone fill in more information?"
64    (let ((retval (make-vector 7 nil)))    (let ((retval (make-vector 7 nil)))
65      (aset retval 0 'cookie)      (aset retval 0 'cookie)
66      (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))      (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
67      (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))      (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
68      (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))      (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
69      (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))      (url-cookie-set-localpart retval (url-cookie-retrieve-arg :localpart args))
70      (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))      (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
71      (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))      (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
72      retval))      retval))
73    
74  (defun url-cookie-p (obj)  (defun url-cookie-p (obj)
75      "Return non-nil if OBJ is a cookie vector object.
76    These objects represent cookies in the URL package.
77    A cookie vector object is a vector of 7 slots:
78     [cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE]."
79    (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))    (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
80    
81  (defgroup url-cookie nil  (defgroup url-cookie nil
# Line 73  Line 86 
86    
87  (defvar url-cookie-storage nil         "Where cookies are stored.")  (defvar url-cookie-storage nil         "Where cookies are stored.")
88  (defvar url-cookie-secure-storage nil  "Where secure cookies are stored.")  (defvar url-cookie-secure-storage nil  "Where secure cookies are stored.")
89  (defcustom url-cookie-file nil         "*Where cookies are stored on disk."  (defcustom url-cookie-file nil
90      "*File where cookies are stored on disk."
91    :type '(choice (const :tag "Default" :value nil) file)    :type '(choice (const :tag "Default" :value nil) file)
92    :group 'url-file    :group 'url-file
93    :group 'url-cookie)    :group 'url-cookie)
# Line 154  telling Microsoft that." Line 168  telling Microsoft that."
168        (write-file fname)        (write-file fname)
169        (kill-buffer (current-buffer))))))        (kill-buffer (current-buffer))))))
170    
171  (defun url-cookie-store (name value &optional expires domain path secure)  (defun url-cookie-store (name value &optional expires domain localpart secure)
172    "Store a netscape-style cookie."    "Store a netscape-style cookie."
173    (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))    (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
174           (tmp storage)           (tmp storage)
# Line 173  telling Microsoft that." Line 187  telling Microsoft that."
187            (while storage            (while storage
188              (setq cur (car storage)              (setq cur (car storage)
189                    storage (cdr storage))                    storage (cdr storage))
190              (if (and (equal path (url-cookie-path cur))              (if (and (equal localpart (url-cookie-localpart cur))
191                       (equal name (url-cookie-name cur)))                       (equal name (url-cookie-name cur)))
192                  (progn                  (progn
193                    (url-cookie-set-expires cur expires)                    (url-cookie-set-expires cur expires)
# Line 186  telling Microsoft that." Line 200  telling Microsoft that."
200                                                         :value value                                                         :value value
201                                                         :expires expires                                                         :expires expires
202                                                         :domain domain                                                         :domain domain
203                                                         :path path                                                         :localpart localpart
204                                                         :secure secure)                                                         :secure secure)
205                                      (cdr found-domain)))))                                      (cdr found-domain)))))
206        ;; Need to add a new top-level domain        ;; Need to add a new top-level domain
# Line 194  telling Microsoft that." Line 208  telling Microsoft that."
208                                     :value value                                     :value value
209                                     :expires expires                                     :expires expires
210                                     :domain domain                                     :domain domain
211                                     :path path                                     :localpart localpart
212                                     :secure secure))                                     :secure secure))
213        (cond        (cond
214         (storage         (storage
# Line 235  telling Microsoft that." Line 249  telling Microsoft that."
249          (> (- cur-norm exp-norm) 1))))))          (> (- cur-norm exp-norm) 1))))))
250    
251  ;;;###autoload  ;;;###autoload
252  (defun url-cookie-retrieve (host path &optional secure)  (defun url-cookie-retrieve (host localpart &optional secure)
253    "Retrieve all the netscape-style cookies for a specified HOST and PATH."    "Retrieve all the netscape-style cookies for a specified HOST and LOCALPART."
254    (let ((storage (if secure    (let ((storage (if secure
255                       (append url-cookie-secure-storage url-cookie-storage)                       (append url-cookie-secure-storage url-cookie-storage)
256                     url-cookie-storage))                     url-cookie-storage))
# Line 244  telling Microsoft that." Line 258  telling Microsoft that."
258          (cookies nil)          (cookies nil)
259          (cur nil)          (cur nil)
260          (retval nil)          (retval nil)
261          (path-regexp nil))          (localpart-regexp nil))
262      (while storage      (while storage
263        (setq cur (car storage)        (setq cur (car storage)
264              storage (cdr storage)              storage (cdr storage)
# Line 255  telling Microsoft that." Line 269  telling Microsoft that."
269            (while cookies            (while cookies
270              (setq cur (car cookies)              (setq cur (car cookies)
271                    cookies (cdr cookies)                    cookies (cdr cookies)
272                    path-regexp (concat "^" (regexp-quote                    localpart-regexp (concat "^" (regexp-quote
273                                             (url-cookie-path cur))))                                                  (url-cookie-localpart cur))))
274              (if (and (string-match path-regexp path)              (if (and (string-match localpart-regexp localpart)
275                       (not (url-cookie-expired-p cur)))                       (not (url-cookie-expired-p cur)))
276                  (setq retval (cons cur retval))))))                  (setq retval (cons cur retval))))))
277      retval))      retval))
278    
279  ;;;###autoload  ;;;###autoload
280  (defun url-cookie-generate-header-lines (host path secure)  (defun url-cookie-generate-header-lines (host localpart secure)
281    (let* ((cookies (url-cookie-retrieve host path secure))    (let* ((cookies (url-cookie-retrieve host localpart secure))
282          (retval nil)           (retval nil)
283          (cur nil)           (cur nil)
284          (chunk nil))           (chunk nil))
285      ;; Have to sort this for sending most specific cookies first      ;; Have to sort this for sending most specific cookies first
286      (setq cookies (and cookies      (setq cookies (and cookies
287                         (sort cookies                         (sort cookies
288                               (function                               (function
289                                (lambda (x y)                                (lambda (x y)
290                                  (> (length (url-cookie-path x))                                  (> (length (url-cookie-localpart x))
291                                     (length (url-cookie-path y))))))))                                     (length (url-cookie-localpart y))))))))
292      (while cookies      (while cookies
293        (setq cur (car cookies)        (setq cur (car cookies)
294              cookies (cdr cookies)              cookies (cdr cookies)
# Line 340  telling Microsoft that." Line 354  telling Microsoft that."
354           (trusted url-cookie-trusted-urls)           (trusted url-cookie-trusted-urls)
355           (untrusted url-cookie-untrusted-urls)           (untrusted url-cookie-untrusted-urls)
356           (expires (cdr-safe (assoc-string "expires" args t)))           (expires (cdr-safe (assoc-string "expires" args t)))
357           (path (or (cdr-safe (assoc-string "path" args t))           (localpart (or (cdr-safe (assoc-string "path" args t))
358                     (file-name-directory                          (file-name-directory
359                      (url-filename url-current-object))))                           (url-filename url-current-object))))
360           (rest nil))           (rest nil))
361      (while args      (while args
362        (if (not (member (downcase (car (car args)))        (if (not (member (downcase (car (car args)))
# Line 422  telling Microsoft that." Line 436  telling Microsoft that."
436          (while rest          (while rest
437            (setq cur (pop rest))            (setq cur (pop rest))
438            (url-cookie-store (car cur) (cdr cur)            (url-cookie-store (car cur) (cdr cur)
439                              expires domain path secure))))                              expires domain localpart secure))))
440       (t       (t
441        (message "%s tried to set a cookie for domain %s - rejected."        (message "%s tried to set a cookie for domain %s - rejected."
442                 (url-host url-current-object) domain)))))                 (url-host url-current-object) domain)))))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26