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 #'(lambda (var val)
  67            (set-default var val)
  68            (if (bound-and-true-p url-setup-done)
  69                (url-history-setup-save-timer)))
  70   :type 'integer
  71   :group 'url-history)
  72
  73 (defvar url-history-timer nil)
  74
  75 (defvar url-history-changed-since-last-save nil
  76   "Whether the history list has changed since the last save operation.")
  77
  78 (defvar url-history-hash-table nil
  79   "Hash table for global history completion.")
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 ;;;###autoload
  84 (defun url-history-setup-save-timer ()
  85   "Reset the history list timer."
  86   (interactive)
  87   (ignore-errors
  88    (cancel-timer url-history-timer))
  89   (setq url-history-timer nil)
  90   (if (and (eq url-history-track t) url-history-save-interval)
  91       (setq url-history-timer (run-at-time url-history-save-interval
  92                                            url-history-save-interval
  93                                            'url-history-save-history))))
  94
  95 ;;;###autoload
  96 (defun url-history-parse-history (&optional fname)
  97   "Parse a history file stored in FNAME."
  98   ;; Parse out the mosaic global history file for completions, etc.
  99   (or fname (setq fname (expand-file-name url-history-file)))
 100   (cond
 101    ((not (file-exists-p fname))
 102     (message "%s does not exist." fname))
 103    ((not (file-readable-p fname))
 104     (message "%s is unreadable." fname))
 105    (t
 106     (condition-case nil
 107         (load fname nil t)
 108       (error (message "Could not load %s" fname)))))
 109   (if (not url-history-hash-table)
 110       (setq url-history-hash-table (make-hash-table :size 31 :test 'equal))))
 111
 112 (defun url-history-update-url (url time)
 113   (setq url-history-changed-since-last-save t)
 114   (puthash (if (vectorp url) (url-recreate-url url) url) time url-history-hash-table))
 115
 116 ;;;###autoload
 117 (defun url-history-save-history (&optional fname)
 118   "Write the global history file into `url-history-file'.
 119 The type of data written is determined by what is in the file to begin
 120 with.  If the type of storage cannot be determined, then prompt the
 121 user for what type to save as."
 122   (interactive)
 123   (or fname (setq fname (expand-file-name url-history-file)))
 124   (cond
 125    ((not url-history-changed-since-last-save) nil)
 126    ((not (file-writable-p fname))
 127     (message "%s is unwritable." fname))
 128    (t
 129     (let ((make-backup-files nil)
 130           (version-control nil)
 131           (require-final-newline t))
 132       (save-excursion
 133         (set-buffer (get-buffer-create " *url-tmp*"))
 134         (erase-buffer)
 135         (let ((count 0))
 136           (maphash (function
 137                        (lambda (key value)
 138                          (while (string-match "[\r\n]+" key)
 139                            (setq key (concat (substring key 0 (match-beginning 0))
 140                                              (substring key (match-end 0) nil))))
 141                          (setq count (1+ count))
 142                          (insert "(puthash \"" key "\""
 143                                  (if (not (stringp value)) " '" "")
 144                                  (prin1-to-string value)
 145                                  " url-history-hash-table)\n")))
 146                       url-history-hash-table)
 147           (goto-char (point-min))
 148           (insert (format
 149                    "(setq url-history-hash-table (make-hash-table :size %d :test 'equal))\n"
 150                    (/ count 4)))
 151           (goto-char (point-max))
 152           (insert "\n")
 153           (write-file fname))
 154         (kill-buffer (current-buffer))))))
 155   (setq url-history-changed-since-last-save nil))
 156
 157 (defun url-have-visited-url (url)
 158   (url-do-setup)
 159   (and url-history-hash-table
 160        (gethash url url-history-hash-table nil)))
 161
 162 (defun url-completion-function (string predicate function)
 163   (url-do-setup)
 164   (cond
 165    ((eq function nil)
 166     (let ((list nil))
 167       (maphash (function (lambda (key val)
 168                               (setq list (cons (cons key val)
 169                                                list))))
 170                   url-history-hash-table)
 171       (try-completion string (nreverse list) predicate)))
 172    ((eq function t)
 173     (let ((stub (concat "^" (regexp-quote string)))
 174           (retval nil))
 175       (maphash
 176        (function
 177         (lambda (url time)
 178           (if (string-match stub url)
 179               (setq retval (cons url retval)))))
 180        url-history-hash-table)
 181       retval))
 182    ((eq function 'lambda)
 183     (and url-history-hash-table
 184          (gethash string url-history-hash-table)
 185          t))
 186    (t
 187     (error "url-completion-function very confused"))))
 188
 189 (provide 'url-history)
 190
 191 ;; arch-tag: fbbbaf63-db36-4e88-bc9f-2939aa93afb2
 192 ;;; url-history.el ends here