code.delx.au - gnu-emacs/blob - lisp/url/url-history.el

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