lisp/net/quickurl.el

   1 ;;; quickurl.el --- Insert an URL based on text at point in buffer.
   2
   3 ;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Pearson <davep@davep.org>
   6 ;; Maintainer: Dave Pearson <davep@davep.org>
   7 ;; Created: 1999-05-28
   8 ;; Keywords: hypermedia
   9
  10 ;; This file is part of GNU emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This package provides a simple method of inserting an URL based on the
  30 ;; text at point in the current buffer. This is part of an on-going effort
  31 ;; to increase the information I provide people while reducing the ammount
  32 ;; of typing I need to do. No-doubt there are undiscovered Emacs packages
  33 ;; out there that do all of this and do it better, feel free to point me to
  34 ;; them, in the mean time I'm having fun playing with Emacs Lisp.
  35 ;;
  36 ;; The URLs are stored in an external file as a list of either cons cells,
  37 ;; or lists. A cons cell entry looks like this:
  38 ;;
  39 ;;    (<Lookup> . <URL>)
  40 ;;
  41 ;; where <Lookup> is a string that acts as the keyword lookup and <URL> is
  42 ;; the URL associated with it. An example might be:
  43 ;;
  44 ;;    ("GNU" . "http://www.gnu.org/")
  45 ;;
  46 ;; A list entry looks like:
  47 ;;
  48 ;;    (<Lookup> <URL> <Comment>)
  49 ;;
  50 ;; where <Lookup> and <URL> are the same as with the cons cell and <Comment>
  51 ;; is any text you like that describes the URL. This description will be
  52 ;; used when presenting a list of URLS using `quickurl-list'. An example
  53 ;; might be:
  54 ;;
  55 ;;    ("FSF" "http://www.fsf.org/" "The Free Software Foundation")
  56 ;;
  57 ;; Given the above, your quickurl file might look like:
  58 ;;
  59 ;; (("GNU"    . "http://www.gnu.org/")
  60 ;;  ("FSF"      "http://www.fsf.org/" "The Free Software Foundation")
  61 ;;  ("emacs"  . "http://www.emacs.org/")
  62 ;;  ("hagbard"  "http://www.hagbard.demon.co.uk" "Hagbard's World"))
  63 ;;
  64 ;; In case you're wondering about the mixture of cons cells and lists,
  65 ;; quickurl started life using just the cons cells, there were no comments.
  66 ;; URL comments are a later addition and so there is a mixture to keep
  67 ;; backward compatibility with existing URL lists.
  68 ;;
  69 ;; The name and location of the file is up to you, the default name used by
  70 ;; `quickurl' is stored in `quickurl-url-file'.
  71 ;;
  72 ;; quickurl is always available from:
  73 ;;
  74 ;;   <URL:http://www.hagbard.demon.co.uk/archives/quickurl.el>
  75 ;;   <URL:http://www.acemake.com/hagbard/archives/quickurl.el>
  76
  77 ;;; TODO:
  78 ;;
  79 ;; o The quickurl-browse-url* functions pretty much duplicate their non
  80 ;;   browsing friends. It would feel better if a more generic solution could
  81 ;;   be found.
  82
  83 ;;; Code:
  84
  85 ;; Things we need:
  86
  87 (eval-when-compile
  88   (require 'cl))
  89 (require 'thingatpt)
  90 (require 'pp)
  91 (require 'browse-url)
  92
  93 ;; Attempt to handle older/other emacs.
  94 (eval-and-compile
  95   ;; If customize isn't available just use defvar instead.
  96   (unless (fboundp 'defgroup)
  97     (defmacro defgroup  (&rest rest) nil)
  98     (defmacro defcustom (symbol init docstring &rest rest)
  99       `(defvar ,symbol ,init ,docstring))))
 100
 101 ;; Customize options.
 102
 103 (defgroup quickurl nil
 104   "Insert an URL based on text at point in buffer."
 105   :version "21.1"
 106   :group  'abbrev
 107   :prefix "quickurl-")
 108
 109 (defcustom quickurl-url-file "~/.quickurls"
 110   "*File that contains the URL list."
 111   :type  'file
 112   :group 'quickurl)
 113
 114 (defcustom quickurl-format-function (lambda (url) (format "<URL:%s>" (quickurl-url-url url)))
 115   "*Function to format the URL before insertion into the current buffer."
 116   :type  'function
 117   :group 'quickurl)
 118
 119 (defcustom quickurl-sort-function (lambda (list)
 120                                     (sort list
 121                                           (lambda (x y)
 122                                             (string<
 123                                              (downcase (quickurl-url-description x))
 124                                              (downcase (quickurl-url-description y))))))
 125   "*Function to sort the URL list."
 126   :type  'function
 127   :group 'quickurl)
 128
 129 (defcustom quickurl-grab-lookup-function #'current-word
 130   "*Function to grab the thing to lookup."
 131   :type  'function
 132   :group 'quickurl)
 133
 134 (defcustom quickurl-assoc-function #'assoc-ignore-case
 135   "*Function to use for alist lookup into `quickurl-urls'."
 136   :type  'function
 137   :group 'quickurl)
 138
 139 (defcustom quickurl-completion-ignore-case t
 140   "*Should `quickurl-ask' ignore case when doing the input lookup?"
 141   :type  'boolean
 142   :group 'quickurl)
 143
 144 (defcustom quickurl-prefix ";; -*- lisp -*-\n\n"
 145   "*Text to write to `quickurl-url-file' before writing the URL list."
 146   :type  'string
 147   :group 'quickurl)
 148
 149 (defcustom quickurl-postfix ""
 150   "*Text to write to `quickurl-url-file' after writing the URL list.
 151
 152 See the constant `quickurl-reread-hook-postfix' for some example text that
 153 could be used here."
 154   :type  'string
 155   :group 'quickurl)
 156
 157 (defcustom quickurl-list-mode-hook nil
 158   "*Hooks for `quickurl-list-mode'."
 159   :type  'hook
 160   :group 'quickurl)
 161
 162 ;; Constants.
 163
 164 ;;;###autoload
 165 (defconst quickurl-reread-hook-postfix
 166     "
 167 ;; Local Variables:
 168 ;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
 169 ;; End:
 170 "
 171   "Example `quickurl-postfix' text that adds a local variable to the
 172 `quickurl-url-file' so that if you edit it by hand it will ensure that
 173 `quickurl-urls' is updated with the new URL list.
 174
 175 To make use of this do something like:
 176
 177   (setq quickurl-postfix quickurl-reread-hook-postfix)
 178
 179 in your ~/.emacs (after loading/requiring quickurl).")
 180
 181 ;; Non-customize variables.
 182
 183 (defvar quickurl-urls nil
 184   "URL alist for use with `quickurl' and `quickurl-ask'.")
 185
 186 (defvar quickurl-list-mode-map nil
 187   "Local keymap for a `quickurl-list-mode' buffer.")
 188
 189 (defvar quickurl-list-buffer-name "*quickurl-list*"
 190   "Name for the URL listinig buffer.")
 191
 192 (defvar quickurl-list-last-buffer nil
 193   "`current-buffer' when `quickurl-list' was called.")
 194
 195 ;; Functions for working with an URL entry.
 196
 197 (defun quickurl-url-commented-p (url)
 198   "Does the URL have a comment?"
 199   (listp (cdr url)))
 200
 201 (defun quickurl-make-url (keyword url &optional comment)
 202   "Create an URL from KEYWORD, URL and (optionaly) COMMENT."
 203   (if (and comment (not (zerop (length comment))))
 204       (list keyword url comment)
 205     (cons keyword url)))
 206
 207 (defun quickurl-url-keyword (url)
 208   "Return the keyword for the URL.
 209
 210 Note that this function is a setfable place."
 211   (car url))
 212
 213 (defsetf quickurl-url-keyword (url) (store)
 214   `(setf (car ,url) ,store))
 215
 216 (defun quickurl-url-url (url)
 217   "Return the actual URL of the URL.
 218
 219 Note that this function is a setfable place."
 220   (if (quickurl-url-commented-p url)
 221       (cadr url)
 222     (cdr url)))
 223
 224 (defsetf quickurl-url-url (url) (store)
 225   `
 226   (if (quickurl-url-commented-p ,url)
 227       (setf (cadr ,url) ,store)
 228     (setf (cdr ,url) ,store)))
 229
 230 (defun quickurl-url-comment (url)
 231   "Get the comment from an URL.
 232
 233 If the URL has no comment an empty string is returned. Also note that this
 234 function is a setfable place."
 235   (if (quickurl-url-commented-p url)
 236       (nth 2 url)
 237     ""))
 238
 239 (defsetf quickurl-url-comment (url) (store)
 240   `
 241   (if (quickurl-url-commented-p ,url)
 242       (if (zerop (length ,store))
 243           (setf (cdr ,url) (cadr ,url))
 244         (setf (nth 2 ,url) ,store))
 245     (unless (zerop (length ,store))
 246       (setf (cdr ,url) (list (cdr ,url) ,store)))))
 247
 248 (defun quickurl-url-description (url)
 249   "Return a description for the URL.
 250
 251 If the URL has a comment then this is returned, otherwise the keyword is
 252 returned."
 253   (let ((desc (quickurl-url-comment url)))
 254     (if (zerop (length desc))
 255         (quickurl-url-keyword url)
 256       desc)))
 257
 258 ;; Main code:
 259
 260 (defun* quickurl-read (&optional (buffer (current-buffer)))
 261   "`read' the URL list from BUFFER into `quickurl-urls'.
 262
 263 Note that this function moves point to `point-min' before doing the `read'
 264 It also restores point after the `read'."
 265   (save-excursion
 266     (setf (point) (point-min))
 267     (setq quickurl-urls (funcall quickurl-sort-function (read buffer)))))
 268
 269 (defun quickurl-load-urls ()
 270   "Load the contents of `quickurl-url-file' into `quickurl-urls'."
 271   (when (file-exists-p quickurl-url-file)
 272     (with-temp-buffer
 273       (insert-file-contents quickurl-url-file)
 274       (quickurl-read))))
 275
 276 (defun quickurl-save-urls ()
 277   "Save the contents of `quickurl-urls' to `quickurl-url-file'."
 278   (with-temp-buffer
 279     (let ((standard-output (current-buffer)))
 280       (princ quickurl-prefix)
 281       (pp quickurl-urls)
 282       (princ quickurl-postfix)
 283       (write-region (point-min) (point-max) quickurl-url-file nil 0))))
 284
 285 (defun quickurl-find-url (lookup)
 286   "Return URL associated with key LOOKUP.
 287
 288 The lookup is done by looking in the alist `quickurl-urls' and the `cons'
 289 for the URL is returned. The actual method used to look into the alist
 290 depends on the setting of the variable `quickurl-assoc-function'."
 291   (funcall quickurl-assoc-function lookup quickurl-urls))
 292
 293 (defun quickurl-insert (url &optional silent)
 294   "Insert URL, formatted using `quickurl-format-function'.
 295
 296 Also display a `message' saying what the URL was unless SILENT is non-nil."
 297   (insert (funcall quickurl-format-function url))
 298   (unless silent
 299     (message "Found %s" (quickurl-url-url url))))
 300
 301 ;;;###autoload
 302 (defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function)))
 303   "Insert an URL based on LOOKUP.
 304
 305 If not supplied LOOKUP is taken to be the word at point in the current
 306 buffer, this default action can be modifed via
 307 `quickurl-grab-lookup-function'."
 308   (interactive)
 309   (when lookup
 310     (quickurl-load-urls)
 311     (let ((url (quickurl-find-url lookup)))
 312       (if (null url)
 313           (error "No URL associated with \"%s\"" lookup)
 314         (when (looking-at "\\w")
 315           (skip-syntax-forward "\\w"))
 316         (insert " ")
 317         (quickurl-insert url)))))
 318
 319 ;;;###autoload
 320 (defun quickurl-ask (lookup)
 321   "Insert an URL, with `completing-read' prompt, based on LOOKUP."
 322   (interactive
 323    (list
 324     (progn
 325       (quickurl-load-urls)
 326       (let ((completion-ignore-case quickurl-completion-ignore-case))
 327         (completing-read "Lookup: " quickurl-urls nil t)))))
 328   (let ((url (quickurl-find-url lookup)))
 329     (when url
 330       (quickurl-insert url))))
 331
 332 (defun quickurl-grab-url ()
 333   "Attempt to grab a word/url pair from point in the current buffer.
 334
 335 Point should be somewhere on the URL and the word is taken to be the thing
 336 that is returned from calling `quickurl-grab-lookup-function' once a
 337 `backward-word' has been issued at the start of the URL.
 338
 339 It is assumed that the URL is either \"unguarded\" or is wrapped inside an
 340 <URL:...> wrapper."
 341   (let ((url (thing-at-point 'url)))
 342     (when url
 343       (save-excursion
 344         (beginning-of-thing 'url)
 345         ;; `beginning-of-thing' doesn't take you to the start of a marked-up
 346         ;; URL, only to the start of the URL within the "markup". So, we
 347         ;; need to do a little more work to get to where we want to be.
 348         (when (thing-at-point-looking-at thing-at-point-markedup-url-regexp)
 349           (search-backward "<URL:"))
 350         (backward-word 1)
 351         (let ((word (funcall quickurl-grab-lookup-function)))
 352           (when word
 353             (quickurl-make-url
 354              ;; The grab function may return the word with properties. I don't
 355              ;; want the properties. I couldn't find a method of stripping
 356              ;; them from a "string" so this will have to do. If you know of
 357              ;; a better method of doing this I'd love to know.
 358              (with-temp-buffer
 359                (insert word)
 360                (buffer-substring-no-properties (point-min) (point-max)))
 361              url)))))))
 362
 363 ;;;###autoload
 364 (defun quickurl-add-url (word url comment)
 365   "Allow the user to interactively add a new URL associated with WORD.
 366
 367 See `quickurl-grab-url' for details on how the default word/url combination
 368 is decided."
 369   (interactive (let ((word-url (quickurl-grab-url)))
 370                  (list (read-string "Word: "    (quickurl-url-keyword word-url))
 371                        (read-string "URL: "     (quickurl-url-url word-url))
 372                        (read-string "Comment: " (quickurl-url-comment word-url)))))
 373   (if (zerop (length word))
 374       (error "You must specify a WORD for lookup")
 375     (quickurl-load-urls)
 376     (let* ((current-url (quickurl-find-url word))
 377            (add-it      (if current-url
 378                             (if (interactive-p)
 379                                 (y-or-n-p (format "\"%s\" exists, replace URL? " word))
 380                               t)
 381                           t)))
 382       (when add-it
 383         (if current-url
 384             (progn
 385               (setf (quickurl-url-url current-url) url)
 386               (setf (quickurl-url-comment current-url) comment))
 387           (push (quickurl-make-url word url comment) quickurl-urls))
 388         (setq quickurl-urls (funcall quickurl-sort-function quickurl-urls))
 389         (quickurl-save-urls)
 390         (when (get-buffer quickurl-list-buffer-name)
 391           (quickurl-list-populate-buffer))
 392         (when (interactive-p)
 393           (message "Added %s" url))))))
 394
 395 ;;;###autoload
 396 (defun* quickurl-browse-url (&optional (lookup (funcall quickurl-grab-lookup-function)))
 397   "Browse the URL associated with LOOKUP.
 398
 399 If not supplied LOOKUP is taken to be the word at point in the
 400 current buffer, this default action can be modifed via
 401 `quickurl-grab-lookup-function'."
 402   (interactive)
 403   (when lookup
 404     (quickurl-load-urls)
 405     (let ((url (quickurl-find-url lookup)))
 406       (if url
 407           (browse-url (quickurl-url-url url))
 408         (error "No URL associated with \"%s\"" lookup)))))
 409
 410 ;;;###autoload
 411 (defun quickurl-browse-url-ask (lookup)
 412   "Browse the URL, with `completing-read' prompt, associated with LOOKUP."
 413   (interactive (list
 414                 (progn
 415                   (quickurl-load-urls)
 416                   (completing-read "Browse: " quickurl-urls nil t))))
 417   (let ((url (quickurl-find-url lookup)))
 418     (when url
 419       (browse-url (quickurl-url-url url)))))
 420
 421 ;;;###autoload
 422 (defun quickurl-edit-urls ()
 423   "Pull `quickurl-url-file' into a buffer for hand editing."
 424   (interactive)
 425   (find-file quickurl-url-file))
 426
 427 ;; quickurl-list mode.
 428
 429 (unless quickurl-list-mode-map
 430   (let ((map (make-sparse-keymap)))
 431     (suppress-keymap map t)
 432     (define-key map "a"           #'quickurl-list-add-url)
 433     (define-key map [(control m)] #'quickurl-list-insert-url)
 434     (define-key map "u"           #'quickurl-list-insert-naked-url)
 435     (define-key map " "           #'quickurl-list-insert-with-lookup)
 436     (define-key map "l"           #'quickurl-list-insert-lookup)
 437     (define-key map "d"           #'quickurl-list-insert-with-desc)
 438     (define-key map [(control g)] #'quickurl-list-quit)
 439     (define-key map "q"           #'quickurl-list-quit)
 440     (define-key map [mouse-2]     #'quickurl-list-mouse-select)
 441     (define-key map "?"           #'describe-mode)
 442     (setq quickurl-list-mode-map map)))
 443
 444 (put 'quickurl-list-mode 'mode-class 'special)
 445
 446 ;;;###autoload
 447 (defun quickurl-list-mode ()
 448   "A mode for browsing the quickurl URL list.
 449
 450 The key bindings for `quickurl-list-mode' are:
 451
 452 \\{quickurl-list-mode-map}"
 453   (interactive)
 454   (kill-all-local-variables)
 455   (use-local-map quickurl-list-mode-map)
 456   (setq major-mode 'quickurl-list-mode
 457         mode-name  "quickurl list")
 458   (run-hooks 'quickurl-list-mode-hook)
 459   (setq buffer-read-only t
 460         truncate-lines   t))
 461
 462 ;;;###autoload
 463 (defun quickurl-list ()
 464   "Display `quickurl-list' as a formatted list using `quickurl-list-mode'."
 465   (interactive)
 466   (quickurl-load-urls)
 467   (unless (string= (buffer-name) quickurl-list-buffer-name)
 468     (setq quickurl-list-last-buffer (current-buffer)))
 469   (pop-to-buffer quickurl-list-buffer-name)
 470   (quickurl-list-populate-buffer)
 471   (quickurl-list-mode))
 472
 473 (defun quickurl-list-populate-buffer ()
 474   "Populate the `quickurl-list' buffer."
 475   (with-current-buffer (get-buffer quickurl-list-buffer-name)
 476     (let ((buffer-read-only nil)
 477           (fmt (format "%%-%ds %%s\n"
 478                        (apply #'max (or (loop for url in quickurl-urls
 479                                               collect (length (quickurl-url-description url)))
 480                                         (list 20))))))
 481       (setf (buffer-string) "")
 482       (loop for url in quickurl-urls
 483             do (let ((start (point)))
 484                  (insert (format fmt (quickurl-url-description url)
 485                                  (quickurl-url-url url)))
 486                  (put-text-property start (1- (point))
 487                                     'mouse-face 'highlight)))
 488       (setf (point) (point-min)))))
 489
 490 (defun quickurl-list-add-url (word url comment)
 491   "Wrapper for `quickurl-add-url' that doesn't guess the parameters."
 492   (interactive "sWord: \nsURL: \nsComment: ")
 493   (quickurl-add-url word url comment))
 494
 495 (defun quickurl-list-quit ()
 496   "Kill the buffer named `quickurl-list-buffer-name'."
 497   (interactive)
 498   (kill-buffer quickurl-list-buffer-name)
 499   (switch-to-buffer quickurl-list-last-buffer)
 500   (delete-other-windows))
 501
 502 (defun quickurl-list-mouse-select (event)
 503   "Select the URL under the mouse click."
 504   (interactive "e")
 505   (setf (point) (posn-point (event-end event)))
 506   (quickurl-list-insert-url))
 507
 508 (defun quickurl-list-insert (type)
 509   "Insert the URL under cursor into `quickurl-list-last-buffer'.
 510 TYPE dictates what will be inserted, options are:
 511   `url'         - Insert the URL as <URL:url>
 512   `naked-url'   - Insert the URL with no formatting
 513   `with-lookup' - Insert \"lookup <URL:url>\"
 514   `with-desc'   - Insert \"description <URL:url>\"
 515   `lookup'      - Insert the lookup for that URL"
 516   (let ((url (nth (save-excursion
 517                     (beginning-of-line)
 518                     (count-lines (point-min) (point)))
 519                   quickurl-urls)))
 520     (if url
 521         (with-current-buffer quickurl-list-last-buffer
 522           (insert
 523            (case type
 524              ('url         (funcall quickurl-format-function url))
 525              ('naked-url   (quickurl-url-url url))
 526              ('with-lookup (format "%s <URL:%s>"
 527                                    (quickurl-url-keyword url)
 528                                    (quickurl-url-url url)))
 529              ('with-desc   (format "%S <URL:%s>"
 530                                    (quickurl-url-description url)
 531                                    (quickurl-url-url url)))
 532              ('lookup      (quickurl-url-keyword url)))))
 533       (error "No URL details on that line"))
 534     url))
 535
 536 (defmacro quickurl-list-make-inserter (type)
 537   "Macro to make a key-response function for use in `quickurl-list-mode-map'."
 538   `(defun ,(intern (format "quickurl-list-insert-%S" type)) ()
 539     ,(format "Insert the result of calling `quickurl-list-insert' with `%s'." type)
 540     (interactive)
 541     (when (quickurl-list-insert ',type)
 542       (quickurl-list-quit))))
 543
 544 (quickurl-list-make-inserter url)
 545 (quickurl-list-make-inserter naked-url)
 546 (quickurl-list-make-inserter with-lookup)
 547 (quickurl-list-make-inserter with-desc)
 548 (quickurl-list-make-inserter lookup)
 549
 550 (provide 'quickurl)
 551
 552 ;;; quickurl.el ends here