700d5c649245

Expose input wrapping to users
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sun, 30 Aug 2020 00:22:27 -0400
parents b148ffd26464
children f0020e905c94
branches/tags (none)
files .TODO.done TODO docs/api.lisp src/basic.lisp src/package.lisp test/tests.lisp

Changes

--- a/.TODO.done	Sat Aug 29 23:57:54 2020 -0400
+++ b/.TODO.done	Sun Aug 30 00:22:27 2020 -0400
@@ -1,5 +1,6 @@
 Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
 Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04
+Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58
 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
 Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
--- a/TODO	Sat Aug 29 23:57:54 2020 -0400
+++ b/TODO	Sun Aug 30 00:22:27 2020 -0400
@@ -1,6 +1,5 @@
 Indentation. | id:0184922ad2c249da5361f439f6449fadcb27d43c
 Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
-Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58
 Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
 Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
 Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/docs/api.lisp	Sat Aug 29 23:57:54 2020 -0400
+++ b/docs/api.lisp	Sun Aug 30 00:22:27 2020 -0400
@@ -21,7 +21,7 @@
 (d-api:draw-class-hierarchy
   "docs/static/errors.svg"
   '(jarl::json-error
-    jarl::json-parsing-error
+    jarl::json-reading-error
     jarl::json-limit-exceeded-error
     jarl::json-size-limit-exceeded-error
     jarl::json-depth-limit-exceeded-error)
--- a/src/basic.lisp	Sat Aug 29 23:57:54 2020 -0400
+++ b/src/basic.lisp	Sun Aug 30 00:22:27 2020 -0400
@@ -4,7 +4,7 @@
 (defparameter *read-size-limit* (expt 2 30)
   "The maximum number of characters to read in a single `jarl:read` call.
 
-  If more than this number of characters would have to be read to finish parsing
+  If more than this number of characters would have to be read to finish reading
   a single object, a `json-size-limit-exceeded-error` will be signaled.
 
   If both the size and depth limits are exceeded by exactly the same character,
@@ -13,7 +13,7 @@
 (defparameter *read-depth-limit* 100
   "The maximum depth of nested objects and vectors to allow in a single `jarl:read` call.
 
-  If parsing a single object would require descending into more than this number
+  If reading a single object would require descending into more than this number
   of JSON objects and/or arrays, a `json-depth-limit-exceeded-error` error will
   be signaled.
 
@@ -21,7 +21,7 @@
   it is unspecified which of the two errors will be signaled.")
 
 
-(defstruct input
+(defstruct (input (:constructor make-input%))
   (stream nil :type stream)
   (line 1 :type (and fixnum (integer 0)))
   (column 0 :type (and fixnum (integer 0)))
@@ -31,6 +31,25 @@
   (size-limit *read-size-limit* :type (and fixnum (integer 0)))
   (string-buffer nil :type (or null stream)))
 
+(defun ensure-stream (stream-or-string)
+  (etypecase stream-or-string
+    (stream stream-or-string)
+    (string (make-string-input-stream stream-or-string))))
+
+(defun make-input (stream-or-string)
+  (make-input% :stream (ensure-stream stream-or-string)))
+
+(defun reset-limits (input)
+  (setf (input-depth input) 0
+        (input-size input) 0
+        (input-depth-limit input) *read-depth-limit*
+        (input-size-limit input) *read-size-limit*))
+
+(defun reset-position (input)
+  (setf (input-line input) 0
+        (input-column input) 0))
+
+
 (defun p (input &optional (eof :eof)) ; peek
   (declare (type input input)
            (optimize (speed 3) (safety 1) (debug 1)))
@@ -60,23 +79,23 @@
   ((line :accessor line :initarg :line)
    (column :accessor column :initarg :column)))
 
-(define-condition json-parsing-error (json-error)
+(define-condition json-reading-error (json-error)
   ((class-designator :accessor class-designator :initarg :class-designator)
    (message :accessor message :initarg :message))
   (:report
    (lambda (c stream)
-     (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
+     (format stream "Error reading JSON~@[ into ~S~] at line ~D column ~D: ~A"
              (class-designator c)
              (line c)
              (column c)
              (message c)))))
 
-(define-condition json-limit-exceeded-error (json-parsing-error)
+(define-condition json-limit-exceeded-error (json-reading-error)
   ((limit :accessor limit :initarg :limit)
    (limit-name :allocation :class))
   (:report
    (lambda (c stream)
-     (format stream "~:(~A~) limit (~D) exceeded while parsing JSON at line ~D column ~D."
+     (format stream "~:(~A~) limit (~D) exceeded while reading JSON at line ~D column ~D."
              (slot-value c 'limit-name)
              (limit c)
              (line c)
@@ -90,7 +109,7 @@
 
 
 (defun e (class input format-string &rest args) ; error
-  (error 'json-parsing-error
+  (error 'json-reading-error
          :class-designator class
          :line (input-line input)
          :column (input-column input)
@@ -128,7 +147,7 @@
   (loop :for next :across remaining-characters
         :for char = (r input)
         :unless (eql next char)
-        :do (e 'keyword input "expected ~S when parsing ~S but got ~S" next literal char))
+        :do (e 'keyword input "expected ~S when reading ~S but got ~S" next literal char))
   literal)
 
 (defun parse-hex-digit (input)
@@ -227,6 +246,7 @@
 
 
 (defmethod read% ((class (eql 'keyword)) contained-class input)
+  (declare (ignore contained-class))
   (let ((ch (r input)))
     (case ch
       (#\t (parse-literal input :true "rue"))
@@ -234,6 +254,7 @@
       (t (e 'keyword input "expected ~S or ~S but got ~S" #\t #\f ch)))))
 
 (defmethod read% ((class (eql 'null)) contained-class input)
+  (declare (ignore contained-class))
   (let ((ch (r input)))
     (if (eql ch #\n)
       (parse-literal input nil "ull")
@@ -265,6 +286,7 @@
       'vector)))
 
 (defmethod read% ((class (eql 'string)) contained-class input)
+  (declare (ignore contained-class))
   (let ((ch (r input)))
     (unless (eql ch #\")
       (e 'string input "expected opening ~S but got ~S" #\" ch)))
@@ -294,8 +316,8 @@
         :with c = (car contained-class)
         :with cc = (cadr contained-class)
         :for name = (read% 'string nil input)
-        :for sep = (parse-kv-separator 'hash-table input)
-        :for value = (progn (skip-whitespace input)
+        :for value = (progn (parse-kv-separator 'hash-table input)
+                            (skip-whitespace input)
                             (read% c cc input))
         :do (progn
               (setf (gethash name result) value)
@@ -308,6 +330,7 @@
     result))
 
 (defmethod read% ((class (eql 'number)) contained-class input)
+  (declare (ignore contained-class))
   (let ((ch (p input)))
     (unless (member ch '(#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
       (r input) ; chomp to ensure accurate column count
@@ -321,6 +344,7 @@
     (t (read% (first contained-class) (second contained-class) input))))
 
 (defmethod read% ((class (eql t)) contained-class input)
+  (declare (ignore contained-class))
   (skip-whitespace input)
   (case (p input)
     (:eof (r input) (e 't input "got ~S" :eof))
@@ -416,21 +440,19 @@
                 (hash-table '(hash-table (t)))
                 (t (list class-designator)))))))
 
-(defun ensure-stream (stream-or-string)
-  (etypecase stream-or-string
-    (stream stream-or-string)
-    (string (make-string-input-stream stream-or-string))))
 
-(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
-  (let ((input (make-input :stream (ensure-stream stream-or-string))))
-    (skip-whitespace input)
-    (if (eql :eof (p input))
-      (if eof-error-p
-        (error 'end-of-file)
-        eof)
-      (destructuring-bind (class &optional contained)
-          (canonicalize-class-designator class-designator)
-        (read% class contained input)))))
+(defun read (class-designator input &optional (eof-error-p t) eof)
+  (etypecase input
+    (input (reset-limits input))
+    ((or stream string) (setf input (make-input input))))
+  (skip-whitespace input)
+  (if (eql :eof (p input))
+    (if eof-error-p
+      (error 'end-of-file)
+      eof)
+    (destructuring-bind (class &optional contained)
+        (canonicalize-class-designator class-designator)
+      (read% class contained input))))
 
 (defun print (object &optional (stream *standard-output*))
   (let ((*read-default-float-format* 'double-float)
--- a/src/package.lisp	Sat Aug 29 23:57:54 2020 -0400
+++ b/src/package.lisp	Sun Aug 30 00:22:27 2020 -0400
@@ -4,7 +4,7 @@
   (:export
     :read :print
 
-    :json-parsing-error :line :column
+    :json-reading-error :line :column
 
     :json-class
     :lisp-case-to-snake-case
--- a/test/tests.lisp	Sat Aug 29 23:57:54 2020 -0400
+++ b/test/tests.lisp	Sun Aug 30 00:22:27 2020 -0400
@@ -83,9 +83,9 @@
     (handler-case
         (progn
           (jarl:read class string)
-          (error "Should have signaled a json-parsing-error when parsing ~S but didn't."
+          (error "Should have signaled a json-reading-error when reading ~S but didn't."
                  class))
-      (jarl::json-parsing-error (e)
+      (jarl::json-reading-error (e)
         (is (equal (list class line col)
                    (list class (jarl:line e) (jarl:column e))))))))
 
@@ -323,7 +323,11 @@
     (signals jarl::json-size-limit-exceeded-error (jarl:read t "             null"))
     (signals jarl::json-size-limit-exceeded-error (jarl:read t "\"foobarbaz"))
     (signals jarl::json-size-limit-exceeded-error (jarl:read t "[[[[[[[[[[[[[[[[[[["))
-    (signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]"))))
+    (signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]"))
+    (let ((input (jarl::make-input "123456789[][1,2,3,4,5,6,7,8,9]")))
+      (is (same 123456789 (jarl:read t input)))
+      (is (same (v) (jarl:read t input)))
+      (signals jarl::json-size-limit-exceeded-error (jarl:read t input)))))
 
 (define-test depth-limit
   ;; TODO Add some more of these.
@@ -332,7 +336,10 @@
     (signals jarl::json-depth-limit-exceeded-error (jarl:read t "[[[[1]]]]"))
     (signals jarl::json-depth-limit-exceeded-error (jarl:read t (json "[{'foo': [[1]]}]")))
     (signals jarl::json-depth-limit-exceeded-error (jarl:read nil "[[[[1]]]]"))
-    (signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))))
+    (signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))
+    (let ((input (jarl::make-input "[[[]]][[[[]]]]")))
+      (is (same (v (v (v))) (jarl:read t input)))
+      (signals jarl::json-depth-limit-exceeded-error (jarl:read t input))) ))
 
 
 ;;;; MOP ----------------------------------------------------------------------
@@ -579,6 +586,19 @@
   (signals error (jarl:read 'us-err "{'id':1, 'foo': 'bar', 'meow': 'wow'}")))
 
 
+;;;; Passing Input ------------------------------------------------------------
+(define-test passing-input
+  (let ((input (jarl::make-input (json "[1,2]  99  [} {}"))))
+    (is (same (v 1 2) (jarl:read '(vector number) input)))
+    (is (same 99 (jarl:read 'number input)))
+    (handler-case
+        (progn (jarl:read 'vector input)
+               (error "Should have signaled an error, but did not."))
+      (jarl::json-reading-error (e)
+        (is (= 1 (jarl::line e)))
+        (is (= 13 (jarl::column e)))))))
+
+
 ;;;; Fuzz Utilities -----------------------------------------------------------
 (defparameter *basic-chars*
   " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")