X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/ffe832ea680b4820f5ff399191f7f2d41350ee2e..77ab81d0545e980c57c0a35510ade29a9e43b4cd:/lisp/url/url-cookie.el

diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 7db8e0a307..c373ef6f66 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -1,38 +1,33 @@
-;;; url-cookie.el --- Netscape Cookie support
+;;; url-cookie.el --- URL cookie support
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
+;;   2009, 2010, 2011  Free Software Foundation, Inc.
 
 ;; Keywords: comm, data, processes, hypermedia
 
 ;; This file is part of GNU Emacs.
 ;;
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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 3, or (at your option)
-;; any later version.
-;;
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
-;;
+
 ;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
 ;;; Code:
 
-(require 'timezone)
 (require 'url-util)
 (require 'url-parse)
-(eval-when-compile (require 'cl))
 
-;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
-;; 'open standard' defining this crap.
+(eval-when-compile (require 'cl))	; defstruct
 
 (defgroup url-cookie nil
   "URL cookies."
@@ -79,41 +74,23 @@ telling Microsoft that."
   "Whether the cookies list has changed since the last save operation.")
 
 (defun url-cookie-parse-file (&optional fname)
-  (setq fname (or fname url-cookie-file))
-  (condition-case ()
-      (load fname nil t)
-    (error
-     ;; It's completely normal for the cookies file not to exist yet.
-     ;; (message "Could not load cookie file %s" fname)
-     )))
+  "Load FNAME, default `url-cookie-file'."
+  ;; It's completely normal for the cookies file not to exist yet.
+  (load (or fname url-cookie-file) t t))
 
 (declare-function url-cookie-p "url-cookie" t t) ; defstruct
 
 (defun url-cookie-clean-up (&optional secure)
-  (let* (
-	 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
-	 (val (symbol-value var))
-	 (cur nil)
-	 (new nil)
-	 (cookies nil)
-	 (cur-cookie nil)
-	 (new-cookies nil)
-	 )
-    (while val
-      (setq cur (car val)
-	    val (cdr val)
-	    new-cookies nil
-	    cookies (cdr cur))
-      (while cookies
-	(setq cur-cookie (car cookies)
-	      cookies (cdr cookies))
-	(if (or (not (url-cookie-p cur-cookie))
-		(url-cookie-expired-p cur-cookie)
-		(null (url-cookie-expires cur-cookie)))
-	    nil
-	  (setq new-cookies (cons cur-cookie new-cookies))))
-      (if (not new-cookies)
-	  nil
+  (let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
+	new new-cookies)
+    (dolist (cur (symbol-value var))
+      (setq new-cookies nil)
+      (dolist (cur-cookie (cdr cur))
+	(or (not (url-cookie-p cur-cookie))
+	    (url-cookie-expired-p cur-cookie)
+	    (null (url-cookie-expires cur-cookie))
+	    (setq new-cookies (cons cur-cookie new-cookies))))
+      (when new-cookies
 	(setcdr cur new-cookies)
 	(setq new (cons cur new))))
     (set var new)))
@@ -146,99 +123,57 @@ telling Microsoft that."
     (setq url-cookies-changed-since-last-save nil))))
 
 (defun url-cookie-store (name value &optional expires domain localpart secure)
-  "Store a netscape-style cookie."
-  (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
-	 (tmp storage)
-	 (cur nil)
-	 (found-domain nil))
-
-    ;; First, look for a matching domain
-    (setq found-domain (assoc domain storage))
-
-    (if found-domain
+  "Store a cookie."
+  (let ((storage (if secure url-cookie-secure-storage url-cookie-storage))
+	tmp found-domain)
+    ;; First, look for a matching domain.
+    (if (setq found-domain (assoc domain storage))
 	;; Need to either stick the new cookie in existing domain storage
 	;; or possibly replace an existing cookie if the names match.
-	(progn
-	  (setq storage (cdr found-domain)
-		tmp nil)
-	  (while storage
-	    (setq cur (car storage)
-		  storage (cdr storage))
-	    (if (and (equal localpart (url-cookie-localpart cur))
-		     (equal name (url-cookie-name cur)))
-		(progn
-		  (setf (url-cookie-expires cur) expires)
-		  (setf (url-cookie-value cur) value)
-		  (setq tmp t))))
-	  (if (not tmp)
-	      ;; New cookie
-	      (setcdr found-domain (cons
-				    (url-cookie-create :name name
-						       :value value
-						       :expires expires
-						       :domain domain
-						       :localpart localpart
-						       :secure secure)
-				    (cdr found-domain)))))
-      ;; Need to add a new top-level domain
+	(unless (dolist (cur (setq storage (cdr found-domain)) tmp)
+		  (and (equal localpart (url-cookie-localpart cur))
+		       (equal name (url-cookie-name cur))
+		       (progn
+			 (setf (url-cookie-expires cur) expires)
+			 (setf (url-cookie-value cur) value)
+			 (setq tmp t))))
+	  ;; New cookie.
+	  (setcdr found-domain (cons
+				(url-cookie-create :name name
+						   :value value
+						   :expires expires
+						   :domain domain
+						   :localpart localpart
+						   :secure secure)
+				(cdr found-domain))))
+      ;; Need to add a new top-level domain.
       (setq tmp (url-cookie-create :name name
 				   :value value
 				   :expires expires
 				   :domain domain
 				   :localpart localpart
 				   :secure secure))
-      (cond
-       (storage
-	(setcdr storage (cons (list domain tmp) (cdr storage))))
-       (secure
-	(setq url-cookie-secure-storage (list (list domain tmp))))
-       (t
-	(setq url-cookie-storage (list (list domain tmp))))))))
+      (cond (storage
+	     (setcdr storage (cons (list domain tmp) (cdr storage))))
+	    (secure
+	     (setq url-cookie-secure-storage (list (list domain tmp))))
+	    (t
+	     (setq url-cookie-storage (list (list domain tmp))))))))
 
 (defun url-cookie-expired-p (cookie)
-  (let* (
-	 (exp (url-cookie-expires cookie))
-	 (cur-date (and exp (timezone-parse-date (current-time-string))))
-	 (exp-date (and exp (timezone-parse-date exp)))
-	 (cur-greg (and cur-date (timezone-absolute-from-gregorian
-				  (string-to-number (aref cur-date 1))
-				  (string-to-number (aref cur-date 2))
-				  (string-to-number (aref cur-date 0)))))
-	 (exp-greg (and exp (timezone-absolute-from-gregorian
-			     (string-to-number (aref exp-date 1))
-			     (string-to-number (aref exp-date 2))
-			     (string-to-number (aref exp-date 0)))))
-	 (diff-in-days (and exp (- cur-greg exp-greg)))
-	 )
-    (cond
-     ((not exp)	nil)			; No expiry == expires at browser quit
-     ((< diff-in-days 0) nil)		; Expires sometime after today
-     ((> diff-in-days 0) t)		; Expired before today
-     (t					; Expires sometime today, check times
-      (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
-	     (exp-time (timezone-parse-time (aref exp-date 3)))
-	     (cur-norm (+ (* 360 (string-to-number (aref cur-time 2)))
-			  (*  60 (string-to-number (aref cur-time 1)))
-			  (*   1 (string-to-number (aref cur-time 0)))))
-	     (exp-norm (+ (* 360 (string-to-number (aref exp-time 2)))
-			  (*  60 (string-to-number (aref exp-time 1)))
-			  (*   1 (string-to-number (aref exp-time 0))))))
-	(> (- cur-norm exp-norm) 1))))))
-
-(defun url-cookie-retrieve (host localpart &optional secure)
-  "Retrieve all the netscape-style cookies for a specified HOST and LOCALPART."
+  "Return non-nil if COOKIE is expired."
+  (let ((exp (url-cookie-expires cookie)))
+    (and exp (> (float-time) (float-time (date-to-time exp))))))
+
+(defun url-cookie-retrieve (host &optional localpart secure)
+  "Retrieve all cookies for a specified HOST and LOCALPART."
   (let ((storage (if secure
 		     (append url-cookie-secure-storage url-cookie-storage)
 		   url-cookie-storage))
 	(case-fold-search t)
-	(cookies nil)
-	(cur nil)
-	(retval nil)
-	(localpart-regexp nil))
-    (while storage
-      (setq cur (car storage)
-	    storage (cdr storage)
-	    cookies (cdr cur))
+	cookies retval localpart-match)
+    (dolist (cur storage)
+      (setq cookies (cdr cur))
       (if (and (car cur)
 	       (string-match
                 (concat "^.*"
@@ -250,32 +185,28 @@ telling Microsoft that."
                            (car cur)))
                         "$") host))
 	  ;; The domains match - a possible hit!
-	  (while cookies
-	    (setq cur (car cookies)
-		  cookies (cdr cookies)
-		  localpart-regexp (concat "^" (regexp-quote
-						(url-cookie-localpart cur))))
-	    (if (and (string-match localpart-regexp localpart)
-		     (not (url-cookie-expired-p cur)))
-		(setq retval (cons cur retval))))))
+	  (dolist (cur cookies)
+	    (and (if (and (stringp
+			   (setq localpart-match (url-cookie-localpart cur)))
+			  (stringp localpart))
+		     (string-match (concat "^" (regexp-quote localpart-match))
+				   localpart)
+		   (equal localpart localpart-match))
+		 (not (url-cookie-expired-p cur))
+		 (setq retval (cons cur retval))))))
     retval))
 
 (defun url-cookie-generate-header-lines (host localpart secure)
-  (let* ((cookies (url-cookie-retrieve host localpart secure))
-	 (retval nil)
-	 (cur nil)
-	 (chunk nil))
-    ;; Have to sort this for sending most specific cookies first
+  (let ((cookies (url-cookie-retrieve host localpart secure))
+	retval chunk)
+    ;; Have to sort this for sending most specific cookies first.
     (setq cookies (and cookies
 		       (sort cookies
-			     (function
-			      (lambda (x y)
-				(> (length (url-cookie-localpart x))
-				   (length (url-cookie-localpart y))))))))
-    (while cookies
-      (setq cur (car cookies)
-	    cookies (cdr cookies)
-	    chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
+			     (lambda (x y)
+			       (> (length (url-cookie-localpart x))
+				  (length (url-cookie-localpart y)))))))
+    (dolist (cur cookies)
+      (setq chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
 	    retval (if (and url-cookie-multiple-line
 			    (< 80 (+ (length retval) (length chunk) 4)))
 		       (concat retval "\r\nCookie: " chunk)
@@ -345,40 +276,38 @@ telling Microsoft that."
 			(file-name-directory
 			 (url-filename url-current-object))))
 	 (rest nil))
-    (while args
-      (if (not (member (downcase (car (car args)))
-		       '("secure" "domain" "expires" "path")))
-	  (setq rest (cons (car args) rest)))
-      (setq args (cdr args)))
+    (dolist (this args)
+      (or (member (downcase (car this)) '("secure" "domain" "expires" "path"))
+	  (setq rest (cons this rest))))
 
     ;; Sometimes we get dates that the timezone package cannot handle very
     ;; gracefully - take care of this here, instead of in url-cookie-expired-p
     ;; to speed things up.
-    (if (and expires
-	     (string-match
-	      (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
-		      "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
-	      expires))
-	(setq expires (concat (match-string 1 expires) " "
-			      (match-string 2 expires) " "
-			      (match-string 3 expires) " "
-			      (match-string 4 expires) " ["
-			      (match-string 5 expires) "]")))
+    (and expires
+	 (string-match
+	  (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
+		  "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
+	  expires)
+	 (setq expires (concat (match-string 1 expires) " "
+			       (match-string 2 expires) " "
+			       (match-string 3 expires) " "
+			       (match-string 4 expires) " ["
+			       (match-string 5 expires) "]")))
 
     ;; This one is for older Emacs/XEmacs variants that don't
     ;; understand this format without tenths of a second in it.
     ;; Wednesday, 30-Dec-2037 16:00:00 GMT
     ;;       - vs -
     ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
-    (if (and expires
-	     (string-match
-	      "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
-	      expires))
-	(setq expires (concat (match-string 1 expires) "-"	; day
-			      (match-string 2 expires) "-"	; month
-			      (match-string 3 expires) " "	; year
-			      (match-string 4 expires) ".00 " ; hour:minutes:seconds
-			      (match-string 6 expires)))) ":" ; timezone
+    (and expires
+	 (string-match
+	  "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
+	  expires)
+	 (setq expires (concat (match-string 1 expires) "-"	; day
+			       (match-string 2 expires) "-"	; month
+			       (match-string 3 expires) " "	; year
+			       (match-string 4 expires) ".00 " ; hour:minutes:seconds
+			       (match-string 6 expires)))) ":" ; timezone
 
     (while (consp trusted)
       (if (string-match (car trusted) current-url)
@@ -388,45 +317,39 @@ telling Microsoft that."
       (if (string-match (car untrusted) current-url)
 	  (setq untrusted (- (match-end 0) (match-beginning 0)))
 	(pop untrusted)))
-    (if (and trusted untrusted)
-	;; Choose the more specific match
-	(if (> trusted untrusted)
-	    (setq untrusted nil)
-	  (setq trusted nil)))
+    (and trusted untrusted
+	 ;; Choose the more specific match.
+	 (set (if (> trusted untrusted) 'untrusted 'trusted) nil))
     (cond
      (untrusted
-      ;; The site was explicity marked as untrusted by the user
+      ;; The site was explicity marked as untrusted by the user.
       nil)
      ((or (eq url-privacy-level 'paranoid)
 	  (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
-      ;; user never wants cookies
+      ;; User never wants cookies.
       nil)
      ((and url-cookie-confirmation
 	   (not trusted)
 	   (save-window-excursion
 	     (with-output-to-temp-buffer "*Cookie Warning*"
 	       (mapcar
-		(function
-		 (lambda (x)
-		   (princ (format "%s - %s" (car x) (cdr x))))) rest))
+		(lambda (x)
+		  (princ (format "%s - %s" (car x) (cdr x)))) rest))
 	     (prog1
 		 (not (funcall url-confirmation-func
 			       (format "Allow %s to set these cookies? "
 				       (url-host url-current-object))))
 	       (if (get-buffer "*Cookie Warning*")
 		   (kill-buffer "*Cookie Warning*")))))
-      ;; user wants to be asked, and declined.
+      ;; User wants to be asked, and declined.
       nil)
      ((url-cookie-host-can-set-p (url-host url-current-object) domain)
-      ;; Cookie is accepted by the user, and passes our security checks
-      (let ((cur nil))
-	(while rest
-	  (setq cur (pop rest))
-	  (url-cookie-store (car cur) (cdr cur)
-			    expires domain localpart secure))))
+      ;; Cookie is accepted by the user, and passes our security checks.
+      (dolist (cur rest)
+	(url-cookie-store (car cur) (cdr cur) expires domain localpart secure)))
      (t
-      (message "%s tried to set a cookie for domain %s - rejected."
-	       (url-host url-current-object) domain)))))
+      (url-lazy-message "%s tried to set a cookie for domain %s - rejected."
+			(url-host url-current-object) domain)))))
 
 (defvar url-cookie-timer nil)
 
@@ -454,5 +377,4 @@ to run the `url-cookie-setup-save-timer' function manually."
 
 (provide 'url-cookie)
 
-;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
 ;;; url-cookie.el ends here