From 080642a2452995f67709becc37e76ee5dd1dc8d3 Mon Sep 17 00:00:00 2001 From: Sacha Chua Date: Wed, 2 Dec 2015 10:53:07 -0500 Subject: [PATCH] org-protocol: Allow key=val&key2=val2-style URLs * lisp/org-protocol.el: Update documentation. (org-protocol-store-link, org-protocol-capture, org-protocol-open-source): Accept new-style links. (org-protocol-check-filename-for-protocol): Updated documentation. (org-protocol-parse-parameters, org-protocol-assign-parameters): New functions. This allows the use of org-protocol on KDE 5 and makes org-protocol links more URI-like. New-style links are of the form: org-protocol://store-link?title=TITLE&url=URL * testing/lisp/test-org-protocol.el: New file. --- lisp/org-protocol.el | 191 ++++++++++++++++++++++++++------------ testing/lisp/test-org-protocol.el | 181 ++++++++++++++++++++++++++++++++++++ 2 files changed, 315 insertions(+), 57 deletions(-) create mode 100644 testing/lisp/test-org-protocol.el diff --git a/lisp/org-protocol.el b/lisp/org-protocol.el index 339f2b7..ce7cb36 100644 --- a/lisp/org-protocol.el +++ b/lisp/org-protocol.el @@ -49,7 +49,7 @@ ;; 4.) Try this from the command line (adjust the URL as needed): ;; ;; $ emacsclient \ -;; org-protocol://store-link://http:%2F%2Flocalhost%2Findex.html/The%20title +;; org-protocol://store-link?url=http:%2F%2Flocalhost%2Findex.html&title=The%20title ;; ;; 5.) Optionally add custom sub-protocols and handlers: ;; @@ -60,7 +60,7 @@ ;; ;; A "sub-protocol" will be found in URLs like this: ;; -;; org-protocol://sub-protocol://data +;; org-protocol://sub-protocol?key=val&key2=val2 ;; ;; If it works, you can now setup other applications for using this feature. ;; @@ -94,20 +94,20 @@ ;; 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)+'/'+ +;; location.href='org-protocol://sub-protocol?url='+ +;; encodeURIComponent(location.href)+'&title='+ +;; encodeURIComponent(document.title)+'&body='+ ;; encodeURIComponent(window.getSelection()) ;; ;; The handler for the sub-protocol \"capture\" detects an optional template ;; char that, if present, triggers the use of a special template. ;; Example: ;; -;; location.href='org-protocol://sub-protocol://x/'+ ... +;; location.href='org-protocol://capture?template=x'+ ... ;; -;; use template ?x. +;; uses template ?x. ;; -;; Note, that using double slashes is optional from org-protocol.el's point of +;; Note that using double slashes is optional from org-protocol.el's point of ;; view because emacsclient squashes the slashes to one. ;; ;; @@ -233,19 +233,27 @@ protocol - protocol to detect in a filename without trailing colon and slashes. `org-protocol-the-protocol'. Double and triple slashes are compressed 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. +function - function that handles requests with protocol and takes + one argument. If a new-style link (key=val&key2=val2) + is given, the argument will be a property list with + the values from the link. If an old-style link is + given (val1/val2), the argument will be the filename + with all protocols stripped. - `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'. + 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 + old-style filenames, if you stay with the conventions + used for the standard handlers in + `org-protocol-protocol-alist-default'. See + `org-protocol-parse-parameters'. kill-client - If t, kill the client immediately, once the sub-protocol is detected. This is necessary for actions that can be interrupted by - `C-g' to avoid dangling emacsclients. Note, that all other command - line arguments but the this one will be discarded, greedy handlers + `C-g' to avoid dangling emacsclients. Note that all other command + line arguments but the this one will be discarded. Greedy handlers still receive the whole list of arguments though. Here is an example: @@ -286,8 +294,8 @@ Slashes are sanitized to double slashes here." uri) (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 + "Split what an org-protocol handler function gets as the first +argument. DATA is that one argument. DATA is split at each occurrence of SEPARATOR (regexp). If no SEPARATOR is specified or SEPARATOR is nil, assume \"/+\". The results of that splitting are returned as a list. If UNHEXIFY is non-nil, hex-decode each split part. @@ -355,28 +363,80 @@ This function transforms it into a flat list." (append (org-protocol-flatten (car l)) (org-protocol-flatten (cdr l))) (list l)))) +(defun org-protocol-parse-parameters (info &optional new-style default-order) + "Return a property list of parameters from INFO. +If NEW-STYLE is non-nil, treat INFO as a query string (ex: +url=URL&title=TITLE) If old-style links are used (ex: +org-protocol://store-link/url/title), assign them to attributes +following DEFAULT-ORDER. + +If no DEFAULT-ORDER is specified, return the list of values. + +If INFO is already a property list, return it unchanged." + (if (listp info) + info + (if new-style + (let ((data (org-protocol-convert-query-to-plist info)) + result) + (while data + (setq result + (append + result + (list + (pop data) + (org-link-unescape (pop data)))))) + result) + (let ((data (org-protocol-split-data info t org-protocol-data-separator))) + (if default-order + (org-protocol-assign-parameters data default-order) + data))))) + +(defun org-protocol-assign-parameters (data default-order) + "Return a property list of parameters from DATA. +Key names are taken from DEFAULT-ORDER, which should be a list of +symbols. If DEFAULT-ORDER is shorter than the number of values +specified, the rest of the values are treated as :key value pairs." + (let (result) + (while default-order + (setq result + (append result + (list (pop default-order) + (pop data))))) + (while data + (setq result + (append result + (list (intern (concat ":" (pop data))) + (pop data))))) + result)) ;;; Standard protocol handlers: (defun org-protocol-store-link (fname) - "Process an org-protocol://store-link:// style url. + "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'. +Parameters: url, title (optional), body (optional) + +Old-style links such as org-protocol://store-link://URL/TITLE are also recognized. + 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)+\\='/\\='+ \\ + javascript:location.href = \\='org-protocol://store-link?url=\\='+ \\ + encodeURIComponent(location.href) + \\='&title=\\=' \\ + 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 org-protocol-data-separator)) - (uri (org-protocol-sanitize-uri (car splitparts))) - (title (cadr splitparts)) +`org-protocol-protocol-alist'. + +FNAME should be a property list. If not, an old-style link of the +form URL/TITLE can also be used." + (let* ((splitparts (org-protocol-parse-parameters fname nil '(:url :title))) + (uri (org-protocol-sanitize-uri (plist-get splitparts :url))) + (title (plist-get splitparts :title)) orglink) (if (boundp 'org-stored-links) (setq org-stored-links (cons (list uri title) org-stored-links))) @@ -388,7 +448,7 @@ The sub-protocol used to reach this function is set in nil) (defun org-protocol-capture (info) - "Process an org-protocol://capture:// style url. + "Process an org-protocol://capture style url. The sub-protocol used to reach this function is set in `org-protocol-protocol-alist'. @@ -396,16 +456,16 @@ The sub-protocol used to reach this function is set in This function detects an URL, title and optional text, separated by `/'. The location for a browser's bookmark looks like this: - javascript:location.href=\\='org-protocol://capture://\\='+ \\ - encodeURIComponent(location.href)+\\='/\\=' \\ - encodeURIComponent(document.title)+\\='/\\='+ \\ + javascript:location.href = \\='org-protocol://capture?url=\\='+ \\ + encodeURIComponent(location.href) + \\='&title=\\=' \\ + encodeURIComponent(document.title) + \\='&body=\\=' + \\ encodeURIComponent(window.getSelection()) By default, it uses the character `org-protocol-default-template-key', which should be associated with a template in `org-capture-templates'. -But you may prepend the encoded URL with a character and a slash like so: +But you may specify the template with a template= query parameter, like this: - javascript:location.href=\\='org-protocol://capture://b/\\='+ ... + javascript:location.href = \\='org-protocol://capture?template=b\\='+ ... Now template ?b will be used." (if (and (boundp 'org-stored-links) @@ -423,17 +483,23 @@ Now template ?b will be used." (defun org-protocol-do-capture (info) "Support `org-capture'." - (let* ((parts (org-protocol-split-data info t org-protocol-data-separator)) - (template (or (and (>= 2 (length (car parts))) (pop parts)) + (let* ((temp-parts (org-protocol-parse-parameters info)) + (parts + (cond + ((listp info) info) + ((= (length (car temp-parts)) 1) ;; First parameter is exactly one character long + (org-protocol-assign-parameters temp-parts '(:template :url :title :body))) + (t + (org-protocol-assign-parameters temp-parts '(:url :title :body))))) + (template (or (plist-get parts :template) org-protocol-default-template-key)) - (url (org-protocol-sanitize-uri (car parts))) + (url (org-protocol-sanitize-uri (plist-get parts :url))) (type (if (string-match "^\\([a-z]+\\):" url) (match-string 1 url))) - (title (or (cadr parts) "")) - (region (or (caddr parts) "")) + (title (or (plist-get parts :title) "")) + (region (or (plist-get parts :body) "")) (orglink (org-make-link-string url (if (string-match "[^[:space:]]" title) title url))) - (query (or (org-protocol-convert-query-to-plist (cadddr parts)) "")) (org-capture-link-is-already-stored t)) ;; avoid call to org-store-link (setq org-stored-links (cons (list url title) org-stored-links)) @@ -443,24 +509,24 @@ Now template ?b will be used." :description title :annotation orglink :initial region - :query query) + :query parts) (raise-frame) (funcall 'org-capture nil template))) (defun org-protocol-open-source (fname) - "Process an org-protocol://open-source:// style url. + "Process an org-protocol://open-source?url= 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://\\='+ \\ + javascript:location.href = \\='org-protocol://open-source?url=\\=' + \\ encodeURIComponent(location.href)" ;; As we enter this function for a match on our protocol, the return value ;; defaults to nil. (let ((result nil) - (f (org-link-unescape fname))) + (f (plist-get (org-protocol-parse-parameters fname nil '(:url)) :url))) (catch 'result (dolist (prolist org-protocol-project-alist) (let* ((base-url (plist-get (cdr prolist) :base-url)) @@ -510,21 +576,26 @@ The location for a browser's bookmark should look like this: ;;; 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. + "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: +This is how the matching is done: - (string-match \"protocol:/+sub-protocol:/+\" ...) + (string-match \"protocol:/+sub-protocol\\\\(://\\\\|\\\\?\\\\)\" ...) protocol and sub-protocol are regexp-quoted. -If a matching protocol is found, the protocol is stripped from fname and the -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." +Old-style links such as \"protocol://sub-protocol://param1/param2\" are +also recognized. + +If a matching protocol is found, the protocol is stripped from +fname and the result is passed to the protocol function as the +first parameter. The second parameter will be non-nil if FNAME +uses key=val&key2=val2-type arguments, or nil if FNAME uses +val/val2-type arguments. 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." (let ((sub-protocols (append org-protocol-protocol-alist org-protocol-protocol-alist-default))) (catch 'fname @@ -532,21 +603,27 @@ as filename." (when (string-match the-protocol fname) (dolist (prolist sub-protocols) (let ((proto (concat the-protocol - (regexp-quote (plist-get (cdr prolist) :protocol)) ":/+"))) + (regexp-quote (plist-get (cdr prolist) :protocol)) "\\(:/+\\|\\?\\)"))) (when (string-match proto fname) (let* ((func (plist-get (cdr prolist) :function)) (greedy (plist-get (cdr prolist) :greedy)) (split (split-string fname proto)) - (result (if greedy restoffiles (cadr split)))) + (result (if greedy restoffiles (cadr split))) + (new-style (string= (match-string 1 fname) "?"))) (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 + (condition-case err + (funcall func (org-protocol-parse-parameters result new-style)) + ('error + (warn "Please update your org protocol handler to deal with new-style links.") + (funcall func result))))) + ;; Greedy protocol handlers are responsible for parsing their own filenames + (funcall func result) (throw 'fname t)))))))) - ;; (message "fname: %s" fname) fname))) (defadvice server-visit-files (before org-protocol-detect-protocol-server activate) diff --git a/testing/lisp/test-org-protocol.el b/testing/lisp/test-org-protocol.el new file mode 100644 index 0000000..817c09c --- /dev/null +++ b/testing/lisp/test-org-protocol.el @@ -0,0 +1,181 @@ +;;; test-org-protocol.el --- tests for org-protocol.el -*- lexical-binding: t; -*- + +;; Copyright (c) Sacha Chua +;; Authors: Sacha Chua + +;; This file is not part of GNU Emacs. + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Code: + +(require 'cl-lib) + +(unless (featurep 'org-protocol) + (signal 'missing-test-dependency "Support for org-protocol")) + +(ert-deftest test-org-protocol/org-protocol-parse-parameters () + "Test `org-protocol-parse-parameters' specifications." + ;; Ignore lists + (let ((data (org-protocol-parse-parameters '(:url "abc" :title "def") nil))) + (should (string= (plist-get data :url) "abc")) + (should (string= (plist-get data :title) "def"))) + ;; Parse new-style links + (let ((data (org-protocol-parse-parameters "url=abc&title=def" t))) + (should (string= (plist-get data :url) "abc")) + (should (string= (plist-get data :title) "def"))) + ;; Parse old-style links + (let ((data (org-protocol-parse-parameters "abc/def" nil '(:url :title)))) + (should (string= (plist-get data :url) "abc")) + (should (string= (plist-get data :title) "def"))) + ;; Parse old-style links even without keys + (let ((data (org-protocol-parse-parameters "b/abc/def" nil))) + (should (equal data '("b" "abc" "def")))) + ;; Parse old-style links with key/val pairs + (let ((data (org-protocol-parse-parameters "b/abc/extrakey/extraval" nil '(:param1 :param2)))) + (should (string= (plist-get data :param1) "b")) + (should (string= (plist-get data :param2) "abc")) + (should (string= (plist-get data :extrakey) "extraval")))) + +(ert-deftest test-org-protocol/org-protocol-store-link () + "Test `org-protocol-store-link' specifications." + ;; Old link style + (let ((uri "/some/directory/org-protocol:/store-link:/URL/TITLE")) + (should (null (org-protocol-check-filename-for-protocol uri (list uri) nil))) + (should (equal (car org-stored-links) '("URL" "TITLE")))) + ;; URL encoded + (let ((uri (format "/some/directory/org-protocol:/store-link:/%s/TITLE" + (url-hexify-string "http://example.com")))) + (should (null (org-protocol-check-filename-for-protocol uri (list uri) nil))) + (should (equal (car org-stored-links) '("http://example.com" "TITLE")))) + ;; Handle multiple slashes, old link style + (let ((uri "/some/directory/org-protocol://store-link://URL2//TITLE2")) + (should (null (org-protocol-check-filename-for-protocol uri (list uri) nil))) + (should (equal (car org-stored-links) '("URL2" "TITLE2")))) + ;; New link style + (let ((uri "/some/directory/org-protocol://store-link?url=URL3&title=TITLE3")) + (should (null (org-protocol-check-filename-for-protocol uri (list uri) nil))) + (should (equal (car org-stored-links) '("URL3" "TITLE3"))))) + +(ert-deftest test-org-protocol/org-protocol-capture () + "Test `org-protocol-capture' specifications." + (let* ((org-protocol-default-template-key "t") + (temp-file-name (make-temp-file "org-protocol-test")) + (org-capture-templates + `(("t" "Test" entry (file ,temp-file-name) "** TODO\n\n%i\n\n%a\n" :kill-buffer t) + ("x" "With params" entry (file ,temp-file-name) "** SOMEDAY\n\n%i\n\n%a\n" :kill-buffer t))) + (test-urls + '( + ;; Old style: + ;; - multiple slashes + ("/some/directory/org-protocol:/capture:/URL/TITLE" + . "** TODO\n\n\n\n[[URL][TITLE]]\n") + ;; - body specification + ("/some/directory/org-protocol:/capture:/URL/TITLE/BODY" + . "** TODO\n\nBODY\n\n[[URL][TITLE]]\n") + ;; - template + ("/some/directory/org-protocol:/capture:/x/URL/TITLE/BODY" + . "** SOMEDAY\n\nBODY\n\n[[URL][TITLE]]\n") + ;; - query parameters, not sure how to include them in template + ("/some/directory/org-protocol:/capture:/x/URL/TITLE/BODY/from/example" + . "** SOMEDAY\n\nBODY\n\n[[URL][TITLE]]\n") + ;; New style: + ;; - multiple slashes + ("/some/directory/org-protocol:/capture?url=NEWURL&title=TITLE" + . "** TODO\n\n\n\n[[NEWURL][TITLE]]\n") + ;; - body specification + ("/some/directory/org-protocol:/capture?url=NEWURL&title=TITLE&body=BODY" + . "** TODO\n\nBODY\n\n[[NEWURL][TITLE]]\n") + ;; - template + ("/some/directory/org-protocol:/capture?template=x&url=NEWURL&title=TITLE&body=BODY" + . "** SOMEDAY\n\nBODY\n\n[[NEWURL][TITLE]]\n") + ;; - query parameters, not sure how to include them in template + ("/some/directory/org-protocol:/capture?template=x&url=URL&title=TITLE&body=BODY&from=example" + . "** SOMEDAY\n\nBODY\n\n[[URL][TITLE]]\n") + ))) + ;; Old link style + (mapc + (lambda (test-case) + (let ((uri (car test-case))) + (org-protocol-check-filename-for-protocol uri (list uri) nil) + (should (string= (buffer-string) (cdr test-case))) + (org-capture-kill))) + test-urls) + (delete-file temp-file-name))) + +(ert-deftest test-org-protocol/org-protocol-open-source () + "Test org-protocol://open-source links." + (let* ((temp-file-name1 (make-temp-file "org-protocol-test1")) + (temp-file-name2 (make-temp-file "org-protocol-test2")) + (org-protocol-project-alist + `((test1 + :base-url "http://example.com/" + :online-suffix ".html" + :working-directory ,(file-name-directory temp-file-name1)) + (test2 + :base-url "http://another.example.com/" + :online-suffix ".js" + :working-directory ,(file-name-directory temp-file-name2)) + )) + (test-cases + (list + ;; Old-style URLs + (cons + (concat "/some/directory/org-protocol:/open-source:/" + (url-hexify-string + (concat "http://example.com/" (file-name-nondirectory temp-file-name1) ".html"))) + temp-file-name1) + (cons + (concat "/some/directory/org-protocol:/open-source:/" + (url-hexify-string + (concat "http://another.example.com/" (file-name-nondirectory temp-file-name2) ".js"))) + temp-file-name2) + ;; New-style URLs + (cons + (concat "/some/directory/org-protocol:/open-source?url=" + (url-hexify-string + (concat "http://example.com/" (file-name-nondirectory temp-file-name1) ".html"))) + temp-file-name1) + (cons + (concat "/some/directory/org-protocol:/open-source?url=" + (url-hexify-string + (concat "http://another.example.com/" (file-name-nondirectory temp-file-name2) ".js"))) + temp-file-name2)))) + (mapc (lambda (test-case) + (should (string= + (org-protocol-check-filename-for-protocol + (car test-case) + (list (car test-case)) nil) + (cdr test-case)))) + test-cases) + (delete-file temp-file-name1) + (delete-file temp-file-name2))) + +(defun test-org-protocol/org-protocol-greedy-handler (fname) + ;; fname should be a list of parsed items + (should (listp fname)) + nil) + +(ert-deftest test-org-protocol/org-protocol-with-greedy-handler () + "Check that greedy handlers are called with all the filenames." + (let ((org-protocol-protocol-alist + '(("protocol-a" :protocol "greedy" :function test-org-protocol/org-protocol-greedy-handler :kill-client t :greedy t)))) + ;; Neither of these should signal errors + (let ((uri "/some/dir/org-protocol://greedy?a=b&c=d") + (uri2 "/some/dir/org-protocol://greedy?e=f&g=h")) + (org-protocol-check-filename-for-protocol uri (list uri uri2) nil)))) + + +;; TODO: Verify greedy protocol handling +;;; test-org-protocol.el ends here -- 2.6.3