commit 786907238bcb86ab9e0e2e9ebcc91c52a6eb024c (HEAD, refs/remotes/origin/master) Author: Eric Abrahamsen Date: Sat Nov 25 18:42:55 2017 -0800 Obsolete gnus-remove-if and gnus-remove-if-not Use seq-remove and seq-filter, respectively, instead. * lisp/gnus/gnus-util.el: Remove functions and replace with define-obsolete-function-alias calls. * lisp/gnus/gnus.el: Require seq here. * lisp/gnus/gnus-art.el (gnus-mime-view-part-as-type): * lisp/gnus/gnus-icalendar.el (gnus-icalendar-event--get-attendee-names): * lisp/gnus/gnus-score.el (gnus-summary-score-effect): * lisp/gnus/gnus-sum.el (gnus-read-move-group-name): * lisp/gnus/gnus-topic.el (gnus-group-prepare-topics): * lisp/gnus/gnus-win.el (gnus-get-buffer-window): * lisp/gnus/nnmail.el (nnmail-purge-split-history): * lisp/gnus/nnmaildir.el (nnmaildir-request-scan): * lisp/gnus/nnrss.el (nnrss-make-hash-index): Replace calls in all these locations. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 97aa878ab6..6ee0d7b023 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5219,7 +5219,7 @@ available media-types." (gnus-completing-read "View as MIME type" (if pred - (gnus-remove-if-not pred (mailcap-mime-types)) + (seq-filter pred (mailcap-mime-types)) (mailcap-mime-types)) nil nil nil (car default))))) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index cca4a81d1c..38c3ea36d6 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -169,7 +169,7 @@ (defun gnus-icalendar-event--get-attendee-names (ical) (let* ((event (car (icalendar--all-events ical))) - (attendee-props (gnus-remove-if-not + (attendee-props (seq-filter (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) @@ -180,7 +180,7 @@ (or (plist-get (cadr prop) 'CN) (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (attendees-by-type (type) - (gnus-remove-if-not + (seq-filter (lambda (p) (string= (attendee-role p) type)) attendee-props)) (attendee-names-by-type diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 765dfab570..a2cc07db46 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -921,7 +921,7 @@ EXTRA is the possible non-standard header." (interactive (list (gnus-completing-read "Header" (mapcar 'car - (gnus-remove-if-not + (seq-filter (lambda (x) (fboundp (nth 2 x))) gnus-header-index)) t) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index e599a8460f..4dee306c81 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -12270,21 +12270,27 @@ save those articles instead." (if (> (length articles) 1) (format "these %d articles" (length articles)) "this article"))) + valid-names (to-newsgroup - (cond - ((null split-name) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix nil default)) - ((= 1 (length split-name)) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix 'gnus-group-history (car split-name))) - (t - (gnus-completing-read - prom (nreverse split-name) nil nil 'gnus-group-history)))) + (progn + (mapatoms (lambda (g) + (when (gnus-valid-move-group-p g) + (push g valid-names))) + gnus-active-hashtb) + (cond + ((null split-name) + (gnus-group-completing-read + prom + valid-names + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom + valid-names + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history))))) (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index ba756e0314..3a37366bd5 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -460,7 +460,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead - (gnus-remove-if (lambda (group) + (seq-remove (lambda (group) (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index b7477a7fa8..ed112273ca 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1117,41 +1117,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (unless (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (unless (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) - -(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (when (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (when (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) +(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1") + +(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1") (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 8e47ae3f98..4f720463b4 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -513,7 +513,7 @@ should have point." (memq frame '(t 0 visible))) (car (let ((frames (frames-on-display-list))) - (gnus-remove-if (lambda (win) (not (memq (window-frame win) + (seq-remove (lambda (win) (not (memq (window-frame win) frames))) (get-buffer-window-list buffer nil frame))))) (t diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 3458fdea71..597470c381 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -33,6 +33,7 @@ (require 'wid-edit) (require 'mm-util) (require 'nnheader) +(require 'seq) ;; These are defined afterwards with gnus-define-group-parameter (defvar gnus-ham-process-destinations) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index ad58d29208..5ed80a9bb6 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -2034,7 +2034,7 @@ If TIME is nil, then return the cutoff time for oldness instead." "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history - (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) + (setcar history (seq-remove (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history)))) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 708a3426af..3e4a87cee7 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -915,7 +915,7 @@ This variable is set by `nnmaildir-request-article'.") (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) dirs (if (zerop (length target-prefix)) dirs - (gnus-remove-if + (seq-remove (lambda (dir) (and (>= (length dir) (length target-prefix)) (string= (substring dir 0 diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 9a3a562a5d..aa19c376d1 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -625,7 +625,7 @@ which RSS 2.0 allows." ;;; Snarf functions (defun nnrss-make-hash-index (item) (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item)) - (setq item (gnus-remove-if + (setq item (seq-remove (lambda (field) (when (listp field) (memq (car field) nnrss-ignore-article-fields))) commit 07bcc2a243693a774fec9a2706eeb75cab619d33 Author: Philipp Stephani Date: Sun Dec 10 18:03:04 2017 +0100 Skip tests for json.c unless compiled with native JSON support. * test/src/json-tests.el (json-serialize/roundtrip) (json-serialize/object, json-parse-string/object) (json-parse-string/string, json-serialize/string) (json-parse-string/incomplete, json-parse-string/trailing) (json-parse-buffer/incomplete, json-parse-buffer/trailing): Skip if JSON functions aren't available. diff --git a/test/src/json-tests.el b/test/src/json-tests.el index 5d3c84a136..07eb41d093 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -27,6 +27,7 @@ (require 'map) (ert-deftest json-serialize/roundtrip () + (skip-unless (fboundp 'json-serialize)) (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"]) (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]")) (should (equal (json-serialize lisp) json)) @@ -42,6 +43,7 @@ (should (eobp))))) (ert-deftest json-serialize/object () + (skip-unless (fboundp 'json-serialize)) (let ((table (make-hash-table :test #'equal))) (puthash "abc" [1 2 t] table) (puthash "def" :null table) @@ -49,6 +51,7 @@ "{\"abc\":[1,2,true],\"def\":null}")))) (ert-deftest json-parse-string/object () + (skip-unless (fboundp 'json-parse-string)) (let ((actual (json-parse-string "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n"))) @@ -58,6 +61,7 @@ '(("abc" . [9 :false]) ("def" . :null)))))) (ert-deftest json-parse-string/string () + (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) @@ -67,18 +71,22 @@ (should-error (json-parse-string "foo") :type 'json-parse-error)) (ert-deftest json-serialize/string () + (skip-unless (fboundp 'json-serialize)) (should (equal (json-serialize ["foo"]) "[\"foo\"]")) (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))) (ert-deftest json-parse-string/incomplete () + (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[123") :type 'json-end-of-file)) (ert-deftest json-parse-string/trailing () + (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) (ert-deftest json-parse-buffer/incomplete () + (skip-unless (fboundp 'json-parse-buffer)) (with-temp-buffer (insert "[123") (goto-char 1) @@ -86,6 +94,7 @@ (should (bobp)))) (ert-deftest json-parse-buffer/trailing () + (skip-unless (fboundp 'json-parse-buffer)) (with-temp-buffer (insert "[123] [456]") (goto-char 1) commit 2b8a1b76920dbdfc39dab2ec29ab7650bf779275 Author: Eli Zaretskii Date: Sun Dec 10 18:36:37 2017 +0200 Support dynamic loading of libjansson on MS-Windows * src/json.c [WINDOWSNT]: Define fn_* function pointers to jansson functions. (json_delete) [WINDOWSNT]: A wrapper around fn_json_delete, needed by json_decref. (init_json_functions) [WINDOWSNT]: New function. (Fjson_serialize, Fjson_insert, Fjson_parse_string) (Fjson_parse_buffer) [WINDOWSNT]: Call init_json_functions if needed, and record JSON in Vlibrary_cache. * src/emacs.c (main): Don't call init_json on WINDOWSNT. * src/w32fns.c (syms_of_w32fns): DEFSYM "json". * lisp/term/w32-win.el (dynamic-library-alist): Add JSON DLL to the list. * configure.ac (HAVE_JSON): Empty JSON_LIBS for MinGW. * nt/INSTALL.W64: * nt/INSTALL: Add information about libjansson. diff --git a/configure.ac b/configure.ac index caee015954..562b19afe6 100644 --- a/configure.ac +++ b/configure.ac @@ -2881,6 +2881,11 @@ if test "${with_json}" = yes; then AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) JSON_OBJ=json.o fi + + # Windows loads libjansson dynamically + if test "${opsys}" = "mingw32"; then + JSON_LIBS= + fi fi AC_SUBST(JSON_LIBS) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 4e0e54ae17..1db90aec98 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -276,7 +276,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gnutls "libgnutls-28.dll" "libgnutls-26.dll")) '(libxml2 "libxml2-2.dll" "libxml2.dll") '(zlib "zlib1.dll" "libz-1.dll") - '(lcms2 "liblcms2-2.dll"))) + '(lcms2 "liblcms2-2.dll") + '(json "libjansson-4.dll"))) ;;; multi-tty support (defvar w32-initialized nil diff --git a/nt/INSTALL b/nt/INSTALL index 30e14293f5..361d607ff6 100644 --- a/nt/INSTALL +++ b/nt/INSTALL @@ -806,6 +806,13 @@ build will run on Windows 9X and newer systems). Prebuilt binaries of lcms2 DLL (for 32-bit builds of Emacs) are available from the ezwinports site and from the MSYS2 project. +* Optional support for JSON + + Emacs can provide built-in support for JSON parsing and + serialization using the libjansson library. Prebuilt binaries of + the libjansson DLL (for 32-bit builds of Emacs) are available from + the ezwinports site and from the MSYS2 project. + This file is part of GNU Emacs. diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64 index e08b72f2ca..41d57bd368 100644 --- a/nt/INSTALL.W64 +++ b/nt/INSTALL.W64 @@ -52,6 +52,7 @@ packages (you can copy and paste it into the shell with Shift + Insert): mingw-w64-x86_64-libjpeg-turbo \ mingw-w64-x86_64-librsvg \ mingw-w64-x86_64-lcms2 \ + mingw-w64-x86_64-jansson \ mingw-w64-x86_64-libxml2 \ mingw-w64-x86_64-gnutls \ mingw-w64-x86_64-zlib diff --git a/src/emacs.c b/src/emacs.c index 7c1ae1f2c5..5a6b896ef4 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1262,7 +1262,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem running_asynch_code = 0; init_random (); -#ifdef HAVE_JSON +#if defined HAVE_JSON && !defined WINDOWSNT init_json (); #endif diff --git a/src/json.c b/src/json.c index dc449e43e1..7025ae165c 100644 --- a/src/json.c +++ b/src/json.c @@ -30,6 +30,126 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "coding.h" +#ifdef WINDOWSNT +# include +# include "w32.h" + +DEF_DLL_FN (void, json_set_alloc_funcs, + (json_malloc_t malloc_fn, json_free_t free_fn)); +DEF_DLL_FN (void, json_delete, (json_t *json)); +DEF_DLL_FN (json_t *, json_array, (void)); +DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value)); +DEF_DLL_FN (size_t, json_array_size, (const json_t *array)); +DEF_DLL_FN (json_t *, json_object, (void)); +DEF_DLL_FN (int, json_object_set_new, + (json_t *object, const char *key, json_t *value)); +DEF_DLL_FN (json_t *, json_null, (void)); +DEF_DLL_FN (json_t *, json_true, (void)); +DEF_DLL_FN (json_t *, json_false, (void)); +DEF_DLL_FN (json_t *, json_integer, (json_int_t value)); +DEF_DLL_FN (json_t *, json_real, (double value)); +DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len)); +DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags)); +DEF_DLL_FN (int, json_dump_callback, + (const json_t *json, json_dump_callback_t callback, void *data, + size_t flags)); +DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer)); +DEF_DLL_FN (double, json_real_value, (const json_t *real)); +DEF_DLL_FN (const char *, json_string_value, (const json_t *string)); +DEF_DLL_FN (size_t, json_string_length, (const json_t *string)); +DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index)); +DEF_DLL_FN (size_t, json_object_size, (const json_t *object)); +DEF_DLL_FN (const char *, json_object_iter_key, (void *iter)); +DEF_DLL_FN (void *, json_object_iter, (json_t *object)); +DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter)); +DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key)); +DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter)); +DEF_DLL_FN (json_t *, json_loads, + (const char *input, size_t flags, json_error_t *error)); +DEF_DLL_FN (json_t *, json_load_callback, + (json_load_callback_t callback, void *data, size_t flags, + json_error_t *error)); + +/* This is called by json_decref, which is an inline function. */ +void json_delete(json_t *json) +{ + fn_json_delete (json); +} + +static bool json_initialized; + +static bool +init_json_functions (void) +{ + HMODULE library = w32_delayed_load (Qjson); + + if (!library) + return false; + + LOAD_DLL_FN (library, json_set_alloc_funcs); + LOAD_DLL_FN (library, json_delete); + LOAD_DLL_FN (library, json_array); + LOAD_DLL_FN (library, json_array_append_new); + LOAD_DLL_FN (library, json_array_size); + LOAD_DLL_FN (library, json_object); + LOAD_DLL_FN (library, json_object_set_new); + LOAD_DLL_FN (library, json_null); + LOAD_DLL_FN (library, json_true); + LOAD_DLL_FN (library, json_false); + LOAD_DLL_FN (library, json_integer); + LOAD_DLL_FN (library, json_real); + LOAD_DLL_FN (library, json_stringn); + LOAD_DLL_FN (library, json_dumps); + LOAD_DLL_FN (library, json_dump_callback); + LOAD_DLL_FN (library, json_integer_value); + LOAD_DLL_FN (library, json_real_value); + LOAD_DLL_FN (library, json_string_value); + LOAD_DLL_FN (library, json_string_length); + LOAD_DLL_FN (library, json_array_get); + LOAD_DLL_FN (library, json_object_size); + LOAD_DLL_FN (library, json_object_iter_key); + LOAD_DLL_FN (library, json_object_iter); + LOAD_DLL_FN (library, json_object_iter_value); + LOAD_DLL_FN (library, json_object_key_to_iter); + LOAD_DLL_FN (library, json_object_iter_next); + LOAD_DLL_FN (library, json_loads); + LOAD_DLL_FN (library, json_load_callback); + + init_json (); + + return true; +} + +#define json_set_alloc_funcs fn_json_set_alloc_funcs +#define json_array fn_json_array +#define json_array_append_new fn_json_array_append_new +#define json_array_size fn_json_array_size +#define json_object fn_json_object +#define json_object_set_new fn_json_object_set_new +#define json_null fn_json_null +#define json_true fn_json_true +#define json_false fn_json_false +#define json_integer fn_json_integer +#define json_real fn_json_real +#define json_stringn fn_json_stringn +#define json_dumps fn_json_dumps +#define json_dump_callback fn_json_dump_callback +#define json_integer_value fn_json_integer_value +#define json_real_value fn_json_real_value +#define json_string_value fn_json_string_value +#define json_string_length fn_json_string_length +#define json_array_get fn_json_array_get +#define json_object_size fn_json_object_size +#define json_object_iter_key fn_json_object_iter_key +#define json_object_iter fn_json_object_iter +#define json_object_iter_value fn_json_object_iter_value +#define json_object_key_to_iter fn_json_object_key_to_iter +#define json_object_iter_next fn_json_object_iter_next +#define json_loads fn_json_loads +#define json_load_callback fn_json_load_callback + +#endif /* WINDOWSNT */ + /* We install a custom allocator so that we can avoid objects larger than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of Emacs’s codebase, which generally uses ptrdiff_t for sizes and @@ -277,6 +397,21 @@ each object. */) { ptrdiff_t count = SPECPDL_INDEX (); +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + json_t *json = lisp_to_json_toplevel (object); record_unwind_protect_ptr (json_release_object, json); @@ -340,6 +475,21 @@ OBJECT. */) { ptrdiff_t count = SPECPDL_INDEX (); +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + json_t *json = lisp_to_json (object); record_unwind_protect_ptr (json_release_object, json); @@ -439,6 +589,22 @@ an error of type `json-parse-error' is signaled. */) (Lisp_Object string) { ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + Lisp_Object encoded = json_encode (string); check_string_without_embedded_nulls (encoded); @@ -493,6 +659,21 @@ not moved. */) { ptrdiff_t count = SPECPDL_INDEX (); +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + ptrdiff_t point = PT_BYTE; struct json_read_buffer_data data = {.point = point}; json_error_t error; diff --git a/src/w32fns.c b/src/w32fns.c index d2d4b2c735..90d09542c4 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10418,6 +10418,7 @@ syms_of_w32fns (void) DEFSYM (Qserif, "serif"); DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); + DEFSYM (Qjson, "json"); Fput (Qundefined_color, Qerror_conditions, listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror)); commit f856d1e4489eac45afab865838abb2b16fb1f14f Author: Philipp Stephani Date: Sun Dec 10 16:55:31 2017 +0100 * configure.ac: Fix minimum Jansson version requirement. diff --git a/configure.ac b/configure.ac index 83369f763a..caee015954 100644 --- a/configure.ac +++ b/configure.ac @@ -2875,7 +2875,7 @@ HAVE_JSON=no JSON_OBJ= if test "${with_json}" = yes; then - EMACS_CHECK_MODULES([JSON], [jansson >= 2.5], + EMACS_CHECK_MODULES([JSON], [jansson >= 2.7], [HAVE_JSON=yes], [HAVE_JSON=no]) if test "${HAVE_JSON}" = yes; then AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) commit abd18254aec76b26e86ae27e91d2c916ec20cc46 Author: Wilfred Hughes Date: Sun Dec 10 13:34:06 2017 +0000 Ensure that we can find definitions when buffer is narrowed find-function-search-for-symbol will reuse the existing buffer if we've already opened the file that contains this symbol. However, if the user has narrowed that buffer, we can't find definitions outside the narrowed area. Instead, search the whole file to find definitions, and teach the help buttons to widen if necessary. * lisp/emacs-lisp/find-func.el (find-function-search-for-symbol): Search the whole buffer for the target symbol. * lisp/help-mode.el: Help buttons now widen the target buffer, if narrowing is in effect and the target position is not in that range. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 29c42f3693..84cc8bc9b7 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -368,28 +368,30 @@ The search is done in the source for library LIBRARY." (concat "\\\\?" (regexp-quote (symbol-name symbol)))))) (case-fold-search)) - (with-syntax-table emacs-lisp-mode-syntax-table - (goto-char (point-min)) - (if (if (functionp regexp) - (funcall regexp symbol) - (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t))) - (progn - (beginning-of-line) - (cons (current-buffer) (point))) - (cons (current-buffer) nil)))))))) + (save-restriction + (widen) + (with-syntax-table emacs-lisp-mode-syntax-table + (goto-char (point-min)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) + (progn + (beginning-of-line) + (cons (current-buffer) (point))) + (cons (current-buffer) nil))))))))) (defun find-function-library (function &optional lisp-only verbose) "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 8bafa46aa9..1e1ae1126c 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -203,12 +203,18 @@ The format is (FUNCTION ARGS...).") (help-C-file-name (indirect-function fun) 'fun))) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun type file))) + (let* ((location + (find-function-search-for-symbol fun type file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) (message "Unable to find location in file"))))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) @@ -219,6 +225,7 @@ The format is (FUNCTION ARGS...).") (if (and file (file-readable-p file)) (progn (pop-to-buffer (find-file-noselect file)) + (widen) (goto-char (point-min)) (if (re-search-forward (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" @@ -234,12 +241,18 @@ The format is (FUNCTION ARGS...).") 'help-function (lambda (var &optional file) (when (eq file 'C-source) (setq file (help-C-file-name var 'var))) - (let ((location (find-variable-noselect var file))) + (let* ((location (find-variable-noselect var file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find variable's definition")) (define-button-type 'help-face-def @@ -248,12 +261,18 @@ The format is (FUNCTION ARGS...).") (require 'find-func) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun 'defface file))) + (let* ((location + (find-function-search-for-symbol fun 'defface file)) + (position (cdr location))) (pop-to-buffer (car location)) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find face's definition")) (define-button-type 'help-package commit ab203e36d5f84a99b6d4b04f1a22ba028be750e3 Author: Philipp Stephani Date: Mon Sep 18 10:51:39 2017 +0200 Implement native JSON support using Jansson * configure.ac: New option --with-json. * src/json.c (Fjson_serialize, Fjson_insert, Fjson_parse_string) (Fjson_parse_buffer): New defuns. (json_malloc, json_free, json_has_prefix, json_has_suffix) (json_make_string, json_build_string, json_encode) (json_out_of_memory, json_parse_error) (json_release_object, check_string_without_embedded_nulls, json_check) (lisp_to_json, lisp_to_json_toplevel, lisp_to_json_toplevel_1) (json_insert, json_insert_callback, json_to_lisp) (json_read_buffer_callback, Fjson_parse_buffer, define_error): New helper functions. (init_json, syms_of_json): New file. * src/lisp.h: Declaration for init_json and syms_of_json. * src/emacs.c (main): Enable JSON functions. * src/eval.c (internal_catch_all, internal_catch_all_1): New helper functions to catch all signals. (syms_of_eval): Add uninterned symbol to signify out of memory. * src/Makefile.in (JSON_LIBS, JSON_CFLAGS, JSON_OBJ, EMACS_CFLAGS) (base_obj, LIBES): Compile json.c if --with-json is enabled. * test/src/json-tests.el (json-serialize/roundtrip) (json-serialize/object, json-parse-string/object) (json-parse-string/string, json-serialize/string) (json-parse-string/incomplete, json-parse-string/trailing) (json-parse-buffer/incomplete, json-parse-buffer/trailing): New unit tests. * doc/lispref/text.texi (Parsing JSON): New manual section. diff --git a/configure.ac b/configure.ac index 61455a4b0f..83369f763a 100644 --- a/configure.ac +++ b/configure.ac @@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support]) OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) +OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) @@ -2870,6 +2871,22 @@ fi AC_SUBST(LIBSYSTEMD_LIBS) AC_SUBST(LIBSYSTEMD_CFLAGS) +HAVE_JSON=no +JSON_OBJ= + +if test "${with_json}" = yes; then + EMACS_CHECK_MODULES([JSON], [jansson >= 2.5], + [HAVE_JSON=yes], [HAVE_JSON=no]) + if test "${HAVE_JSON}" = yes; then + AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) + JSON_OBJ=json.o + fi +fi + +AC_SUBST(JSON_LIBS) +AC_SUBST(JSON_CFLAGS) +AC_SUBST(JSON_OBJ) + NOTIFY_OBJ= NOTIFY_SUMMARY=no @@ -5366,7 +5383,7 @@ emacs_config_features= for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ - XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do + XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do case $opt in CANNOT_DUMP) eval val=\${$opt} ;; @@ -5416,6 +5433,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} + Does Emacs use -ljansson? ${HAVE_JSON} Does Emacs directly use zlib? ${HAVE_ZLIB} Does Emacs have dynamic modules support? ${HAVE_MODULES} Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 35ba5d0ddd..5b288d9750 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -61,6 +61,7 @@ the character after point. * Checksum/Hash:: Computing cryptographic hashes. * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. * Parsing HTML/XML:: Parsing HTML and XML. +* Parsing JSON:: Parsing and generating JSON values. * Atomic Changes:: Installing several buffer changes atomically. * Change Hooks:: Supplying functions to be run when text is changed. @end menu @@ -4934,6 +4935,92 @@ textual nodes that just contain white-space. @end table +@node Parsing JSON +@section Parsing and generating JSON values +@cindex JSON + + When Emacs is compiled with JSON support, it provides a couple of +functions to convert between Lisp objects and JSON values. Any JSON +value can be converted to a Lisp object, but not vice versa. +Specifically: + +@itemize + +@item +JSON has a couple of keywords: @code{null}, @code{false}, and +@code{true}. These are represented in Lisp using the keywords +@code{:null}, @code{:false}, and @code{t}, respectively. + +@item +JSON only has floating-point numbers. They can represent both Lisp +integers and Lisp floating-point numbers. + +@item +JSON strings are always Unicode strings. Lisp strings can contain +non-Unicode characters. + +@item +JSON has only one sequence type, the array. JSON arrays are +represented using Lisp vectors. + +@item +JSON has only one map type, the object. JSON objects are represented +using Lisp hashtables. + +@end itemize + +@noindent +Note that @code{nil} doesn't represent any JSON values: this is to +avoid confusion, because @code{nil} could either represent +@code{null}, @code{false}, or an empty array, all of which are +different JSON values. + + If some Lisp object can't be represented in JSON, the serialization +functions will signal an error of type @code{wrong-type-argument}. +The parsing functions will signal the following errors: + +@table @code + +@item json-end-of-file + Signaled when encountering a premature end of the input text. + +@item json-trailing-content + Signaled when encountering unexpected input after the first JSON + object parsed. + +@item json-parse-error + Signaled when encountering invalid JSON syntax. + +@end table + + Only top-level values (arrays and objects) can be serialized to +JSON. The subobjects within these top-level values can be of any +type. Likewise, the parsing functions will only return vectors and +hashtables. + +@defun json-serialize object +This function returns a new Lisp string which contains the JSON +representation of @var{object}. +@end defun + +@defun json-insert object +This function inserts the JSON representation of @var{object} into the +current buffer before point. +@end defun + +@defun json-parse-string string +This function parses the JSON value in @var{string}, which must be a +Lisp string. +@end defun + +@defun json-parse-buffer +This function reads the next JSON value from the current buffer, +starting at point. It moves point to the position immediately after +the value if a value could be read and converted to Lisp; otherwise it +doesn't move point. +@end defun + + @node Atomic Changes @section Atomic Change Groups @cindex atomic changes diff --git a/etc/NEWS b/etc/NEWS index dd7d983970..c0d0d42d3f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -24,6 +24,13 @@ When you add a new item, use the appropriate mark if you are sure it applies, * Installation Changes in Emacs 27.1 +** The new configure option '--with-json' adds support for JSON using +the Jansson library. It is on by default; use 'configure +--with-json=no' to build without Jansson support. The new JSON +functions 'json-serialize', 'json-insert', 'json-parse-string', and +'json-parse-buffer' are typically much faster than their Lisp +counterparts from json.el. + * Startup Changes in Emacs 27.1 @@ -164,6 +171,10 @@ remote systems, which support this check. If the optional third argument is non-nil, 'make-string' will produce a multibyte string even if its second argument is an ASCII character. +** New JSON parsing and serialization functions 'json-serialize', +'json-insert', 'json-parse-string', and 'json-parse-buffer'. These +are implemented in C using the Jansson library. + * Changes in Emacs 27.1 on Non-Free Operating Systems diff --git a/src/Makefile.in b/src/Makefile.in index 9a8c9c85f0..b395627893 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ +JSON_LIBS = @JSON_LIBS@ +JSON_CFLAGS = @JSON_CFLAGS@ +JSON_OBJ = @JSON_OBJ@ + INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ @@ -363,7 +367,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(WEBKIT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) @@ -397,7 +401,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) ## Object files used on some machine or other. @@ -493,7 +497,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ + $(JSON_LIBS) ## FORCE it so that admin/unidata can decide whether these files ## are up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/emacs.c b/src/emacs.c index 808abcd9aa..7c1ae1f2c5 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1262,6 +1262,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem running_asynch_code = 0; init_random (); +#ifdef HAVE_JSON + init_json (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1608,6 +1612,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_threads (); syms_of_profiler (); +#ifdef HAVE_JSON + syms_of_json (); +#endif + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/eval.c b/src/eval.c index 47c4f17eab..b774fd0613 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), } } +static Lisp_Object +internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) +{ + struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = function (argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + Fsignal (Qno_catch, val); + } +} + +/* Like a combination of internal_condition_case_1 and internal_catch. + Catches all signals and throws. Never exits nonlocally; returns + Qcatch_all_memory_full if no handler could be allocated. */ + +Lisp_Object +internal_catch_all (Lisp_Object (*function) (void *), void *argument, + Lisp_Object (*handler) (Lisp_Object)) +{ + struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = internal_catch_all_1 (function, argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + return handler (val); + } +} + struct handler * push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) { @@ -4067,6 +4118,9 @@ alist of active lexical bindings. */); inhibit_lisp_code = Qnil; + DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); + Funintern (Qcatch_all_memory_full, Qnil); + defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); diff --git a/src/json.c b/src/json.c new file mode 100644 index 0000000000..dc449e43e1 --- /dev/null +++ b/src/json.c @@ -0,0 +1,576 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017 Free Software Foundation, Inc. + +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 . */ + +#include + +#include +#include +#include +#include + +#include + +#include "lisp.h" +#include "buffer.h" +#include "coding.h" + +/* We install a custom allocator so that we can avoid objects larger + than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of + Emacs’s codebase, which generally uses ptrdiff_t for sizes and + indices. The other functions in this file also generally assume + that size_t values never exceed PTRDIFF_MAX. */ + +static void * +json_malloc (size_t size) +{ + if (size > PTRDIFF_MAX) + { + errno = ENOMEM; + return NULL; + } + return malloc (size); +} + +static void +json_free (void *ptr) +{ + free (ptr); +} + +void +init_json (void) +{ + json_set_alloc_funcs (json_malloc, json_free); +} + +/* Return whether STRING starts with PREFIX. */ + +static bool +json_has_prefix (const char *string, const char *prefix) +{ + size_t string_len = strlen (string); + size_t prefix_len = strlen (prefix); + return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; +} + +/* Return whether STRING ends with SUFFIX. */ + +static bool +json_has_suffix (const char *string, const char *suffix) +{ + size_t string_len = strlen (string); + size_t suffix_len = strlen (suffix); + return string_len >= suffix_len + && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; +} + +/* Create a multibyte Lisp string from the UTF-8 string in + [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not + contain a valid UTF-8 string, an unspecified string is + returned. */ + +static Lisp_Object +json_make_string (const char *data, ptrdiff_t size) +{ + return code_convert_string (make_specified_string (data, -1, size, false), + Qutf_8_unix, Qt, false, true, true); +} + +/* Create a multibyte Lisp string from the null-terminated UTF-8 + string beginning at DATA. If the string is not a valid UTF-8 + string, an unspecified string is returned. */ + +static Lisp_Object +json_build_string (const char *data) +{ + return json_make_string (data, strlen (data)); +} + +/* Return a unibyte string containing the sequence of UTF-8 encoding + units of the UTF-8 representation of STRING. If STRING does not + represent a sequence of Unicode scalar values, return a string with + unspecified contents. */ + +static Lisp_Object +json_encode (Lisp_Object string) +{ + return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); +} + +static _Noreturn void +json_out_of_memory (void) +{ + xsignal0 (Qjson_out_of_memory); +} + +/* Signal a Lisp error corresponding to the JSON ERROR. */ + +static _Noreturn void +json_parse_error (const json_error_t *error) +{ + Lisp_Object symbol; + /* FIXME: Upstream Jansson should have a way to return error codes + without parsing the error messages. See + https://github.com/akheron/jansson/issues/352. */ + if (json_has_suffix (error->text, "expected near end of file")) + symbol = Qjson_end_of_file; + else if (json_has_prefix (error->text, "end of file expected")) + symbol = Qjson_trailing_content; + else + symbol = Qjson_parse_error; + xsignal (symbol, + list5 (json_build_string (error->text), + json_build_string (error->source), make_natnum (error->line), + make_natnum (error->column), make_natnum (error->position))); +} + +static void +json_release_object (void *object) +{ + json_decref (object); +} + +/* Signal an error if OBJECT is not a string, or if OBJECT contains + embedded null characters. */ + +static void +check_string_without_embedded_nulls (Lisp_Object object) +{ + CHECK_STRING (object); + CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, + Qstring_without_embedded_nulls_p, object); +} + +/* Signal an error of type `json-out-of-memory' if OBJECT is + NULL. */ + +static json_t * +json_check (json_t *object) +{ + if (object == NULL) + json_out_of_memory (); + return object; +} + +static json_t *lisp_to_json (Lisp_Object); + +/* Convert a Lisp object to a toplevel JSON object (array or object). + This returns Lisp_Object so we can use unbind_to. The return value + is always nil. */ + +static _GL_ARG_NONNULL ((2)) Lisp_Object +lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) +{ + if (VECTORP (lisp)) + { + ptrdiff_t size = ASIZE (lisp); + *json = json_check (json_array ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i = 0; i < size; ++i) + { + int status + = json_array_append_new (*json, lisp_to_json (AREF (lisp, i))); + if (status == -1) + json_out_of_memory (); + } + eassert (json_array_size (*json) == size); + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (HASH_TABLE_P (lisp)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); + *json = json_check (json_object ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key = json_encode (HASH_KEY (h, i)); + /* We can’t specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + int status = json_object_set_new (*json, SSDATA (key), + lisp_to_json (HASH_VALUE (h, i))); + if (status == -1) + json_out_of_memory (); + } + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + wrong_type_argument (Qjson_value_p, lisp); +} + +/* Convert LISP to a toplevel JSON object (array or object). Signal + an error of type `wrong-type-argument' if LISP is not a vector or + hashtable. */ + +static json_t * +lisp_to_json_toplevel (Lisp_Object lisp) +{ + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + json_t *json; + lisp_to_json_toplevel_1 (lisp, &json); + --lisp_eval_depth; + return json; +} + +/* Convert LISP to any JSON object. Signal an error of type + `wrong-type-argument' if the type of LISP can't be converted to a + JSON object. */ + +static json_t * +lisp_to_json (Lisp_Object lisp) +{ + if (EQ (lisp, QCnull)) + return json_check (json_null ()); + else if (EQ (lisp, QCfalse)) + return json_check (json_false ()); + else if (EQ (lisp, Qt)) + return json_check (json_true ()); + else if (INTEGERP (lisp)) + { + CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); + return json_check (json_integer (XINT (lisp))); + } + else if (FLOATP (lisp)) + return json_check (json_real (XFLOAT_DATA (lisp))); + else if (STRINGP (lisp)) + { + Lisp_Object encoded = json_encode (lisp); + ptrdiff_t size = SBYTES (encoded); + return json_check (json_stringn (SSDATA (encoded), size)); + } + + /* LISP now must be a vector or hashtable. */ + return lisp_to_json_toplevel (lisp); +} + +DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, + doc: /* Return the JSON representation of OBJECT as a string. +OBJECT must be a vector or hashtable, and its elements can recursively +contain `:null', `:false', t, numbers, strings, or other vectors and +hashtables. `:null', `:false', and t will be converted to JSON null, +false, and true values, respectively. Vectors will be converted to +JSON arrays, and hashtables to JSON objects. Hashtable keys must be +strings without embedded null characters and must be unique within +each object. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + json_t *json = lisp_to_json_toplevel (object); + record_unwind_protect_ptr (json_release_object, json); + + char *string = json_dumps (json, JSON_COMPACT); + if (string == NULL) + json_out_of_memory (); + record_unwind_protect_ptr (free, string); + + return unbind_to (count, json_build_string (string)); +} + +struct json_buffer_and_size +{ + const char *buffer; + ptrdiff_t size; +}; + +static Lisp_Object +json_insert (void *data) +{ + struct json_buffer_and_size *buffer_and_size = data; + /* FIXME: This should be possible without creating an intermediate + string object. */ + Lisp_Object string + = json_make_string (buffer_and_size->buffer, buffer_and_size->size); + insert1 (string); + return Qnil; +} + +struct json_insert_data +{ + /* nil if json_insert succeeded, otherwise the symbol + Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ + Lisp_Object error; +}; + +/* Callback for json_dump_callback that inserts the UTF-8 string in + [BUFFER, BUFFER + SIZE) into the current buffer. + If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string, + an unspecified string is inserted into the buffer. DATA must point + to a structure of type json_insert_data. This function may not + exit nonlocally. It catches all nonlocal exits and stores them in + data->error for reraising. */ + +static int +json_insert_callback (const char *buffer, size_t size, void *data) +{ + struct json_insert_data *d = data; + struct json_buffer_and_size buffer_and_size + = {.buffer = buffer, .size = size}; + d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity); + return NILP (d->error) ? 0 : -1; +} + +DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL, + doc: /* Insert the JSON representation of OBJECT before point. +This is the same as (insert (json-serialize OBJECT)), but potentially +faster. See the function `json-serialize' for allowed values of +OBJECT. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + json_t *json = lisp_to_json (object); + record_unwind_protect_ptr (json_release_object, json); + + struct json_insert_data data; + int status + = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); + if (status == -1) + { + if (CONSP (data.error)) + xsignal (XCAR (data.error), XCDR (data.error)); + else + json_out_of_memory (); + } + + return unbind_to (count, Qnil); +} + +/* Convert a JSON object to a Lisp object. */ + +static _GL_ARG_NONNULL ((1)) Lisp_Object +json_to_lisp (json_t *json) +{ + switch (json_typeof (json)) + { + case JSON_NULL: + return QCnull; + case JSON_FALSE: + return QCfalse; + case JSON_TRUE: + return Qt; + case JSON_INTEGER: + /* Return an integer if possible, a floating-point number + otherwise. This loses precision for integers with large + magnitude; however, such integers tend to be nonportable + anyway because many JSON implementations use only 64-bit + floating-point numbers with 53 mantissa bits. See + https://tools.ietf.org/html/rfc7159#section-6 for some + discussion. */ + return make_fixnum_or_float (json_integer_value (json)); + case JSON_REAL: + return make_float (json_real_value (json)); + case JSON_STRING: + return json_make_string (json_string_value (json), + json_string_length (json)); + case JSON_ARRAY: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_array_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound); + for (ptrdiff_t i = 0; i < size; ++i) + ASET (result, i, + json_to_lisp (json_array_get (json, i))); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal, + QCsize, make_natnum (size)); + struct Lisp_Hash_Table *h = XHASH_TABLE (result); + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = json_build_string (key_str); + EMACS_UINT hash; + ptrdiff_t i = hash_lookup (h, key, &hash); + /* Keys in JSON objects are unique, so the key can’t be + present yet. */ + eassert (i < 0); + hash_put (h, key, json_to_lisp (value), hash); + } + --lisp_eval_depth; + return result; + } + } + /* Can’t get here. */ + emacs_abort (); +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL, + doc: /* Parse the JSON STRING into a Lisp object. +This is essentially the reverse operation of `json-serialize', which +see. The returned object will be a vector or hashtable. Its elements +will be `:null', `:false', t, numbers, strings, or further vectors and +hashtables. If there are duplicate keys in an object, all but the +last one are ignored. If STRING doesn't contain a valid JSON object, +an error of type `json-parse-error' is signaled. */) + (Lisp_Object string) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object encoded = json_encode (string); + check_string_without_embedded_nulls (encoded); + + json_error_t error; + json_t *object = json_loads (SSDATA (encoded), 0, &error); + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + if (object != NULL) + record_unwind_protect_ptr (json_release_object, object); + + return unbind_to (count, json_to_lisp (object)); +} + +struct json_read_buffer_data +{ + /* Byte position of position to read the next chunk from. */ + ptrdiff_t point; +}; + +/* Callback for json_load_callback that reads from the current buffer. + DATA must point to a structure of type json_read_buffer_data. + data->point must point to the byte position to read from; after + reading, data->point is advanced accordingly. The buffer point + itself is ignored. This function may not exit nonlocally. */ + +static size_t +json_read_buffer_callback (void *buffer, size_t buflen, void *data) +{ + struct json_read_buffer_data *d = data; + + /* First, parse from point to the gap or the end of the accessible + portion, whatever is closer. */ + ptrdiff_t point = d->point; + ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; + ptrdiff_t count = end - point; + if (buflen < count) + count = buflen; + memcpy (buffer, BYTE_POS_ADDR (point), count); + d->point += count; + return count; +} + +DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, + 0, 0, NULL, + doc: /* Read JSON object from current buffer starting at point. +This is similar to `json-parse-string', which see. Move point after +the end of the object if parsing was successful. On error, point is +not moved. */) + (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + ptrdiff_t point = PT_BYTE; + struct json_read_buffer_data data = {.point = point}; + json_error_t error; + json_t *object = json_load_callback (json_read_buffer_callback, &data, + JSON_DISABLE_EOF_CHECK, &error); + + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + record_unwind_protect_ptr (json_release_object, object); + + /* Convert and then move point only if everything succeeded. */ + Lisp_Object lisp = json_to_lisp (object); + + /* Adjust point by how much we just read. */ + point += error.position; + SET_PT_BOTH (BYTE_TO_CHAR (point), point); + + return unbind_to (count, lisp); +} + +/* Simplified version of ‘define-error’ that works with pure + objects. */ + +static void +define_error (Lisp_Object name, const char *message, Lisp_Object parent) +{ + eassert (SYMBOLP (name)); + eassert (SYMBOLP (parent)); + Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); + eassert (CONSP (parent_conditions)); + eassert (!NILP (Fmemq (parent, parent_conditions))); + eassert (NILP (Fmemq (name, parent_conditions))); + Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); + Fput (name, Qerror_message, build_pure_c_string (message)); +} + +void +syms_of_json (void) +{ + DEFSYM (QCnull, ":null"); + DEFSYM (QCfalse, ":false"); + + DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); + DEFSYM (Qjson_value_p, "json-value-p"); + + DEFSYM (Qutf_8_unix, "utf-8-unix"); + + DEFSYM (Qjson_error, "json-error"); + DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); + DEFSYM (Qjson_parse_error, "json-parse-error"); + DEFSYM (Qjson_end_of_file, "json-end-of-file"); + DEFSYM (Qjson_trailing_content, "json-trailing-content"); + DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); + define_error (Qjson_error, "generic JSON error", Qerror); + define_error (Qjson_out_of_memory, + "not enough memory for creating JSON object", Qjson_error); + define_error (Qjson_parse_error, "could not parse JSON stream", + Qjson_error); + define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); + define_error (Qjson_trailing_content, "trailing content after JSON stream", + Qjson_parse_error); + define_error (Qjson_object_too_deep, + "object cyclic or Lisp evaluation too deep", Qjson_error); + + DEFSYM (Qpure, "pure"); + DEFSYM (Qside_effect_free, "side-effect-free"); + + DEFSYM (Qjson_serialize, "json-serialize"); + DEFSYM (Qjson_parse_string, "json-parse-string"); + Fput (Qjson_serialize, Qpure, Qt); + Fput (Qjson_serialize, Qside_effect_free, Qt); + Fput (Qjson_parse_string, Qpure, Qt); + Fput (Qjson_parse_string, Qside_effect_free, Qt); + + defsubr (&Sjson_serialize); + defsubr (&Sjson_insert); + defsubr (&Sjson_parse_string); + defsubr (&Sjson_parse_buffer); +} diff --git a/src/lisp.h b/src/lisp.h index 68824d6b39..91ed14fa4c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3452,6 +3452,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t); extern void reset_image_types (void); extern void syms_of_image (void); +#ifdef HAVE_JSON +/* Defined in json.c. */ +extern void init_json (void); +extern void syms_of_json (void); +#endif + /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); extern _Noreturn void buffer_overflow (void); @@ -3875,6 +3881,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype); extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); extern void specbind (Lisp_Object, Lisp_Object); diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 0000000000..5d3c84a136 --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,97 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; 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 . + +;;; Commentary: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(ert-deftest json-serialize/roundtrip () + (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"]) + (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/object () + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}")))) + +(ert-deftest json-parse-string/object () + (let ((actual + (json-parse-string + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n"))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null)))))) + +(ert-deftest json-parse-string/string () + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) + (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") + ["\nasdфывfgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) + (should-error (json-parse-string "foo") :type 'json-parse-error)) + +(ert-deftest json-serialize/string () + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) + "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))) + +(ert-deftest json-parse-string/incomplete () + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) + +(ert-deftest json-parse-buffer/incomplete () + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(provide 'json-tests) +;;; json-tests.el ends here commit 402e790ad4cff87d0e40e516a15553c408f12de1 Author: Michael Albinus Date: Sun Dec 10 10:48:34 2017 +0100 * doc/misc/tramp.texi (Archive file names): Precise example. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 3869e19fb9..db2f14b8df 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3100,15 +3100,19 @@ similar @samp{/scp:user@@host:...}. See the constant @code{tramp-archive-all-gvfs-methods} for a complete list of @code{tramp-gvfs} supported method names. -If @code{url-handler-mode} is enabled, archives could be visited via -URLs, like @file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. -This allows complex file operations like +If @value{tramp} is loaded and @code{url-handler-mode} is enabled, +archives could be visited via URLs, like +@file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. This +allows complex file operations like @lisp @group -(ediff-directories - "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" - "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") +(progn + (require 'tramp) + (url-handler-mode 1) + (ediff-directories + "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" + "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "")) @end group @end lisp