IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'import_guile_json' into maint

Browse Source
This commit is contained in:
Geert Janssens 2018-05-03 21:20:28 +02:00
commit 65c7139072
12 changed files with 1120 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
borrowed/CMakeLists.txt
View File

@ -1,6 +1,7 @@
ADD_SUBDIRECTORY(libc)
ADD_SUBDIRECTORY(goffice)
ADD_SUBDIRECTORY(guile-json)
ADD_SUBDIRECTORY(gwengui-gtk3)
SET_LOCAL_DIST(borrowed_DIST_local CMakeLists.txt README)
SET(borrowed_DIST ${borrowed_DIST_local} ${libc_DIST} ${goffice_DIST} ${gwengui_gtk3_DIST} PARENT_SCOPE)
SET(borrowed_DIST ${borrowed_DIST_local} ${libc_DIST} ${guile-json_DIST} ${goffice_DIST} ${gwengui_gtk3_DIST} PARENT_SCOPE)

9
borrowed/guile-json/AUTHORS Normal file
View File

@ -0,0 +1,9 @@
Aleix Conchillo Flaque <aconchillo@gmail.com> is the author and current
maintainer of guile-json. More details at <http://hacks-galore.org/aleix>.
List of contributors (in alphabetical order):
Jan Nieuwenhuizen <janneke@gnu.org>
Ian Price <ianprice90@googlemail.com>
David Thompson <dthompson2@worcester.edu>
Doug Woos <doug@gamechanger.io>

19
borrowed/guile-json/CMakeLists.txt Normal file
View File

@ -0,0 +1,19 @@
add_subdirectory(json)
gnc_add_scheme_targets (guile-json
json.scm
gnucash
""
FALSE
)
set_local_dist(guile-json_DIST_LOCAL
AUTHORS
CMakeLists.txt
COPYING.LESSER
json.scm
NEWS
README
)
SET(guile-json_DIST ${guile-json_DIST_LOCAL} ${guile-json-details_DIST} PARENT_SCOPE)

165
borrowed/guile-json/COPYING.LESSER Normal file
View File

@ -0,0 +1,165 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

62
borrowed/guile-json/NEWS Normal file
View File

@ -0,0 +1,62 @@
* Version 0.6.0 (Jan 16, 2017)
- Deprecate json macro in favor of scheme data types.
* Version 0.5.0 (Feb 21, 2015)
- Allow converting simple alists to json
e.g.: (scm->json-string '((a . 1) (b . 2))))
(thanks to Jan Nieuwenhuizen)
* Version 0.4.0 (Aug 17, 2014)
- Add unquote-splicing support to json form.
(thanks to David Thompson)
* Version 0.3.1 (Jul 6, 2013)
- Use pure sh script syntax in env.in.
(thanks to Andrew Gaylard)
* Version 0.3.0 (May 13, 2013)
- Re-licensed under LGPLv3.
- Use new guile.m4 macro.
- Convert rationals to floats to comply with JSON spec.
(closes github #3, patch from Doug Woos)
* Version 0.2.0 (Apr 2, 2013)
- Improve parser errors by providing an additional parser argument to
the json-invalid exception.
* Version 0.1.3 (Feb 10, 2013)
- Automatically update pkg-list.scm version.
* Version 0.1.2 (Feb 7, 2013)
- Fix pretty printing.
- Use (display) instead of (simple-format) when possible.
* Version 0.1.1 (Feb 2, 2013)
- Use (car)/(cdr) instead of (drop-right)/(last). This should be more
efficient.
* Version 0.1.0 (Jan 30, 2013)
Initial release.

158
borrowed/guile-json/README Normal file
View File

@ -0,0 +1,158 @@
* guile-json
guile-json is a JSON module for Guile. It supports parsing and
building JSON documents according to the http://json.org
specification. These are the main features:
- Mostly complies with http://json.org specification (see UTF-8 below).
- Build JSON documents programmatically using scheme data types.
- Supports UTF-8 (doesn't fully support unicode hexadecimal digits).
- Allows JSON pretty printing.
* Installation
guile-json is freely available for download under the terms of the GNU
Lesser General Public License version 3 (LGPLv3+).
Download the latest tarball and untar it:
- [[http://download.savannah.gnu.org/releases/guile-json/guile-json-0.6.0.tar.gz][guile-json-0.6.0.tar.gz]]
Then, run the typical sequence:
: $ ./configure --prefix=<guile-prefix>
: $ make
: $ sudo make install
Where <guile-prefix> should preferably be the same as your system Guile
installation directory (e.g. /usr).
If everything installed successfully you should be up and running:
: $ guile
: scheme@(guile-user)> (use-modules (json))
: scheme@(guile-user)> (scm->json '(1 2 3))
: [1, 2, 3]
It might be that you installed guile-json somewhere differently than
your system's Guile. If so, you need to indicate Guile where to find
guile-json, for example:
: $ GUILE_LOAD_PATH=/usr/local/share/guile/site guile
A pkg-list.scm file is also provided for users of the
Guildhall/Dorodango packaging system.
* Usage
guile-json provides a few procedures to parse and build a JSON
document. A JSON document is transformed into or from native Guile
values according to the following table:
| JSON | Guile |
|--------+-------------|
| string | string |
| number | number |
| object | hash-table* |
| array | list |
| true | #t |
| false | #f |
| null | #nil |
*Note* (*): Association lists are also tranformed to JSON objects, in
this case ordered will be preserved.
To start using guile-json procedures and macros you first need to load
the module:
: scheme@(guile-user)> (use-modules (json))
** Procedures
- (*json->scm* #:optional port) : Reads a JSON document from the given
port, or from the current input port if none is given.
- /port/ : is optional, it defaults to the current input port.
- (*json-string->scm* str) : Reads a JSON document from the given
string.
- (*scm->json* native #:optional port #:key escape pretty) : Creates a
JSON document from the given native Guile value. The JSON document is
written into the given port, or to the current output port if non is
given.
- /port/ : it defaults to the current output port.
- /escape/ : if true, the slash (/ solidus) character will be escaped.
- /pretty/ : if true, the JSON document will be pretty printed.
- (*scm->json-string* native #:key escape pretty) : Creates a JSON
document from the given native Guile value into a string.
- /escape/ : if true, the slash (/ solidus) character will be escaped.
- /pretty/ : if true, the JSON document will be pretty printed.
** Exceptions
A /json-invalid/ exception is thrown if an error is found during the
JSON parsing. Since version 0.2.0, the /json-invalid/ exception has a
single parser argument (see predicate and accessors below). The line or
column where the error occured can be easily obtained from the parser
port (calling /port-line/ or /port-column/ on the port).
- (*json-parser?* parser) : Tells whether the given argument is a JSON
parser record type.
- (*json-parser-port* parser) : Get the port that the parser was reading
from.
** Examples
- Build the string "hello world":
: scheme@(guile-user)> (scm->json "hello world")
: "hello world"
- Build the [1, 2, 3] array:
: scheme@(guile-user)> (scm->json '(1 2 3))
: [1, 2, 3]
- Build the [1, 2, 3, 4] array using unquote-splicing:
: scheme@(guile-user)> (define values '(2 3))
: scheme@(guile-user)> (scm->json `(1 ,@values 4))
: [1, 2, 3, 4]
- Build the object { "project" : "foo", "author" : "bar" } using an
association list (see how symbols can also be used):
: scheme@(guile-user)> (scm->json '(("project" . "foo") (author . bar)))
: {"project" : "foo","author" : "bar"}
- Build again the same object { "project" : "foo", "author" : "bar" }
using a hash table:
: scheme@(guile-user)> (scm->json (alist->hash-table '((project . foo) (author . bar))))
: {"project" : "foo","author" : "bar"}
- Build the object { "values" : [ 234, 98.56 ] }:
: scheme@(guile-user)> (scm->json '(("values" 234 98.56)))
: {"values" : [234, 98.56]}
- Build the object { "values" : [ 234, 98.56 ] } again, this time using
a variable:
: scheme@(guile-user)> (define values '(234 98.56))
: scheme@(guile-user)> (scm->json `(("values" ,@values)))
: {"values" : [234, 98.56]}

45
borrowed/guile-json/json.scm Normal file
View File

@ -0,0 +1,45 @@
;;; (json) --- Guile JSON implementation.
;; Copyright (C) 2013 Aleix Conchillo Flaque <aconchillo@gmail.com>
;;
;; This file is part of guile-json.
;;
;; guile-json is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; guile-json 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with guile-json; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Commentary:
;; JSON module for Guile
;;; Code:
(define-module (json)
#:use-module (json builder)
#:use-module (json parser)
#:use-module (json syntax))
(define-syntax re-export-modules
(syntax-rules ()
((_ (mod ...) ...)
(begin
(module-use! (module-public-interface (current-module))
(resolve-interface '(mod ...)))
...))))
(re-export-modules (json builder)
(json parser)
(json syntax))
;;; (json) ends here

17
borrowed/guile-json/json/CMakeLists.txt Normal file
View File

@ -0,0 +1,17 @@
set (scm-guile-json-details
builder.scm
parser.scm
syntax.scm
)
gnc_add_scheme_targets (guile-json-details
"${scm-guile-json-details}"
gnucash/json
""
FALSE
)
set_dist_list (guile-json-details_DIST
CMakeLists.txt
${scm-guile-json-details}
)

212
borrowed/guile-json/json/builder.scm Normal file
View File

@ -0,0 +1,212 @@
;;; (json builder) --- Guile JSON implementation.
;; Copyright (C) 2013 Aleix Conchillo Flaque <aconchillo@gmail.com>
;; Copyright (C) 2015,2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;
;; This file is part of guile-json.
;;
;; guile-json is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; guile-json 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with guile-json; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Commentary:
;; JSON module for Guile
;;; Code:
(define-module (json builder)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (rnrs bytevectors)
#:export (scm->json
scm->json-string))
;;
;; String builder helpers
;;
(define (unicode->string unicode)
(format #f "\\u~4,'0x" unicode))
(define (char->unicode-string c)
(let ((unicode (char->integer c)))
(if (< unicode 32)
(unicode->string unicode)
(string c))))
(define (u8v-2->unicode bv)
(let ((bv0 (bytevector-u8-ref bv 0))
(bv1 (bytevector-u8-ref bv 1)))
(+ (ash (logand bv0 #b00011111) 6)
(logand bv1 #b00111111))))
(define (u8v-3->unicode bv)
(let ((bv0 (bytevector-u8-ref bv 0))
(bv1 (bytevector-u8-ref bv 1))
(bv2 (bytevector-u8-ref bv 2)))
(+ (ash (logand bv0 #b00001111) 12)
(ash (logand bv1 #b00111111) 6)
(logand bv2 #b00111111))))
(define (build-char-string c)
(let* ((bv (string->utf8 (string c)))
(len (bytevector-length bv)))
(cond
;; A single byte UTF-8
((eq? len 1) (char->unicode-string c))
;; If we have a 2 or 3 byte UTF-8 we need to output it as \uHHHH
((or (eq? len 2) (eq? len 3))
(let ((unicode (if (eq? len 2)
(u8v-2->unicode bv)
(u8v-3->unicode bv))))
(unicode->string unicode)))
;; A 4 byte UTF-8 needs to output as \uHHHH\uHHHH
((eq? len 4)
(let ((bv4 (string->utf16 (string c))))
(string-append
(unicode->string (+ (ash (bytevector-u8-ref bv4 0) 8)
(bytevector-u8-ref bv4 1)))
(unicode->string (+ (ash (bytevector-u8-ref bv4 2) 8)
(bytevector-u8-ref bv4 3))))))
;; Anything else should wrong, hopefully.
(else (throw 'json-invalid)))))
;;
;; Object builder functions
;;
(define (build-object-pair p port escape pretty level)
(display (indent-string pretty level) port)
(json-build-string (car p) port escape)
(display " : " port)
(json-build (cdr p) port escape pretty level))
(define (build-newline port pretty)
(cond (pretty (newline port))))
(define (indent-string pretty level)
(if pretty (format #f "~v_" (* 4 level)) ""))
;;
;; Main builder functions
;;
(define (json-build-null port)
(display "null" port))
(define (json-build-boolean scm port)
(display (if scm "true" "false") port))
(define (json-build-number scm port)
(if (and (rational? scm) (not (integer? scm)))
(display (number->string (exact->inexact scm)) port)
(display (number->string scm) port)))
(define (->string x)
(cond ((char? x) (make-string 1 x))
((number? x) (number->string x))
((symbol? x) (symbol->string x))
(else x)))
(define (atom? x)
(or (char? x) (number? x) (string? x) (symbol? x)))
(define (json-alist? x)
(and (pair? x)
(let loop ((x x))
(or (null? x)
(null? (car x))
(and (pair? (car x)) (atom? (caar x))
(loop (cdr x)))))))
(define (json-build-string scm port escape)
(display "\"" port)
(display
(list->string
(fold-right append '()
(map
(lambda (c)
(case c
((#\" #\\) `(#\\ ,c))
((#\bs) '(#\\ #\b))
((#\ff) '(#\\ #\f))
((#\lf) '(#\\ #\n))
((#\cr) '(#\\ #\r))
((#\ht) '(#\\ #\t))
((#\/) (if escape `(#\\ ,c) (list c)))
(else (string->list (build-char-string c)))))
(string->list (->string scm)))))
port)
(display "\"" port))
(define (json-build-array scm port escape pretty level)
(display "[" port)
(unless (null? scm)
(json-build (car scm) port escape pretty (+ level 1))
(for-each (lambda (v)
(display ", " port)
(json-build v port escape pretty (+ level 1)))
(cdr scm)))
(display "]" port))
(define (json-build-object scm port escape pretty level)
(build-newline port pretty)
(simple-format port "~A{" (indent-string pretty level))
(build-newline port pretty)
(let ((pairs scm))
(unless (null? pairs)
(build-object-pair (car pairs) port escape pretty (+ level 1))
(for-each (lambda (p)
(display "," port)
(build-newline port pretty)
(build-object-pair p port escape pretty (+ level 1)))
(cdr pairs))))
(build-newline port pretty)
(simple-format port "~A}" (indent-string pretty level)))
(define (json-build scm port escape pretty level)
(cond
((eq? scm #nil) (json-build-null port))
((boolean? scm) (json-build-boolean scm port))
((number? scm) (json-build-number scm port))
((symbol? scm) (json-build-string (symbol->string scm) port escape))
((string? scm) (json-build-string scm port escape))
((json-alist? scm) (json-build-object scm port escape pretty level))
((list? scm) (json-build-array scm port escape pretty level))
((hash-table? scm)
(json-build-object (hash-map->list cons scm) port escape pretty level))
(else (throw 'json-invalid))))
;;
;; Public procedures
;;
(define* (scm->json scm
#:optional (port (current-output-port))
#:key (escape #f) (pretty #f))
"Creates a JSON document from native. The argument @var{scm} contains
the native value of the JSON document. Takes one optional argument,
@var{port}, which defaults to the current output port where the JSON
document will be written."
(json-build scm port escape pretty 0))
(define* (scm->json-string scm #:key (escape #f) (pretty #f))
"Creates a JSON document from native into a string. The argument
@var{scm} contains the native value of the JSON document."
(call-with-output-string
(lambda (p)
(scm->json scm p #:escape escape #:pretty pretty))))
;;; (json builder) ends here

351
borrowed/guile-json/json/parser.scm Normal file
View File

@ -0,0 +1,351 @@
;;; (json parser) --- Guile JSON implementation.
;; Copyright (C) 2013 Aleix Conchillo Flaque <aconchillo@gmail.com>
;;
;; This file is part of guile-json.
;;
;; guile-json is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; guile-json 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with guile-json; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Commentary:
;; JSON module for Guile
;;; Code:
(define-module (json parser)
#:use-module (ice-9 rdelim)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-9)
#:export (json->scm
json-string->scm
json-parser?
json-parser-port))
;;
;; Parser record and read helpers
;;
(define-record-type json-parser
(make-json-parser port)
json-parser?
(port json-parser-port))
(define (parser-peek-char parser)
(peek-char (json-parser-port parser)))
(define (parser-read-char parser)
(read-char (json-parser-port parser)))
(define (parser-read-delimited parser delim handle-delim)
(let ((port (json-parser-port parser)))
(read-delimited delim port handle-delim)))
;;
;; Number parsing helpers
;;
;; Read + or -. . If something different is found, return empty string.
(define (read-sign parser)
(let loop ((c (parser-peek-char parser)) (s ""))
(case c
((#\+ #\-)
(let ((ch (parser-read-char parser)))
(string-append s (string ch))))
(else s))))
;; Read digits [0..9]. If something different is found, return empty
;; string.
(define (read-digits parser)
(let loop ((c (parser-peek-char parser)) (s ""))
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(let ((ch (parser-read-char parser)))
(loop (parser-peek-char parser)
(string-append s (string ch)))))
(else s))))
(define (read-exp-part parser)
(let ((c (parser-peek-char parser)) (s ""))
(case c
;; Stop parsing if whitespace found.
((#\ht #\vt #\lf #\cr #\sp) s)
;; We might be in an array or object, so stop here too.
((#\, #\] #\}) s)
;; We might have the exponential part
((#\e #\E)
(let ((ch (parser-read-char parser)) ; current char
(sign (read-sign parser))
(digits (read-digits parser)))
;; If we don't have sign or digits, we have an invalid
;; number.
(if (not (and (string-null? sign)
(string-null? digits)))
(string-append s (string ch) sign digits)
#f)))
;; If we have a character different than e or E, we have an
;; invalid number.
(else #f))))
(define (read-real-part parser)
(let ((c (parser-peek-char parser)) (s ""))
(case c
;; Stop parsing if whitespace found.
((#\ht #\vt #\lf #\cr #\sp) s)
;; We might be in an array or object, so stop here too.
((#\, #\] #\}) s)
;; If we read . we might have a real number
((#\.)
(let ((ch (parser-read-char parser))
(digits (read-digits parser)))
;; If we have digits, try to read the exponential part,
;; otherwise we have an invalid number.
(cond
((not (string-null? digits))
(let ((exp (read-exp-part parser)))
(cond
(exp (string-append s (string ch) digits exp))
(else #f))))
(else #f))))
;; If we have a character different than . we might continue
;; processing.
(else #f))))
(define (read-number parser)
(let loop ((c (parser-peek-char parser)) (s ""))
(case c
;; Stop parsing if whitespace found.
((#\ht #\vt #\lf #\cr #\sp) s)
;; We might be in an array or object, so stop here too.
((#\, #\] #\}) s)
((#\-)
(let ((ch (parser-read-char parser)))
(loop (parser-peek-char parser)
(string-append s (string ch)))))
((#\0)
(let ((ch (parser-read-char parser)))
(string-append s
(string ch)
(or (read-real-part parser)
(throw 'json-invalid parser)))))
((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(let ((ch (parser-read-char parser)))
(string-append s
(string ch)
(read-digits parser)
(or (read-real-part parser)
(read-exp-part parser)
(throw 'json-invalid parser)))))
(else (throw 'json-invalid parser)))))
;;
;; Object parsing helpers
;;
(define (read-pair parser)
;; Read string key
(let ((key (json-read-string parser)))
(let loop ((c (parser-peek-char parser)))
(case c
;; Skip whitespaces
((#\ht #\vt #\lf #\cr #\sp)
(parser-read-char parser)
(loop (parser-peek-char parser)))
;; Skip colon and read value
((#\:)
(parser-read-char parser)
(cons key (json-read parser)))
;; invalid object
(else (throw 'json-invalid parser))))))
(define (read-object parser)
(let loop ((c (parser-peek-char parser))
(pairs (make-hash-table)))
(case c
;; Skip whitespaces
((#\ht #\vt #\lf #\cr #\sp)
(parser-read-char parser)
(loop (parser-peek-char parser) pairs))
;; end of object
((#\})
(parser-read-char parser)
pairs)
;; Read one pair and continue
((#\")
(let ((pair (read-pair parser)))
(hash-set! pairs (car pair) (cdr pair))
(loop (parser-peek-char parser) pairs)))
;; Skip comma and read more pairs
((#\,)
(parser-read-char parser)
(loop (parser-peek-char parser) pairs))
;; invalid object
(else (throw 'json-invalid parser)))))
;;
;; Array parsing helpers
;;
(define (read-array parser)
(let loop ((c (parser-peek-char parser)) (values '()))
(case c
;; Skip whitespace and comma
((#\ht #\vt #\lf #\cr #\sp #\,)
(parser-read-char parser)
(loop (parser-peek-char parser) values))
;; end of array
((#\])
(parser-read-char parser)
values)
;; this can be any json object
(else
(let ((value (json-read parser)))
(loop (parser-peek-char parser)
(append values (list value))))))))
;;
;; String parsing helpers
;;
(define (expect parser expected)
(let ((ch (parser-read-char parser)))
(if (not (char=? ch expected))
(throw 'json-invalid parser)
ch)))
(define (expect-string parser expected)
(list->string
(map (lambda (ch) (expect parser ch))
(string->list expected))))
(define (read-hex-digit parser)
(let ((c (parser-read-char parser)))
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f) c)
(else (throw 'json-invalid parser)))))
(define (read-control-char parser)
(let ((c (parser-read-char parser)))
(case c
((#\" #\\ #\/) (string c))
((#\b) (string #\bs))
((#\f) (string #\ff))
((#\n) (string #\lf))
((#\r) (string #\cr))
((#\t) (string #\ht))
((#\u)
(let* ((utf1 (string (read-hex-digit parser)
(read-hex-digit parser)))
(utf2 (string (read-hex-digit parser)
(read-hex-digit parser)))
(vu8 (list (string->number utf1 16)
(string->number utf2 16)))
(utf (u8-list->bytevector vu8)))
(utf16->string utf)))
(else #f))))
(define (read-string parser)
;; Read characters until \ or " are found.
(let loop ((result "")
(current (parser-read-delimited parser "\\\"" 'split)))
(case (cdr current)
((#\")
(string-append result (car current)))
((#\\)
(let ((ch (read-control-char parser)))
(if ch
(loop (string-append result (car current) ch)
(parser-read-delimited parser "\\\"" 'split))
(throw 'json-invalid parser ))))
(else
(throw 'json-invalid parser)))))
;;
;; Main parser functions
;;
(define-syntax json-read-delimited
(syntax-rules ()
((json-read-delimited parser delim read-func)
(let loop ((c (parser-read-char parser)))
(case c
;; skip whitespace
((#\ht #\vt #\lf #\cr #\sp) (loop (parser-peek-char parser)))
;; read contents
((delim) (read-func parser))
(else (throw 'json-invalid parser)))))))
(define (json-read-true parser)
(expect-string parser "true")
#t)
(define (json-read-false parser)
(expect-string parser "false")
#f)
(define (json-read-null parser)
(expect-string parser "null")
#nil)
(define (json-read-object parser)
(json-read-delimited parser #\{ read-object))
(define (json-read-array parser)
(json-read-delimited parser #\[ read-array))
(define (json-read-string parser)
(json-read-delimited parser #\" read-string))
(define (json-read-number parser)
(string->number (read-number parser)))
(define (json-read parser)
(let loop ((c (parser-peek-char parser)))
(cond
;;If we reach the end we might have an incomplete document
((eof-object? c) (throw 'json-invalid parser))
(else
(case c
;; skip whitespaces
((#\ht #\vt #\lf #\cr #\sp)
(parser-read-char parser)
(loop (parser-peek-char parser)))
;; read json values
((#\t) (json-read-true parser))
((#\f) (json-read-false parser))
((#\n) (json-read-null parser))
((#\{) (json-read-object parser))
((#\[) (json-read-array parser))
((#\") (json-read-string parser))
;; anything else should be a number
(else (json-read-number parser)))))))
;;
;; Public procedures
;;
(define* (json->scm #:optional (port (current-input-port)))
"Parse a JSON document into native. Takes one optional argument,
@var{port}, which defaults to the current input port from where the JSON
document is read."
(json-read (make-json-parser port)))
(define* (json-string->scm str)
"Parse a JSON document into native. Takes a string argument,
@var{str}, that contains the JSON document."
(call-with-input-string str (lambda (p) (json->scm p))))
;;; (json parser) ends here

76
borrowed/guile-json/json/syntax.scm Normal file
View File

@ -0,0 +1,76 @@
;;; (json syntax) --- Guile JSON implementation.
;; Copyright (C) 2013-2017 Aleix Conchillo Flaque <aconchillo@gmail.com>
;;
;; This file is part of guile-json.
;;
;; guile-json is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; guile-json 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with guile-json; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Commentary:
;; JSON module for Guile
;;; Code:
(define-module (json syntax)
#:use-module (ice-9 deprecated)
#:use-module (ice-9 match)
#:export (json))
(define (list->hash-table lst)
(let loop ((table (make-hash-table))
(lst lst))
(match lst
(((key value) . rest)
(hash-set! table key value)
(loop table rest))
(() table))))
(define-syntax json
(syntax-rules (unquote unquote-splicing array object)
((_ (unquote val))
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
val))
((_ ((unquote-splicing val) . rest))
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
(append val (json rest))))
((_ (array val . rest))
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
(cons (json val) (json rest))))
((_ (object key+val ...))
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
(list->hash-table
(json (array key+val ...)))))
((_ (val . rest))
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
(cons (json val) (json rest))))
((_ val)
(begin
(issue-deprecation-warning
"`json' macro is deprecated. Use scheme data types instead.")
(quote val)))))
;;; (json syntax) ends here

4
po/POTFILES.in
View File

@ -3,6 +3,10 @@
borrowed/goffice/go-charmap-sel.c
borrowed/goffice/go-glib-extras.c
borrowed/goffice/go-optionmenu.c
borrowed/guile-json/json/builder.scm
borrowed/guile-json/json/parser.scm
borrowed/guile-json/json/syntax.scm
borrowed/guile-json/json.scm
borrowed/gwengui-gtk3/gtk3_gui.c
borrowed/gwengui-gtk3/gtk3_gui_dialog.c
borrowed/gwengui-gtk3/w_checkbox.c