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 ;; 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 (convert-standard-filename "~/.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)
 261   "`read' the URL list from BUFFER into `quickurl-urls'.
 262
 263 BUFFER, if nil, defaults to current buffer.
 264 Note that this function moves point to `point-min' before doing the `read'
 265 It also restores point after the `read'."
 266   (save-excursion
 267     (setf (point) (point-min))
 268     (setq quickurl-urls (funcall quickurl-sort-function
 269                                  (read (or buffer (current-buffer)))))))
 270
 271 (defun quickurl-load-urls ()
 272   "Load the contents of `quickurl-url-file' into `quickurl-urls'."
 273   (when (file-exists-p quickurl-url-file)
 274     (with-temp-buffer
 275       (insert-file-contents quickurl-url-file)
 276       (quickurl-read))))
 277
 278 (defun quickurl-save-urls ()
 279   "Save the contents of `quickurl-urls' to `quickurl-url-file'."
 280   (with-temp-buffer
 281     (let ((standard-output (current-buffer)))
 282       (princ quickurl-prefix)
 283       (pp quickurl-urls)
 284       (princ quickurl-postfix)
 285       (write-region (point-min) (point-max) quickurl-url-file nil 0))))
 286
 287 (defun quickurl-find-url (lookup)
 288   "Return URL associated with key LOOKUP.
 289
 290 The lookup is done by looking in the alist `quickurl-urls' and the `cons'
 291 for the URL is returned. The actual method used to look into the alist
 292 depends on the setting of the variable `quickurl-assoc-function'."
 293   (funcall quickurl-assoc-function lookup quickurl-urls))
 294
 295 (defun quickurl-insert (url &optional silent)
 296   "Insert URL, formatted using `quickurl-format-function'.
 297
 298 Also display a `message' saying what the URL was unless SILENT is non-nil."
 299   (insert (funcall quickurl-format-function url))
 300   (unless silent
 301     (message "Found %s" (quickurl-url-url url))))
 302
 303 ;;;###autoload
 304 (defun* quickurl (&optional lookup)
 305   "Insert an URL based on LOOKUP.
 306
 307 If not supplied LOOKUP is taken to be the word at point in the current
 308 buffer, this default action can be modifed via
 309 `quickurl-grab-lookup-function'."
 310   (interactive)
 311   (when (or lookup
 312             (setq lookup (funcall quickurl-grab-lookup-function)))
 313     (quickurl-load-urls)
 314     (let ((url (quickurl-find-url lookup)))
 315       (if (null url)
 316           (error "No URL associated with \"%s\"" lookup)
 317         (when (looking-at "\\w")
 318           (skip-syntax-forward "\\w"))
 319         (insert " ")
 320         (quickurl-insert url)))))
 321
 322 ;;;###autoload
 323 (defun quickurl-ask (lookup)
 324   "Insert an URL, with `completing-read' prompt, based on LOOKUP."
 325   (interactive
 326    (list
 327     (progn
 328       (quickurl-load-urls)
 329       (let ((completion-ignore-case quickurl-completion-ignore-case))
 330         (completing-read "Lookup: " quickurl-urls nil t)))))
 331   (let ((url (quickurl-find-url lookup)))
 332     (when url
 333       (quickurl-insert url))))
 334
 335 (defun quickurl-grab-url ()
 336   "Attempt to grab a word/url pair from point in the current buffer.
 337
 338 Point should be somewhere on the URL and the word is taken to be the thing
 339 that is returned from calling `quickurl-grab-lookup-function' once a
 340 `backward-word' has been issued at the start of the URL.
 341
 342 It is assumed that the URL is either \"unguarded\" or is wrapped inside an
 343 <URL:...> wrapper."
 344   (let ((url (thing-at-point 'url)))
 345     (when url
 346       (save-excursion
 347         (beginning-of-thing 'url)
 348         ;; `beginning-of-thing' doesn't take you to the start of a marked-up
 349         ;; URL, only to the start of the URL within the "markup". So, we
 350         ;; need to do a little more work to get to where we want to be.
 351         (when (thing-at-point-looking-at thing-at-point-markedup-url-regexp)
 352           (search-backward "<URL:"))
 353         (backward-word 1)
 354         (let ((word (funcall quickurl-grab-lookup-function)))
 355           (when word
 356             (quickurl-make-url
 357              ;; The grab function may return the word with properties. I don't
 358              ;; want the properties. I couldn't find a method of stripping
 359              ;; them from a "string" so this will have to do. If you know of
 360              ;; a better method of doing this I'd love to know.
 361              (with-temp-buffer
 362                (insert word)
 363                (buffer-substring-no-properties (point-min) (point-max)))
 364              url)))))))
 365
 366 ;;;###autoload
 367 (defun quickurl-add-url (word url comment)
 368   "Allow the user to interactively add a new URL associated with WORD.
 369
 370 See `quickurl-grab-url' for details on how the default word/url combination
 371 is decided."
 372   (interactive (let ((word-url (quickurl-grab-url)))
 373                  (list (read-string "Word: "    (quickurl-url-keyword word-url))
 374                        (read-string "URL: "     (quickurl-url-url word-url))
 375                        (read-string "Comment: " (quickurl-url-comment word-url)))))
 376   (if (zerop (length word))
 377       (error "You must specify a WORD for lookup")
 378     (quickurl-load-urls)
 379     (let* ((current-url (quickurl-find-url word))
 380            (add-it      (if current-url
 381                             (if (interactive-p)
 382                                 (y-or-n-p (format "\"%s\" exists, replace URL? " word))
 383                               t)
 384                           t)))
 385       (when add-it
 386         (if current-url
 387             (progn
 388               (setf (quickurl-url-url current-url) url)
 389               (setf (quickurl-url-comment current-url) comment))
 390           (push (quickurl-make-url word url comment) quickurl-urls))
 391         (setq quickurl-urls (funcall quickurl-sort-function quickurl-urls))
 392         (quickurl-save-urls)
 393         (when (get-buffer quickurl-list-buffer-name)
 394           (quickurl-list-populate-buffer))
 395         (when (interactive-p)
 396           (message "Added %s" url))))))
 397
 398 ;;;###autoload
 399 (defun quickurl-browse-url (&optional lookup)
 400   "Browse the URL associated with LOOKUP.
 401
 402 If not supplied LOOKUP is taken to be the word at point in the
 403 current buffer, this default action can be modifed via
 404 `quickurl-grab-lookup-function'."
 405   (interactive)
 406   (when (or lookup
 407             (setq lookup (funcall quickurl-grab-lookup-function)))
 408     (quickurl-load-urls)
 409     (let ((url (quickurl-find-url lookup)))
 410       (if url
 411           (browse-url (quickurl-url-url url))
 412         (error "No URL associated with \"%s\"" lookup)))))
 413
 414 ;;;###autoload
 415 (defun quickurl-browse-url-ask (lookup)
 416   "Browse the URL, with `completing-read' prompt, associated with LOOKUP."
 417   (interactive (list
 418                 (progn
 419                   (quickurl-load-urls)
 420                   (completing-read "Browse: " quickurl-urls nil t))))
 421   (let ((url (quickurl-find-url lookup)))
 422     (when url
 423       (browse-url (quickurl-url-url url)))))
 424
 425 ;;;###autoload
 426 (defun quickurl-edit-urls ()
 427   "Pull `quickurl-url-file' into a buffer for hand editing."
 428   (interactive)
 429   (find-file quickurl-url-file))
 430
 431 ;; quickurl-list mode.
 432
 433 (unless quickurl-list-mode-map
 434   (let ((map (make-sparse-keymap)))
 435     (suppress-keymap map t)
 436     (define-key map "a"           #'quickurl-list-add-url)
 437     (define-key map [(control m)] #'quickurl-list-insert-url)
 438     (define-key map "u"           #'quickurl-list-insert-naked-url)
 439     (define-key map " "           #'quickurl-list-insert-with-lookup)
 440     (define-key map "l"           #'quickurl-list-insert-lookup)
 441     (define-key map "d"           #'quickurl-list-insert-with-desc)
 442     (define-key map [(control g)] #'quickurl-list-quit)
 443     (define-key map "q"           #'quickurl-list-quit)
 444     (define-key map [mouse-2]     #'quickurl-list-mouse-select)
 445     (define-key map "?"           #'describe-mode)
 446     (setq quickurl-list-mode-map map)))
 447
 448 (put 'quickurl-list-mode 'mode-class 'special)
 449
 450 ;;;###autoload
 451 (defun quickurl-list-mode ()
 452   "A mode for browsing the quickurl URL list.
 453
 454 The key bindings for `quickurl-list-mode' are:
 455
 456 \\{quickurl-list-mode-map}"
 457   (interactive)
 458   (kill-all-local-variables)
 459   (use-local-map quickurl-list-mode-map)
 460   (setq major-mode 'quickurl-list-mode
 461         mode-name  "quickurl list")
 462   (run-mode-hooks 'quickurl-list-mode-hook)
 463   (setq buffer-read-only t
 464         truncate-lines   t))
 465
 466 ;;;###autoload
 467 (defun quickurl-list ()
 468   "Display `quickurl-list' as a formatted list using `quickurl-list-mode'."
 469   (interactive)
 470   (quickurl-load-urls)
 471   (unless (string= (buffer-name) quickurl-list-buffer-name)
 472     (setq quickurl-list-last-buffer (current-buffer)))
 473   (pop-to-buffer quickurl-list-buffer-name)
 474   (quickurl-list-populate-buffer)
 475   (quickurl-list-mode))
 476
 477 (defun quickurl-list-populate-buffer ()
 478   "Populate the `quickurl-list' buffer."
 479   (with-current-buffer (get-buffer quickurl-list-buffer-name)
 480     (let ((buffer-read-only nil)
 481           (fmt (format "%%-%ds %%s\n"
 482                        (apply #'max (or (loop for url in quickurl-urls
 483                                               collect (length (quickurl-url-description url)))
 484                                         (list 20))))))
 485       (setf (buffer-string) "")
 486       (loop for url in quickurl-urls
 487             do (let ((start (point)))
 488                  (insert (format fmt (quickurl-url-description url)
 489                                  (quickurl-url-url url)))
 490                  (add-text-properties start (1- (point))
 491                                     '(mouse-face highlight
 492                                       help-echo "mouse-2: insert this URL"))))
 493       (setf (point) (point-min)))))
 494
 495 (defun quickurl-list-add-url (word url comment)
 496   "Wrapper for `quickurl-add-url' that doesn't guess the parameters."
 497   (interactive "sWord: \nsURL: \nsComment: ")
 498   (quickurl-add-url word url comment))
 499
 500 (defun quickurl-list-quit ()
 501   "Kill the buffer named `quickurl-list-buffer-name'."
 502   (interactive)
 503   (kill-buffer quickurl-list-buffer-name)
 504   (switch-to-buffer quickurl-list-last-buffer)
 505   (delete-other-windows))
 506
 507 (defun quickurl-list-mouse-select (event)
 508   "Select the URL under the mouse click."
 509   (interactive "e")
 510   (setf (point) (posn-point (event-end event)))
 511   (quickurl-list-insert-url))
 512
 513 (defun quickurl-list-insert (type)
 514   "Insert the URL under cursor into `quickurl-list-last-buffer'.
 515 TYPE dictates what will be inserted, options are:
 516   `url'         - Insert the URL as <URL:url>
 517   `naked-url'   - Insert the URL with no formatting
 518   `with-lookup' - Insert \"lookup <URL:url>\"
 519   `with-desc'   - Insert \"description <URL:url>\"
 520   `lookup'      - Insert the lookup for that URL"
 521   (let ((url (nth (save-excursion
 522                     (beginning-of-line)
 523                     (count-lines (point-min) (point)))
 524                   quickurl-urls)))
 525     (if url
 526         (with-current-buffer quickurl-list-last-buffer
 527           (insert
 528            (case type
 529              ('url         (funcall quickurl-format-function url))
 530              ('naked-url   (quickurl-url-url url))
 531              ('with-lookup (format "%s <URL:%s>"
 532                                    (quickurl-url-keyword url)
 533                                    (quickurl-url-url url)))
 534              ('with-desc   (format "%S <URL:%s>"
 535                                    (quickurl-url-description url)
 536                                    (quickurl-url-url url)))
 537              ('lookup      (quickurl-url-keyword url)))))
 538       (error "No URL details on that line"))
 539     url))
 540
 541 (defmacro quickurl-list-make-inserter (type)
 542   "Macro to make a key-response function for use in `quickurl-list-mode-map'."
 543   `(defun ,(intern (format "quickurl-list-insert-%S" type)) ()
 544     ,(format "Insert the result of calling `quickurl-list-insert' with `%s'." type)
 545     (interactive)
 546     (when (quickurl-list-insert ',type)
 547       (quickurl-list-quit))))
 548
 549 (quickurl-list-make-inserter url)
 550 (quickurl-list-make-inserter naked-url)
 551 (quickurl-list-make-inserter with-lookup)
 552 (quickurl-list-make-inserter with-desc)
 553 (quickurl-list-make-inserter lookup)
 554
 555 (provide 'quickurl)
 556
 557 ;;; arch-tag: a8183ea5-80c2-4082-a7d1-b0fdf2da467e
 558 ;;; quickurl.el ends here