X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/2536fb611876d5526fe40b9bee2a16e2836d4ff3..82b9f9f5f4d356f49f76d60981a5925888205f12:/lisp/url/url-cookie.el diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 44ef8aed77..e056db38a9 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -1,32 +1,29 @@ ;;; url-cookie.el --- Netscape Cookie support -;; Copyright (C) 1996, 1997, 1998, 1999, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 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 2, 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 . ;;; Commentary: ;;; Code: -(require 'timezone) (require 'url-util) (require 'url-parse) (eval-when-compile (require 'cl)) @@ -87,6 +84,8 @@ telling Microsoft that." ;; (message "Could not load cookie file %s" fname) ))) +(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)) @@ -117,19 +116,17 @@ telling Microsoft that." (set var new))) (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)) - (message "Cookies file %s (see variable `url-cookie-file') is unwritable." fname)) - (t + (when url-cookies-changed-since-last-save + (or fname (setq fname (expand-file-name url-cookie-file))) + (if (condition-case nil + (progn + (url-make-private-file fname) + nil) + (error t)) + (message "Error accessing cookie file `%s'" fname) (url-cookie-clean-up) (url-cookie-clean-up t) - (with-current-buffer (get-buffer-create " *cookies*") - (erase-buffer) - (fundamental-mode) + (with-temp-buffer (insert ";; Emacs-W3 HTTP cookies file\n" ";; Automatically generated file!!! DO NOT EDIT!!!\n\n" "(setq url-cookie-storage\n '") @@ -142,9 +139,8 @@ telling Microsoft that." ";; 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)))))) + (write-file fname)) + (setq url-cookies-changed-since-last-save nil)))) (defun url-cookie-store (name value &optional expires domain localpart secure) "Store a netscape-style cookie." @@ -197,36 +193,11 @@ telling Microsoft that." (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) + "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 the netscape-style cookies for a specified HOST and LOCALPART." (let ((storage (if secure (append url-cookie-secure-storage url-cookie-storage) @@ -235,7 +206,7 @@ telling Microsoft that." (cookies nil) (cur nil) (retval nil) - (localpart-regexp nil)) + (localpart-match nil)) (while storage (setq cur (car storage) storage (cdr storage) @@ -254,9 +225,12 @@ telling Microsoft that." (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) + localpart-match (url-cookie-localpart cur)) + (if (and (if (stringp localpart-match) + (string-match (concat "^" (regexp-quote + localpart-match)) + localpart) + (equal localpart localpart-match)) (not (url-cookie-expired-p cur))) (setq retval (cons cur retval)))))) retval)) @@ -426,8 +400,8 @@ telling Microsoft that." (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)