Coverage report: /home/ellis/comp/core/lib/dat/xml/xml.lisp

KindCoveredAll%
expression5581429 39.0
branch79210 37.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/dat/xml.lisp --- XML Data Format
2
 
3
 ;; based on the re-implementation of https://github.com/rpgoldman/xmls
4
 
5
 ;;; Code:
6
 (in-package :dat/xml)
7
 
8
 ;;; Vars
9
 (defvar *strip-comments* t)
10
 (defvar *compress-whitespace* t)
11
 (defvar *discard-processing-instructions*)
12
 
13
 (eval-when (:compile-toplevel :load-toplevel :execute)
14
   (declaim (type vector *entities*))
15
   (defvar *entities*
16
     #(("lt;" #\<)
17
       ("gt;" #\>)
18
       ("amp;" #\&)
19
       ("apos;" #\')
20
       ("quot;" #\")))
21
   (defvar *whitespace* (remove-duplicates
22
                         '(#\Newline #\Space #\Tab #\Return #\Linefeed))))
23
 (defvar *char-escapes*
24
   (let ((table (make-array 256 :element-type 'string :initial-element "")))
25
     (loop
26
       for code from 0 to 255
27
       for char = (code-char code)
28
       for entity = (first (find char *entities* :test #'char= :key #'second))
29
       do (setf (svref table code)
30
                (cond
31
                  (entity
32
                   (concatenate 'string "&" entity))
33
                  ((and (or (< code 32) (> code 126))
34
                        (not (= code 10))
35
                        (not (= code 9)))
36
                   (format nil "&#x~x;" code))
37
                  (t
38
                   (format nil "~x" char))))
39
       finally (return table))
40
     table))
41
 
42
 (defvar *parser-stream* nil
43
   "The currently-being-parsed stream. Used so that we can appropriately track
44
 the line number.")
45
 (defvar *parser-line-number* nil)
46
 
47
 ;;; Conditions
48
 (define-condition xml-parse-error (error)
49
   ((line :initarg :line
50
          :initform nil
51
          :reader error-line))
52
   (:report (lambda (xpe stream)
53
              (format stream "XML-PARSE-ERROR~@[ at line ~d~]"
54
                      (error-line xpe)))))
55
 
56
 (defmethod initialize-instance :after ((obj xml-parse-error) &key)
57
   (unless (slot-value obj 'line)
58
     (when *parser-line-number*
59
       (setf (slot-value obj 'line) *parser-line-number*))))
60
 
61
 ;;; Nodes
62
 (defstruct (xml-node (:constructor %make-xml-node))
63
   name
64
   ns
65
   attrs
66
   children)
67
 
68
 (std:defaccessor ast:ast ((self xml-node)) (xml-node-children self))
69
 (std:defaccessor std:name ((self xml-node)) (xml-node-name self))
70
 
71
 (defun make-xml-node (&key name ns attrs child children)
72
   "Convenience function for creating a new xml node."
73
   (when (and child children)
74
     (error "Cannot specify both :child and :children for MAKE-NODE."))
75
   (let ((children (if child
76
                       (list child)
77
                       children)))
78
     (%make-xml-node :name name :ns ns
79
                     :children children
80
                     :attrs attrs)))
81
 
82
 ;;; Proc Inst
83
 (defstruct proc-inst
84
   (target "" :type string)
85
   (contents "" :type string))
86
 
87
 ;;; Utilities
88
 (defun compress-whitespace (str)
89
   (if *compress-whitespace*
90
       (progn
91
         (setf str (string-trim *whitespace* str))
92
         (if (= 0 (length str))
93
             nil
94
             str))
95
       str))
96
 
97
 (defun write-escaped (string stream)
98
   (write-string (escape-for-html string) stream))
99
 
100
 (defun escape-for-html (string)
101
   "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output."
102
   (with-output-to-string (out)
103
     (with-input-from-string (in string)
104
       (loop for char = (read-char in nil nil)
105
             while char
106
             do (case char
107
                  ((#\<) (write-string "&lt;" out))
108
                  ((#\>) (write-string "&gt;" out))
109
                  ((#\") (write-string "&quot;" out))
110
                  ((#\') (write-string "&#039;" out))
111
                  ((#\&) (write-string "&amp;" out))
112
                  (otherwise (write-char char out)))))))
113
 
114
 (defun make-extendable-string (&optional (size 10))
115
   "Creates an adjustable string with a fill pointer."
116
   (make-array size
117
               :element-type 'character
118
               :adjustable t
119
               :fill-pointer 0))
120
 
121
 (defun push-string (c string)
122
   "Shorthand function for adding characters to an extendable string."
123
   (vector-push-extend c string))
124
 
125
 (defun translate-raw-value (raw-value)
126
   "Helper function for xml generation."
127
   (etypecase raw-value
128
     (string raw-value)
129
     (symbol (symbol-name raw-value))
130
     (integer (format nil "~D" raw-value))
131
     (float (format nil "~G" raw-value))))
132
 
133
 (defun generate-xml (e s indent)
134
   "Renders a lisp node tree to an xml string stream."
135
   (if (> indent 0) (incf indent))
136
   (etypecase e
137
     (xml-node
138
      (progn
139
        (dotimes (i (* 2 (- indent 2)))
140
          (write-char #\Space s))
141
        (format s "<~A~@[ xmlns=\"~A\"~]" (xml-node-name e) (xml-node-ns e))
142
        (loop for a in (xml-node-attrs e)
143
              do (progn
144
                   (write-char #\Space s)
145
                   (write-string (first a) s)
146
                   (write-char #\= s)
147
                   (write-char #\" s)
148
                   (write-escaped (translate-raw-value (second a)) s)
149
                   (write-char #\" s))))
150
      (if (null (xml-node-children e))
151
          (progn
152
            (write-string "/>" s)
153
            (if (> indent 0) (write-char #\Newline s)))
154
          (progn
155
            (write-char #\> s)
156
            (if (> indent 0) (write-char #\Newline s))
157
            (mapc #'(lambda (c) (generate-xml c s indent)) (xml-node-children e))
158
            (if (> indent 0)
159
                (progn
160
                  (dotimes (i (* 2 (- indent 2)))
161
                    (write-char #\Space s))))
162
            (format s "</~A>" (xml-node-name e))
163
            (if (> indent 0) (write-char #\Newline s)))))
164
     (number
165
      (generate-xml (translate-raw-value e) s indent))
166
     (symbol
167
      (generate-xml (translate-raw-value e) s indent))
168
     (string
169
      (progn
170
        (if (> indent 0)
171
            (progn
172
              (dotimes (i (* 2 (- indent 2)))
173
                (write-char #\Space s))))
174
        (write-escaped e s)
175
        (if (> indent 0) (write-char #\Newline s))))))
176
 
177
 ;;; Parser State
178
 (defstruct state
179
   "Represents parser state.  Passed among rules to avoid threading issues."
180
   (got-doctype nil)
181
   (lines 1 :type integer)
182
   nsstack
183
   stream)
184
 
185
 (defun resolve-entity (ent)
186
   "Resolves the xml entity ENT to a character.  Numeric entities are
187
 converted using CODE-CHAR, which only works in implementations that
188
 internally encode strings in US-ASCII, ISO-8859-1 or UCS."
189
   (declare (type simple-string ent))
190
   (or (and (>= (length ent) 2)
191
            (char= (char ent 0) #\#)
192
            (code-char
193
             (if (char= (char ent 1) #\x)
194
                 (parse-integer ent :start 2 :end (- (length ent) 1) :radix 16)
195
                 (parse-integer ent :start 1 :end (- (length ent) 1)))))
196
       (second (find ent *entities* :test #'string= :key #'first))
197
       (error "Unable to resolve entity ~S" ent)))
198
 
199
 (declaim (inline peek-stream))
200
 (defun peek-stream (stream)
201
   "Looks one character ahead in the input stream.  Serves as a potential hook for
202
 character translation."
203
   (peek-char nil stream nil))
204
 
205
 (defun read-stream (stream)
206
   "Reads a character from the stream, translating entities as it goes."
207
   (let ((c (read-char stream nil)))
208
     (if (and c (not (char= c #\&)))
209
         c
210
         (loop with ent = (make-extendable-string 5)
211
               for char = (read-char stream)
212
               do (push-string char ent)
213
               until (char= char #\;)
214
               finally (return (resolve-entity (coerce ent 'simple-string)))))))
215
 
216
 ;; Shadow READ-CHAR and UNREAD-CHAR
217
 (defun read-char (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p)
218
   (let ((eof-p nil))
219
     (let ((c
220
             (catch 'char-return
221
               (handler-bind
222
                   ((end-of-file
223
                      #'(lambda (e)
224
                          (declare (ignore e))
225
                          (unless eof-error-p
226
                            (setf eof-p t)
227
                            (throw 'char-return eof-value)))))
228
                 (common-lisp:read-char stream t nil recursive-p)))))
229
       (when (and (eq stream *parser-stream*)
230
                  (not eof-p)
231
                  (char= c #\newline))
232
         (incf *parser-line-number*))
233
       c)))
234
 
235
 (defun unread-char (char &optional (stream *standard-input*))
236
   (when (char= char #\newline)
237
     (decf *parser-line-number*))
238
   (common-lisp:unread-char char stream))
239
 
240
 (define-symbol-macro next-char (peek-stream (state-stream s)))
241
 
242
 (defmacro eat ()
243
   "Consumes one character from the input stream."
244
   `(read-char (state-stream s)))
245
 
246
 (defmacro puke (char)
247
   "The opposite of EAT."
248
   `(unread-char ,char (state-stream s)))
249
 
250
 (defmacro match (&rest matchers)
251
   "Attempts to match the next input character with one of the supplied matchers."
252
   `(let ((c (peek-stream (state-stream s))))
253
      (and c
254
           (or ,@(loop for m in matchers
255
                       collect (etypecase m
256
                                 (standard-char `(char= ,m c))
257
                                 (symbol `(,m c)))))
258
           ;; cheat here a little bit - eat entire char entity instead
259
           ;; of peeked char
260
           (read-stream (state-stream s)))))
261
 
262
 (defmacro match-seq (&rest sequence)
263
   "Tries to match the supplied matchers in sequence with characters in the input stream."
264
   `(and ,@(loop for s in sequence
265
                 collect `(match ,s))))
266
 
267
 (defmacro match* (&rest sequence)
268
   "Matches any occurances of any of the supplied matchers."
269
   `(loop with data = (make-extendable-string 10)
270
          for c = (match ,@sequence)
271
          while c
272
          do (push-string c data)
273
          finally (return data)))
274
 
275
 (defmacro match+ (&rest sequence)
276
   "Matches one or more occurances of any of the supplied matchers."
277
   `(and (peek ,@sequence)
278
         (match* ,@sequence)))
279
 
280
 (defmacro peek (&rest matchers)
281
   "Looks ahead for an occurance of any of the supplied matchers."
282
   `(let ((c (peek-stream (state-stream s))))
283
      (or ,@(loop for m in matchers
284
                  collect (etypecase m
285
                            (standard-char `(char= ,m c))
286
                            (symbol `(,m c)))))))
287
 
288
 (defmacro must (&rest body)
289
   "Throws a parse error if the supplied forms do not succeed."
290
   `(or (progn ,@body)
291
        (error 'xml-parse-error)))
292
 
293
 ;;; Parser Internal
294
 (defstruct element
295
   "Common return type of all rule functions."
296
   (type nil :type symbol)
297
   (val nil))
298
 
299
 (defun resolve-namespace (elem env)
300
   "Maps the ns prefix to its associated url via the supplied ns env."
301
   (let ((ns (xml-node-ns elem)))
302
     (dolist (e env)
303
       (let ((nsurl (assoc ns e :test #'string=)))
304
         (and nsurl
305
              (setf (xml-node-ns elem) (cadr nsurl))
306
              (return ns))))))
307
 
308
 ;;; Match and Rule Utils
309
 (defmacro defmatch (name &rest body)
310
   "Match definition macro that provides a common lexical environment for matchers."
311
   `(defun ,name (c)
312
      ,@body))
313
 
314
 (defmacro defrule (name &rest body)
315
   "Rule definition macro that provides a common lexical environment for rules."
316
   `(defun ,name (s)
317
      ,@body))
318
 
319
 (defmacro matchfn (name)
320
   "Convenience macro for creating an anonymous function wrapper around a matcher macro."
321
   `(lambda (s) (match ,name)))
322
 
323
 (defun none-or-more (s func)
324
   "Collects any matches of the supplied rule with the input stream."
325
   (declare (type function func))
326
   (let ((val (funcall func s)))
327
     (if val
328
         (multiple-value-bind (res nextval)
329
             (none-or-more s func)
330
           (values res (cons val nextval)))
331
         (values t nil))))
332
 
333
 (defun one-or-more (s func)
334
   "Collects one or more matches of the supplied rule with the input stream."
335
   (declare (type function func))
336
   (let ((val (funcall func s)))
337
     (if val
338
         (multiple-value-bind (res nextval)
339
             (none-or-more s func)
340
           (declare (ignore res))
341
           (cons val nextval))
342
         nil)))
343
 
344
 ;;; Matchers
345
 (defmatch digit ()
346
   (and c (digit-char-p c)))
347
 
348
 (defmatch letter ()
349
   (and c (alpha-char-p c)))
350
 
351
 ;; Modified because *whitespace* is not defined at compile
352
 ;; time. [2004/08/31:rpg]
353
 (defmatch ws-char ()
354
   (member c *whitespace*))
355
 ;;;  (case c
356
 ;;;    (#.*whitespace* t)
357
 ;;;    (t nil)))
358
 
359
 (defmatch namechar ()
360
   (or
361
    (and c (alpha-char-p c))
362
    (and c (digit-char-p c))
363
    (case c
364
      ((#\. #\- #\_ #\:) t))))
365
 
366
 (defmatch ncname-char ()
367
   (or
368
    (and c (alpha-char-p c))
369
    (and c (digit-char-p c))
370
    (case c
371
      ((#\. #\- #\_) t))))
372
 
373
 (defmatch attr-text-dq ()
374
   (and c (not (member c (list #\< #\")))))
375
 
376
 (defmatch attr-text-sq ()
377
   (and c (not (member c (list #\< #\')))))
378
 
379
 (defmatch chardata ()
380
   (and c (not (char= c #\<))))
381
 
382
 (defmatch comment-char ()
383
   (and c (not (eql c #\-))))
384
 
385
 ;;; Rules
386
 (defrule ncname ()
387
   (and (peek letter #\_)
388
        (match+ ncname-char)))
389
 
390
 (defrule qname ()
391
   (let (name suffix)
392
     (and
393
      (setf name (ncname s))
394
      (or
395
       (and
396
        (match #\:)
397
        (setf suffix (ncname s)))
398
       t))
399
     (values name suffix)))
400
 
401
 (defrule attr-or-nsdecl ()
402
   (let (suffix name val)
403
     (and
404
      (setf (values name suffix) (qname s))
405
      (or
406
       (and
407
        (progn
408
          (match* ws-char)
409
          (match #\=))
410
        (or
411
         (and
412
          (progn
413
            (match* ws-char)
414
            (match #\"))
415
          (setf val (match* attr-text-dq))
416
          (match #\"))
417
         (and
418
          (progn
419
            (match* ws-char)
420
            (match #\'))
421
          (setf val (match* attr-text-sq))
422
          (match #\'))))
423
       t)
424
      (if (string= "xmlns" name)
425
          (list 'nsdecl suffix val)
426
          ;; If SUFFIX is true, then NAME is Prefix and SUFFIX is
427
          ;; LocalPart.
428
          (if suffix
429
              (list 'attr suffix val :attr-ns name)
430
              (list 'attr name val))))))
431
 
432
 (defrule ws ()
433
   (and (match+ ws-char)
434
        (make-element :type 'whitespace :val nil)))
435
 
436
 (defrule name ()
437
   (and
438
    (peek namechar #\_ #\:)
439
    (match* namechar)))
440
 
441
 (defrule ws-attr-or-nsdecl ()
442
   (and
443
    (ws s)
444
    (attr-or-nsdecl s)))
445
 
446
 (defrule start-tag ()
447
   (let (name suffix attrs nsdecls)
448
     (and
449
      (peek namechar)
450
      (setf (values name suffix) (qname s))
451
      (multiple-value-bind (res a)
452
          (none-or-more s #'ws-attr-or-nsdecl)
453
        (mapcar (lambda (x) (if (eq (car x) 'attr)
454
                                (push (cdr x) attrs)
455
                                (push (cdr x) nsdecls)))
456
                a)
457
        res)
458
      (or (ws s) t)
459
      (values
460
       (make-xml-node
461
        :name (or suffix name)
462
        :ns (and suffix name)
463
        :attrs attrs)
464
       nsdecls))))
465
 
466
 (defrule end-tag ()
467
   (let (name suffix)
468
     (and
469
      (match #\/)
470
      (setf (values name suffix) (qname s))
471
      (or (ws s) t)
472
      (match #\>)
473
      (make-element :type 'end-tag :val (or suffix name)))))
474
 
475
 (defrule comment ()
476
   (and
477
    (match-seq #\! #\- #\-)
478
    (progn
479
      (loop until (match-seq #\- #\- #\>)
480
            do (eat))
481
      t)
482
    (make-element :type 'comment)))
483
 
484
 ;; For the CDATA matching of ]]> I by hand generated an NFA, and then
485
 ;; determinized it (also by hand).  Then I did a simpler thing of just pushing
486
 ;; ALL the data onto the data string, and truncating it when done.
487
 (defrule comment-or-cdata ()
488
   (and
489
    (peek #\!)
490
    (must (or (comment s)
491
              (and
492
               (match-seq #\[ #\C #\D #\A #\T #\A #\[)
493
               (loop with data = (make-extendable-string 50)
494
                     with state = 0
495
                     for char = (eat)
496
                     do (push-string char data)
497
                     do (case state
498
                          (0
499
                           (case char
500
                             (#\]
501
                              (trace! :cdata "State 0 Match #\], go to state {0,1} = 4.")
502
                              (setf state 4))
503
                             (otherwise
504
                              (trace! :cdata "State 0 Non-], go to (remain in) state 0."))))
505
                          (4 ; {0, 1}
506
                           (case char
507
                             (#\]
508
                              (trace! :cdata "State 4 {0, 1}, match ], go to state {0,1,2} = 5")
509
                              (setf state 5))
510
                             (otherwise
511
                              (trace! :cdata "State 4 {0, 1}, Non-], go to state 0.")
512
                              (setf state 0))))
513
                          (5 ; {0, 1, 2}
514
                           (case char
515
                             (#\]
516
                              (trace! :cdata "State 5 {0, 1, 2}, match ], stay in state 5."))
517
                             (#\>
518
                              (trace! :cdata "State 5 {0, 1, 2}, match >, finish match and go to state 3.")
519
                              (setf state 3))
520
                             (otherwise
521
                              (trace! :cdata "State 5 {0, 1, 2}, find neither ] nor >; go to state 0.")
522
                              (setf state 0))))
523
                          )
524
                     until (eql state 3)
525
                     finally (return (make-element
526
                                      :type 'cdata
527
                                      :val (coerce
528
                                            ;; rip the ]]> off the end of the data and return it...
529
                                            (subseq data 0 (- (fill-pointer data) 3))
530
                                            'simple-string)))))))))
531
 
532
 
533
 (declaim (ftype function element))     ; forward decl for content rule
534
 (defrule content ()
535
   (if (match #\<)
536
       (must (or (comment-or-cdata s)
537
                 (processing-instruction s)
538
                 (element s)
539
                 (end-tag s)))
540
       (or (let (content)
541
             (and (setf content (match+ chardata))
542
                  (make-element :type 'data :val (compress-whitespace content)))))))
543
 
544
 (defrule element ()
545
   (let (elem children nsdecls end-name)
546
     (and
547
      ;; parse front end of tag
548
      (multiple-value-bind (e n)
549
          (start-tag s)
550
        (setf elem e)
551
        (setf nsdecls n)
552
        e)
553
      ;; resolve namespaces *before* parsing children
554
      (if nsdecls (push nsdecls (state-nsstack s)) t)
555
      (or (if (or nsdecls (state-nsstack s))
556
              (resolve-namespace elem (state-nsstack s)))
557
          t)
558
      ;; parse end-tag and children
559
      (or
560
       (match-seq #\/ #\>)
561
       (and
562
        (match #\>)
563
        (loop for c = (content s)
564
              while c
565
              do (etypecase c
566
                   (element (case (element-type c)
567
                              (end-tag
568
                               (return (setf end-name (element-val c))))
569
                              ;; processing instructions may be discarded
570
                              (pi
571
                               (unless *discard-processing-instructions*
572
                                 (when (element-val c)
573
                                   (push (element-val c) children))))
574
                              (t (if (element-val c)
575
                                     (push (element-val c) children)))))))
576
        (string= (xml-node-name elem) end-name)))
577
      ;; package up new node
578
      (progn
579
        (setf (xml-node-children elem) (nreverse children))
580
        (make-element :type 'elem :val elem)))))
581
 
582
 (defrule processing-instruction ()
583
   (let (name contents)
584
     (and
585
      (match #\?)
586
      (setf name (name s))
587
      (not (string= name "xml"))
588
      ;; contents of a processing instruction can be arbitrary stuff, as long
589
      ;; as it doesn't contain ?>...
590
      (setf contents (pi-contents s))
591
      ;; if we get here, we have eaten ?> off the input in the course of
592
      ;; processing PI-CONTENTS
593
      (make-element :type 'pi :val (make-proc-inst :target name :contents contents)))))
594
 
595
 (defrule pi-contents ()
596
   (loop with data = (make-extendable-string 50)
597
         with state = 0
598
         for char = (eat)
599
         do (push-string char data)
600
         do (ecase state
601
              (0
602
               (case char
603
                 (#\?
604
                  (trace! :pi-contents "State 0 Match #\?, go to state 1.")
605
                  (setf state 1))
606
                 (otherwise
607
                  (trace! :pi-contents "State 0 ~c, go to (remain in) state 0." char))))
608
              (1
609
               (case char
610
                 (#\>
611
                  (trace! :pi-contents "State 1 Match #\>, done.")
612
                  (setf state 2))
613
                 (otherwise
614
                  (trace! :pi-contents "State 1, ~c, do not match #\>, return to 0." char)
615
                  (setf state 0)))))
616
         until (eql state 2)
617
         finally (return (coerce
618
                          ;; rip the ?> off the end of the data and return it...
619
                          (subseq data 0 (max 0 (- (fill-pointer data) 2)))
620
                          'simple-string))))
621
 
622
 (defrule xmldecl ()
623
   (let (name contents)
624
     (and
625
      (match #\?)
626
      (setf name (name s))
627
      (string= name "xml")
628
      (setf contents (none-or-more s #'ws-attr-or-nsdecl))
629
      (match-seq #\? #\>)
630
      (make-element :type 'xmldecl :val contents))))
631
 
632
 (defrule comment-or-doctype ()
633
   ;; skip dtd - bail out to comment if it's a comment
634
   ;; only match doctype once
635
   (and
636
    (peek #\!)
637
    (or (comment s)
638
        (and (not (state-got-doctype s))
639
             (must (match-seq #\D #\O #\C #\T #\Y #\P #\E))
640
             (loop with level = 1
641
                   do (case (eat)
642
                        (#\> (decf level))
643
                        (#\< (incf level)))
644
                   until (eq level 0)
645
                   finally (return t))
646
             (setf (state-got-doctype s) t)
647
             (make-element :type 'doctype)))))
648
 
649
 (defrule misc ()
650
   (or
651
    (ws s)
652
    (and (match #\<) (must (or (processing-instruction s)
653
                               (comment-or-doctype s)
654
                               (element s))))))
655
 
656
 (defrule document ()
657
   (let (elem)
658
     (if (match #\<)
659
         (must (or (xmldecl s)
660
                   (comment-or-doctype s)
661
                   (setf elem (element s)))))
662
     ;; NOTE: I don't understand this: it seems to parse arbitrary crap
663
     (unless elem
664
       (loop for c = (misc s)
665
             while c
666
             do (cond ((eql (element-type c) 'elem)
667
                       (return (setf elem c)))
668
                      ((and (eql (element-type c) 'pi)
669
                            (not *discard-processing-instructions*))
670
                       (return (setf elem c))))))
671
     
672
     (and elem (element-val elem))))
673
 
674
 ;;; Public API
675
 (defun write-xml (e s &key (indent nil))
676
   "Renders a lisp node tree to an xml stream.  Indents if indent is non-nil."
677
   (if (null s)
678
       (toxml e :indent indent)
679
       (generate-xml e s (if indent 1 0))))
680
 
681
 (defun write-prologue (xml-decl doctype s)
682
   "Render the leading <?xml ... ?> and <!DOCTYPE ... > tags to an xml stream."
683
   (format s "<?xml")
684
   (dolist (attrib xml-decl)
685
     (format s " ~A=\"~A\"" (car attrib) (cdr attrib)))
686
   (format s " ?>~%")
687
   (when doctype
688
     (format s "<!DOCTYPE ~A>~%" doctype)))
689
 
690
 (defun write-prolog (xml-decl doctype s)
691
   (write-prologue xml-decl doctype s))
692
 
693
 (defun toxml (e &key (indent nil))
694
   "Renders a lisp node tree to an xml string."
695
   (with-output-to-string (s)
696
     (write-xml e s :indent indent)))
697
 
698
 (defun xml-parse (s &key (compress-whitespace t) (quash-errors t))
699
   "Parses the supplied stream or string into a lisp node tree."
700
   (let* ((*compress-whitespace* compress-whitespace)
701
          (*discard-processing-instructions* t)
702
          (stream
703
            (etypecase s
704
              (string (make-string-input-stream s))
705
              (stream s)))
706
          (*parser-stream* stream)
707
          (*parser-line-number* 1))
708
     (if quash-errors
709
         (handler-case
710
             (document (make-state :stream stream))
711
           (end-of-file () nil)
712
           (xml-parse-error () nil))
713
         (document (make-state :stream stream)))))
714
 
715
 ;;; Xmlrep
716
 (defun make-xmlrep (tag &key (representation-kind :node) namespace attribs children)
717
   (case representation-kind
718
     ((:list)
719
      (cond
720
        (namespace
721
         (list (list tag namespace) (list attribs) children))
722
        (t
723
         (list tag (list attribs) children))))
724
     ((:node)
725
      (make-xml-node :name tag :ns namespace :attrs attribs :children children))
726
     (otherwise
727
      (error "REPRESENTATION-KIND must be :LIST or :NODE, got ~s" representation-kind))))
728
 
729
 (defgeneric xmlrep-add-child! (xmlrep child)
730
   (:method ((xmlrep xml-node) child)
731
     (setf (xml-node-children xmlrep)
732
           (append (xml-node-children xmlrep)
733
                   (list child))))
734
   (:method ((xmlrep cons) child)
735
     (setf (cddr xmlrep)
736
           (append (cddr xmlrep)
737
                   (list child)))))
738
 
739
 (defgeneric xmlrep-tag (treenode)
740
   (:method ((treenode xml-node))
741
     (xml-node-name treenode))
742
   (:method ((treenode cons))
743
     (let ((tag-name (car treenode)))
744
       ;; detect the "namespaced" case
745
       (cond
746
         ((consp tag-name) (car tag-name))
747
         (t tag-name)))))
748
 
749
 (defun xmlrep-tagmatch (tag treenode)
750
   ;;child nodes to XMLREPs could be strings or nodes
751
   (unless (stringp treenode)
752
     (string-equal tag (xmlrep-tag treenode))))
753
 
754
 (defgeneric xmlrep-attribs (treenode)
755
   (:method ((treenode xml-node))
756
     (xml-node-attrs treenode))
757
   (:method ((treenode cons))
758
     (cadr treenode)))
759
 
760
 (defgeneric (setf xmlrep-attribs) (attribs treenode)
761
   (:argument-precedence-order treenode attribs)
762
   (:method (attribs (treenode xml-node))
763
     (setf (xml-node-attrs treenode) attribs))
764
   (:method (attribs (treenode cons))
765
     (setf (cadr treenode) attribs)))
766
 
767
 (defgeneric xmlrep-children (treenode)
768
   (:method ((treenode xml-node))
769
     (xml-node-children treenode))
770
   (:method ((treenode cons))
771
     (cddr treenode)))
772
 
773
 (defgeneric (setf xmlrep-children) (children treenode)
774
   (:argument-precedence-order treenode children)
775
   (:method (children (treenode xml-node))
776
     (setf (xml-node-children treenode) children))
777
   (:method (children (treenode cons))
778
     (setf (cddr treenode) children)))
779
 
780
 (defun xmlrep-string-child (treenode &optional (if-unfound :error))
781
   (let ((children (xmlrep-children treenode)))
782
     (if (and (eq (length children) 1) (typep (first children) 'string))
783
         (first children)
784
         (if (eq if-unfound :error)
785
             (error "Node does not have a single string child: ~a" treenode)
786
             if-unfound)
787
         )))
788
 
789
 (defun xmlrep-integer-child (treenode)
790
   (parse-integer (xmlrep-string-child treenode)))
791
 
792
 (defun xmlrep-find-child-tags (tag treenode)
793
   "Find all the children of TREENODE with TAG."
794
   (remove-if-not #'(lambda (child) (xmlrep-tagmatch tag child))
795
                  (xmlrep-children treenode)))
796
 
797
 (defun xmlrep-find-child-tag (tag treenode
798
                               &optional (if-unfound :error))
799
   "Find a single child of TREENODE with TAG.  Returns an error
800
 if there is more or less than one such child."
801
   (let ((matches (xmlrep-find-child-tags tag treenode)))
802
     (case (length matches)
803
       (0 (if (eq if-unfound :error)
804
              (error "Couldn't find child tag ~A in ~A"
805
                     tag treenode)
806
              if-unfound))
807
       (1 (first matches))
808
       (otherwise (error "Child tag ~A multiply defined in ~A"
809
                         tag treenode)))))
810
 
811
 (defun xmlrep-attrib-value (attrib treenode
812
                             &optional (if-undefined :error))
813
   "Find the value of ATTRIB, a string, in TREENODE.
814
 if there is no ATTRIB, will return the value of IF-UNDEFINED,
815
 which defaults to :ERROR."
816
   (let ((found-attrib (find-attrib attrib treenode)))
817
     (cond (found-attrib
818
            (second found-attrib))
819
           ((eq if-undefined :error)
820
            (error "XML attribute ~S undefined in ~S"
821
                   attrib treenode))
822
           (t
823
            if-undefined))))
824
 
825
 (defun find-attrib (attrib treenode)
826
   "Returns the attrib CELL (not the attrib value) from 
827
 TREENODE, if found.  This cell will be a list of length 2,
828
 the attrib name (a string) and its value."
829
   (find attrib (xmlrep-attribs treenode)
830
         :test #'string=
831
         :key #'car))
832
 
833
 (defun (setf xmlrep-attrib-value) (value attrib treenode)
834
   ;; ideally, we would check this...
835
   (let ((old-val (xmlrep-attrib-value attrib treenode nil)))
836
     (if old-val
837
         (cond ((null value)
838
                ;; just delete this attribute...
839
                (setf (xmlrep-attribs treenode)
840
                      (remove attrib (xmlrep-attribs treenode)
841
                              :test #'string=
842
                              :key #'first))
843
                nil)
844
               (t (let ((cell (find-attrib attrib treenode)))
845
                    (setf (second cell) value)
846
                    value)))
847
         ;; no old value
848
         (cond ((null value)
849
                nil)                         ; no old value to delete
850
               (t
851
                (setf (xmlrep-attribs treenode)
852
                      (append (xmlrep-attribs treenode)
853
                              (list (list attrib value))))
854
                value)))))
855
 
856
 (defun xmlrep-boolean-attrib-value (attrib treenode
857
                                     &optional (if-undefined :error))
858
   "Find the value of ATTRIB, a string, in TREENODE.
859
 The value should be either \"true\" or \"false\".  The
860
 function will return T or NIL, accordingly.  If there is no ATTRIB,
861
 will return the value of IF-UNDEFINED, which defaults to :ERROR."
862
   (let ((val (xmlrep-attrib-value attrib treenode
863
                                   if-undefined)))
864
     (cond ((string-equal val "true")
865
            t)
866
           ((string-equal val "false") nil)
867
           (t (error "Not a boolean value, ~A for attribute ~A."
868
                     val attrib)))))
869
 
870
 ;;; XML extraction
871
 (defun extract-path (key-list xml)
872
   "Extracts data from XML parse tree.  KEY-LIST is a path for descending down
873
 named objects in the XML parse tree.  For each KEY-LIST element, XML subforms
874
 are searched for a matching tag name.  Finally the whole last XML subform on the
875
 path is normally returned if found; however the symbol * may be added at the end
876
 of KEY-LIST to return list of all objects /enclosed/ by the last subform on
877
 KEY-LIST. Also KEY-LIST may be dotted as explained below to return XML tag
878
 attributes from the last subform on KEY-LIST.
879
 
880
 XML is to have the forms as returned by PARSE-TO-LIST or PARSE:
881
         (tag-name (attributes-list) subform*),
882
         ((tag-name . name-space) (attributes-list) subform*), or
883
         #s(node :name tag-name
884
                 :ns name-space
885
                 :attrs attributes-list
886
                 :children subform*)
887
 
888
 The first element in KEY-LIST must match the top level form in XML.
889
 Subsequently each element in the KEY-LIST is to match a subform.
890
 
891
 An element of KEY-LIST may be a string atom.  In that case the first subform
892
 with tag-name matching the string is matched.  An element of KEY-LIST may also
893
 be a list of string atoms in this format:
894
         (tag-name (attribute-name attribute-value) ...)
895
 
896
 The first subform with name matching TAG-NAME /and/ having attributes matching
897
 attribute-names and attribute-values is matched.  Zero or more attribute/value
898
 pairs may be given.
899
 
900
 Normally the whole subform matching last element in KEY-LIST is returned.  The
901
 symbol * can be the last element of KEY-LIST to return list of all subforms
902
 enclosed by the last matched form.  Attributes of last matched subform may be
903
 searched by ending KEY-LIST in dot notation, in which case the string after dot
904
 matches an attribute name.  The two element list of attribute name and value is
905
 returned. The symbol * may be used after dot to return the whole attribute list.
906
 
907
 In the case where the search fails NIL is returned.  However it is possible that
908
 the search partially succeeds down the key path.  Three values are returned
909
 altogether and the 2nd and 3rd values give information about how much of
910
 KEY-LIST was matched, and at what point in XML:
911
         (values RESULT  KEY-LIST-FRAGMENT  XML-FRAGMENT)
912
 
913
 When RESULT is non-NIL, the others are NIL. When result is NIL however, the
914
 others are:
915
         XML-FRAGMENT
916
           The last XML form that /did/ match in the key list.  It matches the first
917
           element of KEY-LIST-FRAGMENT.
918
 
919
         KEY-LIST-FRAGMENT
920
           The /remaining/ part of the KEY-LIST that did not succeed.  However the
921
           /first/ item on KEY-LIST-FRAGMENT matches the XML-FRAGMENT returned.  The
922
           failure is at the second item on KEY-LIST-FRAGMENT.
923
 
924
 In the case of complete failure, where even the very first item on KEY-LIST does not
925
 match the top XML form given, all three return values are NIL.  (It suffices to check
926
 the first two return values.)"
927
   (labels ((attribs-match-p ( key-attribs-list xml-attribs-list )
928
              ;; search for (attr-name attr-value) pairs from KEY-ATTRIBS-LIST on
929
              ;; XML-ATTRIBS-LIST.  true if all key pairs found.
930
              (loop
931
                :with attribs-match-var := t
932
                :for attrib-key-pair  :in key-attribs-list
933
                :do
934
                   (setq attribs-match-var
935
                         (and attribs-match-var
936
                              (find attrib-key-pair xml-attribs-list :test #'equal)))
937
                :finally (return attribs-match-var)))
938
            (find-test ( key xml-form )
939
              ;; test whether the XML-FORM matches KEY
940
              (cond
941
                ;; just the XML tag name in key
942
                ;; XML name is simple string
943
                ((and (stringp key)
944
                      (stringp (xmlrep-tag xml-form)))
945
                 (string-equal key (xmlrep-tag xml-form)))
946
                ;; key form (tag-name (attr-name attr-value) ...)
947
                ((and (find-test (car key) xml-form)
948
                      (attribs-match-p (cdr key) (xmlrep-attribs xml-form))))))
949
            (descend ( key-list xml-form )
950
              ;; recursive run down KEY-LIST.  If XML-FORM runs down to NIL before reaching
951
              ;; the end of KEY-LIST, it will be NIL at the end.  If not, what is
952
              ;; remaining of XML-FORM is the found item.
953
              (cond
954
                ;; KEY-LIST ends without dotted item, at the target XML form
955
                ((null (cdr key-list))
956
                 (values xml-form nil nil))
957
                ;; dotted item at the end of KEY-LIST, search attribute list of target XML form
958
                ((atom (cdr key-list))
959
                 (if (eq '* (cdr key-list))
960
                     (values (xmlrep-attribs xml-form) nil nil)
961
                     (find (cdr key-list)  (xmlrep-attribs xml-form)
962
                           :test (lambda (key item) (equal key (car item))))))
963
                ;; more tag names to match on KEY-LIST
964
                ('t
965
                 (if (eq '* (cadr key-list))
966
                     (values (xmlrep-children xml-form) nil nil)
967
                     (let ((selected-xml-form (find (cadr key-list)  (xmlrep-children xml-form)
968
                                                    :test #'find-test)))
969
                       (if selected-xml-form
970
                           (descend (cdr key-list) selected-xml-form)
971
                           ;; no matching sub-form, indicate what part of KEY-LIST did not match
972
                           (values nil key-list xml-form))))))))
973
     ;; empty list, degenerate usage
974
     (when (null key-list)
975
       (error "KEY-LIST is empty."))
976
     ;; search down after initial match
977
     (if (find-test (car key-list) xml)
978
         (descend  key-list xml)
979
         (values nil nil nil))))
980
 
981
 ;;; DAT Proto
982
 (defmethod deserialize ((self string) (fmt (eql :xml)) &key)
983
   (declare (ignore fmt))
984
   (xml-parse self))
985
 (defmethod deserialize ((self stream) (fmt (eql :xml)) &key)
986
   (declare (ignore fmt))
987
   (xml-parse self))
988
 (defmethod deserialize ((self pathname) (fmt (eql :xml)) &key)
989
   (declare (ignore fmt))
990
   (with-open-file (f self)
991
     (xml-parse f)))
992
 
993
 (defmethod serialize (self (fmt (eql :xml)) &key indent stream)
994
   (write-xml self stream :indent indent))