lisp/net/quickurl.el

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