1 ;;; muse-protocols.el --- URL protocols that Muse recognizes
3 ;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
5 ;; Author: Brad Collins (brad AT chenla DOT org)
7 ;; This file is part of Emacs Muse. It is not part of GNU Emacs.
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.
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.
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.
26 ;; Here's an example for adding a protocol for the site yubnub, a Web
27 ;; Command line service.
29 ;; (add-to-list 'muse-url-protocols '("yubnub://" muse-browse-url-yubnub
30 ;; muse-resolve-url-yubnub))
32 ;; (defun muse-resolve-url-yubnub (url)
33 ;; "Resolve a yubnub URL."
34 ;; ;; Remove the yubnub://
35 ;; (when (string-match "\\`yubnub://\\(.+\\)" url)
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="
46 ;; Phillip Lord (Phillip.Lord AT newcastle DOT ac DOT uk) provided a
47 ;; handler for DOI URLs.
49 ;; Stefan Schlee fixed a bug with handling of colons at the end of
52 ;; Valery V. Vorotyntsev contribued the woman:// protocol handler and
53 ;; simplified `muse-browse-url-man'.
57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
64 (require 'muse-regexps
)
66 (defvar muse-url-regexp nil
67 "A regexp used to match URLs within a Muse page.
68 This is autogenerated from `muse-url-protocols'.")
70 (defun muse-update-url-regexp (sym value
)
72 (concat "\\<\\(" (mapconcat 'car value
"\\|") "\\)"
73 "[^][" muse-regexp-blank
"\"'()<>^`{}\n]*"
74 "[^][" muse-regexp-blank
"\"'()<>^`{}.,;:\n]+"))
77 (defcustom muse-url-protocols
78 '(("info://" muse-browse-url-info nil
)
79 ("man://" muse-browse-url-man nil
)
80 ("woman://" 'muse-browse-url-woman nil
)
81 ("google://" muse-browse-url-google muse-resolve-url-google
)
82 ("http:/?/?" browse-url identity
)
83 ("https:/?/?" browse-url identity
)
84 ("ftp:/?/?" browse-url identity
)
85 ("gopher://" browse-url identity
)
86 ("telnet://" browse-url identity
)
87 ("wais://" browse-url identity
)
88 ("file://?" browse-url identity
)
89 ("dict:" muse-browse-url-dict muse-resolve-url-dict
)
90 ("doi:" muse-browse-url-doi muse-resolve-url-doi
)
91 ("news:" browse-url identity
)
92 ("snews:" browse-url identity
)
93 ("mailto:" browse-url identity
))
94 "A list of (PROTOCOL BROWSE-FUN RESOLVE-FUN) used to match URL protocols.
95 PROTOCOL describes the first part of the URL, including the
96 \"://\" part. This may be a regexp.
98 BROWSE-FUN should accept URL as an argument and open the URL in
101 RESOLVE-FUN should accept URL as an argument and return the final
102 URL, or nil if no URL should be included."
103 :type
'(repeat (list :tag
"Protocol"
104 (string :tag
"Regexp")
105 (function :tag
"Browse")
106 (choice (function :tag
"Resolve")
107 (const :tag
"Don't resolve" nil
))))
108 :set
'muse-update-url-regexp
111 (add-hook 'muse-update-values-hook
113 (muse-update-url-regexp 'muse-url-protocols muse-url-protocols
)))
115 (defcustom muse-wikipedia-country
"en"
116 "Indicate the 2-digit country code that we use for Wikipedia
119 :options
'("de" "en" "es" "fr" "it" "pl" "pt" "ja" "nl" "sv")
122 (defun muse-protocol-find (proto list
)
123 "Return the first element of LIST whose car matches the regexp PROTO."
124 (setq list
(copy-alist list
))
127 (when (string-match (caar list
) proto
)
128 (setq entry
(car list
)
130 (setq list
(cdr list
)))
134 (defun muse-browse-url (url &optional other-window
)
135 "Handle URL with the function specified in `muse-url-protocols'.
136 If OTHER-WINDOW is non-nil, open in a different window."
137 (interactive (list (read-string "URL: ")
139 ;; Strip text properties
140 (when (fboundp 'set-text-properties
)
141 (set-text-properties 0 (length url
) nil url
))
143 (switch-to-buffer-other-window (current-buffer)))
144 (when (string-match muse-url-regexp url
)
145 (let* ((proto (concat "\\`" (match-string 1 url
)))
146 (entry (muse-protocol-find proto muse-url-protocols
)))
148 (funcall (cadr entry
) url
)))))
150 (defun muse-resolve-url (url &rest ignored
)
151 "Resolve URL with the function specified in `muse-url-protocols'."
152 (when (string-match muse-url-regexp url
)
153 (let* ((proto (concat "\\`" (match-string 1 url
)))
154 (entry (muse-protocol-find proto muse-url-protocols
)))
156 (let ((func (car (cddr entry
))))
158 (setq url
(funcall func url
))
162 (defun muse-protocol-add (protocol browse-function resolve-function
)
163 "Add PROTOCOL to `muse-url-protocols'. PROTOCOL may be a regexp.
165 BROWSE-FUNCTION should be a function that visits a URL in the
168 RESOLVE-FUNCTION should be a function that transforms a URL for
169 publishing or returns nil if not linked."
170 (add-to-list 'muse-url-protocols
171 (list protocol browse-function resolve-function
))
172 (muse-update-url-regexp 'muse-url-protocols
175 (defun muse-resolve-url-dict (url)
176 "Return the Wikipedia link corresponding with the given URL."
177 (when (string-match "\\`dict:\\(.+\\)" url
)
178 (concat "http://" muse-wikipedia-country
".wikipedia.org/"
179 "wiki/Special:Search?search=" (match-string 1 url
))))
181 (defun muse-browse-url-dict (url)
182 "If this is a Wikipedia URL, browse it."
183 (let ((dict-url (muse-resolve-url-dict url
)))
185 (browse-url dict-url
))))
187 (defun muse-resolve-url-doi (url)
188 "Return the URL through DOI proxy server."
189 (when (string-match "\\`doi:\\(.+\\)" url
)
190 (concat "http://dx.doi.org/"
191 (match-string 1 url
))))
193 (defun muse-browse-url-doi (url)
194 "If this is a DOI URL, browse it.
196 DOI's (digitial object identifiers) are a standard identifier
197 used in the publishing industry."
198 (let ((doi-url (muse-resolve-url-doi url
)))
200 (browse-url doi-url
))))
202 (defun muse-resolve-url-google (url)
203 "Return the correct Google search string."
204 (when (string-match "\\`google:/?/?\\(.+\\)" url
)
205 (concat "http://www.google.com/search?q="
206 (match-string 1 url
))))
208 (defun muse-browse-url-google (url)
209 "If this is a Google URL, jump to it."
210 (let ((google-url (muse-resolve-url-google url
)))
212 (browse-url google-url
))))
214 (defun muse-browse-url-info (url)
215 "If this in an Info URL, jump to it."
218 ((string-match "\\`info://\\([^#\n]+\\)#\\(.+\\)" url
)
219 (Info-find-node (match-string 1 url
)
220 (match-string 2 url
)))
221 ((string-match "\\`info://\\([^#\n]+\\)" url
)
222 (Info-find-node (match-string 1 url
)
224 ((string-match "\\`info://(\\([^)\n]+\\))\\(.+\\)" url
)
225 (Info-find-node (match-string 1 url
) (match-string 2 url
)))
226 ((string-match "\\`info://\\(.+\\)" url
)
227 (Info-find-node (match-string 1 url
) "Top"))))
229 (defun muse-browse-url-man (url)
230 "If this in a manpage URL, jump to it."
231 (when (string-match "\\`man://\\([^(]+\\(([^)]+)\\)?\\)" url
)
232 (man (match-string 1 url
))))
234 (defun muse-browse-url-woman (url)
235 "If this is a WoMan URL, jump to it."
236 (when (string-match "\\`woman://\\(.+\\)" url
)
237 (woman (match-string 1 url
))))
239 (provide 'muse-protocols
)
241 ;;; muse-protocols.el ends here