lisp/muse-protocols.el

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