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 |
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) |
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) |
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) |
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 |
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 |
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)) |
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) |
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) |
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))) |
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))))) |