code.delx.au - gnu-emacs-elpa/blob - packages/muse/muse-protocols.el

   1 ;;; muse-protocols.el --- URL protocols that Muse recognizes
   2
   3 ;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Brad Collins (brad AT chenla DOT org)
   7
   8 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   9
  10 ;; Emacs Muse is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published
  12 ;; by the Free Software Foundation; either version 3, or (at your
  13 ;; option) any later version.
  14
  15 ;; Emacs Muse is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Here's an example for adding a protocol for the site yubnub, a Web
  28 ;; Command line service.
  29 ;;
  30 ;; (add-to-list 'muse-url-protocols '("yubnub://" muse-browse-url-yubnub
  31 ;;                                                muse-resolve-url-yubnub))
  32 ;;
  33 ;; (defun muse-resolve-url-yubnub (url)
  34 ;;   "Resolve a yubnub URL."
  35 ;;   ;; Remove the yubnub://
  36 ;;   (when (string-match "\\`yubnub://\\(.+\\)" url)
  37 ;;     (match-string 1)))
  38 ;;
  39 ;; (defun muse-browse-url-yubnub (url)
  40 ;;   "If this is a yubnub URL-command, jump to it."
  41 ;;   (setq url (muse-resolve-url-yubnub url))
  42 ;;   (browse-url (concat "http://yubnub.org/parser/parse?command="
  43 ;;                       url)))
  44
  45 ;;; Contributors:
  46
  47 ;; Phillip Lord (Phillip.Lord AT newcastle DOT ac DOT uk) provided a
  48 ;; handler for DOI URLs.
  49
  50 ;; Stefan Schlee fixed a bug with handling of colons at the end of
  51 ;; URLs.
  52
  53 ;; Valery V. Vorotyntsev contribued the woman:// protocol handler and
  54 ;; simplified `muse-browse-url-man'.
  55
  56 ;;; Code:
  57
  58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59 ;;
  60 ;; Muse URL Protocols
  61 ;;
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63
  64 (require 'info)
  65 (require 'muse-regexps)
  66
  67 (defvar muse-url-regexp nil
  68   "A regexp used to match URLs within a Muse page.
  69 This is autogenerated from `muse-url-protocols'.")
  70
  71 (defun muse-update-url-regexp (sym value)
  72   (setq muse-url-regexp
  73         (concat "\\<\\(" (mapconcat 'car value "\\|") "\\)"
  74                 "[^][" muse-regexp-blank "\"'()<>^`{}\n]*"
  75                 "[^][" muse-regexp-blank "\"'()<>^`{}.,;:\n]+"))
  76   (set sym value))
  77
  78 (defcustom muse-url-protocols
  79   '(("[uU][rR][lL]:" muse-browse-url-url identity)
  80     ("info://" muse-browse-url-info nil)
  81     ("man://" muse-browse-url-man nil)
  82     ("woman://" muse-browse-url-woman nil)
  83     ("google://" muse-browse-url-google muse-resolve-url-google)
  84     ("http:/?/?" browse-url identity)
  85     ("https:/?/?" browse-url identity)
  86     ("ftp:/?/?" browse-url identity)
  87     ("gopher://" browse-url identity)
  88     ("telnet://" browse-url identity)
  89     ("wais://" browse-url identity)
  90     ("file://?" browse-url identity)
  91     ("dict:" muse-browse-url-dict muse-resolve-url-dict)
  92     ("doi:" muse-browse-url-doi muse-resolve-url-doi)
  93     ("news:" browse-url identity)
  94     ("snews:" browse-url identity)
  95     ("mailto:" browse-url identity))
  96   "A list of (PROTOCOL BROWSE-FUN RESOLVE-FUN) used to match URL protocols.
  97 PROTOCOL describes the first part of the URL, including the
  98 \"://\" part.  This may be a regexp.
  99
 100 BROWSE-FUN should accept URL as an argument and open the URL in
 101 the current window.
 102
 103 RESOLVE-FUN should accept URL as an argument and return the final
 104 URL, or nil if no URL should be included."
 105   :type '(repeat (list :tag "Protocol"
 106                        (string :tag "Regexp")
 107                        (function :tag "Browse")
 108                        (choice (function :tag "Resolve")
 109                                (const :tag "Don't resolve" nil))))
 110   :set 'muse-update-url-regexp
 111   :group 'muse)
 112
 113 (add-hook 'muse-update-values-hook
 114           (lambda ()
 115             (muse-update-url-regexp 'muse-url-protocols muse-url-protocols)))
 116
 117 (defcustom muse-wikipedia-country "en"
 118   "Indicate the 2-digit country code that we use for Wikipedia
 119 queries."
 120   :type 'string
 121   :options '("de" "en" "es" "fr" "it" "pl" "pt" "ja" "nl" "sv")
 122   :group 'muse)
 123
 124 (defun muse-protocol-find (proto list)
 125   "Return the first element of LIST whose car matches the regexp PROTO."
 126   (catch 'found
 127     (dolist (item list)
 128       (when (string-match (concat "\\`" (car item)) proto)
 129         (throw 'found item)))))
 130
 131 ;;;###autoload
 132 (defun muse-browse-url (url &optional other-window)
 133   "Handle URL with the function specified in `muse-url-protocols'.
 134 If OTHER-WINDOW is non-nil, open in a different window."
 135   (interactive (list (read-string "URL: ")
 136                      current-prefix-arg))
 137   ;; Strip text properties
 138   (when (fboundp 'set-text-properties)
 139     (set-text-properties 0 (length url) nil url))
 140   (when other-window
 141     (switch-to-buffer-other-window (current-buffer)))
 142   (when (string-match muse-url-regexp url)
 143     (let* ((proto (match-string 1 url))
 144            (entry (muse-protocol-find proto muse-url-protocols)))
 145       (when entry
 146         (funcall (cadr entry) url)))))
 147
 148 (defun muse-resolve-url (url &rest ignored)
 149   "Resolve URL with the function specified in `muse-url-protocols'."
 150   (when (string-match muse-url-regexp url)
 151     (let* ((proto (match-string 1 url))
 152            (entry (muse-protocol-find proto muse-url-protocols)))
 153       (when entry
 154         (let ((func (car (cddr entry))))
 155           (if func
 156               (setq url (funcall func url))
 157             (setq url nil))))))
 158   url)
 159
 160 (defun muse-protocol-add (protocol browse-function resolve-function)
 161   "Add PROTOCOL to `muse-url-protocols'.  PROTOCOL may be a regexp.
 162
 163 BROWSE-FUNCTION should be a function that visits a URL in the
 164 current buffer.
 165
 166 RESOLVE-FUNCTION should be a function that transforms a URL for
 167 publishing or returns nil if not linked."
 168   (add-to-list 'muse-url-protocols
 169                (list protocol browse-function resolve-function))
 170   (muse-update-url-regexp 'muse-url-protocols
 171                           muse-url-protocols))
 172
 173 (defun muse-browse-url-url (url)
 174   "Call `muse-protocol-browse-url' to browse URL.
 175 This is used when we are given something like
 176 \"URL:http://example.org/\".
 177
 178 If you're looking for a good example for how to make a custom URL
 179 handler, look at `muse-browse-url-dict' instead."
 180   (when (string-match "\\`[uU][rR][lL]:\\(.+\\)" url)
 181     (muse-browse-url (match-string 1 url))))
 182
 183 (defun muse-resolve-url-dict (url)
 184   "Return the Wikipedia link corresponding with the given URL."
 185   (when (string-match "\\`dict:\\(.+\\)" url)
 186     (concat "http://" muse-wikipedia-country ".wikipedia.org/"
 187             "wiki/Special:Search?search=" (match-string 1 url))))
 188
 189 (defun muse-browse-url-dict (url)
 190   "If this is a Wikipedia URL, browse it."
 191   (let ((dict-url (muse-resolve-url-dict url)))
 192     (when dict-url
 193       (browse-url dict-url))))
 194
 195 (defun muse-resolve-url-doi (url)
 196   "Return the URL through DOI proxy server."
 197   (when (string-match "\\`doi:\\(.+\\)" url)
 198     (concat "http://dx.doi.org/"
 199             (match-string 1 url))))
 200
 201 (defun muse-browse-url-doi (url)
 202   "If this is a DOI URL, browse it.
 203
 204 DOI's (digitial object identifiers) are a standard identifier
 205 used in the publishing industry."
 206   (let ((doi-url (muse-resolve-url-doi url)))
 207     (when doi-url
 208       (browse-url doi-url))))
 209
 210 (defun muse-resolve-url-google (url)
 211   "Return the correct Google search string."
 212   (when (string-match "\\`google:/?/?\\(.+\\)" url)
 213     (concat "http://www.google.com/search?q="
 214             (match-string 1 url))))
 215
 216 (defun muse-browse-url-google (url)
 217   "If this is a Google URL, jump to it."
 218   (let ((google-url (muse-resolve-url-google url)))
 219     (when google-url
 220       (browse-url google-url))))
 221
 222 (defun muse-browse-url-info (url)
 223   "If this in an Info URL, jump to it."
 224   (require 'info)
 225   (cond
 226    ((string-match "\\`info://\\([^#\n]+\\)#\\(.+\\)" url)
 227     (Info-find-node (match-string 1 url)
 228                     (match-string 2 url)))
 229    ((string-match "\\`info://\\([^#\n]+\\)" url)
 230     (Info-find-node (match-string 1 url)
 231                     "Top"))
 232    ((string-match "\\`info://(\\([^)\n]+\\))\\(.+\\)" url)
 233     (Info-find-node (match-string 1 url) (match-string 2 url)))
 234    ((string-match "\\`info://\\(.+\\)" url)
 235     (Info-find-node (match-string 1 url) "Top"))))
 236
 237 (defun muse-browse-url-man (url)
 238   "If this in a manpage URL, jump to it."
 239   (require 'man)
 240   (when (string-match "\\`man://\\([^(]+\\(([^)]+)\\)?\\)" url)
 241     (man (match-string 1 url))))
 242
 243 (defun muse-browse-url-woman (url)
 244   "If this is a WoMan URL, jump to it."
 245   (require 'woman)
 246   (when (string-match "\\`woman://\\(.+\\)" url)
 247     (woman (match-string 1 url))))
 248
 249 (provide 'muse-protocols)
 250
 251 ;;; muse-protocols.el ends here