>From aff151930a73c22bb3fdf3ae9b442cecc08aaa67 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-parse-parameters): New function to simplify handling of old- or new-style links. (org-protocol-assign-parameters): New function to simplify handling of old- or new-style links. (org-protocol-store-link): Accept new-style links like org-protocol://store-link?title=TITLE&url=URL (org-protocol-capture): Accept new-style links like org-protocol://capture?title=TITLE&url=URL&template=x&body=BODY (org-protocol-do-capture): Update to accept new-style links. (org-protocol-open-source): Accept new-style links like org-protocol://open-source?url=URL (org-protocol-check-filename-for-protocol): Updated documentation. This allows the use of org-protocol on KDE 5 and makes org-protocol links more URI-like. * testing/lisp/test-org-protocol.el: New file. --- lisp/org-protocol.el | 194 +++++++++++++++++++++++++++----------- testing/lisp/test-org-protocol.el | 170 +++++++++++++++++++++++++++++++++ 2 files changed, 307 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..7f301e4 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,21 @@ 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 +function - function that handles requests with protocol and takes two + arguments: the filename with all protocols stripped, and a new-style + argument that indicates whether new-style arguments (key=val&key2=val2) + or old-style arguments (val/val2) were used. 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, + `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'. + `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 +288,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 +357,85 @@ 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 new-style &optional default-order unhexify separator) + "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 UNHEXIFY is t, hex-decode each value. If UNHEXIFY is a +function, use that function to decode each value. + +If SEPARATOR is non-nil, use it when parsing old-style links." + (if new-style + (let ((data + (org-protocol-convert-query-to-plist info)) + result) + (if unhexify + (progn + (while data + (setq result + (append + result + (list + (pop data) + (funcall (if (fboundp unhexify) unhexify + 'org-link-unescape) (pop data)))))) + result) + data)) + (let ((data + (org-protocol-split-data info unhexify 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. +(defun org-protocol-store-link (fname &optional new-style) + "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)) + (let* ((splitparts (org-protocol-parse-parameters + fname new-style '(:url :title) t)) + (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))) @@ -387,8 +446,8 @@ The sub-protocol used to reach this function is set in uri)) nil) -(defun org-protocol-capture (info) - "Process an org-protocol://capture:// style url. +(defun org-protocol-capture (info &optional new-style) + "Process an org-protocol://capture style url. The sub-protocol used to reach this function is set in `org-protocol-protocol-alist'. @@ -396,20 +455,20 @@ 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) - (org-protocol-do-capture info)) + (org-protocol-do-capture info new-style)) (message "Item captured.")) nil) @@ -421,19 +480,25 @@ Now template ?b will be used." (list (intern (concat ":" (car c))) (cadr c)))) (split-string query "&"))))) -(defun org-protocol-do-capture (info) +(defun org-protocol-do-capture (info &optional new-style) "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 new-style nil t)) + (parts + (cond + (new-style temp-parts) + ((= (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 +508,26 @@ 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. +(defun org-protocol-open-source (fname &optional new-style) + "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 (org-link-unescape + (plist-get (org-protocol-parse-parameters fname new-style '(:url)) + :url)))) (catch 'result (dolist (prolist org-protocol-project-alist) (let* ((base-url (plist-get (cdr prolist) :base-url)) @@ -510,21 +577,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,19 +604,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 result new-style) + (wrong-number-of-arguments + (funcall func result))))) + (condition-case err + (funcall func result new-style) + (wrong-number-of-arguments + (funcall func result))) (throw 'fname t)))))))) ;; (message "fname: %s" fname) fname))) diff --git a/testing/lisp/test-org-protocol.el b/testing/lisp/test-org-protocol.el new file mode 100644 index 0000000..e75e965 --- /dev/null +++ b/testing/lisp/test-org-protocol.el @@ -0,0 +1,170 @@ +;;; 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." + (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"))) + (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"))) + (let ((data (org-protocol-parse-parameters "b/abc/def" nil))) + (should (equal data '("b" "abc" "def")))) + (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"))))) + +(defun test-org-protocol/one-arg-fn (info) nil) +(defun test-org-protocol/two-arg-fn (info2) nil) +(ert-deftest test-org-protocol/org-protocol-check-filename-for-protocol () + "Make sure existing functions will work with one or two args." + (let ((org-protocol-protocol-alist + '(("protocol-a" :protocol "only-one-arg" :function test-org-protocol/one-arg-fn :kill-client t) + ("protocol-b" :protocol "two-args" :function test-org-protocol/two-arg-fn :kill-client t)) + )) + ;; Neither of these should signal errors + (let ((uri "/some/dir/org-protocol://only-one-arg?a=b")) + (org-protocol-check-filename-for-protocol uri (list uri) nil)) + (let ((uri "/some/dir/org-protocol://two-args?a=b")) + (should (null (org-protocol-check-filename-for-protocol uri (list uri) nil)))))) + +(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))) +;;; test-org-protocol.el ends here -- 2.6.3