Commit | Line | Data |
---|---|---|
c8d0cf5c CD |
1 | ;;; org-protocol.el --- Intercept calls from emacsclient to trigger custom actions. |
2 | ;; | |
114f9c96 | 3 | ;; Copyright (C) 2008, 2009, 2010 |
54a0dee5 | 4 | ;; Free Software Foundation, Inc. |
c8d0cf5c CD |
5 | ;; |
6 | ;; Author: Bastien Guerry <bzg AT altern DOT org> | |
7 | ;; Author: Daniel M German <dmg AT uvic DOT org> | |
8 | ;; Author: Sebastian Rose <sebastian_rose AT gmx DOT de> | |
9 | ;; Author: Ross Patterson <me AT rpatterson DOT net> | |
10 | ;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de> | |
11 | ;; Keywords: org, emacsclient, wp | |
5dec9555 | 12 | ;; Version: 6.33x |
c8d0cf5c CD |
13 | |
14 | ;; This file is part of GNU Emacs. | |
15 | ;; | |
16 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
17 | ;; it under the terms of the GNU General Public License as published by | |
18 | ;; the Free Software Foundation, either version 3 of the License, or | |
19 | ;; (at your option) any later version. | |
20 | ||
21 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
22 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
23 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
24 | ;; GNU General Public License for more details. | |
25 | ||
26 | ;; You should have received a copy of the GNU General Public License | |
27 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
28 | ||
29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
30 | ;;; Commentary: | |
31 | ;; | |
32 | ;; Intercept calls from emacsclient to trigger custom actions. | |
33 | ;; | |
34 | ;; This is done by advising `server-visit-files' to scann the list of filenames | |
35 | ;; for `org-protocol-the-protocol' and sub-procols defined in | |
36 | ;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'. | |
37 | ;; | |
38 | ;; Any application that supports calling external programs with an URL | |
39 | ;; as argument may be used with this functionality. | |
40 | ;; | |
41 | ;; | |
42 | ;; Usage: | |
43 | ;; ------ | |
44 | ;; | |
45 | ;; 1.) Add this to your init file (.emacs probably): | |
46 | ;; | |
47 | ;; (add-to-list 'load-path "/path/to/org-protocol/") | |
48 | ;; (require 'org-protocol) | |
49 | ;; | |
50 | ;; 3.) Ensure emacs-server is up and running. | |
51 | ;; 4.) Try this from the command line (adjust the URL as needed): | |
52 | ;; | |
53 | ;; $ emacsclient \ | |
54 | ;; org-protocol://store-link://http:%2F%2Flocalhost%2Findex.html/The%20title | |
55 | ;; | |
56 | ;; 5.) Optionally add custom sub-protocols and handlers: | |
57 | ;; | |
58 | ;; (setq org-protocol-protocol-alist | |
59 | ;; '(("my-protocol" | |
60 | ;; :protocol "my-protocol" | |
61 | ;; :function my-protocol-handler-fuction))) | |
62 | ;; | |
63 | ;; A "sub-protocol" will be found in URLs like this: | |
64 | ;; | |
65 | ;; org-protocol://sub-protocol://data | |
66 | ;; | |
67 | ;; If it works, you can now setup other applications for using this feature. | |
68 | ;; | |
69 | ;; | |
70 | ;; As of March 2009 Firefox users follow the steps documented on | |
71 | ;; http://kb.mozillazine.org/Register_protocol, Opera setup is described here: | |
72 | ;; http://www.opera.com/support/kb/view/535/ | |
73 | ;; | |
74 | ;; | |
75 | ;; Documentation | |
76 | ;; ------------- | |
77 | ;; | |
78 | ;; org-protocol.el comes with and installs handlers to open sources of published | |
79 | ;; online content, store and insert the browser's URLs and cite online content | |
80 | ;; by clicking on a bookmark in Firefox, Opera and probably other browsers and | |
81 | ;; applications: | |
82 | ;; | |
83 | ;; * `org-protocol-open-source' uses the sub-protocol \"open-source\" and maps | |
84 | ;; URLs to local filenames defined in `org-protocol-project-alist'. | |
85 | ;; | |
86 | ;; * `org-protocol-store-link' stores an Org-link (if Org-mode is present) and | |
87 | ;; pushes the browsers URL to the `kill-ring' for yanking. This handler is | |
88 | ;; triggered through the sub-protocol \"store-link\". | |
89 | ;; | |
90 | ;; * Call `org-protocol-remember' by using the sub-protocol \"remember\". If | |
8bfe682a | 91 | ;; Org-mode is loaded, emacs will pop-up a remember buffer and fill the |
c8d0cf5c CD |
92 | ;; template with the data provided. I.e. the browser's URL is inserted as an |
93 | ;; Org-link of which the page title will be the description part. If text | |
94 | ;; was select in the browser, that text will be the body of the entry. | |
95 | ;; | |
96 | ;; You may use the same bookmark URL for all those standard handlers and just | |
97 | ;; adjust the sub-protocol used: | |
98 | ;; | |
99 | ;; location.href='org-protocol://sub-protocol://'+ | |
100 | ;; encodeURIComponent(location.href)+'/'+ | |
101 | ;; encodeURIComponent(document.title)+'/'+ | |
102 | ;; encodeURIComponent(window.getSelection()) | |
103 | ;; | |
104 | ;; The handler for the sub-protocol \"remember\" detects an optional template | |
105 | ;; char that, if present, triggers the use of a special template. | |
106 | ;; Example: | |
107 | ;; | |
108 | ;; location.href='org-protocol://sub-protocol://x/'+ ... | |
109 | ;; | |
110 | ;; use template ?x. | |
111 | ;; | |
8bfe682a CD |
112 | ;; Note, that using double slashes is optional from org-protocol.el's point of |
113 | ;; view because emacsclient squashes the slashes to one. | |
c8d0cf5c CD |
114 | ;; |
115 | ;; | |
116 | ;; provides: 'org-protocol | |
117 | ;; | |
118 | ;;; Code: | |
119 | ||
120 | (require 'org) | |
121 | (eval-when-compile | |
122 | (require 'cl)) | |
123 | ||
124 | (declare-function org-publish-initialize-files-alist "org-publish" | |
125 | (&optional refresh)) | |
126 | (declare-function org-publish-get-project-from-filename "org-publish" | |
127 | (filename &optional up)) | |
9d459fc5 | 128 | (declare-function server-edit "server" (&optional arg)) |
c8d0cf5c CD |
129 | |
130 | ||
131 | (defgroup org-protocol nil | |
132 | "Intercept calls from emacsclient to trigger custom actions. | |
133 | ||
134 | This is done by advising `server-visit-files' to scann the list of filenames | |
135 | for `org-protocol-the-protocol' and sub-procols defined in | |
136 | `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'." | |
137 | :version "22.1" | |
138 | :group 'convenience | |
139 | :group 'org) | |
140 | ||
141 | ||
142 | ;;; Variables: | |
143 | ||
144 | (defconst org-protocol-protocol-alist-default | |
145 | '(("org-remember" :protocol "remember" :function org-protocol-remember :kill-client t) | |
146 | ("org-store-link" :protocol "store-link" :function org-protocol-store-link) | |
147 | ("org-open-source" :protocol "open-source" :function org-protocol-open-source)) | |
148 | "Default protocols to use. | |
149 | See `org-protocol-protocol-alist' for a description of this variable.") | |
150 | ||
151 | ||
152 | (defconst org-protocol-the-protocol "org-protocol" | |
153 | "This is the protocol to detect if org-protocol.el is loaded. | |
154 | `org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold the | |
155 | sub-protocols that trigger the required action. You will have to define just one | |
156 | protocol handler OS-wide (MS-Windows) or per application (Linux). That protocol | |
157 | handler should call emacsclient.") | |
158 | ||
159 | ||
160 | ;;; User variables: | |
161 | ||
162 | (defcustom org-protocol-reverse-list-of-files t | |
163 | "* The filenames passed on the commandline are passed to the emacs-server in | |
164 | reversed order. Set to `t' (default) to re-reverse the list, i.e. use the | |
165 | sequence on the command line. If nil, the sequence of the filenames is | |
166 | unchanged." | |
167 | :group 'org-protocol | |
168 | :type 'boolean) | |
169 | ||
170 | ||
171 | (defcustom org-protocol-project-alist nil | |
172 | "* Map URLs to local filenames for `org-protocol-open-source' (open-source). | |
173 | ||
174 | Each element of this list must be of the form: | |
175 | ||
176 | (module-name :property value property: value ...) | |
177 | ||
178 | where module-name is an arbitrary name. All the values are strings. | |
179 | ||
180 | Possible properties are: | |
181 | ||
182 | :online-suffix - the suffix to strip from the published URLs | |
183 | :working-suffix - the replacement for online-suffix | |
184 | :base-url - the base URL, e.g. http://www.example.com/project/ | |
185 | Last slash required. | |
186 | :working-directory - the local working directory. This is, what base-url will | |
187 | be replaced with. | |
5dec9555 CD |
188 | :redirects - A list of cons cells, each of which maps a regular |
189 | expression to match to a path relative to :working-directory. | |
c8d0cf5c CD |
190 | |
191 | Example: | |
192 | ||
193 | (setq org-protocol-project-alist | |
194 | '((\"http://orgmode.org/worg/\" | |
195 | :online-suffix \".php\" | |
196 | :working-suffix \".org\" | |
197 | :base-url \"http://orgmode.org/worg/\" | |
198 | :working-directory \"/home/user/org/Worg/\") | |
199 | (\"http://localhost/org-notes/\" | |
200 | :online-suffix \".html\" | |
201 | :working-suffix \".org\" | |
202 | :base-url \"http://localhost/org/\" | |
5dec9555 CD |
203 | :working-directory \"/home/user/org/\" |
204 | :rewrites ((\"org/?$\" . \"index.php\"))))) | |
205 | ||
206 | The last line tells `org-protocol-open-source' to open | |
207 | /home/user/org/index.php, if the URL cannot be mapped to an existing | |
208 | file, and ends with either \"org\" or \"org/\". | |
c8d0cf5c CD |
209 | |
210 | Consider using the interactive functions `org-protocol-create' and | |
211 | `org-protocol-create-for-org' to help you filling this variable with valid contents." | |
212 | :group 'org-protocol | |
213 | :type 'alist) | |
214 | ||
215 | ||
216 | (defcustom org-protocol-protocol-alist nil | |
217 | "* Register custom handlers for org-protocol. | |
218 | ||
219 | Each element of this list must be of the form: | |
220 | ||
221 | (module-name :protocol protocol :function func :kill-client nil) | |
222 | ||
223 | protocol - protocol to detect in a filename without trailing colon and slashes. | |
224 | See rfc1738 section 2.1 for more on this. | |
225 | If you define a protocol \"my-protocol\", `org-protocol-check-filename-for-protocol' | |
226 | will search filenames for \"org-protocol:/my-protocol:/\" | |
227 | and trigger your action for every match. `org-protocol' is defined in | |
228 | `org-protocol-the-protocol'. Double and tripple slashes are compressed | |
229 | to one by emacsclient. | |
230 | ||
231 | function - function that handles requests with protocol and takes exactly one | |
232 | argument: the filename with all protocols stripped. If the function | |
233 | returns nil, emacsclient and -server do nothing. Any non-nil return | |
234 | value is considered a valid filename and thus passed to the server. | |
235 | ||
236 | `org-protocol.el provides some support for handling those filenames, | |
237 | if you stay with the conventions used for the standard handlers in | |
238 | `org-protocol-protocol-alist-default'. See `org-protocol-split-data'. | |
239 | ||
240 | kill-client - If t, kill the client immediately, once the sub-protocol is | |
8bfe682a | 241 | detected. This is necessary for actions that can be interrupted by |
c8d0cf5c CD |
242 | `C-g' to avoid dangeling emacsclients. Note, that all other command |
243 | line arguments but the this one will be discarded, greedy handlers | |
244 | still receive the whole list of arguments though. | |
245 | ||
246 | Here is an example: | |
247 | ||
248 | (setq org-protocol-protocol-alist | |
249 | '((\"my-protocol\" | |
250 | :protocol \"my-protocol\" | |
251 | :function my-protocol-handler-fuction) | |
252 | (\"your-protocol\" | |
253 | :protocol \"your-protocol\" | |
254 | :function your-protocol-handler-fuction)))" | |
255 | :group 'org-protocol | |
256 | :type '(alist)) | |
257 | ||
258 | (defcustom org-protocol-default-template-key "w" | |
259 | "The default org-remember-templates key to use." | |
260 | :group 'org-protocol | |
261 | :type 'string) | |
262 | ||
263 | ||
264 | ;;; Helper functions: | |
265 | ||
266 | (defun org-protocol-sanitize-uri (uri) | |
267 | "emacsclient compresses double and tripple slashes. | |
268 | Slashes are sanitized to double slashes here." | |
269 | (when (string-match "^\\([a-z]+\\):/" uri) | |
270 | (let* ((splitparts (split-string uri "/+"))) | |
271 | (setq uri (concat (car splitparts) "//" (mapconcat 'identity (cdr splitparts) "/"))))) | |
272 | uri) | |
273 | ||
274 | ||
275 | (defun org-protocol-split-data(data &optional unhexify separator) | |
276 | "Split, what a org-protocol handler function gets as only argument. | |
277 | data is that one argument. Data is splitted at each occurrence of separator | |
278 | (regexp). If no separator is specified or separator is nil, assume \"/+\". | |
279 | The results of that splitting are return as a list. If unhexify is non-nil, | |
280 | hex-decode each split part. If unhexify is a function, use that function to | |
281 | decode each split part." | |
282 | (let* ((sep (or separator "/+")) | |
283 | (split-parts (split-string data sep))) | |
284 | (if unhexify | |
285 | (if (fboundp unhexify) | |
286 | (mapcar unhexify split-parts) | |
287 | (mapcar 'org-protocol-unhex-string split-parts)) | |
288 | split-parts))) | |
289 | ||
8bfe682a CD |
290 | ;; This inline function is needed in org-protocol-unhex-compound to do |
291 | ;; the right thing to decode UTF-8 char integer values. | |
292 | (eval-when-compile | |
293 | (if (>= emacs-major-version 23) | |
294 | (defsubst org-protocol-char-to-string(c) | |
295 | "Defsubst to decode UTF-8 character values in emacs 23 and beyond." | |
296 | (char-to-string c)) | |
297 | (defsubst org-protocol-char-to-string (c) | |
298 | "Defsubst to decode UTF-8 character values in emacs 22." | |
299 | (string (decode-char 'ucs c))))) | |
300 | ||
c8d0cf5c CD |
301 | (defun org-protocol-unhex-string(str) |
302 | "Unhex hexified unicode strings as returned from the JavaScript function | |
303 | encodeURIComponent. E.g. `%C3%B6' is the german Umlaut `ü'." | |
304 | (setq str (or str "")) | |
305 | (let ((tmp "") | |
306 | (case-fold-search t)) | |
307 | (while (string-match "\\(%[0-9a-f][0-9a-f]\\)+" str) | |
308 | (let* ((start (match-beginning 0)) | |
309 | (end (match-end 0)) | |
310 | (hex (match-string 0 str)) | |
311 | (replacement (org-protocol-unhex-compound hex))) | |
312 | (setq tmp (concat tmp (substring str 0 start) replacement)) | |
313 | (setq str (substring str end)))) | |
314 | (setq tmp (concat tmp str)) | |
315 | tmp)) | |
316 | ||
317 | ||
318 | (defun org-protocol-unhex-compound (hex) | |
319 | "Unhexify unicode hex-chars. E.g. `%C3%B6' is the german Umlaut `ü'." | |
320 | (let* ((bytes (remove "" (split-string hex "%"))) | |
321 | (ret "") | |
322 | (eat 0) | |
323 | (sum 0)) | |
324 | (while bytes | |
325 | (let* ((b (pop bytes)) | |
326 | (a (elt b 0)) | |
327 | (b (elt b 1)) | |
328 | (c1 (if (> a ?9) (+ 10 (- a ?A)) (- a ?0))) | |
329 | (c2 (if (> b ?9) (+ 10 (- b ?A)) (- b ?0))) | |
330 | (val (+ (lsh c1 4) c2)) | |
331 | (shift | |
332 | (if (= 0 eat) ;; new byte | |
333 | (if (>= val 252) 6 | |
334 | (if (>= val 248) 5 | |
335 | (if (>= val 240) 4 | |
336 | (if (>= val 224) 3 | |
337 | (if (>= val 192) 2 0))))) | |
338 | 6)) | |
339 | (xor | |
340 | (if (= 0 eat) ;; new byte | |
341 | (if (>= val 252) 252 | |
342 | (if (>= val 248) 248 | |
343 | (if (>= val 240) 240 | |
344 | (if (>= val 224) 224 | |
345 | (if (>= val 192) 192 0))))) | |
346 | 128))) | |
347 | (if (>= val 192) (setq eat shift)) | |
348 | (setq val (logxor val xor)) | |
349 | (setq sum (+ (lsh sum shift) val)) | |
350 | (if (> eat 0) (setq eat (- eat 1))) | |
351 | (when (= 0 eat) | |
8bfe682a | 352 | (setq ret (concat ret (org-protocol-char-to-string sum))) |
c8d0cf5c CD |
353 | (setq sum 0)) |
354 | )) ;; end (while bytes | |
355 | ret )) | |
356 | ||
357 | (defun org-protocol-flatten-greedy (param-list &optional strip-path replacement) | |
358 | "Greedy handlers might recieve a list like this from emacsclient: | |
359 | '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\") | |
360 | where \"/dir/\" is the absolute path to emacsclients working directory. This | |
361 | function transforms it into a flat list utilizing `org-protocol-flatten' and | |
362 | transforms the elements of that list as follows: | |
363 | ||
364 | If strip-path is non-nil, remove the \"/dir/\" prefix from all members of | |
365 | param-list. | |
366 | ||
367 | If replacement is string, replace the \"/dir/\" prefix with it. | |
368 | ||
369 | The first parameter, the one that contains the protocols, is always changed. | |
370 | Everything up to the end of the protocols is stripped. | |
371 | ||
372 | Note, that this function will always behave as if | |
373 | `org-protocol-reverse-list-of-files' was set to t and the returned list will | |
374 | reflect that. I.e. emacsclients first parameter will be the first one in the | |
375 | returned list." | |
376 | (let* ((l (org-protocol-flatten (if org-protocol-reverse-list-of-files | |
377 | param-list | |
378 | (reverse param-list)))) | |
379 | (trigger (car l)) | |
380 | (len 0) | |
381 | dir | |
382 | ret) | |
383 | (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-z0-9][-_a-zA-z0-9]*:/+\\)\\(.*\\)" trigger) | |
384 | (setq dir (match-string 1 trigger)) | |
385 | (setq len (length dir)) | |
386 | (setcar l (concat dir (match-string 3 trigger)))) | |
387 | (if strip-path | |
388 | (progn | |
389 | (dolist (e l ret) | |
390 | (setq ret | |
391 | (append ret | |
392 | (list | |
393 | (if (stringp e) | |
394 | (if (stringp replacement) | |
395 | (setq e (concat replacement (substring e len))) | |
396 | (setq e (substring e len))) | |
397 | e))))) | |
398 | ret) | |
399 | l))) | |
400 | ||
401 | ||
402 | (defun org-protocol-flatten (l) | |
403 | "Greedy handlers might recieve a list like this from emacsclient: | |
404 | '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\") | |
405 | where \"/dir/\" is the absolute path to emacsclients working directory. This | |
406 | function transforms it into a flat list." | |
407 | (if (null l) () | |
408 | (if (listp l) | |
409 | (append (org-protocol-flatten (car l)) (org-protocol-flatten (cdr l))) | |
410 | (list l)))) | |
411 | ||
412 | ;;; Standard protocol handlers: | |
413 | ||
414 | (defun org-protocol-store-link (fname) | |
415 | "Process an org-protocol://store-link:// style url | |
416 | and store a browser URL as an org link. Also pushes the links URL to the | |
417 | `kill-ring'. | |
418 | ||
419 | The location for a browser's bookmark has to look like this: | |
420 | ||
421 | javascript:location.href='org-protocol://store-link://'+ \\ | |
422 | encodeURIComponent(location.href) | |
423 | encodeURIComponent(document.title)+'/'+ \\ | |
424 | ||
425 | Don't use `escape()'! Use `encodeURIComponent()' instead. The title of the page | |
426 | could contain slashes and the location definitely will. | |
427 | ||
428 | The sub-protocol used to reach this function is set in | |
429 | `org-protocol-protocol-alist'." | |
430 | (let* ((splitparts (org-protocol-split-data fname t)) | |
431 | (uri (org-protocol-sanitize-uri (car splitparts))) | |
432 | (title (cadr splitparts)) | |
433 | orglink) | |
434 | (if (boundp 'org-stored-links) | |
435 | (setq org-stored-links (cons (list uri title) org-stored-links))) | |
436 | (kill-new uri) | |
437 | (message "`%s' to insert new org-link, `%s' to insert `%s'" | |
438 | (substitute-command-keys"\\[org-insert-link]") | |
439 | (substitute-command-keys"\\[yank]") | |
440 | uri)) | |
441 | nil) | |
442 | ||
c8d0cf5c CD |
443 | (defun org-protocol-remember (info) |
444 | "Process an org-protocol://remember:// style url. | |
445 | ||
446 | The sub-protocol used to reach this function is set in | |
447 | `org-protocol-protocol-alist'. | |
448 | ||
8bfe682a | 449 | This function detects an URL, title and optional text, separated by '/' |
c8d0cf5c CD |
450 | The location for a browser's bookmark has to look like this: |
451 | ||
452 | javascript:location.href='org-protocol://remember://'+ \\ | |
453 | encodeURIComponent(location.href)+'/' \\ | |
454 | encodeURIComponent(document.title)+'/'+ \\ | |
455 | encodeURIComponent(window.getSelection()) | |
456 | ||
457 | By default, it uses the character `org-protocol-default-template-key', | |
458 | which should be associated with a template in `org-remember-templates'. | |
459 | But you may prepend the encoded URL with a character and a slash like so: | |
460 | ||
461 | javascript:location.href='org-protocol://org-store-link://b/'+ ... | |
462 | ||
463 | Now template ?b will be used." | |
464 | ||
465 | (if (and (boundp 'org-stored-links) | |
466 | (fboundp 'org-remember)) | |
467 | (let* ((parts (org-protocol-split-data info t)) | |
468 | (template (or (and (= 1 (length (car parts))) (pop parts)) | |
469 | org-protocol-default-template-key)) | |
470 | (url (org-protocol-sanitize-uri (car parts))) | |
471 | (type (if (string-match "^\\([a-z]+\\):" url) | |
472 | (match-string 1 url))) | |
473 | (title (cadr parts)) | |
474 | (region (caddr parts)) | |
475 | (orglink (org-make-link-string url title)) | |
476 | remember-annotation-functions) | |
477 | (setq org-stored-links | |
478 | (cons (list url title) org-stored-links)) | |
479 | (kill-new orglink) | |
480 | (org-store-link-props :type type | |
481 | :link url | |
482 | :description title | |
483 | :initial region) | |
484 | (raise-frame) | |
485 | (org-remember nil (string-to-char template))) | |
486 | ||
487 | (message "Org-mode not loaded.")) | |
488 | nil) | |
489 | ||
c8d0cf5c CD |
490 | (defun org-protocol-open-source (fname) |
491 | "Process an org-protocol://open-source:// style url. | |
492 | ||
493 | Change a filename by mapping URLs to local filenames as set | |
494 | in `org-protocol-project-alist'. | |
495 | ||
496 | The location for a browser's bookmark should look like this: | |
497 | ||
498 | javascript:location.href='org-protocol://open-source://'+ \\ | |
499 | encodeURIComponent(location.href)" | |
500 | ||
501 | ;; As we enter this function for a match on our protocol, the return value | |
502 | ;; defaults to nil. | |
503 | (let ((result nil) | |
504 | (f (org-protocol-unhex-string fname))) | |
505 | (catch 'result | |
506 | (dolist (prolist org-protocol-project-alist) | |
507 | (let* ((base-url (plist-get (cdr prolist) :base-url)) | |
508 | (wsearch (regexp-quote base-url))) | |
509 | ||
510 | (when (string-match wsearch f) | |
511 | (let* ((wdir (plist-get (cdr prolist) :working-directory)) | |
512 | (strip-suffix (plist-get (cdr prolist) :online-suffix)) | |
513 | (add-suffix (plist-get (cdr prolist) :working-suffix)) | |
5dec9555 CD |
514 | ;; Strip "[?#].*$" if `f' is a redirect with another |
515 | ;; ending than strip-suffix here: | |
516 | (f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f))) | |
517 | (start-pos (+ (string-match wsearch f1) (length base-url))) | |
c8d0cf5c | 518 | (end-pos (string-match |
5dec9555 CD |
519 | (regexp-quote strip-suffix) f1)) |
520 | ;; We have to compare redirects without suffix below: | |
521 | (f2 (concat wdir (substring f1 start-pos end-pos))) | |
522 | (the-file (concat f2 add-suffix))) | |
523 | ||
524 | ;; Note: the-file may still contain `%C3' et al here because browsers | |
525 | ;; tend to encode `ä' in URLs to `%25C3' - `%25' being `%'. | |
526 | ;; So the results may vary. | |
527 | ||
528 | ;; -- start redirects -- | |
529 | (unless (file-exists-p the-file) | |
530 | (message "File %s does not exist.\nTesting for rewritten URLs." the-file) | |
531 | (let ((rewrites (plist-get (cdr prolist) :rewrites))) | |
532 | (when rewrites | |
533 | (message "Rewrites found: %S" rewrites) | |
534 | (mapc | |
535 | (lambda (rewrite) | |
536 | "Try to match a rewritten URL and map it to a real file." | |
537 | ;; Compare redirects without suffix: | |
538 | (if (string-match (car rewrite) f2) | |
539 | (throw 'result (concat wdir (cdr rewrite))))) | |
540 | rewrites)))) | |
541 | ;; -- end of redirects -- | |
542 | ||
c8d0cf5c CD |
543 | (if (file-readable-p the-file) |
544 | (throw 'result the-file)) | |
545 | (if (file-exists-p the-file) | |
546 | (message "%s: permission denied!" the-file) | |
547 | (message "%s: no such file or directory." the-file)))))) | |
548 | result))) | |
549 | ||
550 | ||
551 | ;;; Core functions: | |
552 | ||
553 | (defun org-protocol-check-filename-for-protocol (fname restoffiles client) | |
554 | "Detect if `org-protocol-the-protocol' and a known sub-protocol is used in fname. | |
555 | Sub-protocols are registered in `org-protocol-protocol-alist' and | |
556 | `org-protocol-protocol-alist-default'. | |
557 | This is, how the matching is done: | |
558 | ||
559 | (string-match \"protocol:/+sub-protocol:/+\" ...) | |
560 | ||
561 | protocol and sub-protocol are regexp-quoted. | |
562 | ||
563 | If a matching protcol is found, the protcol is stripped from fname and the | |
564 | result is passed to the protocols function as the only parameter. If the | |
565 | function returns nil, the filename is removed from the list of filenames | |
566 | passed from emacsclient to the server. | |
567 | If the function returns a non nil value, that value is passed to the server | |
568 | as filename." | |
569 | (let ((sub-protocols (append org-protocol-protocol-alist org-protocol-protocol-alist-default))) | |
570 | (catch 'fname | |
571 | (let ((the-protocol (concat (regexp-quote org-protocol-the-protocol) ":/+"))) | |
572 | (when (string-match the-protocol fname) | |
573 | (dolist (prolist sub-protocols) | |
574 | (let ((proto (concat the-protocol (regexp-quote (plist-get (cdr prolist) :protocol)) ":/+"))) | |
575 | (when (string-match proto fname) | |
576 | (let* ((func (plist-get (cdr prolist) :function)) | |
577 | (greedy (plist-get (cdr prolist) :greedy)) | |
578 | (splitted (split-string fname proto)) | |
579 | (result (if greedy restoffiles (cadr splitted)))) | |
580 | (when (plist-get (cdr prolist) :kill-client) | |
581 | (message "Greedy org-protocol handler. Killing client.") | |
582 | (server-edit)) | |
583 | (when (fboundp func) | |
584 | (unless greedy | |
585 | (throw 'fname (funcall func result))) | |
586 | (funcall func result) | |
587 | (throw 'fname t)))))))) | |
588 | ;; (message "fname: %s" fname) | |
589 | fname))) | |
590 | ||
591 | ||
592 | (defadvice server-visit-files (before org-protocol-detect-protocol-server activate) | |
593 | "Advice server-visit-flist to call `org-protocol-modify-filename-for-protocol'." | |
594 | (let ((flist (if org-protocol-reverse-list-of-files | |
595 | (reverse (ad-get-arg 0)) | |
596 | (ad-get-arg 0))) | |
597 | (client (ad-get-arg 1))) | |
598 | (catch 'greedy | |
599 | (dolist (var flist) | |
600 | (let ((fname (expand-file-name (car var)))) ;; `\' to `/' on windows. FIXME: could this be done any better? | |
601 | (setq fname (org-protocol-check-filename-for-protocol fname (member var flist) client)) | |
602 | (if (eq fname t) ;; greedy? We need the `t' return value. | |
603 | (progn | |
604 | (ad-set-arg 0 nil) | |
605 | (throw 'greedy t)) | |
606 | (if (stringp fname) ;; probably filename | |
607 | (setcar var fname) | |
608 | (ad-set-arg 0 (delq var (ad-get-arg 0)))))) | |
609 | )))) | |
610 | ||
611 | ;;; Org specific functions: | |
612 | ||
613 | (defun org-protocol-create-for-org () | |
614 | "Create a org-protocol project for the current file's Org-mode project. | |
615 | This works, if the file visited is part of a publishing project in | |
616 | `org-publish-project-alist'. This functions calls `org-protocol-create' to do | |
617 | most of the work." | |
618 | (interactive) | |
619 | (require 'org-publish) | |
620 | (org-publish-initialize-files-alist) | |
621 | (let ((all (or (org-publish-get-project-from-filename buffer-file-name)))) | |
622 | (if all (org-protocol-create (cdr all)) | |
623 | (message "Not in an org-project. Did mean %s?" | |
624 | (substitute-command-keys"\\[org-protocol-create]"))))) | |
625 | ||
626 | ||
627 | (defun org-protocol-create(&optional project-plist) | |
628 | "Create a new org-protocol project interactively. | |
629 | An org-protocol project is an entry in `org-protocol-project-alist' | |
630 | which is used by `org-protocol-open-source'. | |
5dec9555 | 631 | Optionally use project-plist to initialize the defaults for this project. If |
c8d0cf5c CD |
632 | project-plist is the CDR of an element in `org-publish-project-alist', reuse |
633 | :base-directory, :html-extension and :base-extension." | |
634 | (interactive) | |
635 | (let ((working-dir (expand-file-name(or (plist-get project-plist :base-directory) default-directory))) | |
636 | (base-url "http://orgmode.org/worg/") | |
637 | (strip-suffix (or (plist-get project-plist :html-extension) ".html")) | |
638 | (working-suffix (if (plist-get project-plist :base-extension) | |
639 | (concat "." (plist-get project-plist :base-extension)) | |
640 | ".org")) | |
641 | ||
642 | (worglet-buffer nil) | |
643 | ||
644 | (insert-default-directory t) | |
645 | (minibuffer-allow-text-properties nil)) | |
646 | ||
647 | (setq base-url (read-string "Base URL of published content: " base-url nil base-url t)) | |
648 | (if (not (string-match "\\/$" base-url)) | |
649 | (setq base-url (concat base-url "/"))) | |
650 | ||
651 | (setq working-dir | |
652 | (expand-file-name | |
653 | (read-directory-name "Local working directory: " working-dir working-dir t))) | |
654 | (if (not (string-match "\\/$" working-dir)) | |
655 | (setq working-dir (concat working-dir "/"))) | |
656 | ||
657 | (setq strip-suffix | |
658 | (read-string | |
659 | (concat "Extension to strip from published URLs ("strip-suffix"): ") | |
660 | strip-suffix nil strip-suffix t)) | |
661 | ||
662 | (setq working-suffix | |
663 | (read-string | |
664 | (concat "Extension of editable files ("working-suffix"): ") | |
665 | working-suffix nil working-suffix t)) | |
666 | ||
5dec9555 | 667 | (when (yes-or-no-p "Save the new org-protocol-project to your init file? ") |
c8d0cf5c CD |
668 | (setq org-protocol-project-alist |
669 | (cons `(,base-url . (:base-url ,base-url | |
670 | :working-directory ,working-dir | |
671 | :online-suffix ,strip-suffix | |
672 | :working-suffix ,working-suffix)) | |
673 | org-protocol-project-alist)) | |
674 | (customize-save-variable 'org-protocol-project-alist org-protocol-project-alist)))) | |
675 | ||
676 | (provide 'org-protocol) | |
26bd9e87 | 677 | |
2c4c2e22 | 678 | ;; arch-tag: b5c5c2ac-77cf-4a94-a649-2163dff95846 |
c8d0cf5c | 679 | ;;; org-protocol.el ends here |