org-protocol.el 28.1 KB
Newer Older
Rasmus's avatar
Rasmus committed
1
;;; org-protocol.el --- Intercept Calls from Emacsclient to Trigger Custom Actions -*- lexical-binding: t; -*-
2
;;
Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2008-2020 Free Software Foundation, Inc.
4
;;
Bastien Guerry's avatar
Bastien Guerry committed
5
;; Authors: Bastien Guerry <bzg@gnu.org>
6 7 8
;;       Daniel M German <dmg AT uvic DOT org>
;;       Sebastian Rose <sebastian_rose AT gmx DOT de>
;;       Ross Patterson <me AT rpatterson DOT net>
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Keywords: org, emacsclient, wp

;; This file is part of GNU Emacs.
;;
;; GNU Emacs 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 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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
25
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
26 27 28 29 30 31

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commentary:
;;
;; Intercept calls from emacsclient to trigger custom actions.
;;
32 33
;; This is done by advising `server-visit-files' to scan the list of filenames
;; for `org-protocol-the-protocol' and sub-protocols defined in
34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'.
;;
;; Any application that supports calling external programs with an URL
;; as argument may be used with this functionality.
;;
;;
;; Usage:
;; ------
;;
;;   1.) Add this to your init file (.emacs probably):
;;
;;       (add-to-list 'load-path "/path/to/org-protocol/")
;;       (require 'org-protocol)
;;
;;   3.) Ensure emacs-server is up and running.
;;   4.) Try this from the command line (adjust the URL as needed):
;;
;;       $ emacsclient \
Rasmus's avatar
Rasmus committed
52
;;         org-protocol://store-link?url=http:%2F%2Flocalhost%2Findex.html&title=The%20title
53 54 55 56 57 58
;;
;;   5.) Optionally add custom sub-protocols and handlers:
;;
;;       (setq org-protocol-protocol-alist
;;             '(("my-protocol"
;;                :protocol "my-protocol"
59
;;                :function my-protocol-handler-function)))
60 61 62
;;
;;       A "sub-protocol" will be found in URLs like this:
;;
Rasmus's avatar
Rasmus committed
63
;;           org-protocol://sub-protocol?key=val&key2=val2
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
;;
;; If it works, you can now setup other applications for using this feature.
;;
;;
;; As of March 2009 Firefox users follow the steps documented on
;; http://kb.mozillazine.org/Register_protocol, Opera setup is described here:
;; http://www.opera.com/support/kb/view/535/
;;
;;
;; Documentation
;; -------------
;;
;; org-protocol.el comes with and installs handlers to open sources of published
;; online content, store and insert the browser's URLs and cite online content
;; by clicking on a bookmark in Firefox, Opera and probably other browsers and
;; applications:
;;
;;   * `org-protocol-open-source' uses the sub-protocol \"open-source\" and maps
;;     URLs to local filenames defined in `org-protocol-project-alist'.
;;
Rasmus's avatar
Rasmus committed
84
;;   * `org-protocol-store-link' stores an Org link (if Org is present) and
85
;;     pushes the browsers URL to the `kill-ring' for yanking.  This handler is
86 87
;;     triggered through the sub-protocol \"store-link\".
;;
88
;;   * Call `org-protocol-capture' by using the sub-protocol \"capture\".  If
Rasmus's avatar
Rasmus committed
89
;;     Org is loaded, Emacs will pop-up a capture buffer and fill the
90 91
;;     template with the data provided.  I.e. the browser's URL is inserted as an
;;     Org-link of which the page title will be the description part.  If text
92 93 94 95 96
;;     was select in the browser, that text will be the body of the entry.
;;
;; You may use the same bookmark URL for all those standard handlers and just
;; adjust the sub-protocol used:
;;
Rasmus's avatar
Rasmus committed
97 98 99
;;     location.href='org-protocol://sub-protocol?url='+
;;           encodeURIComponent(location.href)+'&title='+
;;           encodeURIComponent(document.title)+'&body='+
100 101
;;           encodeURIComponent(window.getSelection())
;;
102
;; The handler for the sub-protocol \"capture\" detects an optional template
103 104 105
;; char that, if present, triggers the use of a special template.
;; Example:
;;
Rasmus's avatar
Rasmus committed
106
;;     location.href='org-protocol://capture?template=x'+ ...
107
;;
Rasmus's avatar
Rasmus committed
108
;;  uses template ?x.
109
;;
Rasmus's avatar
Rasmus committed
110
;; Note that using double slashes is optional from org-protocol.el's point of
111
;; view because emacsclient squashes the slashes to one.
112 113 114 115 116 117 118
;;
;;
;; provides: 'org-protocol
;;
;;; Code:

(require 'org)
Bastien's avatar
Bastien committed
119
(require 'ol)
120

Paul Eggert's avatar
Paul Eggert committed
121
(declare-function org-publish-get-project-from-filename "ox-publish"
122
		  (filename &optional up))
Glenn Morris's avatar
Glenn Morris committed
123
(declare-function server-edit "server" (&optional arg))
124

Rasmus's avatar
Rasmus committed
125
(defvar org-capture-link-is-already-stored)
Bastien's avatar
Bastien committed
126
(defvar org-capture-templates)
127 128 129 130

(defgroup org-protocol nil
  "Intercept calls from emacsclient to trigger custom actions.

Paul Eggert's avatar
Paul Eggert committed
131 132
This is done by advising `server-visit-files' to scan the list of filenames
for `org-protocol-the-protocol' and sub-protocols defined in
133 134 135 136 137 138 139 140 141
`org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'."
  :version "22.1"
  :group 'convenience
  :group 'org)


;;; Variables:

(defconst org-protocol-protocol-alist-default
Bastien Guerry's avatar
Bastien Guerry committed
142
  '(("org-capture"     :protocol "capture"     :function org-protocol-capture  :kill-client t)
143 144 145 146 147 148 149
    ("org-store-link"  :protocol "store-link"  :function org-protocol-store-link)
    ("org-open-source" :protocol "open-source" :function org-protocol-open-source))
  "Default protocols to use.
See `org-protocol-protocol-alist' for a description of this variable.")

(defconst org-protocol-the-protocol "org-protocol"
  "This is the protocol to detect if org-protocol.el is loaded.
150 151 152 153
`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold
the sub-protocols that trigger the required action.  You will have to define
just one protocol handler OS-wide (MS-Windows) or per application (Linux).
That protocol handler should call emacsclient.")
154 155 156 157

;;; User variables:

(defcustom org-protocol-reverse-list-of-files t
158
  "Non-nil means re-reverse the list of filenames passed on the command line.
159 160 161
The filenames passed on the command line are passed to the emacs-server in
reverse order.  Set to t (default) to re-reverse the list, i.e. use the
sequence on the command line.  If nil, the sequence of the filenames is
162 163 164 165 166
unchanged."
  :group 'org-protocol
  :type 'boolean)

(defcustom org-protocol-project-alist nil
167
  "Map URLs to local filenames for `org-protocol-open-source' (open-source).
168 169 170 171 172

Each element of this list must be of the form:

  (module-name :property value property: value ...)

173
where module-name is an arbitrary name.  All the values are strings.
174 175 176 177 178 179 180

Possible properties are:

  :online-suffix     - the suffix to strip from the published URLs
  :working-suffix    - the replacement for online-suffix
  :base-url          - the base URL, e.g. http://www.example.com/project/
                       Last slash required.
181
  :working-directory - the local working directory.  This is, what base-url will
182
                       be replaced with.
183 184
  :redirects         - A list of cons cells, each of which maps a regular
                       expression to match to a path relative to :working-directory.
185 186 187 188

Example:

   (setq org-protocol-project-alist
Rasmus's avatar
Rasmus committed
189
       \\='((\"https://orgmode.org/worg/\"
190 191
          :online-suffix \".php\"
          :working-suffix \".org\"
Rasmus's avatar
Rasmus committed
192
          :base-url \"https://orgmode.org/worg/\"
193 194 195 196 197
          :working-directory \"/home/user/org/Worg/\")
         (\"http://localhost/org-notes/\"
          :online-suffix \".html\"
          :working-suffix \".org\"
          :base-url \"http://localhost/org/\"
198
          :working-directory \"/home/user/org/\"
Rasmus's avatar
Rasmus committed
199 200 201 202 203 204 205 206
          :rewrites ((\"org/?$\" . \"index.php\")))
         (\"Hugo based blog\"
          :base-url \"https://www.site.com/\"
          :working-directory \"~/site/content/post/\"
          :online-suffix \".html\"
          :working-suffix \".md\"
          :rewrites ((\"\\(https://site.com/[0-9]+/[0-9]+/[0-9]+/\\)\" . \".md\")))))

207 208 209 210

   The last line tells `org-protocol-open-source' to open
   /home/user/org/index.php, if the URL cannot be mapped to an existing
   file, and ends with either \"org\" or \"org/\".
211 212 213 214 215 216 217

Consider using the interactive functions `org-protocol-create' and
`org-protocol-create-for-org' to help you filling this variable with valid contents."
  :group 'org-protocol
  :type 'alist)

(defcustom org-protocol-protocol-alist nil
218
  "Register custom handlers for org-protocol.
219 220 221 222 223

Each element of this list must be of the form:

  (module-name :protocol protocol :function func :kill-client nil)

Rasmus's avatar
Rasmus committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
protocol - protocol to detect in a filename without trailing
           colon and slashes.  See rfc1738 section 2.1 for more
           on this.  If you define a protocol \"my-protocol\",
           `org-protocol-check-filename-for-protocol' will search
           filenames for \"org-protocol:/my-protocol\" and
           trigger your action for every match.  `org-protocol'
           is defined in `org-protocol-the-protocol'.  Double and
           triple slashes are compressed to one by emacsclient.

function - function that handles requests with protocol and takes
           one argument.  If a new-style link (key=val&key2=val2)
           is given, the argument will be a property list with
           the values from the link.  If an old-style link is
           given (val1/val2), the argument will be the filename
           with all protocols stripped.

           If the function returns nil, emacsclient and -server
           do nothing.  Any non-nil return value is considered a
           valid filename and thus passed to the server.

           `org-protocol.el' provides some support for handling
           old-style filenames, if you follow the conventions
           used for the standard handlers in
           `org-protocol-protocol-alist-default'.  See
           `org-protocol-parse-parameters'.
249 250

kill-client - If t, kill the client immediately, once the sub-protocol is
251
           detected.  This is necessary for actions that can be interrupted by
Rasmus's avatar
Rasmus committed
252 253
           `C-g' to avoid dangling emacsclients.  Note that all other command
           line arguments but the this one will be discarded.  Greedy handlers
254 255 256 257 258
           still receive the whole list of arguments though.

Here is an example:

  (setq org-protocol-protocol-alist
Paul Eggert's avatar
Paul Eggert committed
259
      \\='((\"my-protocol\"
260
         :protocol \"my-protocol\"
261
         :function my-protocol-handler-function)
262 263
        (\"your-protocol\"
         :protocol \"your-protocol\"
264
         :function your-protocol-handler-function)))"
265 266 267
  :group 'org-protocol
  :type '(alist))

Carsten Dominik's avatar
Carsten Dominik committed
268
(defcustom org-protocol-default-template-key nil
269 270 271
  "The default template key to use.
This is usually a single character string but can also be a
string with two characters."
272
  :group 'org-protocol
Bastien Guerry's avatar
Bastien Guerry committed
273
  :type '(choice (const nil) (string)))
274

Bastien Guerry's avatar
Bastien Guerry committed
275
(defcustom org-protocol-data-separator "/+\\|\\?"
276
  "The default data separator to use.
Rasmus's avatar
Rasmus committed
277
This should be a single regexp string."
278
  :group 'org-protocol
Bastien Guerry's avatar
Bastien Guerry committed
279 280
  :version "24.4"
  :package-version '(Org . "8.0")
281
  :type 'regexp)
282

283 284 285
;;; Helper functions:

(defun org-protocol-sanitize-uri (uri)
Rasmus's avatar
Rasmus committed
286 287
  "Sanitize slashes to double-slashes in URI.
Emacsclient compresses double and triple slashes."
288 289 290 291 292
  (when (string-match "^\\([a-z]+\\):/" uri)
    (let* ((splitparts (split-string uri "/+")))
      (setq uri (concat (car splitparts) "//" (mapconcat 'identity (cdr splitparts) "/")))))
  uri)

293
(defun org-protocol-split-data (data &optional unhexify separator)
Rasmus's avatar
Rasmus committed
294 295 296 297 298 299
  "Split the DATA argument for an org-protocol handler function.
If UNHEXIFY is non-nil, hex-decode each split part.  If UNHEXIFY
is a function, use that function to decode each split part.  The
string is split at each occurrence of SEPARATOR (regexp).  If no
SEPARATOR is specified or SEPARATOR is nil, assume \"/+\".  The
results of that splitting are returned as a list."
Bastien Guerry's avatar
Bastien Guerry committed
300
  (let* ((sep (or separator "/+\\|\\?"))
301
         (split-parts (split-string data sep)))
Bastien's avatar
Bastien committed
302 303 304
    (cond ((not unhexify) split-parts)
	  ((fboundp unhexify) (mapcar unhexify split-parts))
	  (t (mapcar #'org-link-decode split-parts)))))
305 306

(defun org-protocol-flatten-greedy (param-list &optional strip-path replacement)
Rasmus's avatar
Rasmus committed
307 308 309 310 311
  "Transform PARAM-LIST into a flat list for greedy handlers.

Greedy handlers might receive a list like this from emacsclient:
\((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\"))
where \"/dir/\" is the absolute path to emacsclient's working directory.  This
312
function transforms it into a flat list using `org-protocol-flatten' and
313 314
transforms the elements of that list as follows:

Rasmus's avatar
Rasmus committed
315
If STRIP-PATH is non-nil, remove the \"/dir/\" prefix from all members of
316 317
param-list.

Rasmus's avatar
Rasmus committed
318
If REPLACEMENT is string, replace the \"/dir/\" prefix with it.
319 320 321 322 323 324

The first parameter, the one that contains the protocols, is always changed.
Everything up to the end of the protocols is stripped.

Note, that this function will always behave as if
`org-protocol-reverse-list-of-files' was set to t and the returned list will
Rasmus's avatar
Rasmus committed
325
reflect that.  emacsclient's first parameter will be the first one in the
326
returned list."
327 328 329 330 331 332 333
  (let* ((l (org-protocol-flatten (if org-protocol-reverse-list-of-files
				      param-list
				    (reverse param-list))))
	 (trigger (car l))
	 (len 0)
	 dir
	 ret)
334
    (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-Z0-9][-_a-zA-Z0-9]*:/+\\)\\(.*\\)" trigger)
335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
      (setq dir (match-string 1 trigger))
      (setq len (length dir))
      (setcar l (concat dir (match-string 3 trigger))))
    (if strip-path
	(progn
	  (dolist (e l ret)
	    (setq ret
		  (append ret
			  (list
			   (if (stringp e)
			       (if (stringp replacement)
				   (setq e (concat replacement (substring e len)))
				 (setq e (substring e len)))
			     e)))))
	  ret)
      l)))
351

352 353 354 355
(defalias 'org-protocol-flatten
  (if (fboundp 'flatten-tree) 'flatten-tree
    (lambda (list)
      "Transform LIST into a flat list.
Rasmus's avatar
Rasmus committed
356 357 358

Greedy handlers might receive a list like this from emacsclient:
\((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\"))
Juanma Barranquero's avatar
Juanma Barranquero committed
359 360
where \"/dir/\" is the absolute path to emacsclients working directory.
This function transforms it into a flat list."
361 362 363 364 365
      (if list
	  (if (consp list)
	      (append (org-protocol-flatten (car list))
		      (org-protocol-flatten (cdr list)))
	    (list list))))))
Rasmus's avatar
Rasmus committed
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383

(defun org-protocol-parse-parameters (info &optional new-style default-order)
  "Return a property list of parameters from INFO.
If NEW-STYLE is non-nil, treat INFO as a query string (ex:
url=URL&title=TITLE).  If old-style links are used (ex:
org-protocol://store-link/url/title), assign them to attributes
following DEFAULT-ORDER.

If no DEFAULT-ORDER is specified, return the list of values.

If INFO is already a property list, return it unchanged."
  (if (listp info)
      info
    (if new-style
	(let ((data (org-protocol-convert-query-to-plist info))
	      result)
	  (while data
	    (setq result
Bastien's avatar
Bastien committed
384 385
		  (append result
			  (list (pop data) (org-link-decode (pop data))))))
Rasmus's avatar
Rasmus committed
386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
	  result)
      (let ((data (org-protocol-split-data info t org-protocol-data-separator)))
	(if default-order
	    (org-protocol-assign-parameters data default-order)
	  data)))))

(defun org-protocol-assign-parameters (data default-order)
  "Return a property list of parameters from DATA.
Key names are taken from DEFAULT-ORDER, which should be a list of
symbols.  If DEFAULT-ORDER is shorter than the number of values
specified, the rest of the values are treated as :key value pairs."
  (let (result)
    (while default-order
      (setq result
	    (append result
		    (list (pop default-order)
			  (pop data)))))
    (while data
      (setq result
	    (append result
		    (list (intern (concat ":" (pop data)))
			  (pop data)))))
    result))
409

410 411 412
;;; Standard protocol handlers:

(defun org-protocol-store-link (fname)
Rasmus's avatar
Rasmus committed
413
  "Process an org-protocol://store-link style url.
414
Additionally store a browser URL as an org link.  Also pushes the
415
link's URL to the `kill-ring'.
416

Rasmus's avatar
Rasmus committed
417 418 419 420 421
Parameters: url, title (optional), body (optional)

Old-style links such as org-protocol://store-link://URL/TITLE are
also recognized.

422 423
The location for a browser's bookmark has to look like this:

Rasmus's avatar
Rasmus committed
424 425 426 427
  javascript:location.href = \\
      \\='org-protocol://store-link?url=\\=' + \\
      encodeURIComponent(location.href) + \\='&title=\\=' + \\
      encodeURIComponent(document.title);
428

Rasmus's avatar
Rasmus committed
429 430 431
Don't use `escape()'!  Use `encodeURIComponent()' instead.  The
title of the page could contain slashes and the location
definitely will.
432 433

The sub-protocol used to reach this function is set in
Rasmus's avatar
Rasmus committed
434 435 436 437 438 439 440 441 442
`org-protocol-protocol-alist'.

FNAME should be a property list.  If not, an old-style link of the
form URL/TITLE can also be used."
  (let* ((splitparts (org-protocol-parse-parameters fname nil '(:url :title)))
         (uri (org-protocol-sanitize-uri (plist-get splitparts :url)))
         (title (plist-get splitparts :title)))
    (when (boundp 'org-stored-links)
      (push (list uri title) org-stored-links))
443
    (kill-new uri)
Bastien's avatar
Bastien committed
444 445 446
    (message "`%s' to insert new Org link, `%s' to insert %S"
             (substitute-command-keys "\\[org-insert-link]")
             (substitute-command-keys "\\[yank]")
447 448 449
             uri))
  nil)

450
(defun org-protocol-capture (info)
Rasmus's avatar
Rasmus committed
451
  "Process an org-protocol://capture style url with INFO.
452

453 454 455
The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'.

Bastien Guerry's avatar
Bastien Guerry committed
456
This function detects an URL, title and optional text, separated
457
by `/'.  The location for a browser's bookmark looks like this:
458

Rasmus's avatar
Rasmus committed
459 460 461
  javascript:location.href = \\='org-protocol://capture?url=\\='+ \\
        encodeURIComponent(location.href) + \\='&title=\\=' \\
        encodeURIComponent(document.title) + \\='&body=\\=' + \\
462 463 464
        encodeURIComponent(window.getSelection())

By default, it uses the character `org-protocol-default-template-key',
465
which should be associated with a template in `org-capture-templates'.
Rasmus's avatar
Rasmus committed
466
You may specify the template with a template= query parameter, like this:
467

Rasmus's avatar
Rasmus committed
468
  javascript:location.href = \\='org-protocol://capture?template=b\\='+ ...
469 470

Now template ?b will be used."
Bastien's avatar
Bastien committed
471 472 473 474 475 476 477 478 479 480 481
  (let* ((parts
	  (pcase (org-protocol-parse-parameters info)
	    ;; New style links are parsed as a plist.
	    ((let `(,(pred keywordp) . ,_) info) info)
	    ;; Old style links, with or without template key, are
	    ;; parsed as a list of strings.
	    (p
	     (let ((k (if (= 1 (length (car p)))
			  '(:template :url :title :body)
			'(:url :title :body))))
	       (org-protocol-assign-parameters p k)))))
Rasmus's avatar
Rasmus committed
482
	 (template (or (plist-get parts :template)
483
		       org-protocol-default-template-key))
Bastien's avatar
Bastien committed
484 485 486 487 488
	 (url (and (plist-get parts :url)
		   (org-protocol-sanitize-uri (plist-get parts :url))))
	 (type (and url
		    (string-match "^\\([a-z]+\\):" url)
		    (match-string 1 url)))
Rasmus's avatar
Rasmus committed
489 490
	 (title (or (plist-get parts :title) ""))
	 (region (or (plist-get parts :body) ""))
Bastien's avatar
Bastien committed
491 492 493 494 495 496 497 498
	 (orglink
	  (if (null url) title
	    (org-link-make-string url (or (org-string-nw-p title) url))))
	 ;; Avoid call to `org-store-link'.
	 (org-capture-link-is-already-stored t))
    ;; Only store link if there's a URL to insert later on.
    (when url (push (list url title) org-stored-links))
    (org-link-store-props :type type
499 500 501
			  :link url
			  :description title
			  :annotation orglink
Bastien Guerry's avatar
Bastien Guerry committed
502
			  :initial region
Rasmus's avatar
Rasmus committed
503
			  :query parts)
504
    (raise-frame)
Bastien's avatar
Bastien committed
505 506 507 508 509 510 511 512 513 514 515 516 517
    (org-capture nil template)
    (message "Item captured.")
    ;; Make sure we do not return a string, as `server-visit-files',
    ;; through `server-edit', would interpret it as a file name.
    nil))

(defun org-protocol-convert-query-to-plist (query)
  "Convert QUERY key=value pairs in the URL to a property list."
  (when query
    (apply 'append (mapcar (lambda (x)
			     (let ((c (split-string x "=")))
			       (list (intern (concat ":" (car c))) (cadr c))))
			   (split-string query "&")))))
518

519
(defun org-protocol-open-source (fname)
Rasmus's avatar
Rasmus committed
520
  "Process an org-protocol://open-source?url= style URL with FNAME.
521 522 523 524 525 526

Change a filename by mapping URLs to local filenames as set
in `org-protocol-project-alist'.

The location for a browser's bookmark should look like this:

Rasmus's avatar
Rasmus committed
527
  javascript:location.href = \\='org-protocol://open-source?url=\\=' + \\
528 529 530 531
        encodeURIComponent(location.href)"
  ;; As we enter this function for a match on our protocol, the return value
  ;; defaults to nil.
  (let ((result nil)
Rasmus's avatar
Rasmus committed
532 533 534
	(f (org-protocol-sanitize-uri
	    (plist-get (org-protocol-parse-parameters fname nil '(:url))
		       :url))))
535 536 537 538 539 540 541 542 543
    (catch 'result
      (dolist (prolist org-protocol-project-alist)
        (let* ((base-url (plist-get (cdr prolist) :base-url))
               (wsearch (regexp-quote base-url)))

          (when (string-match wsearch f)
            (let* ((wdir (plist-get (cdr prolist) :working-directory))
                   (strip-suffix (plist-get (cdr prolist) :online-suffix))
                   (add-suffix (plist-get (cdr prolist) :working-suffix))
544 545 546 547
		   ;; Strip "[?#].*$" if `f' is a redirect with another
		   ;; ending than strip-suffix here:
		   (f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f)))
                   (start-pos (+ (string-match wsearch f1) (length base-url)))
548
                   (end-pos (string-match
549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
			     (regexp-quote strip-suffix) f1))
		   ;; We have to compare redirects without suffix below:
		   (f2 (concat wdir (substring f1 start-pos end-pos)))
                   (the-file (concat f2 add-suffix)))

	      ;; Note: the-file may still contain `%C3' et al here because browsers
	      ;; tend to encode `&auml;' in URLs to `%25C3' - `%25' being `%'.
	      ;; So the results may vary.

	      ;; -- start redirects --
	      (unless (file-exists-p the-file)
		(message "File %s does not exist.\nTesting for rewritten URLs." the-file)
		(let ((rewrites (plist-get (cdr prolist) :rewrites)))
		  (when rewrites
		    (message "Rewrites found: %S" rewrites)
Rasmus's avatar
Rasmus committed
564 565 566 567
		    (dolist (rewrite rewrites)
		      ;; Try to match a rewritten URL and map it to
		      ;; a real file.  Compare redirects without
		      ;; suffix.
Rasmus's avatar
Rasmus committed
568 569 570 571 572 573
		      (when (string-match (car rewrite) f1)
			(let ((replacement
			       (concat (directory-file-name
					(replace-match "" nil nil f1 1))
				       (cdr rewrite))))
			  (throw 'result (concat wdir replacement))))))))
574 575
	      ;; -- end of redirects --

576 577 578 579 580 581 582 583 584 585
              (if (file-readable-p the-file)
                  (throw 'result the-file))
              (if (file-exists-p the-file)
                  (message "%s: permission denied!" the-file)
                (message "%s: no such file or directory." the-file))))))
      result)))


;;; Core functions:

Rasmus's avatar
Rasmus committed
586 587
(defun org-protocol-check-filename-for-protocol (fname restoffiles _client)
  "Check if `org-protocol-the-protocol' and a valid protocol are used in FNAME.
588
Sub-protocols are registered in `org-protocol-protocol-alist' and
Rasmus's avatar
Rasmus committed
589
`org-protocol-protocol-alist-default'.  This is how the matching is done:
590

Rasmus's avatar
Rasmus committed
591
  (string-match \"protocol:/+sub-protocol\\\\(://\\\\|\\\\?\\\\)\" ...)
592 593 594

protocol and sub-protocol are regexp-quoted.

Rasmus's avatar
Rasmus committed
595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
Old-style links such as \"protocol://sub-protocol://param1/param2\" are
also recognized.

If a matching protocol is found, the protocol is stripped from
fname and the result is passed to the protocol function as the
first parameter.  The second parameter will be non-nil if FNAME
uses key=val&key2=val2-type arguments, or nil if FNAME uses
val/val2-type arguments.  If the function returns nil, the
filename is removed from the list of filenames passed from
emacsclient to the server.  If the function returns a non-nil
value, that value is passed to the server as filename.

If the handler function is greedy, RESTOFFILES will also be passed to it.

CLIENT is ignored."
610 611
  (let ((sub-protocols (append org-protocol-protocol-alist
			       org-protocol-protocol-alist-default)))
612
    (catch 'fname
Rasmus's avatar
Rasmus committed
613 614
      (let ((the-protocol (concat (regexp-quote org-protocol-the-protocol)
				  ":/+")))
615 616
        (when (string-match the-protocol fname)
          (dolist (prolist sub-protocols)
Rasmus's avatar
Rasmus committed
617 618 619 620
            (let ((proto
		   (concat the-protocol
			   (regexp-quote (plist-get (cdr prolist) :protocol))
			   "\\(:/+\\|\\?\\)")))
621 622 623
              (when (string-match proto fname)
                (let* ((func (plist-get (cdr prolist) :function))
                       (greedy (plist-get (cdr prolist) :greedy))
Paul Eggert's avatar
Paul Eggert committed
624
                       (split (split-string fname proto))
Rasmus's avatar
Rasmus committed
625 626
                       (result (if greedy restoffiles (cadr split)))
		       (new-style (string= (match-string 1 fname) "?")))
627
                  (when (plist-get (cdr prolist) :kill-client)
628
		    (message "Greedy org-protocol handler.  Killing client.")
629 630 631
		    (server-edit))
                  (when (fboundp func)
                    (unless greedy
Rasmus's avatar
Rasmus committed
632 633 634 635 636 637 638 639 640 641
                      (throw 'fname
			     (if new-style
				 (funcall func (org-protocol-parse-parameters
						result new-style))
			       (warn "Please update your Org Protocol handler \
to deal with new-style links.")
			       (funcall func result))))
		    ;; Greedy protocol handlers are responsible for
		    ;; parsing their own filenames.
		    (funcall func result)
642 643 644 645 646 647 648 649 650 651 652
                    (throw 'fname t))))))))
      fname)))

(defadvice server-visit-files (before org-protocol-detect-protocol-server activate)
  "Advice server-visit-flist to call `org-protocol-modify-filename-for-protocol'."
  (let ((flist (if org-protocol-reverse-list-of-files
                   (reverse  (ad-get-arg 0))
                 (ad-get-arg 0)))
        (client (ad-get-arg 1)))
    (catch 'greedy
      (dolist (var flist)
653
	;; `\' to `/' on windows.  FIXME: could this be done any better?
654 655 656
        (let ((fname  (expand-file-name (car var))))
          (setq fname (org-protocol-check-filename-for-protocol
		       fname (member var flist)  client))
657
          (if (eq fname t) ;; greedy? We need the t return value.
658 659 660 661 662
              (progn
                (ad-set-arg 0 nil)
                (throw 'greedy t))
            (if (stringp fname) ;; probably filename
                (setcar var fname)
663
              (ad-set-arg 0 (delq var (ad-get-arg 0))))))))))
664 665 666 667

;;; Org specific functions:

(defun org-protocol-create-for-org ()
668
  "Create an Org protocol project for the current file's project.
Bastien Guerry's avatar
Bastien Guerry committed
669 670 671
The visited file needs to be part of a publishing project in
`org-publish-project-alist' for this to work.  The function
delegates most of the work to `org-protocol-create'."
672
  (interactive)
Rasmus's avatar
Rasmus committed
673
  (require 'ox-publish)
674 675
  (let ((all (or (org-publish-get-project-from-filename buffer-file-name))))
    (if all (org-protocol-create (cdr all))
Rasmus's avatar
Rasmus committed
676 677 678 679
      (message "%s"
	       (substitute-command-keys
		"Not in an Org project.  \
Did you mean `\\[org-protocol-create]'?")))))
680

681
(defun org-protocol-create (&optional project-plist)
682
  "Create a new org-protocol project interactively.
Bastien Guerry's avatar
Bastien Guerry committed
683 684 685 686 687
An org-protocol project is an entry in
`org-protocol-project-alist' which is used by
`org-protocol-open-source'.  Optionally use PROJECT-PLIST to
initialize the defaults for this project.  If PROJECT-PLIST is
the cdr of an element in `org-publish-project-alist', reuse
688 689
:base-directory, :html-extension and :base-extension."
  (interactive)
690 691 692
  (let ((working-dir (expand-file-name
		      (or (plist-get project-plist :base-directory)
			  default-directory)))
Rasmus's avatar
Rasmus committed
693
        (base-url "https://orgmode.org/worg/")
694 695 696 697 698 699 700 701
        (strip-suffix (or (plist-get project-plist :html-extension) ".html"))
        (working-suffix (if (plist-get project-plist :base-extension)
                            (concat "." (plist-get project-plist :base-extension))
                          ".org"))
        (insert-default-directory t)
        (minibuffer-allow-text-properties nil))

    (setq base-url (read-string "Base URL of published content: " base-url nil base-url t))
Rasmus's avatar
Rasmus committed
702 703
    (or (string-suffix-p "/" base-url)
	(setq base-url (concat base-url "/")))
704 705 706 707

    (setq working-dir
          (expand-file-name
           (read-directory-name "Local working directory: " working-dir working-dir t)))
Rasmus's avatar
Rasmus committed
708 709
    (or (string-suffix-p "/" working-dir)
	(setq working-dir (concat working-dir "/")))
710 711 712

    (setq strip-suffix
          (read-string
713
           (concat "Extension to strip from published URLs (" strip-suffix "): ")
714
	   strip-suffix nil strip-suffix t))
715 716 717

    (setq working-suffix
          (read-string
718
           (concat "Extension of editable files (" working-suffix "): ")
719
	   working-suffix nil working-suffix t))
720

721
    (when (yes-or-no-p "Save the new org-protocol-project to your init file? ")
722 723
      (setq org-protocol-project-alist
            (cons `(,base-url . (:base-url ,base-url
724 725 726
					   :working-directory ,working-dir
					   :online-suffix ,strip-suffix
					   :working-suffix ,working-suffix))
727 728 729 730
                  org-protocol-project-alist))
      (customize-save-variable 'org-protocol-project-alist org-protocol-project-alist))))

(provide 'org-protocol)
Glenn Morris's avatar
Glenn Morris committed
731

732
;;; org-protocol.el ends here