lisp/org-protocol.el

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