code.delx.au - gnu-emacs/blob - lisp/org/org-protocol.el

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