lisp/net/quickurl.el

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