This file is indexed.

/usr/share/common-lisp/source/yason/parse.lisp is in cl-yason 0.7.5-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
;; This file is part of yason, a Common Lisp JSON parser/encoder
;;
;; Copyright (c) 2008-2014 Hans Huebner and contributors
;; All rights reserved.
;;
;; Please see the file LICENSE in the distribution.

(in-package :yason)

(defconstant +default-string-length+ 20
  "Default length of strings that are created while reading json input.")

(defvar *parse-object-key-fn* #'identity
  "Function to call to convert a key string in a JSON array to a key
  in the CL hash produced.")

(defvar *parse-json-arrays-as-vectors* nil
  "If set to a true value, JSON arrays will be parsed as vectors, not
  as lists.")

(defvar *parse-json-booleans-as-symbols* nil
  "If set to a true value, JSON booleans will be read as the symbols
  TRUE and FALSE, not as T and NIL, respectively.")

(defvar *parse-json-null-as-keyword* nil
  "If set to a true value, JSON nulls will be read as the keyword :NULL, not as NIL.")

(defvar *parse-object-as* :hash-table
  "Set to either :hash-table, :plist or :alist to determine the data
  structure that objects are parsed to.")

(defvar *parse-object-as-alist* nil
  "DEPRECATED, provided for backward compatibility")

(defun make-adjustable-string ()
  "Return an adjustable empty string, usable as a buffer for parsing strings and numbers."
  (make-array +default-string-length+
              :adjustable t :fill-pointer 0 :element-type 'character))

(defun parse-number (input)
  ;; would be
  ;; (cl-ppcre:scan-to-strings "^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+|)(?:[eE][-+]?[0-9]+|)" buffer)
  ;; but we want to operate on streams
  (let ((buffer (make-adjustable-string)))
    (loop while (position (peek-char nil input nil) ".0123456789+-Ee")
          do (vector-push-extend (read-char input) buffer))
    (values (read-from-string buffer))))

(defun parse-unicode-escape (input)
  (let ((char-code (let ((buffer (make-string 4)))
                     (read-sequence buffer input)
                     (parse-integer buffer :radix 16))))
    (if (and (>= char-code #xd800)
             (<= char-code #xdbff))
        (let ((buffer (make-string 6)))
          (read-sequence buffer input)
          (when (not (string= buffer "\\u" :end1 2))
            (error "Lead Surrogate without Tail Surrogate"))
          (let ((tail-code (parse-integer buffer :radix 16 :start 2)))
            (when (not (and (>= tail-code #xdc00)
                            (<= tail-code #xdfff)))
              (error "Lead Surrogate without Tail Surrogate"))
            (code-char (+ #x010000
                          (ash (- char-code #xd800) 10)
                          (- tail-code #xdc00)))))
        (code-char char-code))))

(defun parse-string (input)
  (let ((output (make-adjustable-string)))
    (labels ((outc (c)
               (vector-push-extend c output))
             (next ()
               (read-char input))
             (peek ()
               (peek-char nil input)))
      (let* ((starting-symbol (next))
             (string-quoted (equal starting-symbol #\")))
        (unless string-quoted
          (outc starting-symbol))
        (loop
          (cond
            ((eql (peek) #\")
             (next)
             (return-from parse-string output))
            ((eql (peek) #\\)
             (next)
             (ecase (next)
               (#\" (outc #\"))
               (#\\ (outc #\\))
               (#\/ (outc #\/))
               (#\b (outc #\Backspace))
               (#\f (outc #\Page))
               (#\n (outc #\Newline))
               (#\r (outc #\Return))
               (#\t (outc #\Tab))
               (#\u (outc (parse-unicode-escape input)))))
            ((and (or (whitespace-p (peek)) 
                      (eql (peek) #\:)) 
                  (not string-quoted)) 
             (return-from parse-string output))
            (t
             (outc (next)))))))))

(defun whitespace-p (char)
  (member char '(#\Space #\Newline #\Tab #\Linefeed #\Return)))

(defun skip-whitespace (input)
  (loop while (and (listen input)
                   (whitespace-p (peek-char nil input)))
        do (read-char input)))

(defun peek-char-skipping-whitespace (input &optional (eof-error-p t))
  (skip-whitespace input)
  (peek-char nil input eof-error-p))

(defun parse-constant (input)
  (destructuring-bind (expected-string return-value)
      (find (peek-char nil input nil)
            `(("true" ,(if *parse-json-booleans-as-symbols* 'true t))
              ("false" ,(if *parse-json-booleans-as-symbols* 'false nil))
              ("null"  ,(if *parse-json-null-as-keyword* :null nil)))
            :key (lambda (entry) (aref (car entry) 0))
            :test #'eql)
    (loop for char across expected-string
          unless (eql (read-char input nil) char)
            do (error "invalid constant"))
    return-value))

(define-condition cannot-convert-key (error)
  ((key-string :initarg :key-string
               :reader key-string))
  (:report (lambda (c stream)
             (format stream "cannot convert key ~S used in JSON object to hash table key"
                     (key-string c)))))

(defun create-container ()
  (ecase *parse-object-as*
    ((:plist :alist)
     nil)
    (:hash-table
     (make-hash-table :test #'equal))))

(defun add-attribute (to key value)
  (ecase *parse-object-as*
    (:plist
     (append to (list key value)))
    (:alist
     (append to (list (cons key value))))
    (:hash-table
     (setf (gethash key to) value)
     to)))

(define-condition expected-colon (error)
  ((key-string :initarg :key-string
               :reader key-string))
  (:report (lambda (c stream)
             (format stream "expected colon to follow key ~S used in JSON object"
                     (key-string c)))))

(defun parse-object (input)
  (let ((return-value (create-container)))
    (read-char input)
    (loop
      (when (eql (peek-char-skipping-whitespace input)
                 #\})
        (return))
      (skip-whitespace input)
      (setf return-value
            (add-attribute return-value
                           (let ((key-string (parse-string input)))
                             (prog1
                                 (or (funcall *parse-object-key-fn* key-string)
                                     (error 'cannot-convert-key :key-string key-string))
                               (skip-whitespace input)
                               (unless (eql #\: (read-char input))
                                 (error 'expected-colon :key-string key-string))
                               (skip-whitespace input)))
                           (parse input)))
      (ecase (peek-char-skipping-whitespace input)
        (#\, (read-char input))
        (#\} nil)))
    (read-char input)
    return-value))

(defconstant +initial-array-size+ 20
  "Initial size of JSON arrays read, they will grow as needed.")

(defun %parse-array (input add-element-function)
  "Parse JSON array from input, calling ADD-ELEMENT-FUNCTION for each array element parsed."
  (read-char input)
  (loop
    (when (eql (peek-char-skipping-whitespace input)
               #\])
      (return))
    (funcall add-element-function (parse input))
    (ecase (peek-char-skipping-whitespace input)
      (#\, (read-char input))
      (#\] nil)))
  (read-char input))

(defun parse-array (input)
  (if *parse-json-arrays-as-vectors*
      (let ((return-value (make-array +initial-array-size+ :adjustable t :fill-pointer 0)))
        (%parse-array input
                      (lambda (element)
                        (vector-push-extend element return-value)))
        return-value)
      (let (return-value)
        (%parse-array input
                      (lambda (element)
                        (push element return-value)))
        (nreverse return-value))))

(defgeneric parse% (input)
  (:method ((input stream))
    ;; backward compatibility code
    (assert (or (not *parse-object-as-alist*)
                (eq *parse-object-as* :hash-table))
            () "unexpected combination of *parse-object-as* and *parse-object-as-alist*, please use *parse-object-as* exclusively")
    (let ((*parse-object-as* (if *parse-object-as-alist*
                                 :alist
                                 *parse-object-as*)))
      ;; end of backward compatibility code
      (check-type *parse-object-as* (member :hash-table :alist :plist))
      (ecase (peek-char-skipping-whitespace input)
        (#\"
         (parse-string input))
        ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
         (parse-number input))
        (#\{
         (parse-object input))
        (#\[
         (parse-array input))
        ((#\t #\f #\n)
         (parse-constant input)))))
  (:method ((input pathname))
    (with-open-file (stream input)
      (parse stream)))
  (:method ((input string))
    (parse (make-string-input-stream input))))

(defun parse (input
              &key
                (object-key-fn *parse-object-key-fn*)
                (object-as *parse-object-as*)
                (json-arrays-as-vectors *parse-json-arrays-as-vectors*)
                (json-booleans-as-symbols *parse-json-booleans-as-symbols*)
                (json-nulls-as-keyword *parse-json-null-as-keyword*))
  "Parse INPUT, which needs to be a string or a stream, as JSON.
  Returns the lisp representation of the JSON structure parsed.  The
  keyword arguments can be used to override the parser settings as
  defined by the respective special variables."
  (let ((*parse-object-key-fn* object-key-fn)
        (*parse-object-as* object-as)
        (*parse-json-arrays-as-vectors* json-arrays-as-vectors)
        (*parse-json-booleans-as-symbols* json-booleans-as-symbols)
        (*parse-json-null-as-keyword* json-nulls-as-keyword))
    (parse% input)))