lisp/net/quickurl.el

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