;;; url-cookie.el --- Netscape Cookie support
-;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
;;
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
;; 'open standard' defining this crap.
-;;
-;; A cookie is stored internally as a vector of 7 slots
-;; [ cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
-
-(defsubst url-cookie-name (cookie) (aref cookie 1))
-(defsubst url-cookie-value (cookie) (aref cookie 2))
-(defsubst url-cookie-expires (cookie) (aref cookie 3))
-(defsubst url-cookie-localpart (cookie) (aref cookie 4))
-(defsubst url-cookie-domain (cookie) (aref cookie 5))
-(defsubst url-cookie-secure (cookie) (aref cookie 6))
-
-(defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
-(defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
-(defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
-(defsubst url-cookie-set-localpart (cookie val) (aset cookie 4 val))
-(defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
-(defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
-(defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
-
-(defsubst url-cookie-create (&rest args)
- "Create a cookie vector object from keyword-value pairs ARGS.
-The keywords allowed are
- :name NAME
- :value VALUE
- :expires TIME
- :localpart LOCALPAR
- :domain DOMAIN
- :secure ???
-Could someone fill in more information?"
- (let ((retval (make-vector 7 nil)))
- (aset retval 0 'cookie)
- (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
- (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
- (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
- (url-cookie-set-localpart retval (url-cookie-retrieve-arg :localpart args))
- (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
- (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
- retval))
-
-(defun url-cookie-p (obj)
- "Return non-nil if OBJ is a cookie vector object.
-These objects represent cookies in the URL package.
-A cookie vector object is a vector of 7 slots:
- [cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE]."
- (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
(defgroup url-cookie nil
- "URL cookies"
+ "URL cookies."
:prefix "url-"
:prefix "url-cookie-"
:group 'url)
+;; A cookie is stored internally as a vector of 7 slots
+;; [ cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
+
+(defstruct (url-cookie
+ (:constructor url-cookie-create)
+ (:copier nil)
+ ;; For compatibility with a previous version which did not use
+ ;; defstruct, and also in order to make sure that the printed
+ ;; representation does not depend on CL internals, we use an
+ ;; explicitly managed tag.
+ (:type vector))
+ (tag 'cookie :read-only t)
+ name value expires localpart domain secure)
+
(defvar url-cookie-storage nil "Where cookies are stored.")
(defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
(defcustom url-cookie-file nil
- "*File where cookies are stored on disk."
+ "File where cookies are stored on disk."
:type '(choice (const :tag "Default" :value nil) file)
:group 'url-file
:group 'url-cookie)
(defcustom url-cookie-confirmation nil
- "*If non-nil, confirmation by the user is required to accept HTTP cookies."
+ "If non-nil, confirmation by the user is required to accept HTTP cookies."
:type 'boolean
:group 'url-cookie)
(defcustom url-cookie-multiple-line nil
- "*If nil, HTTP requests put all cookies for the server on one line.
+ "If nil, HTTP requests put all cookies for the server on one line.
Some web servers, such as http://www.hotmail.com/, only accept cookies
when they are on one line. This is broken behavior, but just try
telling Microsoft that."
(defvar url-cookies-changed-since-last-save nil
"Whether the cookies list has changed since the last save operation.")
-;;;###autoload
(defun url-cookie-parse-file (&optional fname)
(setq fname (or fname url-cookie-file))
(condition-case ()
(load fname nil t)
- (error (message "Could not load cookie file %s" fname))))
+ (error
+ ;; It's completely normal for the cookies file not to exist yet.
+ ;; (message "Could not load cookie file %s" fname)
+ )))
(defun url-cookie-clean-up (&optional secure)
(let* (
(setq new (cons cur new))))
(set var new)))
-;;;###autoload
(defun url-cookie-write-file (&optional fname)
(setq fname (or fname url-cookie-file))
+ (unless (file-directory-p (file-name-directory fname))
+ (ignore-errors (make-directory (file-name-directory fname))))
(cond
((not url-cookies-changed-since-last-save) nil)
((not (file-writable-p fname))
(t
(url-cookie-clean-up)
(url-cookie-clean-up t)
- (save-excursion
- (set-buffer (get-buffer-create " *cookies*"))
+ (with-current-buffer (get-buffer-create " *cookies*")
(erase-buffer)
(fundamental-mode)
(insert ";; Emacs-W3 HTTP cookies file\n"
(insert ")\n(setq url-cookie-secure-storage\n '")
(pp url-cookie-secure-storage (current-buffer))
(insert ")\n")
+ (insert "\f\n;; Local Variables:\n"
+ ";; version-control: never\n"
+ ";; no-byte-compile: t\n"
+ ";; End:\n")
+ (set (make-local-variable 'version-control) 'never)
(write-file fname)
+ (setq url-cookies-changed-since-last-save nil)
(kill-buffer (current-buffer))))))
(defun url-cookie-store (name value &optional expires domain localpart secure)
(if (and (equal localpart (url-cookie-localpart cur))
(equal name (url-cookie-name cur)))
(progn
- (url-cookie-set-expires cur expires)
- (url-cookie-set-value cur value)
+ (setf (url-cookie-expires cur) expires)
+ (setf (url-cookie-value cur) value)
(setq tmp t))))
(if (not tmp)
;; New cookie
(* 1 (string-to-number (aref exp-time 0))))))
(> (- cur-norm exp-norm) 1))))))
-;;;###autoload
(defun url-cookie-retrieve (host localpart &optional secure)
"Retrieve all the netscape-style cookies for a specified HOST and LOCALPART."
(let ((storage (if secure
storage (cdr storage)
cookies (cdr cur))
(if (and (car cur)
- (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
+ (string-match
+ (concat "^.*"
+ (regexp-quote
+ ;; Remove the dot from wildcard domains
+ ;; before matching.
+ (if (eq ?. (aref (car cur) 0))
+ (substring (car cur) 1)
+ (car cur)))
+ "$") host))
;; The domains match - a possible hit!
(while cookies
(setq cur (car cookies)
(setq retval (cons cur retval))))))
retval))
-;;;###autoload
(defun url-cookie-generate-header-lines (host localpart secure)
(let* ((cookies (url-cookie-retrieve host localpart secure))
(retval nil)
'.'s in the domain name in order to set a cookie.")
(defcustom url-cookie-trusted-urls nil
- "*A list of regular expressions matching URLs to always accept cookies from."
+ "A list of regular expressions matching URLs to always accept cookies from."
:type '(repeat regexp)
:group 'url-cookie)
(defcustom url-cookie-untrusted-urls nil
- "*A list of regular expressions matching URLs to never accept cookies from."
+ "A list of regular expressions matching URLs to never accept cookies from."
:type '(repeat regexp)
:group 'url-cookie)
(defun url-cookie-host-can-set-p (host domain)
(let ((numdots 0)
- (tmp domain)
(last nil)
(case-fold-search t)
(mindots 3))
((>= numdots mindots) ; We have enough dots in domain name
;; Need to check and make sure the host is actually _in_ the
;; domain it wants to set a cookie for though.
- (string-match (concat (regexp-quote domain) "$") host))
+ (string-match (concat (regexp-quote
+ ;; Remove the dot from wildcard domains
+ ;; before matching.
+ (if (eq ?. (aref domain 0))
+ (substring domain 1)
+ domain))
+ "$") host))
(t
nil))))
-;;;###autoload
(defun url-cookie-handle-set-cookie (str)
(setq url-cookies-changed-since-last-save t)
(let* ((args (url-parse-args str t))
(defvar url-cookie-timer nil)
(defcustom url-cookie-save-interval 3600
- "*The number of seconds between automatic saves of cookies.
+ "The number of seconds between automatic saves of cookies.
Default is 1 hour. Note that if you change this variable outside of
the `customize' interface after `url-do-setup' has been run, you need
to run the `url-cookie-setup-save-timer' function manually."
- :set (function (lambda (var val)
- (set-default var val)
- (and (featurep 'url)
- (fboundp 'url-cookie-setup-save-timer)
- (url-cookie-setup-save-timer))))
+ :set #'(lambda (var val)
+ (set-default var val)
+ (if (bound-and-true-p url-setup-done)
+ (url-cookie-setup-save-timer)))
:type 'integer
- :group 'url)
+ :group 'url-cookie)
-;;;###autoload
(defun url-cookie-setup-save-timer ()
"Reset the cookie saver timer."
(interactive)
- (ignore-errors
- (cond ((fboundp 'cancel-timer) (cancel-timer url-cookie-timer))
- ((fboundp 'delete-itimer) (delete-itimer url-cookie-timer))))
+ (ignore-errors (cancel-timer url-cookie-timer))
(setq url-cookie-timer nil)
(if url-cookie-save-interval
- (setq url-cookie-timer
- (cond
- ((fboundp 'run-at-time)
- (run-at-time url-cookie-save-interval
- url-cookie-save-interval
- 'url-cookie-write-file))
- ((fboundp 'start-itimer)
- (start-itimer "url-cookie-saver" 'url-cookie-write-file
- url-cookie-save-interval
- url-cookie-save-interval))))))
+ (setq url-cookie-timer (run-at-time url-cookie-save-interval
+ url-cookie-save-interval
+ #'url-cookie-write-file))))
(provide 'url-cookie)
HCoop / bpt / emacs.git / blobdiff