--- /dev/null
+;;; muse-protocols.el --- URL protocols that Muse recognizes
+
+;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: Brad Collins (brad AT chenla DOT org)
+
+;; This file is part of Emacs Muse. It is not part of GNU Emacs.
+
+;; Emacs Muse 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 3, or (at your
+;; option) any later version.
+
+;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Here's an example for adding a protocol for the site yubnub, a Web
+;; Command line service.
+;;
+;; (add-to-list 'muse-url-protocols '("yubnub://" muse-browse-url-yubnub
+;; muse-resolve-url-yubnub))
+;;
+;; (defun muse-resolve-url-yubnub (url)
+;; "Resolve a yubnub URL."
+;; ;; Remove the yubnub://
+;; (when (string-match "\\`yubnub://\\(.+\\)" url)
+;; (match-string 1)))
+;;
+;; (defun muse-browse-url-yubnub (url)
+;; "If this is a yubnub URL-command, jump to it."
+;; (setq url (muse-resolve-url-yubnub url))
+;; (browse-url (concat "http://yubnub.org/parser/parse?command="
+;; url)))
+
+;;; Contributors:
+
+;; Phillip Lord (Phillip.Lord AT newcastle DOT ac DOT uk) provided a
+;; handler for DOI URLs.
+
+;; Stefan Schlee fixed a bug with handling of colons at the end of
+;; URLs.
+
+;; Valery V. Vorotyntsev contribued the woman:// protocol handler and
+;; simplified `muse-browse-url-man'.
+
+;;; Code:
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Muse URL Protocols
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'info)
+(require 'muse-regexps)
+
+(defvar muse-url-regexp nil
+ "A regexp used to match URLs within a Muse page.
+This is autogenerated from `muse-url-protocols'.")
+
+(defun muse-update-url-regexp (sym value)
+ (setq muse-url-regexp
+ (concat "\\<\\(" (mapconcat 'car value "\\|") "\\)"
+ "[^][" muse-regexp-blank "\"'()<>^`{}\n]*"
+ "[^][" muse-regexp-blank "\"'()<>^`{}.,;:\n]+"))
+ (set sym value))
+
+(defcustom muse-url-protocols
+ '(("[uU][rR][lL]:" muse-browse-url-url identity)
+ ("info://" muse-browse-url-info nil)
+ ("man://" muse-browse-url-man nil)
+ ("woman://" muse-browse-url-woman nil)
+ ("google://" muse-browse-url-google muse-resolve-url-google)
+ ("http:/?/?" browse-url identity)
+ ("https:/?/?" browse-url identity)
+ ("ftp:/?/?" browse-url identity)
+ ("gopher://" browse-url identity)
+ ("telnet://" browse-url identity)
+ ("wais://" browse-url identity)
+ ("file://?" browse-url identity)
+ ("dict:" muse-browse-url-dict muse-resolve-url-dict)
+ ("doi:" muse-browse-url-doi muse-resolve-url-doi)
+ ("news:" browse-url identity)
+ ("snews:" browse-url identity)
+ ("mailto:" browse-url identity))
+ "A list of (PROTOCOL BROWSE-FUN RESOLVE-FUN) used to match URL protocols.
+PROTOCOL describes the first part of the URL, including the
+\"://\" part. This may be a regexp.
+
+BROWSE-FUN should accept URL as an argument and open the URL in
+the current window.
+
+RESOLVE-FUN should accept URL as an argument and return the final
+URL, or nil if no URL should be included."
+ :type '(repeat (list :tag "Protocol"
+ (string :tag "Regexp")
+ (function :tag "Browse")
+ (choice (function :tag "Resolve")
+ (const :tag "Don't resolve" nil))))
+ :set 'muse-update-url-regexp
+ :group 'muse)
+
+(add-hook 'muse-update-values-hook
+ (lambda ()
+ (muse-update-url-regexp 'muse-url-protocols muse-url-protocols)))
+
+(defcustom muse-wikipedia-country "en"
+ "Indicate the 2-digit country code that we use for Wikipedia
+queries."
+ :type 'string
+ :options '("de" "en" "es" "fr" "it" "pl" "pt" "ja" "nl" "sv")
+ :group 'muse)
+
+(defun muse-protocol-find (proto list)
+ "Return the first element of LIST whose car matches the regexp PROTO."
+ (catch 'found
+ (dolist (item list)
+ (when (string-match (concat "\\`" (car item)) proto)
+ (throw 'found item)))))
+
+;;;###autoload
+(defun muse-browse-url (url &optional other-window)
+ "Handle URL with the function specified in `muse-url-protocols'.
+If OTHER-WINDOW is non-nil, open in a different window."
+ (interactive (list (read-string "URL: ")
+ current-prefix-arg))
+ ;; Strip text properties
+ (when (fboundp 'set-text-properties)
+ (set-text-properties 0 (length url) nil url))
+ (when other-window
+ (switch-to-buffer-other-window (current-buffer)))
+ (when (string-match muse-url-regexp url)
+ (let* ((proto (match-string 1 url))
+ (entry (muse-protocol-find proto muse-url-protocols)))
+ (when entry
+ (funcall (cadr entry) url)))))
+
+(defun muse-resolve-url (url &rest ignored)
+ "Resolve URL with the function specified in `muse-url-protocols'."
+ (when (string-match muse-url-regexp url)
+ (let* ((proto (match-string 1 url))
+ (entry (muse-protocol-find proto muse-url-protocols)))
+ (when entry
+ (let ((func (car (cddr entry))))
+ (if func
+ (setq url (funcall func url))
+ (setq url nil))))))
+ url)
+
+(defun muse-protocol-add (protocol browse-function resolve-function)
+ "Add PROTOCOL to `muse-url-protocols'. PROTOCOL may be a regexp.
+
+BROWSE-FUNCTION should be a function that visits a URL in the
+current buffer.
+
+RESOLVE-FUNCTION should be a function that transforms a URL for
+publishing or returns nil if not linked."
+ (add-to-list 'muse-url-protocols
+ (list protocol browse-function resolve-function))
+ (muse-update-url-regexp 'muse-url-protocols
+ muse-url-protocols))
+
+(defun muse-browse-url-url (url)
+ "Call `muse-protocol-browse-url' to browse URL.
+This is used when we are given something like
+\"URL:http://example.org/\".
+
+If you're looking for a good example for how to make a custom URL
+handler, look at `muse-browse-url-dict' instead."
+ (when (string-match "\\`[uU][rR][lL]:\\(.+\\)" url)
+ (muse-browse-url (match-string 1 url))))
+
+(defun muse-resolve-url-dict (url)
+ "Return the Wikipedia link corresponding with the given URL."
+ (when (string-match "\\`dict:\\(.+\\)" url)
+ (concat "http://" muse-wikipedia-country ".wikipedia.org/"
+ "wiki/Special:Search?search=" (match-string 1 url))))
+
+(defun muse-browse-url-dict (url)
+ "If this is a Wikipedia URL, browse it."
+ (let ((dict-url (muse-resolve-url-dict url)))
+ (when dict-url
+ (browse-url dict-url))))
+
+(defun muse-resolve-url-doi (url)
+ "Return the URL through DOI proxy server."
+ (when (string-match "\\`doi:\\(.+\\)" url)
+ (concat "http://dx.doi.org/"
+ (match-string 1 url))))
+
+(defun muse-browse-url-doi (url)
+ "If this is a DOI URL, browse it.
+
+DOI's (digitial object identifiers) are a standard identifier
+used in the publishing industry."
+ (let ((doi-url (muse-resolve-url-doi url)))
+ (when doi-url
+ (browse-url doi-url))))
+
+(defun muse-resolve-url-google (url)
+ "Return the correct Google search string."
+ (when (string-match "\\`google:/?/?\\(.+\\)" url)
+ (concat "http://www.google.com/search?q="
+ (match-string 1 url))))
+
+(defun muse-browse-url-google (url)
+ "If this is a Google URL, jump to it."
+ (let ((google-url (muse-resolve-url-google url)))
+ (when google-url
+ (browse-url google-url))))
+
+(defun muse-browse-url-info (url)
+ "If this in an Info URL, jump to it."
+ (require 'info)
+ (cond
+ ((string-match "\\`info://\\([^#\n]+\\)#\\(.+\\)" url)
+ (Info-find-node (match-string 1 url)
+ (match-string 2 url)))
+ ((string-match "\\`info://\\([^#\n]+\\)" url)
+ (Info-find-node (match-string 1 url)
+ "Top"))
+ ((string-match "\\`info://(\\([^)\n]+\\))\\(.+\\)" url)
+ (Info-find-node (match-string 1 url) (match-string 2 url)))
+ ((string-match "\\`info://\\(.+\\)" url)
+ (Info-find-node (match-string 1 url) "Top"))))
+
+(defun muse-browse-url-man (url)
+ "If this in a manpage URL, jump to it."
+ (require 'man)
+ (when (string-match "\\`man://\\([^(]+\\(([^)]+)\\)?\\)" url)
+ (man (match-string 1 url))))
+
+(defun muse-browse-url-woman (url)
+ "If this is a WoMan URL, jump to it."
+ (require 'woman)
+ (when (string-match "\\`woman://\\(.+\\)" url)
+ (woman (match-string 1 url))))
+
+(provide 'muse-protocols)
+
+;;; muse-protocols.el ends here