code.delx.au - gnu-emacs/blob - lisp/quickurl.el

   1 ;;; quickurl.el --- Insert an URL based on text at point in buffer.
   2
   3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Pearson <davep@hagbard.demon.co.uk>
   6 ;; Maintainer: Dave Pearson <davep@hagbard.demon.co.uk>
   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   :group  'abbrev
 106   :prefix "quickurl-")
 107
 108 (defcustom quickurl-url-file "~/.quickurls"
 109   "*File that contains the URL list."
 110   :type  'file
 111   :group 'quickurl)
 112
 113 (defcustom quickurl-format-function (lambda (url) (format "<URL:%s>" url))
 114   "*Function to format the URL before insertion into the current buffer."
 115   :type  'function
 116   :group 'quickurl)
 117
 118 (defcustom quickurl-sort-function (lambda (list)
 119                                     (sort list
 120                                           (lambda (x y)
 121                                             (string<
 122                                              (downcase (quickurl-url-description x))
 123                                              (downcase (quickurl-url-description y))))))
 124   "*Function to sort the URL list."
 125   :type  'function
 126   :group 'quickurl)
 127
 128 (defcustom quickurl-grab-lookup-function #'current-word
 129   "*Function to grab the thing to lookup."
 130   :type  'function
 131   :group 'quickurl)
 132
 133 (defcustom quickurl-assoc-function #'assoc-ignore-case
 134   "*Function to use for alist lookup into `quickurl-urls'."
 135   :type  'function
 136   :group 'quickurl)
 137
 138 (defcustom quickurl-prefix ";; -*- lisp -*-\n\n"
 139   "*Text to write to `quickurl-url-file' before writing the URL list."
 140   :type  'string
 141   :group 'quickurl)
 142
 143 (defcustom quickurl-postfix ""
 144   "*Text to write to `quickurl-url-file' after writing the URL list.
 145
 146 See the constant `quickurl-reread-hook-postfix' for some example text that
 147 could be used here."
 148   :type  'string
 149   :group 'quickurl)
 150
 151 (defcustom quickurl-list-mode-hook nil
 152   "*Hooks for `quickurl-list-mode'."
 153   :type  'hook
 154   :group 'quickurl)
 155
 156 ;; Constants.
 157
 158 ;;;###autoload
 159 (defconst quickurl-reread-hook-postfix
 160     "
 161 ;; Local Variables:
 162 ;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
 163 ;; End:
 164 "
 165   "Example `quickurl-postfix' text that adds a local variable to the
 166 `quickurl-url-file' so that if you edit it by hand it will ensure that
 167 `quickurl-urls' is updated with the new URL list.
 168
 169 To make use of this do something like:
 170
 171   (setq quickurl-postfix quickurl-reread-hook-postfix)
 172
 173 in your ~/.emacs (after loading/requiring quickurl).")
 174
 175 ;; Non-customize variables.
 176
 177 (defvar quickurl-urls nil
 178   "URL alist for use with `quickurl' and `quickurl-ask'.")
 179
 180 (defvar quickurl-list-mode-map nil
 181   "Local keymap for a `quickurl-list-mode' buffer.")
 182
 183 (defvar quickurl-list-buffer-name "*quickurl-list*"
 184   "Name for the URL listinig buffer.")
 185
 186 (defvar quickurl-list-last-buffer nil
 187   "`current-buffer' when `quickurl-list' was called.")
 188
 189 ;; Functions for working with an URL entry.
 190
 191 (defun quickurl-url-commented-p (url)
 192   "Does the URL have a comment?"
 193   (listp (cdr url)))
 194
 195 (defun quickurl-make-url (keyword url &optional comment)
 196   "Create an URL from KEYWORD, URL and (optionaly) COMMENT."
 197   (if (and comment (not (zerop (length comment))))
 198       (list keyword url comment)
 199     (cons keyword url)))
 200
 201 (defun quickurl-url-keyword (url)
 202   "Return the keyword for the URL.
 203
 204 Note that this function is a setfable place."
 205   (car url))
 206
 207 (defsetf quickurl-url-keyword (url) (store)
 208   `(setf (car ,url) ,store))
 209
 210 (defun quickurl-url-url (url)
 211   "Return the actual URL of the URL.
 212
 213 Note that this function is a setfable place."
 214   (if (quickurl-url-commented-p url)
 215       (cadr url)
 216     (cdr url)))
 217
 218 (defsetf quickurl-url-url (url) (store)
 219   `
 220   (if (quickurl-url-commented-p ,url)
 221       (setf (cadr ,url) ,store)
 222     (setf (cdr ,url) ,store)))
 223
 224 (defun quickurl-url-comment (url)
 225   "Get the comment from an URL.
 226
 227 If the URL has no comment an empty string is returned. Also note that this
 228 function is a setfable place."
 229   (if (quickurl-url-commented-p url)
 230       (nth 2 url)
 231     ""))
 232
 233 (defsetf quickurl-url-comment (url) (store)
 234   `
 235   (if (quickurl-url-commented-p ,url)
 236       (if (zerop (length ,store))
 237           (setf (cdr ,url) (cadr ,url))
 238         (setf (nth 2 ,url) ,store))
 239     (unless (zerop (length ,store))
 240       (setf (cdr ,url) (list (cdr ,url) ,store)))))
 241
 242 (defun quickurl-url-description (url)
 243   "Return a description for the URL.
 244
 245 If the URL has a comment then this is returned, otherwise the keyword is
 246 returned."
 247   (let ((desc (quickurl-url-comment url)))
 248     (if (zerop (length desc))
 249         (quickurl-url-keyword url)
 250       desc)))
 251
 252 ;; Main code:
 253
 254 (defun* quickurl-read (&optional (buffer (current-buffer)))
 255   "`read' the URL list from BUFFER into `quickurl-urls'.
 256
 257 Note that this function moves point to `point-min' before doing the `read'
 258 It also restores point after the `read'."
 259   (save-excursion
 260     (setf (point) (point-min))
 261     (setq quickurl-urls (funcall quickurl-sort-function (read buffer)))))
 262
 263 (defun quickurl-load-urls ()
 264   "Load the contents of `quickurl-url-file' into `quickurl-urls'."
 265   (when (file-exists-p quickurl-url-file)
 266     (with-temp-buffer
 267       (insert-file-contents quickurl-url-file)
 268       (quickurl-read))))
 269
 270 (defun quickurl-save-urls ()
 271   "Save the contents of `quickurl-urls' to `quickurl-url-file'."
 272   (with-temp-buffer
 273     (let ((standard-output (current-buffer)))
 274       (princ quickurl-prefix)
 275       (pp quickurl-urls)
 276       (princ quickurl-postfix)
 277       (write-region (point-min) (point-max) quickurl-url-file nil 0))))
 278
 279 (defun quickurl-find-url (lookup)
 280   "Return URL associated with key LOOKUP.
 281
 282 The lookup is done by looking in the alist `quickurl-urls' and the `cons'
 283 for the URL is returned. The actual method used to look into the alist
 284 depends on the setting of the variable `quickurl-assoc-function'."
 285   (funcall quickurl-assoc-function lookup quickurl-urls))
 286
 287 (defun quickurl-insert (url &optional silent)
 288   "Insert URL, formatted using `quickurl-format-function'.
 289
 290 Also display a `message' saying what the URL was unless SILENT is non-nil."
 291   (insert (funcall quickurl-format-function (quickurl-url-url url)))
 292   (unless silent
 293     (message "Found %s" (quickurl-url-url url))))
 294
 295 ;;;###autoload
 296 (defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function)))
 297   "Insert an URL based on LOOKUP.
 298
 299 If not supplied LOOKUP is taken to be the word at point in the current
 300 buffer, this default action can be modifed via
 301 `quickurl-grab-lookup-function'."
 302   (interactive)
 303   (when lookup
 304     (quickurl-load-urls)
 305     (let ((url (quickurl-find-url lookup)))
 306       (if (null url)
 307           (error "No URL associated with \"%s\"" lookup)
 308         (when (looking-at "\\w")
 309           (skip-syntax-forward "\\w"))
 310         (insert " ")
 311         (quickurl-insert url)))))
 312
 313 ;;;###autoload
 314 (defun quickurl-ask (lookup)
 315   "Insert an URL, with `completing-read' prompt, based on LOOKUP."
 316   (interactive
 317    (list
 318     (progn
 319       (quickurl-load-urls)
 320       (completing-read "Lookup: " quickurl-urls nil t))))
 321   (let ((url (quickurl-find-url lookup)))
 322     (when url
 323       (quickurl-insert url))))
 324
 325 (defun quickurl-grab-url ()
 326   "Attempt to grab a word/url pair from point in the current buffer.
 327
 328 Point should be somewhere on the URL and the word is taken to be the thing
 329 that is returned from calling `quickurl-grab-lookup-function' once a
 330 `backward-word' has been issued at the start of the URL.
 331
 332 It is assumed that the URL is either \"unguarded\" or is wrapped inside an
 333 <URL:...> wrapper."
 334   (let ((url (thing-at-point 'url)))
 335     (when url
 336       (save-excursion
 337         (beginning-of-thing 'url)
 338         ;; `beginning-of-thing' doesn't take you to the start of a marked-up
 339         ;; URL, only to the start of the URL within the "markup". So, we
 340         ;; need to do a little more work to get to where we want to be.
 341         (when (thing-at-point-looking-at thing-at-point-markedup-url-regexp)
 342           (search-backward "<URL:"))
 343         (backward-word 1)
 344         (let ((word (funcall quickurl-grab-lookup-function)))
 345           (when word
 346             (quickurl-make-url
 347              ;; The grab function may return the word with properties. I don't
 348              ;; want the properties. I couldn't find a method of stripping
 349              ;; them from a "string" so this will have to do. If you know of
 350              ;; a better method of doing this I'd love to know.
 351              (with-temp-buffer
 352                (insert word)
 353                (buffer-substring-no-properties (point-min) (point-max)))
 354              url)))))))
 355
 356 ;;;###autoload
 357 (defun quickurl-add-url (word url comment)
 358   "Allow the user to interactively add a new URL associated with WORD.
 359
 360 See `quickurl-grab-url' for details on how the default word/url combination
 361 is decided."
 362   (interactive (let ((word-url (quickurl-grab-url)))
 363                  (list (read-string "Word: "    (quickurl-url-keyword word-url))
 364                        (read-string "URL: "     (quickurl-url-url word-url))
 365                        (read-string "Comment: " (quickurl-url-comment word-url)))))
 366   (if (zerop (length word))
 367       (error "You must specify a WORD for lookup")
 368     (quickurl-load-urls)
 369     (let* ((current-url (quickurl-find-url word))
 370            (add-it      (if current-url
 371                             (if (interactive-p)
 372                                 (y-or-n-p (format "\"%s\" exists, replace URL? " word))
 373                               t)
 374                           t)))
 375       (when add-it
 376         (if current-url
 377             (progn
 378               (setf (quickurl-url-url current-url) url)
 379               (setf (quickurl-url-comment current-url) comment))
 380           (push (quickurl-make-url word url comment) quickurl-urls))
 381         (setq quickurl-urls (funcall quickurl-sort-function quickurl-urls))
 382         (quickurl-save-urls)
 383         (when (get-buffer quickurl-list-buffer-name)
 384           (quickurl-list-populate-buffer))
 385         (when (interactive-p)
 386           (message "Added %s" url))))))
 387
 388 ;;;###autoload
 389 (defun* quickurl-browse-url (&optional (lookup (funcall quickurl-grab-lookup-function)))
 390   "Browse the URL associated with LOOKUP.
 391
 392 If not supplied LOOKUP is taken to be the word at point in the
 393 current buffer, this default action can be modifed via
 394 `quickurl-grab-lookup-function'."
 395   (interactive)
 396   (when lookup
 397     (quickurl-load-urls)
 398     (let ((url (quickurl-find-url lookup)))
 399       (if url
 400           (browse-url (quickurl-url-url url))
 401         (error "No URL associated with \"%s\"" lookup)))))
 402
 403 ;;;###autoload
 404 (defun quickurl-browse-url-ask (lookup)
 405   "Browse the URL, with `completing-read' prompt, associated with LOOKUP."
 406   (interactive (list
 407                 (progn
 408                   (quickurl-load-urls)
 409                   (completing-read "Browse: " quickurl-urls nil t))))
 410   (let ((url (quickurl-find-url lookup)))
 411     (when url
 412       (browse-url (quickurl-url-url url)))))
 413
 414 ;;;###autoload
 415 (defun quickurl-edit-urls ()
 416   "Pull `quickurl-url-file' into a buffer for hand editing."
 417   (interactive)
 418   (find-file quickurl-url-file))
 419
 420 ;; quickurl-list mode.
 421
 422 (unless quickurl-list-mode-map
 423   (let ((map (make-sparse-keymap)))
 424     (suppress-keymap map t)
 425     (define-key map "a"           #'quickurl-list-add-url)
 426     (define-key map [(control m)] #'quickurl-list-insert-url)
 427     (define-key map "u"           #'quickurl-list-insert-naked-url)
 428     (define-key map " "           #'quickurl-list-insert-with-lookup)
 429     (define-key map "l"           #'quickurl-list-insert-lookup)
 430     (define-key map "d"           #'quickurl-list-insert-with-desc)
 431     (define-key map [(control g)] #'quickurl-list-quit)
 432     (define-key map "q"           #'quickurl-list-quit)
 433     (define-key map [mouse-2]     #'quickurl-list-mouse-select)
 434     (define-key map "?"           #'describe-mode)
 435     (setq quickurl-list-mode-map map)))
 436
 437 (put 'quickurl-list-mode 'mode-class 'special)
 438
 439 ;;;###autoload
 440 (defun quickurl-list-mode ()
 441   "A mode for browsing the quickurl URL list.
 442
 443 The key bindings for `quickurl-list-mode' are:
 444
 445 \\{quickurl-list-mode-map}"
 446   (interactive)
 447   (kill-all-local-variables)
 448   (use-local-map quickurl-list-mode-map)
 449   (setq major-mode 'quickurl-list-mode
 450         mode-name  "quickurl list")
 451   (run-hooks 'quickurl-list-mode-hook)
 452   (setq buffer-read-only t
 453         truncate-lines   t))
 454
 455 ;;;###autoload
 456 (defun quickurl-list ()
 457   "Display `quickurl-list' as a formatted list using `quickurl-list-mode'."
 458   (interactive)
 459   (quickurl-load-urls)
 460   (unless (string= (buffer-name) quickurl-list-buffer-name)
 461     (setq quickurl-list-last-buffer (current-buffer)))
 462   (pop-to-buffer quickurl-list-buffer-name)
 463   (quickurl-list-populate-buffer)
 464   (quickurl-list-mode))
 465
 466 (defun quickurl-list-populate-buffer ()
 467   "Populate the `quickurl-list' buffer."
 468   (with-current-buffer (get-buffer quickurl-list-buffer-name)
 469     (let ((buffer-read-only nil)
 470           (fmt (format "%%-%ds %%s\n"
 471                        (apply #'max (or (loop for url in quickurl-urls
 472                                               collect (length (quickurl-url-description url)))
 473                                         (list 20))))))
 474       (setf (buffer-string) "")
 475       (loop for url in quickurl-urls
 476             do (let ((start (point)))
 477                  (insert (format fmt (quickurl-url-description url)
 478                                  (quickurl-url-url url)))
 479                  (put-text-property start (1- (point))
 480                                     'mouse-face 'highlight)))
 481       (setf (point) (point-min)))))
 482
 483 (defun quickurl-list-add-url (word url comment)
 484   "Wrapper for `quickurl-add-url' that doesn't guess the parameters."
 485   (interactive "sWord: \nsURL: \nsComment: ")
 486   (quickurl-add-url word url comment))
 487
 488 (defun quickurl-list-quit ()
 489   "Kill the buffer named `quickurl-list-buffer-name'."
 490   (interactive)
 491   (kill-buffer quickurl-list-buffer-name)
 492   (switch-to-buffer quickurl-list-last-buffer)
 493   (delete-other-windows))
 494
 495 (defun quickurl-list-mouse-select (event)
 496   "Select the URL under the mouse click."
 497   (interactive "e")
 498   (setf (point) (posn-point (event-end event)))
 499   (quickurl-list-insert-url))
 500
 501 (defun quickurl-list-insert (type)
 502   "Insert the URL under cursor into `quickurl-list-last-buffer'.
 503 TYPE dictates what will be inserted, options are:
 504   `url'         - Insert the URL as <URL:url>
 505   `naked-url'   - Insert the URL with no formatting
 506   `with-lookup' - Insert \"lookup <URL:url>\"
 507   `with-desc'   - Insert \"description <URL:url>\"
 508   `lookup'      - Insert the lookup for that URL"
 509   (let ((url (nth (save-excursion
 510                     (beginning-of-line)
 511                     (count-lines (point-min) (point)))
 512                   quickurl-urls)))
 513     (if url
 514         (with-current-buffer quickurl-list-last-buffer
 515           (insert
 516            (case type
 517              ('url         (format "<URL:%s>" (quickurl-url-url url)))
 518              ('naked-url   (quickurl-url-url url))
 519              ('with-lookup (format "%s <URL:%s>"
 520                                    (quickurl-url-keyword url)
 521                                    (quickurl-url-url url)))
 522              ('with-desc   (format "%S <URL:%s>"
 523                                    (quickurl-url-description url)
 524                                    (quickurl-url-url url)))
 525              ('lookup      (quickurl-url-keyword url)))))
 526       (error "No URL details on that line"))
 527     url))
 528
 529 (defmacro quickurl-list-make-inserter (type)
 530   "Macro to make a key-response function for use in `quickurl-list-mode-map'."
 531   `(defun ,(intern (format "quickurl-list-insert-%S" type)) ()
 532     ,(format "Insert the result of calling `quickurl-list-insert' with `%s'." type)
 533     (interactive)
 534     (when (quickurl-list-insert ',type)
 535       (quickurl-list-quit))))
 536
 537 (quickurl-list-make-inserter url)
 538 (quickurl-list-make-inserter naked-url)
 539 (quickurl-list-make-inserter with-lookup)
 540 (quickurl-list-make-inserter with-desc)
 541 (quickurl-list-make-inserter lookup)
 542
 543 (provide 'quickurl)
 544
 545 ;;; quickurl.el ends here