Commit 8749abea authored by Gerd Moellmann's avatar Gerd Moellmann
Browse files

Moved here from lisp.

parent b33dd3b0
This diff is collapsed.
This diff is collapsed.
;;; goto-addr.el --- click to browse URL or to send to e-mail address
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Author: Eric Ding <ericding@mit.edu>
;; Maintainer: Eric Ding <ericding@mit.edu>
;; Created: 15 Aug 1995
;; Keywords: mh-e, www, mouse, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package allows you to click or hit a key sequence while on a
;; URL or e-mail address, and either load the URL into a browser of
;; your choice using the browse-url package, or if it's an e-mail
;; address, to send an e-mail to that address. By default, we bind to
;; the [mouse-2] and the [C-c return] key sequences.
;; INSTALLATION
;;
;; To use goto-address in a particular mode (for example, while
;; reading mail in mh-e), add something like this in your .emacs file:
;;
;; (add-hook 'mh-show-mode-hook 'goto-address)
;;
;; The mouse click method is bound to [mouse-2] on highlighted URL's or
;; e-mail addresses only; it functions normally everywhere else. To bind
;; another mouse click to the function, add the following to your .emacs
;; (for example):
;;
;; (setq goto-address-highlight-keymap
;; (let ((m (make-sparse-keymap)))
;; (define-key m [S-mouse-2] 'goto-address-at-mouse)
;; m))
;;
;; BUG REPORTS
;;
;; Please send bug reports to me at ericding@mit.edu.
;; Known bugs/features:
;; * goto-address-mail-regexp only catches foo@bar.org style addressing,
;; not stuff like X.400 addresses, etc.
;; * regexp also catches Message-Id line, since it is in the format of
;; an Internet e-mail address (like Compuserve addresses)
;; * If show buffer is fontified after goto-address-fontify is run
;; (say, using font-lock-fontify-buffer), then font-lock face will
;; override goto-address faces.
;;; Code:
(require 'browse-url)
(defgroup goto-address nil
"Click to browse URL or to send to e-mail address."
:group 'mouse
:group 'hypermedia)
;;; I don't expect users to want fontify'ing without highlighting.
(defcustom goto-address-fontify-p t
"*If t, URL's and e-mail addresses in buffer are fontified.
But only if `goto-address-highlight-p' is also non-nil."
:type 'boolean
:group 'goto-address)
(defcustom goto-address-highlight-p t
"*If t, URL's and e-mail addresses in buffer are highlighted."
:type 'boolean
:group 'goto-address)
(defcustom goto-address-fontify-maximum-size 30000
"*Maximum size of file in which to fontify and/or highlight URL's."
:type 'integer
:group 'goto-address)
(defvar goto-address-mail-regexp
"[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
"A regular expression probably matching an e-mail address.")
(defvar goto-address-url-regexp
(concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|"
"telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:"
"[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*"
"[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
"A regular expression probably matching a URL.")
(defvar goto-address-highlight-keymap
(let ((m (make-sparse-keymap)))
(define-key m [mouse-2] 'goto-address-at-mouse)
m)
"keymap to hold goto-addr's mouse key defs under highlighted URLs.")
(defcustom goto-address-url-face 'bold
"*Face to use for URLs."
:type 'face
:group 'goto-address)
(defcustom goto-address-url-mouse-face 'highlight
"*Face to use for URLs when the mouse is on them."
:type 'face
:group 'goto-address)
(defcustom goto-address-mail-face 'italic
"*Face to use for e-mail addresses."
:type 'face
:group 'goto-address)
(defcustom goto-address-mail-mouse-face 'secondary-selection
"*Face to use for e-mail addresses when the mouse is on them."
:type 'face
:group 'goto-address)
(defun goto-address-fontify ()
"Fontify the URL's and e-mail addresses in the current buffer.
This function implements `goto-address-highlight-p'
and `goto-address-fontify-p'."
(save-excursion
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t)
(modified (buffer-modified-p)))
(goto-char (point-min))
(if (< (- (point-max) (point)) goto-address-fontify-maximum-size)
(progn
(while (re-search-forward goto-address-url-regexp nil t)
(let* ((s (match-beginning 0))
(e (match-end 0))
(this-overlay (make-overlay s e)))
(and goto-address-fontify-p
(overlay-put this-overlay 'face goto-address-url-face))
(overlay-put this-overlay
'mouse-face goto-address-url-mouse-face)
(overlay-put this-overlay
'local-map goto-address-highlight-keymap)))
(goto-char (point-min))
(while (re-search-forward goto-address-mail-regexp nil t)
(let* ((s (match-beginning 0))
(e (match-end 0))
(this-overlay (make-overlay s e)))
(and goto-address-fontify-p
(overlay-put this-overlay 'face goto-address-mail-face))
(overlay-put this-overlay 'mouse-face
goto-address-mail-mouse-face)
(overlay-put this-overlay
'local-map goto-address-highlight-keymap)))))
(and (buffer-modified-p)
(not modified)
(set-buffer-modified-p nil)))))
;;; code to find and goto addresses; much of this has been blatantly
;;; snarfed from browse-url.el
;;;###autoload
(defun goto-address-at-mouse (event)
"Send to the e-mail address or load the URL clicked with the mouse.
Send mail to address at position of mouse click. See documentation for
`goto-address-find-address-at-point'. If no address is found
there, then load the URL at or before the position of the mouse click."
(interactive "e")
(save-excursion
(let ((posn (event-start event)))
(set-buffer (window-buffer (posn-window posn)))
(goto-char (posn-point posn))
(let ((address
(save-excursion (goto-address-find-address-at-point))))
(if (string-equal address "")
(let ((url (browse-url-url-at-point)))
(if (string-equal url "")
(error "No e-mail address or URL found")
(browse-url url)))
(compose-mail address))))))
;;;###autoload
(defun goto-address-at-point ()
"Send to the e-mail address or load the URL at point.
Send mail to address at point. See documentation for
`goto-address-find-address-at-point'. If no address is found
there, then load the URL at or before point."
(interactive)
(save-excursion
(let ((address (save-excursion (goto-address-find-address-at-point))))
(if (string-equal address "")
(let ((url (browse-url-url-at-point)))
(if (string-equal url "")
(error "No e-mail address or URL found")
(browse-url url)))
(compose-mail address)))))
(defun goto-address-find-address-at-point ()
"Find e-mail address around or before point.
Then search backwards to beginning of line for the start of an e-mail
address. If no e-mail address found, return the empty string."
(let ((bol (save-excursion (beginning-of-line) (point))))
(re-search-backward "[^-_A-z0-9.@]" bol 'lim)
(if (or (looking-at goto-address-mail-regexp) ; already at start
(let ((eol (save-excursion (end-of-line) (point))))
(and (re-search-forward goto-address-mail-regexp eol 'lim)
(goto-char (match-beginning 0)))))
(buffer-substring (match-beginning 0) (match-end 0))
"")))m
;;;###autoload
(defun goto-address ()
"Sets up goto-address functionality in the current buffer.
Allows user to use mouse/keyboard command to click to go to a URL
or to send e-mail.
By default, goto-address binds to mouse-2 and C-c RET.
Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
`goto-address-highlight-p' for more information)."
(interactive)
(local-set-key "\C-c\r" 'goto-address-at-point)
(if goto-address-highlight-p
(goto-address-fontify)))
(provide 'goto-addr)
;;; goto-addr.el ends here.
This diff is collapsed.
;;; quickurl.el --- Insert an URL based on text at point in buffer.
;; Copyright (C) 1999 Free Software Foundation, Inc.
;; Author: Dave Pearson <davep@hagbard.demon.co.uk>
;; Maintainer: Dave Pearson <davep@hagbard.demon.co.uk>
;; Created: 1999-05-28
;; Keywords: hypermedia
;; This file is part of GNU emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;
;; This package provides a simple method of inserting an URL based on the
;; text at point in the current buffer. This is part of an on-going effort
;; to increase the information I provide people while reducing the ammount
;; of typing I need to do. No-doubt there are undiscovered Emacs packages
;; out there that do all of this and do it better, feel free to point me to
;; them, in the mean time I'm having fun playing with Emacs Lisp.
;;
;; The URLs are stored in an external file as a list of either cons cells,
;; or lists. A cons cell entry looks like this:
;;
;; (<Lookup> . <URL>)
;;
;; where <Lookup> is a string that acts as the keyword lookup and <URL> is
;; the URL associated with it. An example might be:
;;
;; ("GNU" . "http://www.gnu.org/")
;;
;; A list entry looks like:
;;
;; (<Lookup> <URL> <Comment>)
;;
;; where <Lookup> and <URL> are the same as with the cons cell and <Comment>
;; is any text you like that describes the URL. This description will be
;; used when presenting a list of URLS using `quickurl-list'. An example
;; might be:
;;
;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation")
;;
;; Given the above, your quickurl file might look like:
;;
;; (("GNU" . "http://www.gnu.org/")
;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation")
;; ("emacs" . "http://www.emacs.org/")
;; ("hagbard" "http://www.hagbard.demon.co.uk" "Hagbard's World"))
;;
;; In case you're wondering about the mixture of cons cells and lists,
;; quickurl started life using just the cons cells, there were no comments.
;; URL comments are a later addition and so there is a mixture to keep
;; backward compatibility with existing URL lists.
;;
;; The name and location of the file is up to you, the default name used by
;; `quickurl' is stored in `quickurl-url-file'.
;;
;; quickurl is always available from:
;;
;; <URL:http://www.hagbard.demon.co.uk/archives/quickurl.el>
;; <URL:http://www.acemake.com/hagbard/archives/quickurl.el>
;;; TODO:
;;
;; o The quickurl-browse-url* functions pretty much duplicate their non
;; browsing friends. It would feel better if a more generic solution could
;; be found.
;;; Code:
;; Things we need:
(eval-when-compile
(require 'cl))
(require 'thingatpt)
(require 'pp)
(require 'browse-url)
;; Attempt to handle older/other emacs.
(eval-and-compile
;; If customize isn't available just use defvar instead.
(unless (fboundp 'defgroup)
(defmacro defgroup (&rest rest) nil)
(defmacro defcustom (symbol init docstring &rest rest)
`(defvar ,symbol ,init ,docstring))))
;; Customize options.
(defgroup quickurl nil
"Insert an URL based on text at point in buffer."
:version "21.1"
:group 'abbrev
:prefix "quickurl-")
(defcustom quickurl-url-file "~/.quickurls"
"*File that contains the URL list."
:type 'file
:group 'quickurl)
(defcustom quickurl-format-function (lambda (url) (format "<URL:%s>" url))
"*Function to format the URL before insertion into the current buffer."
:type 'function
:group 'quickurl)
(defcustom quickurl-sort-function (lambda (list)
(sort list
(lambda (x y)
(string<
(downcase (quickurl-url-description x))
(downcase (quickurl-url-description y))))))
"*Function to sort the URL list."
:type 'function
:group 'quickurl)
(defcustom quickurl-grab-lookup-function #'current-word
"*Function to grab the thing to lookup."
:type 'function
:group 'quickurl)
(defcustom quickurl-assoc-function #'assoc-ignore-case
"*Function to use for alist lookup into `quickurl-urls'."
:type 'function
:group 'quickurl)
(defcustom quickurl-completion-ignore-case t
"*Should `quickurl-ask' ignore case when doing the input lookup?"
:type 'boolean
:group 'quickurl)
(defcustom quickurl-prefix ";; -*- lisp -*-\n\n"
"*Text to write to `quickurl-url-file' before writing the URL list."
:type 'string
:group 'quickurl)
(defcustom quickurl-postfix ""
"*Text to write to `quickurl-url-file' after writing the URL list.
See the constant `quickurl-reread-hook-postfix' for some example text that
could be used here."
:type 'string
:group 'quickurl)
(defcustom quickurl-list-mode-hook nil
"*Hooks for `quickurl-list-mode'."
:type 'hook
:group 'quickurl)
;; Constants.
;;;###autoload
(defconst quickurl-reread-hook-postfix
"
;; Local Variables:
;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
;; End:
"
"Example `quickurl-postfix' text that adds a local variable to the
`quickurl-url-file' so that if you edit it by hand it will ensure that
`quickurl-urls' is updated with the new URL list.
To make use of this do something like:
(setq quickurl-postfix quickurl-reread-hook-postfix)
in your ~/.emacs (after loading/requiring quickurl).")
;; Non-customize variables.
(defvar quickurl-urls nil
"URL alist for use with `quickurl' and `quickurl-ask'.")
(defvar quickurl-list-mode-map nil
"Local keymap for a `quickurl-list-mode' buffer.")
(defvar quickurl-list-buffer-name "*quickurl-list*"
"Name for the URL listinig buffer.")
(defvar quickurl-list-last-buffer nil
"`current-buffer' when `quickurl-list' was called.")
;; Functions for working with an URL entry.
(defun quickurl-url-commented-p (url)
"Does the URL have a comment?"
(listp (cdr url)))
(defun quickurl-make-url (keyword url &optional comment)
"Create an URL from KEYWORD, URL and (optionaly) COMMENT."
(if (and comment (not (zerop (length comment))))
(list keyword url comment)
(cons keyword url)))
(defun quickurl-url-keyword (url)
"Return the keyword for the URL.
Note that this function is a setfable place."
(car url))
(defsetf quickurl-url-keyword (url) (store)
`(setf (car ,url) ,store))
(defun quickurl-url-url (url)
"Return the actual URL of the URL.
Note that this function is a setfable place."
(if (quickurl-url-commented-p url)
(cadr url)
(cdr url)))
(defsetf quickurl-url-url (url) (store)
`
(if (quickurl-url-commented-p ,url)
(setf (cadr ,url) ,store)
(setf (cdr ,url) ,store)))
(defun quickurl-url-comment (url)
"Get the comment from an URL.
If the URL has no comment an empty string is returned. Also note that this
function is a setfable place."
(if (quickurl-url-commented-p url)
(nth 2 url)
""))
(defsetf quickurl-url-comment (url) (store)
`
(if (quickurl-url-commented-p ,url)
(if (zerop (length ,store))
(setf (cdr ,url) (cadr ,url))
(setf (nth 2 ,url) ,store))
(unless (zerop (length ,store))
(setf (cdr ,url) (list (cdr ,url) ,store)))))
(defun quickurl-url-description (url)
"Return a description for the URL.
If the URL has a comment then this is returned, otherwise the keyword is
returned."
(let ((desc (quickurl-url-comment url)))
(if (zerop (length desc))
(quickurl-url-keyword url)
desc)))
;; Main code:
(defun* quickurl-read (&optional (buffer (current-buffer)))
"`read' the URL list from BUFFER into `quickurl-urls'.
Note that this function moves point to `point-min' before doing the `read'
It also restores point after the `read'."
(save-excursion
(setf (point) (point-min))
(setq quickurl-urls (funcall quickurl-sort-function (read buffer)))))
(defun quickurl-load-urls ()
"Load the contents of `quickurl-url-file' into `quickurl-urls'."
(when (file-exists-p quickurl-url-file)
(with-temp-buffer
(insert-file-contents quickurl-url-file)
(quickurl-read))))
(defun quickurl-save-urls ()
"Save the contents of `quickurl-urls' to `quickurl-url-file'."
(with-temp-buffer
(let ((standard-output (current-buffer)))
(princ quickurl-prefix)
(pp quickurl-urls)
(princ quickurl-postfix)
(write-region (point-min) (point-max) quickurl-url-file nil 0))))
(defun quickurl-find-url (lookup)
"Return URL associated with key LOOKUP.
The lookup is done by looking in the alist `quickurl-urls' and the `cons'
for the URL is returned. The actual method used to look into the alist
depends on the setting of the variable `quickurl-assoc-function'."
(funcall quickurl-assoc-function lookup quickurl-urls))
(defun quickurl-insert (url &optional silent)
"Insert URL, formatted using `quickurl-format-function'.
Also display a `message' saying what the URL was unless SILENT is non-nil."
(insert (funcall quickurl-format-function (quickurl-url-url url)))
(unless silent
(message "Found %s" (quickurl-url-url url))))
;;;###autoload
(defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function)))
"Insert an URL based on LOOKUP.
If not supplied LOOKUP is taken to be the word at point in the current
buffer, this default action can be modifed via
`quickurl-grab-lookup-function'."
(interactive)
(when lookup
(quickurl-load-urls)
(let ((url (quickurl-find-url lookup)))
(if (null url)
(error "No URL associated with \"%s\"" lookup)
(when (looking-at "\\w")
(skip-syntax-forward "\\w"))
(insert " ")
(quickurl-insert url)))))
;;;###autoload
(defun quickurl-ask (lookup)
"Insert an URL, with `completing-read' prompt, based on LOOKUP."
(interactive
(list
(progn
(quickurl-load-urls)
(let ((completion-ignore-case quickurl-completion-ignore-case))
(completing-read "Lookup: " quickurl-urls nil t)))))
(let ((url (quickurl-find-url lookup)))
(when url
(quickurl-insert url))))
(defun quickurl-grab-url ()
"Attempt to grab a word/url pair from point in the current buffer.
Point should be somewhere on the URL and the word is taken to be the thing
that is returned from calling `quickurl-grab-lookup-function' once a
`backward-word' has been issued at the start of the URL.
It is assumed that the URL is either \"unguarded\" or is wrapped inside an
<URL:...> wrapper."
(let ((url (thing-at-point 'url)))
(when url
(save-excursion
(beginning-of-thing 'url)
;; `beginning-of-thing' doesn't take you to the start of a marked-up
;; URL, only to the start of the URL within the "markup". So, we
;; need to do a little more work to get to where we want to be.
(when (thing-at-point-looking-at thing-at-point-markedup-url-regexp)
(search-backward "<URL:"))
(backward-word 1)
(let ((word (funcall quickurl-grab-lookup-function)))
(when word
(quickurl-make-url
;; The grab function may return the word with properties. I don't
;; want the properties. I couldn't find a method of stripping
;; them from a "string" so this will have to do. If you know of
;; a better method of doing this I'd love to know.
(with-temp-buffer
(insert word)
(buffer-substring-no-properties (point-min) (point-max)))
url)))))))
;;;###autoload
(defun quickurl-add-url (word url comment)
"Allow the user to interactively add a new URL associated with WORD.
See `quickurl-grab-url' for details on how the default word/url combination
is decided."
(interactive (let ((word-url (quickurl-grab-url)))
(list (read-string "Word: " (quickurl-url-keyword word-url))
(read-string "URL: " (quickurl-url-url word-url))
(read-string "Comment: " (quickurl-url-comment word-url)))))
(if (zerop (length word))
(error "You must specify a WORD for lookup")
(quickurl-load-urls)
(let* ((current-url (quickurl-find-url word))
(add-it (if current-url
(if (interactive-p)
(y-or-n-p (format "\"%s\" exists, replace URL? " word))
t)
t)))
(when add-it
(if current-url
(progn
(setf (quickurl-url-url current-url) url)
(setf (quickurl-url-comment current-url) comment))
(push (quickurl-make-url word url comment) quickurl-urls))
(setq quickurl-urls (funcall quickurl-sort-function quickurl-urls))
(quickurl-save-urls)