lisp/url/url-history.el

   1 ;;; url-history.el --- Global history tracking for URL package
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Keywords: comm, data, processes, hypermedia
   7
   8 ;; This file is part of GNU Emacs.
   9 ;;
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 ;; This can get a recursive require.
  30 ;;(require 'url)
  31 (eval-when-compile (require 'cl))
  32 (require 'url-parse)
  33 (autoload 'url-do-setup "url")
  34
  35 (defgroup url-history nil
  36   "History variables in the URL package."
  37   :prefix "url-history"
  38   :group 'url)
  39
  40 (defcustom url-history-track nil
  41   "*Controls whether to keep a list of all the URLs being visited.
  42 If non-nil, the URL package will keep track of all the URLs visited.
  43 If set to t, then the list is saved to disk at the end of each Emacs
  44 session."
  45   :set #'(lambda (var val)
  46            (set-default var val)
  47            (and (bound-and-true-p 'url-setup-done)
  48                 (url-history-setup-save-timer)))
  49   :type '(choice (const :tag "off" nil)
  50                  (const :tag "on" t)
  51                  (const :tag "within session" 'session))
  52   :group 'url-history)
  53
  54 (defcustom url-history-file nil
  55   "*The global history file for the URL package.
  56 This file contains a list of all the URLs you have visited.  This file
  57 is parsed at startup and used to provide URL completion."
  58   :type '(choice (const :tag "Default" :value nil) file)
  59   :group 'url-history)
  60
  61 (defcustom url-history-save-interval 3600
  62   "*The number of seconds between automatic saves of the history list.
  63 Default is 1 hour.  Note that if you change this variable outside of
  64 the `customize' interface after `url-do-setup' has been run, you need
  65 to run the `url-history-setup-save-timer' function manually."
  66   :set (function (lambda (var val)
  67                    (set-default var val)
  68                    (and (featurep 'url)
  69                         (fboundp 'url-history-setup-save-timer)
  70                         (let ((def (symbol-function
  71                                     'url-history-setup-save-timer)))
  72                           (not (and (listp def) (eq 'autoload (car def)))))
  73                         (url-history-setup-save-timer))))
  74   :type 'integer
  75   :group 'url-history)
  76
  77 (defvar url-history-timer nil)
  78
  79 (defvar url-history-list nil
  80   "List of urls visited this session.")
  81
  82 (defvar url-history-changed-since-last-save nil
  83   "Whether the history list has changed since the last save operation.")
  84
  85 (defvar url-history-hash-table nil
  86   "Hash table for global history completion.")
  87
  88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89
  90 ;;;###autoload
  91 (defun url-history-setup-save-timer ()
  92   "Reset the history list timer."
  93   (interactive)
  94   (ignore-errors
  95     (cond ((fboundp 'cancel-timer) (cancel-timer url-history-timer))
  96           ((fboundp 'delete-itimer) (delete-itimer url-history-timer))))
  97   (setq url-history-timer nil)
  98   (if (and (eq url-history-track t) url-history-save-interval)
  99       (setq url-history-timer
 100             (cond
 101              ((fboundp 'run-at-time)
 102               (run-at-time url-history-save-interval
 103                            url-history-save-interval
 104                            'url-history-save-history))
 105              ((fboundp 'start-itimer)
 106               (start-itimer "url-history-saver" 'url-history-save-history
 107                             url-history-save-interval
 108                             url-history-save-interval))))))
 109
 110 ;;;###autoload
 111 (defun url-history-parse-history (&optional fname)
 112   "Parse a history file stored in FNAME."
 113   ;; Parse out the mosaic global history file for completions, etc.
 114   (or fname (setq fname (expand-file-name url-history-file)))
 115   (cond
 116    ((not (file-exists-p fname))
 117     (message "%s does not exist." fname))
 118    ((not (file-readable-p fname))
 119     (message "%s is unreadable." fname))
 120    (t
 121     (condition-case nil
 122         (load fname nil t)
 123       (error (message "Could not load %s" fname)))))
 124   (if (not url-history-hash-table)
 125       (setq url-history-hash-table (make-hash-table :size 31 :test 'equal))))
 126
 127 (defun url-history-update-url (url time)
 128   (setq url-history-changed-since-last-save t)
 129   (puthash (if (vectorp url) (url-recreate-url url) url) time url-history-hash-table))
 130
 131 ;;;###autoload
 132 (defun url-history-save-history (&optional fname)
 133   "Write the global history file into `url-history-file'.
 134 The type of data written is determined by what is in the file to begin
 135 with.  If the type of storage cannot be determined, then prompt the
 136 user for what type to save as."
 137   (interactive)
 138   (or fname (setq fname (expand-file-name url-history-file)))
 139   (cond
 140    ((not url-history-changed-since-last-save) nil)
 141    ((not (file-writable-p fname))
 142     (message "%s is unwritable." fname))
 143    (t
 144     (let ((make-backup-files nil)
 145           (version-control nil)
 146           (require-final-newline t))
 147       (save-excursion
 148         (set-buffer (get-buffer-create " *url-tmp*"))
 149         (erase-buffer)
 150         (let ((count 0))
 151           (maphash (function
 152                        (lambda (key value)
 153                          (while (string-match "[\r\n]+" key)
 154                            (setq key (concat (substring key 0 (match-beginning 0))
 155                                              (substring key (match-end 0) nil))))
 156                          (setq count (1+ count))
 157                          (insert "(puthash \"" key "\""
 158                                  (if (not (stringp value)) " '" "")
 159                                  (prin1-to-string value)
 160                                  " url-history-hash-table)\n")))
 161                       url-history-hash-table)
 162           (goto-char (point-min))
 163           (insert (format
 164                    "(setq url-history-hash-table (make-hash-table :size %d :test 'equal))\n"
 165                    (/ count 4)))
 166           (goto-char (point-max))
 167           (insert "\n")
 168           (write-file fname))
 169         (kill-buffer (current-buffer))))))
 170   (setq url-history-changed-since-last-save nil))
 171
 172 (defun url-have-visited-url (url)
 173   (url-do-setup)
 174   (and url-history-hash-table
 175        (gethash url url-history-hash-table nil)))
 176
 177 (defun url-completion-function (string predicate function)
 178   (url-do-setup)
 179   (cond
 180    ((eq function nil)
 181     (let ((list nil))
 182       (maphash (function (lambda (key val)
 183                               (setq list (cons (cons key val)
 184                                                list))))
 185                   url-history-hash-table)
 186       (try-completion string (nreverse list) predicate)))
 187    ((eq function t)
 188     (let ((stub (concat "^" (regexp-quote string)))
 189           (retval nil))
 190       (maphash
 191        (function
 192         (lambda (url time)
 193           (if (string-match stub url)
 194               (setq retval (cons url retval)))))
 195        url-history-hash-table)
 196       retval))
 197    ((eq function 'lambda)
 198     (and url-history-hash-table
 199          (gethash string url-history-hash-table)
 200          t))
 201    (t
 202     (error "url-completion-function very confused"))))
 203
 204 (provide 'url-history)
 205
 206 ;; arch-tag: fbbbaf63-db36-4e88-bc9f-2939aa93afb2
 207 ;;; url-history.el ends here