org-protocol.el 25.5 KB
Newer Older
1
;;; org-protocol.el --- Intercept calls from emacsclient to trigger custom actions.
2
;;
3
;; Copyright (C) 2008-2012  Free Software Foundation, Inc.
4
;;
5 6 7 8
;; Authors: Bastien Guerry <bzg AT gnu DOT org>
;;       Daniel M German <dmg AT uvic DOT org>
;;       Sebastian Rose <sebastian_rose AT gmx DOT de>
;;       Ross Patterson <me AT rpatterson DOT net>
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Keywords: org, emacsclient, wp

;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commentary:
;;
;; Intercept calls from emacsclient to trigger custom actions.
;;
32 33
;; This is done by advising `server-visit-files' to scan the list of filenames
;; for `org-protocol-the-protocol' and sub-protocols defined in
34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'.
;;
;; Any application that supports calling external programs with an URL
;; as argument may be used with this functionality.
;;
;;
;; Usage:
;; ------
;;
;;   1.) Add this to your init file (.emacs probably):
;;
;;       (add-to-list 'load-path "/path/to/org-protocol/")
;;       (require 'org-protocol)
;;
;;   3.) Ensure emacs-server is up and running.
;;   4.) Try this from the command line (adjust the URL as needed):
;;
;;       $ emacsclient \
;;         org-protocol://store-link://http:%2F%2Flocalhost%2Findex.html/The%20title
;;
;;   5.) Optionally add custom sub-protocols and handlers:
;;
;;       (setq org-protocol-protocol-alist
;;             '(("my-protocol"
;;                :protocol "my-protocol"
59
;;                :function my-protocol-handler-function)))
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
;;
;;       A "sub-protocol" will be found in URLs like this:
;;
;;           org-protocol://sub-protocol://data
;;
;; If it works, you can now setup other applications for using this feature.
;;
;;
;; As of March 2009 Firefox users follow the steps documented on
;; http://kb.mozillazine.org/Register_protocol, Opera setup is described here:
;; http://www.opera.com/support/kb/view/535/
;;
;;
;; Documentation
;; -------------
;;
;; org-protocol.el comes with and installs handlers to open sources of published
;; online content, store and insert the browser's URLs and cite online content
;; by clicking on a bookmark in Firefox, Opera and probably other browsers and
;; applications:
;;
;;   * `org-protocol-open-source' uses the sub-protocol \"open-source\" and maps
;;     URLs to local filenames defined in `org-protocol-project-alist'.
;;
;;   * `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 87
;;     triggered through the sub-protocol \"store-link\".
;;
88 89 90 91
;;   * Call `org-protocol-capture' by using the sub-protocol \"capture\".  If
;;     Org-mode is loaded, Emacs will pop-up a capture buffer and fill the
;;     template with the data provided.  I.e. the browser's URL is inserted as an
;;     Org-link of which the page title will be the description part.  If text
92 93
;;     was select in the browser, that text will be the body of the entry.
;;
94 95 96 97 98
;;   * Call `org-protocol-remember' by using the sub-protocol \"remember\".
;;     This is provided for backward compatibility.
;;     You may read `org-capture' as `org-remember' throughout this file if
;;     you still use `org-remember'.
;;
99 100 101 102 103 104 105 106
;; You may use the same bookmark URL for all those standard handlers and just
;; adjust the sub-protocol used:
;;
;;     location.href='org-protocol://sub-protocol://'+
;;           encodeURIComponent(location.href)+'/'+
;;           encodeURIComponent(document.title)+'/'+
;;           encodeURIComponent(window.getSelection())
;;
107
;; The handler for the sub-protocol \"capture\" detects an optional template
108 109 110 111 112 113 114
;; char that, if present, triggers the use of a special template.
;; Example:
;;
;;     location.href='org-protocol://sub-protocol://x/'+ ...
;;
;;  use template ?x.
;;
115 116
;; Note, that using double slashes is optional from org-protocol.el's point of
;; view because emacsclient squashes the slashes to one.
117 118 119 120 121 122 123 124 125 126 127 128
;;
;;
;; provides: 'org-protocol
;;
;;; Code:

(require 'org)
(eval-when-compile
  (require 'cl))

(declare-function org-publish-get-project-from-filename "org-publish"
		  (filename &optional up))
Glenn Morris's avatar
Glenn Morris committed
129
(declare-function server-edit "server" (&optional arg))
130

131 132 133 134 135 136 137 138 139 140 141 142
(define-obsolete-function-alias
  'org-protocol-unhex-compound 'org-link-unescape-compound
  "2011-02-17")

(define-obsolete-function-alias
  'org-protocol-unhex-string 'org-link-unescape
  "2011-02-17")

(define-obsolete-function-alias
  'org-protocol-unhex-single-byte-sequence
  'org-link-unescape-single-byte-sequence
  "2011-02-17")
143 144 145 146

(defgroup org-protocol nil
  "Intercept calls from emacsclient to trigger custom actions.

Paul Eggert's avatar
Paul Eggert committed
147 148
This is done by advising `server-visit-files' to scan the list of filenames
for `org-protocol-the-protocol' and sub-protocols defined in
149 150 151 152 153 154 155 156 157 158
`org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'."
  :version "22.1"
  :group 'convenience
  :group 'org)


;;; Variables:

(defconst org-protocol-protocol-alist-default
  '(("org-remember"    :protocol "remember"    :function org-protocol-remember :kill-client t)
159
    ("org-capture"     :protocol "capture"     :function org-protocol-capture  :kill-client t)
160 161 162 163 164 165 166
    ("org-store-link"  :protocol "store-link"  :function org-protocol-store-link)
    ("org-open-source" :protocol "open-source" :function org-protocol-open-source))
  "Default protocols to use.
See `org-protocol-protocol-alist' for a description of this variable.")

(defconst org-protocol-the-protocol "org-protocol"
  "This is the protocol to detect if org-protocol.el is loaded.
167 168 169 170
`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold
the sub-protocols that trigger the required action.  You will have to define
just one protocol handler OS-wide (MS-Windows) or per application (Linux).
That protocol handler should call emacsclient.")
171 172 173 174

;;; User variables:

(defcustom org-protocol-reverse-list-of-files t
175
  "Non-nil means re-reverse the list of filenames passed on the command line.
176 177 178
The filenames passed on the command line are passed to the emacs-server in
reverse order.  Set to t (default) to re-reverse the list, i.e. use the
sequence on the command line.  If nil, the sequence of the filenames is
179 180 181 182 183
unchanged."
  :group 'org-protocol
  :type 'boolean)

(defcustom org-protocol-project-alist nil
184
  "Map URLs to local filenames for `org-protocol-open-source' (open-source).
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199

Each element of this list must be of the form:

  (module-name :property value property: value ...)

where module-name is an arbitrary name. All the values are strings.

Possible properties are:

  :online-suffix     - the suffix to strip from the published URLs
  :working-suffix    - the replacement for online-suffix
  :base-url          - the base URL, e.g. http://www.example.com/project/
                       Last slash required.
  :working-directory - the local working directory. This is, what base-url will
                       be replaced with.
200 201
  :redirects         - A list of cons cells, each of which maps a regular
                       expression to match to a path relative to :working-directory.
202 203 204 205 206 207 208 209 210 211 212 213 214

Example:

   (setq org-protocol-project-alist
       '((\"http://orgmode.org/worg/\"
          :online-suffix \".php\"
          :working-suffix \".org\"
          :base-url \"http://orgmode.org/worg/\"
          :working-directory \"/home/user/org/Worg/\")
         (\"http://localhost/org-notes/\"
          :online-suffix \".html\"
          :working-suffix \".org\"
          :base-url \"http://localhost/org/\"
215 216 217 218 219 220
          :working-directory \"/home/user/org/\"
          :rewrites ((\"org/?$\" . \"index.php\")))))

   The last line tells `org-protocol-open-source' to open
   /home/user/org/index.php, if the URL cannot be mapped to an existing
   file, and ends with either \"org\" or \"org/\".
221 222 223 224 225 226 227

Consider using the interactive functions `org-protocol-create' and
`org-protocol-create-for-org' to help you filling this variable with valid contents."
  :group 'org-protocol
  :type 'alist)

(defcustom org-protocol-protocol-alist nil
228
  "Register custom handlers for org-protocol.
229 230 231 232 233 234 235 236 237 238

Each element of this list must be of the form:

  (module-name :protocol protocol :function func :kill-client nil)

protocol - protocol to detect in a filename without trailing colon and slashes.
           See rfc1738 section 2.1 for more on this.
           If you define a protocol \"my-protocol\", `org-protocol-check-filename-for-protocol'
           will search filenames for \"org-protocol:/my-protocol:/\"
           and trigger your action for every match. `org-protocol' is defined in
239
           `org-protocol-the-protocol'. Double and triple slashes are compressed
240 241 242 243 244 245 246 247 248 249 250 251
           to one by emacsclient.

function - function that handles requests with protocol and takes exactly one
           argument: the filename with all protocols stripped. If the function
           returns nil, emacsclient and -server do nothing. Any non-nil return
           value is considered a valid filename and thus passed to the server.

           `org-protocol.el provides some support for handling those filenames,
           if you stay with the conventions used for the standard handlers in
           `org-protocol-protocol-alist-default'. See `org-protocol-split-data'.

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 255 256 257 258 259 260 261
           line arguments but the this one will be discarded, greedy handlers
           still receive the whole list of arguments though.

Here is an example:

  (setq org-protocol-protocol-alist
      '((\"my-protocol\"
         :protocol \"my-protocol\"
262
         :function my-protocol-handler-function)
263 264
        (\"your-protocol\"
         :protocol \"your-protocol\"
265
         :function your-protocol-handler-function)))"
266 267 268
  :group 'org-protocol
  :type '(alist))

Carsten Dominik's avatar
Carsten Dominik committed
269
(defcustom org-protocol-default-template-key nil
270 271 272
  "The default template key to use.
This is usually a single character string but can also be a
string with two characters."
273 274 275 276 277 278
  :group 'org-protocol
  :type 'string)

;;; Helper functions:

(defun org-protocol-sanitize-uri (uri)
279
  "emacsclient compresses double and triple slashes.
280 281 282 283 284 285
Slashes are sanitized to double slashes here."
  (when (string-match "^\\([a-z]+\\):/" uri)
    (let* ((splitparts (split-string uri "/+")))
      (setq uri (concat (car splitparts) "//" (mapconcat 'identity (cdr splitparts) "/")))))
  uri)

286 287 288 289
(defun org-protocol-split-data (data &optional unhexify separator)
  "Split what an org-protocol handler function gets as only argument.
DATA is that one argument.  DATA is split at each occurrence of
SEPARATOR (regexp).  If no SEPARATOR is specified or SEPARATOR is
290
nil, assume \"/+\".  The results of that splitting are returned
291 292
as a list.  If UNHEXIFY is non-nil, hex-decode each split part.
If UNHEXIFY is a function, use that function to decode each split
293
part."
294 295 296 297 298
  (let* ((sep (or separator "/+"))
         (split-parts (split-string data sep)))
    (if unhexify
	(if (fboundp unhexify)
	    (mapcar unhexify split-parts)
299
	  (mapcar 'org-link-unescape split-parts))
300 301 302
      split-parts)))

(defun org-protocol-flatten-greedy (param-list &optional strip-path replacement)
Juanma Barranquero's avatar
Juanma Barranquero committed
303
  "Greedy handlers might receive a list like this from emacsclient:
304
 '((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\")
Juanma Barranquero's avatar
Juanma Barranquero committed
305
where \"/dir/\" is the absolute path to emacsclients working directory.  This
306
function transforms it into a flat list using `org-protocol-flatten' and
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
transforms the elements of that list as follows:

If strip-path is non-nil, remove the \"/dir/\" prefix from all members of
param-list.

If replacement is string, replace the \"/dir/\" prefix with it.

The first parameter, the one that contains the protocols, is always changed.
Everything up to the end of the protocols is stripped.

Note, that this function will always behave as if
`org-protocol-reverse-list-of-files' was set to t and the returned list will
reflect that. I.e. emacsclients first parameter will be the first one in the
returned list."
(let* ((l (org-protocol-flatten (if org-protocol-reverse-list-of-files
				    param-list
				  (reverse param-list))))
      (trigger (car l))
      (len 0)
      dir
      ret)
  (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-z0-9][-_a-zA-z0-9]*:/+\\)\\(.*\\)" trigger)
    (setq dir (match-string 1 trigger))
    (setq len (length dir))
    (setcar l (concat dir (match-string 3 trigger))))
  (if strip-path
      (progn
       (dolist (e l ret)
         (setq ret
               (append ret
                       (list
                        (if (stringp e)
                            (if (stringp replacement)
                                (setq e (concat replacement (substring e len)))
                              (setq e (substring e len)))
                          e)))))
       ret)
    l)))

(defun org-protocol-flatten (l)
Juanma Barranquero's avatar
Juanma Barranquero committed
347
  "Greedy handlers might receive a list like this from emacsclient:
348
 '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\")
Juanma Barranquero's avatar
Juanma Barranquero committed
349 350
where \"/dir/\" is the absolute path to emacsclients working directory.
This function transforms it into a flat list."
351 352 353 354 355
  (if (null l) ()
    (if (listp l)
       (append (org-protocol-flatten (car l)) (org-protocol-flatten (cdr l)))
      (list l))))

356

357 358 359
;;; Standard protocol handlers:

(defun org-protocol-store-link (fname)
360 361 362
  "Process an org-protocol://store-link:// style url.
Additionally store a browser URL as an org link. Also pushes the
link's URL to the `kill-ring'.
363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387

The location for a browser's bookmark has to look like this:

  javascript:location.href='org-protocol://store-link://'+ \\
        encodeURIComponent(location.href)
        encodeURIComponent(document.title)+'/'+ \\

Don't use `escape()'! Use `encodeURIComponent()' instead. The title of the page
could contain slashes and the location definitely will.

The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'."
  (let* ((splitparts (org-protocol-split-data fname t))
         (uri (org-protocol-sanitize-uri (car splitparts)))
         (title (cadr splitparts))
         orglink)
    (if (boundp 'org-stored-links)
      (setq org-stored-links (cons (list uri title) org-stored-links)))
    (kill-new uri)
    (message "`%s' to insert new org-link, `%s' to insert `%s'"
             (substitute-command-keys"\\[org-insert-link]")
             (substitute-command-keys"\\[yank]")
             uri))
  nil)

388
(defun org-protocol-remember (info)
389 390
  "Process an org-protocol://remember:// style url.

391 392 393 394 395 396 397 398 399 400
The location for a browser's bookmark has to look like this:

  javascript:location.href='org-protocol://remember://'+ \\
        encodeURIComponent(location.href)+'/' \\
        encodeURIComponent(document.title)+'/'+ \\
        encodeURIComponent(window.getSelection())

See the docs for `org-protocol-capture' for more information."

  (if (and (boundp 'org-stored-links)
401
           (fboundp 'org-capture)
402
	   (org-protocol-do-capture info 'org-remember))
403
      (message "Item remembered."))
404 405
  nil)

406
(defun org-protocol-capture (info)
407 408
  "Process an org-protocol://capture:// style url.

409 410 411
The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'.

412
This function detects an URL, title and optional text, separated by '/'
413 414
The location for a browser's bookmark has to look like this:

415
  javascript:location.href='org-protocol://capture://'+ \\
416 417 418 419 420
        encodeURIComponent(location.href)+'/' \\
        encodeURIComponent(document.title)+'/'+ \\
        encodeURIComponent(window.getSelection())

By default, it uses the character `org-protocol-default-template-key',
421
which should be associated with a template in `org-capture-templates'.
422 423
But you may prepend the encoded URL with a character and a slash like so:

424
  javascript:location.href='org-protocol://capture://b/'+ ...
425 426 427

Now template ?b will be used."
  (if (and (boundp 'org-stored-links)
428
           (fboundp 'org-capture)
429
	   (org-protocol-do-capture info 'org-capture))
430
      (message "Item captured."))
431 432
  nil)

433 434 435 436
(defun org-protocol-do-capture (info capture-func)
  "Support `org-capture' and `org-remember' alike.
CAPTURE-FUNC is either the symbol `org-remember' or `org-capture'."
  (let* ((parts (org-protocol-split-data info t))
437
	 (template (or (and (>= 2 (length (car parts))) (pop parts))
438 439 440 441
		       org-protocol-default-template-key))
	 (url (org-protocol-sanitize-uri (car parts)))
	 (type (if (string-match "^\\([a-z]+\\):" url)
		   (match-string 1 url)))
442
	 (title (or (cadr parts) ""))
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
	 (region (or (caddr parts) ""))
	 (orglink (org-make-link-string
		   url (if (string-match "[^[:space:]]" title) title url)))
	 (org-capture-link-is-already-stored t) ;; avoid call to org-store-link
	 remember-annotation-functions)
    (setq org-stored-links
	  (cons (list url title) org-stored-links))
    (kill-new orglink)
    (org-store-link-props :type type
			  :link url
			  :description title
			  :annotation orglink
			  :initial region)
    (raise-frame)
    (funcall capture-func nil template)))

459 460 461 462 463 464 465 466 467 468 469 470 471
(defun org-protocol-open-source (fname)
  "Process an org-protocol://open-source:// style url.

Change a filename by mapping URLs to local filenames as set
in `org-protocol-project-alist'.

The location for a browser's bookmark should look like this:

  javascript:location.href='org-protocol://open-source://'+ \\
        encodeURIComponent(location.href)"
  ;; As we enter this function for a match on our protocol, the return value
  ;; defaults to nil.
  (let ((result nil)
472
        (f (org-link-unescape fname)))
473 474 475 476 477 478 479 480 481
    (catch 'result
      (dolist (prolist org-protocol-project-alist)
        (let* ((base-url (plist-get (cdr prolist) :base-url))
               (wsearch (regexp-quote base-url)))

          (when (string-match wsearch f)
            (let* ((wdir (plist-get (cdr prolist) :working-directory))
                   (strip-suffix (plist-get (cdr prolist) :online-suffix))
                   (add-suffix (plist-get (cdr prolist) :working-suffix))
482 483 484 485
		   ;; Strip "[?#].*$" if `f' is a redirect with another
		   ;; ending than strip-suffix here:
		   (f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f)))
                   (start-pos (+ (string-match wsearch f1) (length base-url)))
486
                   (end-pos (string-match
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
			     (regexp-quote strip-suffix) f1))
		   ;; We have to compare redirects without suffix below:
		   (f2 (concat wdir (substring f1 start-pos end-pos)))
                   (the-file (concat f2 add-suffix)))

	      ;; Note: the-file may still contain `%C3' et al here because browsers
	      ;; tend to encode `&auml;' in URLs to `%25C3' - `%25' being `%'.
	      ;; So the results may vary.

	      ;; -- start redirects --
	      (unless (file-exists-p the-file)
		(message "File %s does not exist.\nTesting for rewritten URLs." the-file)
		(let ((rewrites (plist-get (cdr prolist) :rewrites)))
		  (when rewrites
		    (message "Rewrites found: %S" rewrites)
		    (mapc
		     (lambda (rewrite)
		       "Try to match a rewritten URL and map it to a real file."
		       ;; Compare redirects without suffix:
		       (if (string-match (car rewrite) f2)
			   (throw 'result (concat wdir (cdr rewrite)))))
		     rewrites))))
	      ;; -- end of redirects --

511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
              (if (file-readable-p the-file)
                  (throw 'result the-file))
              (if (file-exists-p the-file)
                  (message "%s: permission denied!" the-file)
                (message "%s: no such file or directory." the-file))))))
      result)))


;;; Core functions:

(defun org-protocol-check-filename-for-protocol (fname restoffiles client)
  "Detect if `org-protocol-the-protocol' and a known sub-protocol is used in fname.
Sub-protocols are registered in `org-protocol-protocol-alist' and
`org-protocol-protocol-alist-default'.
This is, how the matching is done:

  (string-match \"protocol:/+sub-protocol:/+\" ...)

protocol and sub-protocol are regexp-quoted.

531
If a matching protocol is found, the protocol is stripped from fname and the
532 533 534 535 536
result is passed to the protocols function as the only parameter. If the
function returns nil, the filename is removed from the list of filenames
passed from emacsclient to the server.
If the function returns a non nil value, that value is passed to the server
as filename."
537 538
  (let ((sub-protocols (append org-protocol-protocol-alist
			       org-protocol-protocol-alist-default)))
539 540 541 542
    (catch 'fname
      (let ((the-protocol (concat (regexp-quote org-protocol-the-protocol) ":/+")))
        (when (string-match the-protocol fname)
          (dolist (prolist sub-protocols)
543 544
            (let ((proto (concat the-protocol
				 (regexp-quote (plist-get (cdr prolist) :protocol)) ":/+")))
545 546 547
              (when (string-match proto fname)
                (let* ((func (plist-get (cdr prolist) :function))
                       (greedy (plist-get (cdr prolist) :greedy))
Paul Eggert's avatar
Paul Eggert committed
548 549
                       (split (split-string fname proto))
                       (result (if greedy restoffiles (cadr split))))
550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568
                  (when (plist-get (cdr prolist) :kill-client)
		    (message "Greedy org-protocol handler. Killing client.")
		    (server-edit))
                  (when (fboundp func)
                    (unless greedy
                      (throw 'fname (funcall func result)))
                    (funcall func result)
                    (throw 'fname t))))))))
      ;; (message "fname: %s" fname)
      fname)))

(defadvice server-visit-files (before org-protocol-detect-protocol-server activate)
  "Advice server-visit-flist to call `org-protocol-modify-filename-for-protocol'."
  (let ((flist (if org-protocol-reverse-list-of-files
                   (reverse  (ad-get-arg 0))
                 (ad-get-arg 0)))
        (client (ad-get-arg 1)))
    (catch 'greedy
      (dolist (var flist)
569 570 571 572
	;; `\' to `/' on windows. FIXME: could this be done any better?
        (let ((fname  (expand-file-name (car var))))
          (setq fname (org-protocol-check-filename-for-protocol
		       fname (member var flist)  client))
573 574 575 576 577 578
          (if (eq fname t) ;; greedy? We need the `t' return value.
              (progn
                (ad-set-arg 0 nil)
                (throw 'greedy t))
            (if (stringp fname) ;; probably filename
                (setcar var fname)
579
              (ad-set-arg 0 (delq var (ad-get-arg 0))))))))))
580 581 582 583 584 585

;;; Org specific functions:

(defun org-protocol-create-for-org ()
  "Create a org-protocol project for the current file's Org-mode project.
This works, if the file visited is part of a publishing project in
586
`org-publish-project-alist'.  This function calls `org-protocol-create' to do
587 588 589 590 591 592 593 594
most of the work."
  (interactive)
  (require 'org-publish)
  (let ((all (or (org-publish-get-project-from-filename buffer-file-name))))
    (if all (org-protocol-create (cdr all))
      (message "Not in an org-project. Did mean %s?"
               (substitute-command-keys"\\[org-protocol-create]")))))

595
(defun org-protocol-create (&optional project-plist)
596 597 598
  "Create a new org-protocol project interactively.
An org-protocol project is an entry in `org-protocol-project-alist'
which is used by `org-protocol-open-source'.
599
Optionally use project-plist to initialize the defaults for this project. If
600 601 602
project-plist is the CDR of an element in `org-publish-project-alist', reuse
:base-directory, :html-extension and :base-extension."
  (interactive)
603 604 605
  (let ((working-dir (expand-file-name
		      (or (plist-get project-plist :base-directory)
			  default-directory)))
606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
        (base-url "http://orgmode.org/worg/")
        (strip-suffix (or (plist-get project-plist :html-extension) ".html"))
        (working-suffix (if (plist-get project-plist :base-extension)
                            (concat "." (plist-get project-plist :base-extension))
                          ".org"))
        (worglet-buffer nil)
        (insert-default-directory t)
        (minibuffer-allow-text-properties nil))

    (setq base-url (read-string "Base URL of published content: " base-url nil base-url t))
    (if (not (string-match "\\/$" base-url))
        (setq base-url (concat base-url "/")))

    (setq working-dir
          (expand-file-name
           (read-directory-name "Local working directory: " working-dir working-dir t)))
    (if (not (string-match "\\/$" working-dir))
        (setq working-dir (concat working-dir "/")))

    (setq strip-suffix
          (read-string
627
           (concat "Extension to strip from published URLs (" strip-suffix "): ")
628 629 630 631
                   strip-suffix nil strip-suffix t))

    (setq working-suffix
          (read-string
632
           (concat "Extension of editable files (" working-suffix "): ")
633 634
                   working-suffix nil working-suffix t))

635
    (when (yes-or-no-p "Save the new org-protocol-project to your init file? ")
636 637 638 639 640 641 642 643 644
      (setq org-protocol-project-alist
            (cons `(,base-url . (:base-url ,base-url
                                 :working-directory ,working-dir
                                 :online-suffix ,strip-suffix
                                 :working-suffix ,working-suffix))
                  org-protocol-project-alist))
      (customize-save-variable 'org-protocol-project-alist org-protocol-project-alist))))

(provide 'org-protocol)
Glenn Morris's avatar
Glenn Morris committed
645

646
;;; org-protocol.el ends here