source: project/release/3/ssax/ssax-utils.scm @ 13362

Last change on this file since 13362 was 13362, checked in by Jim Ursetto, 11 years ago

ssax: remove STRING from standard bindings, allows Unicode entities

File size: 5.0 KB
Line 
1(include "ssax.scm")
2(use ssax-core)
3(use srfi-1 extras)
4
5(declare
6  (fixnum))
7
8;========================================================================
9;               Highest-level parsers: XML to SXML
10;
11
12; procedure: SSAX:XML->SXML PORT NAMESPACE-PREFIX-ASSIG
13;
14; This is an instance of a SSAX parser above that returns an SXML
15; representation of the XML document to be read from PORT.
16; NAMESPACE-PREFIX-ASSIG is a list of (USER-PREFIX . URI-STRING)
17; that assigns USER-PREFIXes to certain namespaces identified by
18; particular URI-STRINGs. It may be an empty list.
19; The procedure returns an SXML tree. The port points out to the
20; first character after the root element.
21
22(define (SSAX:XML->SXML port namespace-prefix-assig)
23  (letrec
24      ((namespaces
25        (map (lambda (el)
26               (cons* #f (car el) (SSAX:uri-string->symbol (cdr el))))
27             namespace-prefix-assig))
28
29       (RES-NAME->SXML
30        (lambda (res-name)
31          (string->symbol
32           (string-append
33            (symbol->string (car res-name))
34            ":"
35            (symbol->string (cdr res-name))))))
36
37       ; given the list of fragments (some of which are text strings)
38       ; reverse the list and concatenate adjacent text strings
39       (reverse-collect-str
40        (lambda (fragments)
41          (if (null? fragments) '()     ; a shortcut
42              (let loop ((fragments fragments) (result '()) (strs '()))
43                (cond
44                 ((null? fragments)
45                  (if (null? strs) result
46                      (cons (string-concatenate strs) result)))
47                 ((string? (car fragments))
48                  (loop (cdr fragments) result (cons (car fragments) strs)))
49                 (else
50                  (loop (cdr fragments)
51                        (cons
52                         (car fragments)
53                         (if (null? strs) result
54                             (cons (string-concatenate strs) result)))
55                        '())))))))
56
57       ; given the list of fragments (some of which are text strings)
58       ; reverse the list and concatenate adjacent text strings
59       ; We also drop "unsignificant" whitespace, that is, whitespace
60       ; in front, behind and between elements. The whitespace that
61       ; is included in character data is not affected.
62       (reverse-collect-str-drop-ws
63        (lambda (fragments)
64          (cond
65           ((null? fragments) '())              ; a shortcut
66           ((and (string? (car fragments))      ; another shortcut
67                 (null? (cdr fragments))        ; remove trailing ws
68                 (string-whitespace? (car fragments))) '())
69           (else
70            (let loop ((fragments fragments) (result '()) (strs '())
71                       (all-whitespace? #t))
72              (cond
73               ((null? fragments)
74                (if all-whitespace? result      ; remove leading ws
75                    (cons (string-concatenate strs) result)))
76               ((string? (car fragments))
77                (loop (cdr fragments) result (cons (car fragments) strs)
78                      (and all-whitespace?
79                           (string-whitespace? (car fragments)))))
80               (else
81                (loop (cdr fragments)
82                      (cons
83                       (car fragments)
84                       (if all-whitespace? result
85                           (cons (string-concatenate strs) result)))
86                      '() #t))))))))
87       )
88    (let ((result
89           (reverse
90            ((SSAX:make-parser
91              NEW-LEVEL-SEED 
92              (lambda (elem-gi attributes namespaces
93                               expected-content seed)
94                '())
95   
96              FINISH-ELEMENT
97              (lambda (elem-gi attributes namespaces parent-seed seed)
98                (let ((seed (reverse-collect-str-drop-ws seed))
99                      (attrs
100                       (attlist-fold
101                        (lambda (attr accum)
102                          (cons (list
103                                 (if (symbol? (car attr)) (car attr)
104                                     (RES-NAME->SXML (car attr)))
105                                 (cdr attr)) accum))
106                        '() attributes)))
107                  (cons
108                   (cons
109                    (if (symbol? elem-gi) elem-gi
110                        (RES-NAME->SXML elem-gi))
111                    (if (null? attrs) seed
112                        (cons (cons '@ attrs) seed)))
113                   parent-seed)))
114
115              CHAR-DATA-HANDLER
116              (lambda (string1 string2 seed)
117                (if (zero? (string-length string2)) (cons string1 seed)
118                    (cons* string2 string1 seed)))
119
120              DOCTYPE
121              (lambda (port docname systemid internal-subset? seed)
122                (when internal-subset?
123                  (SSAX:warn port
124                             "Internal DTD subset is not currently handled ")
125                  (SSAX:skip-internal-dtd port))
126                (SSAX:warn port "DOCTYPE DECL " docname " "
127                           systemid " found and skipped")
128                (values #f '() namespaces seed))
129
130              UNDECL-ROOT
131              (lambda (elem-gi seed)
132                (values #f '() namespaces seed))
133
134              PI
135              ((*DEFAULT* .
136                          (lambda (port pi-tag seed)
137                            (cons
138                             (list '*PI* pi-tag (SSAX:read-pi-body-as-string port))
139                             seed))))
140              )
141             port '()))))
142      (cons '*TOP*
143            (if (null? namespace-prefix-assig) result
144                (cons (cons '*NAMESPACES* 
145                            (map (lambda (ns) (list (car ns) (cdr ns)))
146                                 namespace-prefix-assig))
147                      result)))
148      )))
149
150;;;; Error handler
151
152;;; According to the SSAX convention this function
153;;; accepts the port as its first argument which is used for
154;;; location of the error in input file.
155;;; Other parameters are considered as error messages,
156;;;  they are printed to stderr as is.
157(define (parser-error port msg . args)
158  (let-values ([(row col) (port-position port)])
159    (signal
160     (make-composite-condition
161      (make-property-condition 'ssax 'port port)
162      (make-property-condition 'exn 'message (apply conc "[SSAX: port " (port-name port) ", at " (add1 row) "/" col "] " msg args))))))
Note: See TracBrowser for help on using the repository browser.