lisp/url/url-history.el

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