lisp/org-protocol.el

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