lisp/org-protocol.el

   1 ;;; org-protocol.el --- Intercept calls from emacsclient to trigger custom actions.
   2 ;;
   3 ;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
   4 ;;
   5 ;; Authors: Bastien Guerry <bzg AT gnu DOT 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://http:%2F%2Flocalhost%2Findex.html/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://data
  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 ;;   * Call `org-protocol-remember' by using the sub-protocol \"remember\".
  95 ;;     This is provided for backward compatibility.
  96 ;;     You may read `org-capture' as `org-remember' throughout this file if
  97 ;;     you still use `org-remember'.
  98 ;;
  99 ;; You may use the same bookmark URL for all those standard handlers and just
 100 ;; adjust the sub-protocol used:
 101 ;;
 102 ;;     location.href='org-protocol://sub-protocol://'+
 103 ;;           encodeURIComponent(location.href)+'/'+
 104 ;;           encodeURIComponent(document.title)+'/'+
 105 ;;           encodeURIComponent(window.getSelection())
 106 ;;
 107 ;; The handler for the sub-protocol \"capture\" detects an optional template
 108 ;; char that, if present, triggers the use of a special template.
 109 ;; Example:
 110 ;;
 111 ;;     location.href='org-protocol://sub-protocol://x/'+ ...
 112 ;;
 113 ;;  use template ?x.
 114 ;;
 115 ;; Note, that using double slashes is optional from org-protocol.el's point of
 116 ;; view because emacsclient squashes the slashes to one.
 117 ;;
 118 ;;
 119 ;; provides: 'org-protocol
 120 ;;
 121 ;;; Code:
 122
 123 (require 'org)
 124 (eval-when-compile
 125   (require 'cl))
 126
 127 (declare-function org-publish-get-project-from-filename "org-publish"
 128                   (filename &optional up))
 129 (declare-function server-edit "server" (&optional arg))
 130
 131 (org-define-obsolete-function-alias
 132   'org-protocol-unhex-compound 'org-link-unescape-compound
 133   "2011-02-17")
 134
 135 (org-define-obsolete-function-alias
 136   'org-protocol-unhex-string 'org-link-unescape
 137   "2011-02-17")
 138
 139 (org-define-obsolete-function-alias
 140   'org-protocol-unhex-single-byte-sequence
 141   'org-link-unescape-single-byte-sequence
 142   "2011-02-17")
 143
 144 (defgroup org-protocol nil
 145   "Intercept calls from emacsclient to trigger custom actions.
 146
 147 This is done by advising `server-visit-files' to scan the list of filenames
 148 for `org-protocol-the-protocol' and sub-protocols defined in
 149 `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'."
 150   :version "22.1"
 151   :group 'convenience
 152   :group 'org)
 153
 154
 155 ;;; Variables:
 156
 157 (defconst org-protocol-protocol-alist-default
 158   '(("org-remember"    :protocol "remember"    :function org-protocol-remember :kill-client t)
 159     ("org-capture"     :protocol "capture"     :function org-protocol-capture  :kill-client t)
 160     ("org-store-link"  :protocol "store-link"  :function org-protocol-store-link)
 161     ("org-open-source" :protocol "open-source" :function org-protocol-open-source))
 162   "Default protocols to use.
 163 See `org-protocol-protocol-alist' for a description of this variable.")
 164
 165 (defconst org-protocol-the-protocol "org-protocol"
 166   "This is the protocol to detect if org-protocol.el is loaded.
 167 `org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold
 168 the sub-protocols that trigger the required action.  You will have to define
 169 just one protocol handler OS-wide (MS-Windows) or per application (Linux).
 170 That protocol handler should call emacsclient.")
 171
 172 ;;; User variables:
 173
 174 (defcustom org-protocol-reverse-list-of-files t
 175   "Non-nil means re-reverse the list of filenames passed on the command line.
 176 The filenames passed on the command line are passed to the emacs-server in
 177 reverse order.  Set to t (default) to re-reverse the list, i.e. use the
 178 sequence on the command line.  If nil, the sequence of the filenames is
 179 unchanged."
 180   :group 'org-protocol
 181   :type 'boolean)
 182
 183 (defcustom org-protocol-project-alist nil
 184   "Map URLs to local filenames for `org-protocol-open-source' (open-source).
 185
 186 Each element of this list must be of the form:
 187
 188   (module-name :property value property: value ...)
 189
 190 where module-name is an arbitrary name.  All the values are strings.
 191
 192 Possible properties are:
 193
 194   :online-suffix     - the suffix to strip from the published URLs
 195   :working-suffix    - the replacement for online-suffix
 196   :base-url          - the base URL, e.g. http://www.example.com/project/
 197                        Last slash required.
 198   :working-directory - the local working directory.  This is, what base-url will
 199                        be replaced with.
 200   :redirects         - A list of cons cells, each of which maps a regular
 201                        expression to match to a path relative to :working-directory.
 202
 203 Example:
 204
 205    (setq org-protocol-project-alist
 206        '((\"http://orgmode.org/worg/\"
 207           :online-suffix \".php\"
 208           :working-suffix \".org\"
 209           :base-url \"http://orgmode.org/worg/\"
 210           :working-directory \"/home/user/org/Worg/\")
 211          (\"http://localhost/org-notes/\"
 212           :online-suffix \".html\"
 213           :working-suffix \".org\"
 214           :base-url \"http://localhost/org/\"
 215           :working-directory \"/home/user/org/\"
 216           :rewrites ((\"org/?$\" . \"index.php\")))))
 217
 218    The last line tells `org-protocol-open-source' to open
 219    /home/user/org/index.php, if the URL cannot be mapped to an existing
 220    file, and ends with either \"org\" or \"org/\".
 221
 222 Consider using the interactive functions `org-protocol-create' and
 223 `org-protocol-create-for-org' to help you filling this variable with valid contents."
 224   :group 'org-protocol
 225   :type 'alist)
 226
 227 (defcustom org-protocol-protocol-alist nil
 228   "Register custom handlers for org-protocol.
 229
 230 Each element of this list must be of the form:
 231
 232   (module-name :protocol protocol :function func :kill-client nil)
 233
 234 protocol - protocol to detect in a filename without trailing colon and slashes.
 235            See rfc1738 section 2.1 for more on this.
 236            If you define a protocol \"my-protocol\", `org-protocol-check-filename-for-protocol'
 237            will search filenames for \"org-protocol:/my-protocol:/\"
 238            and trigger your action for every match. `org-protocol' is defined in
 239            `org-protocol-the-protocol'.  Double and triple slashes are compressed
 240            to one by emacsclient.
 241
 242 function - function that handles requests with protocol and takes exactly one
 243            argument: the filename with all protocols stripped.  If the function
 244            returns nil, emacsclient and -server do nothing.  Any non-nil return
 245            value is considered a valid filename and thus passed to the server.
 246
 247            `org-protocol.el provides some support for handling those filenames,
 248            if you stay with the conventions used for the standard handlers in
 249            `org-protocol-protocol-alist-default'.  See `org-protocol-split-data'.
 250
 251 kill-client - If t, kill the client immediately, once the sub-protocol is
 252            detected.  This is necessary for actions that can be interrupted by
 253            `C-g' to avoid dangling emacsclients.  Note, that all other command
 254            line arguments but the this one will be discarded, greedy handlers
 255            still receive the whole list of arguments though.
 256
 257 Here is an example:
 258
 259   (setq org-protocol-protocol-alist
 260       '((\"my-protocol\"
 261          :protocol \"my-protocol\"
 262          :function my-protocol-handler-function)
 263         (\"your-protocol\"
 264          :protocol \"your-protocol\"
 265          :function your-protocol-handler-function)))"
 266   :group 'org-protocol
 267   :type '(alist))
 268
 269 (defcustom org-protocol-default-template-key nil
 270   "The default template key to use.
 271 This is usually a single character string but can also be a
 272 string with two characters."
 273   :group 'org-protocol
 274   :type 'string)
 275
 276 (defcustom org-protocol-data-separator "/+"
 277   "The default data separator to use.
 278    This should be a single regexp string."
 279   :group 'org-protocol
 280   :type 'string)
 281
 282 ;;; Helper functions:
 283
 284 (defun org-protocol-sanitize-uri (uri)
 285   "emacsclient compresses double and triple slashes.
 286 Slashes are sanitized to double slashes here."
 287   (when (string-match "^\\([a-z]+\\):/" uri)
 288     (let* ((splitparts (split-string uri "/+")))
 289       (setq uri (concat (car splitparts) "//" (mapconcat 'identity (cdr splitparts) "/")))))
 290   uri)
 291
 292 (defun org-protocol-split-data (data &optional unhexify separator)
 293   "Split what an org-protocol handler function gets as only argument.
 294 DATA is that one argument.  DATA is split at each occurrence of
 295 SEPARATOR (regexp).  If no SEPARATOR is specified or SEPARATOR is
 296 nil, assume \"/+\".  The results of that splitting are returned
 297 as a list.  If UNHEXIFY is non-nil, hex-decode each split part.
 298 If UNHEXIFY is a function, use that function to decode each split
 299 part."
 300   (let* ((sep (or separator "/+"))
 301          (split-parts (split-string data sep)))
 302     (if unhexify
 303         (if (fboundp unhexify)
 304             (mapcar unhexify split-parts)
 305           (mapcar 'org-link-unescape split-parts))
 306       split-parts)))
 307
 308 (defun org-protocol-flatten-greedy (param-list &optional strip-path replacement)
 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 emacsclients 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.  I.e. emacsclients 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 (defun org-protocol-flatten (l)
 353   "Greedy handlers might receive a list like this from emacsclient:
 354  '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\")
 355 where \"/dir/\" is the absolute path to emacsclients working directory.
 356 This function transforms it into a flat list."
 357   (if (null l) ()
 358     (if (listp l)
 359         (append (org-protocol-flatten (car l)) (org-protocol-flatten (cdr l)))
 360       (list l))))
 361
 362
 363 ;;; Standard protocol handlers:
 364
 365 (defun org-protocol-store-link (fname)
 366   "Process an org-protocol://store-link:// style url.
 367 Additionally store a browser URL as an org link.  Also pushes the
 368 link's URL to the `kill-ring'.
 369
 370 The location for a browser's bookmark has to look like this:
 371
 372   javascript:location.href='org-protocol://store-link://'+ \\
 373         encodeURIComponent(location.href)
 374         encodeURIComponent(document.title)+'/'+ \\
 375
 376 Don't use `escape()'! Use `encodeURIComponent()' instead.  The title of the page
 377 could contain slashes and the location definitely will.
 378
 379 The sub-protocol used to reach this function is set in
 380 `org-protocol-protocol-alist'."
 381   (let* ((splitparts (org-protocol-split-data fname t org-protocol-data-separator))
 382          (uri (org-protocol-sanitize-uri (car splitparts)))
 383          (title (cadr splitparts))
 384          orglink)
 385     (if (boundp 'org-stored-links)
 386         (setq org-stored-links (cons (list uri title) org-stored-links)))
 387     (kill-new uri)
 388     (message "`%s' to insert new org-link, `%s' to insert `%s'"
 389              (substitute-command-keys"\\[org-insert-link]")
 390              (substitute-command-keys"\\[yank]")
 391              uri))
 392   nil)
 393
 394 (defun org-protocol-remember (info)
 395   "Process an org-protocol://remember:// style url.
 396
 397 The location for a browser's bookmark has to look like this:
 398
 399   javascript:location.href='org-protocol://remember://'+ \\
 400         encodeURIComponent(location.href)+'/' \\
 401         encodeURIComponent(document.title)+'/'+ \\
 402         encodeURIComponent(window.getSelection())
 403
 404 See the docs for `org-protocol-capture' for more information."
 405
 406   (if (and (boundp 'org-stored-links)
 407            (fboundp 'org-capture)
 408            (org-protocol-do-capture info 'org-remember))
 409       (message "Item remembered."))
 410   nil)
 411
 412 (defun org-protocol-capture (info)
 413   "Process an org-protocol://capture:// style url.
 414
 415 The sub-protocol used to reach this function is set in
 416 `org-protocol-protocol-alist'.
 417
 418 This function detects an URL, title and optional text, separated by '/'
 419 The location for a browser's bookmark has to look like this:
 420
 421   javascript:location.href='org-protocol://capture://'+ \\
 422         encodeURIComponent(location.href)+'/' \\
 423         encodeURIComponent(document.title)+'/'+ \\
 424         encodeURIComponent(window.getSelection())
 425
 426 By default, it uses the character `org-protocol-default-template-key',
 427 which should be associated with a template in `org-capture-templates'.
 428 But you may prepend the encoded URL with a character and a slash like so:
 429
 430   javascript:location.href='org-protocol://capture://b/'+ ...
 431
 432 Now template ?b will be used."
 433   (if (and (boundp 'org-stored-links)
 434            (fboundp 'org-capture)
 435            (org-protocol-do-capture info 'org-capture))
 436       (message "Item captured."))
 437   nil)
 438
 439 (defun org-protocol-do-capture (info capture-func)
 440   "Support `org-capture' and `org-remember' alike.
 441 CAPTURE-FUNC is either the symbol `org-remember' or `org-capture'."
 442   (let* ((parts (org-protocol-split-data info t org-protocol-data-separator))
 443          (template (or (and (>= 2 (length (car parts))) (pop parts))
 444                        org-protocol-default-template-key))
 445          (url (org-protocol-sanitize-uri (car parts)))
 446          (type (if (string-match "^\\([a-z]+\\):" url)
 447                    (match-string 1 url)))
 448          (title (or (cadr parts) ""))
 449          (region (or (caddr parts) ""))
 450          (orglink (org-make-link-string
 451                    url (if (string-match "[^[:space:]]" title) title url)))
 452          (org-capture-link-is-already-stored t) ;; avoid call to org-store-link
 453          remember-annotation-functions)
 454     (setq org-stored-links
 455           (cons (list url title) org-stored-links))
 456     (kill-new orglink)
 457     (org-store-link-props :type type
 458                           :link url
 459                           :description title
 460                           :annotation orglink
 461                           :initial region)
 462     (raise-frame)
 463     (funcall capture-func nil template)))
 464
 465 (defun org-protocol-open-source (fname)
 466   "Process an org-protocol://open-source:// style url.
 467
 468 Change a filename by mapping URLs to local filenames as set
 469 in `org-protocol-project-alist'.
 470
 471 The location for a browser's bookmark should look like this:
 472
 473   javascript:location.href='org-protocol://open-source://'+ \\
 474         encodeURIComponent(location.href)"
 475   ;; As we enter this function for a match on our protocol, the return value
 476   ;; defaults to nil.
 477   (let ((result nil)
 478         (f (org-link-unescape fname)))
 479     (catch 'result
 480       (dolist (prolist org-protocol-project-alist)
 481         (let* ((base-url (plist-get (cdr prolist) :base-url))
 482                (wsearch (regexp-quote base-url)))
 483
 484           (when (string-match wsearch f)
 485             (let* ((wdir (plist-get (cdr prolist) :working-directory))
 486                    (strip-suffix (plist-get (cdr prolist) :online-suffix))
 487                    (add-suffix (plist-get (cdr prolist) :working-suffix))
 488                    ;; Strip "[?#].*$" if `f' is a redirect with another
 489                    ;; ending than strip-suffix here:
 490                    (f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f)))
 491                    (start-pos (+ (string-match wsearch f1) (length base-url)))
 492                    (end-pos (string-match
 493                              (regexp-quote strip-suffix) f1))
 494                    ;; We have to compare redirects without suffix below:
 495                    (f2 (concat wdir (substring f1 start-pos end-pos)))
 496                    (the-file (concat f2 add-suffix)))
 497
 498               ;; Note: the-file may still contain `%C3' et al here because browsers
 499               ;; tend to encode `&auml;' in URLs to `%25C3' - `%25' being `%'.
 500               ;; So the results may vary.
 501
 502               ;; -- start redirects --
 503               (unless (file-exists-p the-file)
 504                 (message "File %s does not exist.\nTesting for rewritten URLs." the-file)
 505                 (let ((rewrites (plist-get (cdr prolist) :rewrites)))
 506                   (when rewrites
 507                     (message "Rewrites found: %S" rewrites)
 508                     (mapc
 509                      (lambda (rewrite)
 510                        "Try to match a rewritten URL and map it to a real file."
 511                        ;; Compare redirects without suffix:
 512                        (if (string-match (car rewrite) f2)
 513                            (throw 'result (concat wdir (cdr rewrite)))))
 514                      rewrites))))
 515               ;; -- end of redirects --
 516
 517               (if (file-readable-p the-file)
 518                   (throw 'result the-file))
 519               (if (file-exists-p the-file)
 520                   (message "%s: permission denied!" the-file)
 521                 (message "%s: no such file or directory." the-file))))))
 522       result)))
 523
 524
 525 ;;; Core functions:
 526
 527 (defun org-protocol-check-filename-for-protocol (fname restoffiles client)
 528   "Detect if `org-protocol-the-protocol' and a known sub-protocol is used in fname.
 529 Sub-protocols are registered in `org-protocol-protocol-alist' and
 530 `org-protocol-protocol-alist-default'.
 531 This is, how the matching is done:
 532
 533   (string-match \"protocol:/+sub-protocol:/+\" ...)
 534
 535 protocol and sub-protocol are regexp-quoted.
 536
 537 If a matching protocol is found, the protocol is stripped from fname and the
 538 result is passed to the protocols function as the only parameter.  If the
 539 function returns nil, the filename is removed from the list of filenames
 540 passed from emacsclient to the server.
 541 If the function returns a non nil value, that value is passed to the server
 542 as filename."
 543   (let ((sub-protocols (append org-protocol-protocol-alist
 544                                org-protocol-protocol-alist-default)))
 545     (catch 'fname
 546       (let ((the-protocol (concat (regexp-quote org-protocol-the-protocol) ":/+")))
 547         (when (string-match the-protocol fname)
 548           (dolist (prolist sub-protocols)
 549             (let ((proto (concat the-protocol
 550                                  (regexp-quote (plist-get (cdr prolist) :protocol)) ":/+")))
 551               (when (string-match proto fname)
 552                 (let* ((func (plist-get (cdr prolist) :function))
 553                        (greedy (plist-get (cdr prolist) :greedy))
 554                        (split (split-string fname proto))
 555                        (result (if greedy restoffiles (cadr split))))
 556                   (when (plist-get (cdr prolist) :kill-client)
 557                     (message "Greedy org-protocol handler.  Killing client.")
 558                     (server-edit))
 559                   (when (fboundp func)
 560                     (unless greedy
 561                       (throw 'fname (funcall func result)))
 562                     (funcall func result)
 563                     (throw 'fname t))))))))
 564       ;; (message "fname: %s" fname)
 565       fname)))
 566
 567 (defadvice server-visit-files (before org-protocol-detect-protocol-server activate)
 568   "Advice server-visit-flist to call `org-protocol-modify-filename-for-protocol'."
 569   (let ((flist (if org-protocol-reverse-list-of-files
 570                    (reverse  (ad-get-arg 0))
 571                  (ad-get-arg 0)))
 572         (client (ad-get-arg 1)))
 573     (catch 'greedy
 574       (dolist (var flist)
 575         ;; `\' to `/' on windows.  FIXME: could this be done any better?
 576         (let ((fname  (expand-file-name (car var))))
 577           (setq fname (org-protocol-check-filename-for-protocol
 578                        fname (member var flist)  client))
 579           (if (eq fname t) ;; greedy? We need the `t' return value.
 580               (progn
 581                 (ad-set-arg 0 nil)
 582                 (throw 'greedy t))
 583             (if (stringp fname) ;; probably filename
 584                 (setcar var fname)
 585               (ad-set-arg 0 (delq var (ad-get-arg 0))))))))))
 586
 587 ;;; Org specific functions:
 588
 589 (defun org-protocol-create-for-org ()
 590   "Create a org-protocol project for the current file's Org-mode project.
 591 This works, if the file visited is part of a publishing project in
 592 `org-publish-project-alist'.  This function calls `org-protocol-create' to do
 593 most of the work."
 594   (interactive)
 595   (require 'org-publish)
 596   (let ((all (or (org-publish-get-project-from-filename buffer-file-name))))
 597     (if all (org-protocol-create (cdr all))
 598       (message "Not in an org-project.  Did mean %s?"
 599                (substitute-command-keys"\\[org-protocol-create]")))))
 600
 601 (defun org-protocol-create (&optional project-plist)
 602   "Create a new org-protocol project interactively.
 603 An org-protocol project is an entry in `org-protocol-project-alist'
 604 which is used by `org-protocol-open-source'.
 605 Optionally use project-plist to initialize the defaults for this project.  If
 606 project-plist is the CDR of an element in `org-publish-project-alist', reuse
 607 :base-directory, :html-extension and :base-extension."
 608   (interactive)
 609   (let ((working-dir (expand-file-name
 610                       (or (plist-get project-plist :base-directory)
 611                           default-directory)))
 612         (base-url "http://orgmode.org/worg/")
 613         (strip-suffix (or (plist-get project-plist :html-extension) ".html"))
 614         (working-suffix (if (plist-get project-plist :base-extension)
 615                             (concat "." (plist-get project-plist :base-extension))
 616                           ".org"))
 617         (worglet-buffer nil)
 618         (insert-default-directory t)
 619         (minibuffer-allow-text-properties nil))
 620
 621     (setq base-url (read-string "Base URL of published content: " base-url nil base-url t))
 622     (if (not (string-match "\\/$" base-url))
 623         (setq base-url (concat base-url "/")))
 624
 625     (setq working-dir
 626           (expand-file-name
 627            (read-directory-name "Local working directory: " working-dir working-dir t)))
 628     (if (not (string-match "\\/$" working-dir))
 629         (setq working-dir (concat working-dir "/")))
 630
 631     (setq strip-suffix
 632           (read-string
 633            (concat "Extension to strip from published URLs (" strip-suffix "): ")
 634            strip-suffix nil strip-suffix t))
 635
 636     (setq working-suffix
 637           (read-string
 638            (concat "Extension of editable files (" working-suffix "): ")
 639            working-suffix nil working-suffix t))
 640
 641     (when (yes-or-no-p "Save the new org-protocol-project to your init file? ")
 642       (setq org-protocol-project-alist
 643             (cons `(,base-url . (:base-url ,base-url
 644                                            :working-directory ,working-dir
 645                                            :online-suffix ,strip-suffix
 646                                            :working-suffix ,working-suffix))
 647                   org-protocol-project-alist))
 648       (customize-save-variable 'org-protocol-project-alist org-protocol-project-alist))))
 649
 650 (provide 'org-protocol)
 651
 652 ;;; org-protocol.el ends here