source: project/ssax/ssax-utils.scm @ 1206

Last change on this file since 1206 was 1206, checked in by daishi, 14 years ago

ssax: parser-error raises a condition

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