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