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