lisp/org-protocol.el

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