lisp/org-protocol.el

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