1 ;;; muse-protocols.el --- URL protocols that Muse recognizes
3 ;; Copyright (C) 2005 Free Software Foundation, Inc.
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)
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.
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.
22 ;; Here's an example for adding a protocol for the site yubnub, a Web
23 ;; Command line service.
25 ;; (add-to-list 'muse-url-protocols '("yubnub://" muse-browse-url-yubnub
26 ;; muse-resolve-url-yubnub))
28 ;; (defun muse-resolve-url-yubnub (url)
29 ;; "Resolve a yubnub URL."
30 ;; ;; Remove the yubnub://
31 ;; (when (string-match "\\`yubnub://\\(.+\\)" url)
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="
42 ;; Brad Collins (brad AT chenla DOT org) created the initial version
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 (require 'muse-regexps
)
56 (defvar muse-url-regexp nil
57 "A regexp used to match URLs within a Muse page.
58 This is autogenerated from `muse-url-protocols'.")
60 (defun muse-update-url-regexp (sym value
)
62 (concat "\\<\\(" (mapconcat 'car value
"\\|") "\\)"
63 "[^][" muse-regexp-blank
"\"'()<>^`{}\n]*"
64 "[^][" muse-regexp-blank
"\"'()<>^`{}.,;\n]+"))
67 (defcustom muse-url-protocols
68 '(("info://" muse-browse-url-info nil
)
69 ("man://" muse-browse-url-man nil
)
70 ("google://" muse-browse-url-google muse-resolve-url-google
)
71 ("http:/?/?" browse-url identity
)
72 ("https:/?/?" browse-url identity
)
73 ("ftp:/?/?" browse-url identity
)
74 ("gopher://" browse-url identity
)
75 ("telnet://" browse-url identity
)
76 ("wais://" browse-url identity
)
77 ("file://?" browse-url identity
)
78 ("news:" browse-url identity
)
79 ("snews:" browse-url identity
)
80 ("mailto:" browse-url identity
))
81 "A list of (PROTOCOL BROWSE-FUN RESOLVE-FUN) used to match URL protocols.
82 PROTOCOL describes the first part of the URL, including the
83 \"://\" part. This may be a regexp.
85 BROWSE-FUN should accept URL as an argument and open the URL in
88 RESOLVE-FUN should accept URL as an argument and return the final
89 URL, or nil if no URL should be included."
90 :type
'(repeat (list :tag
"Protocol"
91 (string :tag
"Regexp")
92 (function :tag
"Browse")
93 (choice (function :tag
"Resolve")
94 (const :tag
"Don't resolve" nil
))))
95 :set
'muse-update-url-regexp
98 (defun muse-protocol-find (proto list
)
99 "Return the first element of LIST whose car matches the regexp PROTO."
100 (setq list
(copy-alist list
))
103 (when (string-match (caar list
) proto
)
104 (setq entry
(car list
)
106 (setq list
(cdr list
)))
110 (defun muse-browse-url (url &optional other-window
)
111 "Handle URL with the function specified in `muse-url-protocols'.
112 If OTHER-WINDOW is non-nil, open in a different window."
113 (interactive (list (read-string "URL: ")
115 ;; Strip text properties
116 (when (fboundp 'set-text-properties
)
117 (set-text-properties 0 (length url
) nil url
))
119 (switch-to-buffer-other-window (current-buffer)))
120 (when (string-match muse-url-regexp url
)
121 (let* ((proto (concat "\\`" (match-string 1 url
)))
122 (entry (muse-protocol-find proto muse-url-protocols
)))
124 (funcall (cadr entry
) url
)))))
126 (defun muse-resolve-url (url &rest ignored
)
127 "Resolve URL with the function specified in `muse-url-protocols'."
128 (when (string-match muse-url-regexp url
)
129 (let* ((proto (concat "\\`" (match-string 1 url
)))
130 (entry (muse-protocol-find proto muse-url-protocols
)))
132 (let ((func (car (cddr entry
))))
134 (setq url
(funcall func url
))
138 (defun muse-protocol-add (protocol browse-function resolve-function
)
139 "Add PROTOCOL to `muse-url-protocols'. PROTOCOL may be a regexp.
141 BROWSE-FUNCTION should be a function that visits a URL in the
144 RESOLVE-FUNCTION should be a function that transforms a URL for
145 publishing or returns nil if not linked."
146 (add-to-list 'muse-url-protocols
147 (list protocol browse-function resolve-function
))
148 (muse-update-url-regexp 'muse-url-protocols
151 (defun muse-resolve-url-google (url)
152 "Return the correct Google search string."
153 (when (string-match "\\`google:/?/?\\(.+\\)" url
)
154 (concat "http://www.google.com/search?q="
155 (match-string 1 url
))))
157 (defun muse-browse-url-google (url)
158 "If this is a Google URL, jump to it."
159 (let ((google-url (muse-resolve-url-google url
)))
161 (browse-url google-url
))))
163 (defun muse-browse-url-info (url)
164 "If this in an Info URL, jump to it."
167 ((string-match "\\`info://\\([^#\n]+\\)#\\(.+\\)" url
)
168 (Info-find-node (match-string 1 url
)
169 (match-string 2 url
)))
170 ((string-match "\\`info://\\([^#\n]+\\)" url
)
171 (Info-find-node (match-string 1 url
)
173 ((string-match "\\`info://(\\([^)\n]+\\))\\(.+\\)" url
)
174 (Info-find-node (match-string 1 url
) (match-string 2 url
)))
175 ((string-match "\\`info://\\(.+\\)" url
)
176 (Info-find-node (match-string 1 url
) "Top"))))
178 (defun muse-browse-url-man (url)
179 "If this in a manpage URL, jump to it."
180 (cond ((string-match "\\`man://\\(.+\\):\\(.+\\)" url
)
181 (manual-entry (concat (match-string 1 url
)
182 "(" (match-string 2 url
) ")")))
183 ((string-match "\\`man://\\(.+\\)" url
)
184 (manual-entry (concat (match-string 1 url
))))))
186 (provide 'muse-protocols
)
188 ;;; muse-protocols.el ends here