lisp/muse-protocols.el

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