source: project/release/4/sxml-tools/sxml-tools/sxml-tools.scm @ 13275

Last change on this file since 13275 was 13275, checked in by sjamaan, 11 years ago

Implement initial version of sxml-tools port to Chicken 4. This port has its sxpath tools removed from it, this can be a separate egg now. TODO: look at naming, make it a clean API instead of the prefixed mess it is now. Then document this on the wiki like with sxml-transforms

File size: 27.9 KB
Line 
1;;                            S X M L   T o o l s               
2; $Revision: 3.14 $ from $Date: 2003/12/23 05:39:31 $:
3;
4; This software is in Public Domain.
5; IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.
6;
7; Please send bug reports and comments to lisovsky@acm.org
8;           Kirill Lisovsky
9;
10;   SXML normal form used for normalization-dependent functions:
11; If attr-list is present it's always the second in SXML element.
12; If aux-list is present - then list of attributes is always
13; included, and aux-list is always the third.
14;   Minimized form is just the same, but all the empty aux-lists are
15; absent, and empty attr-lists are present only in elements with aux-lists
16; present.
17
18;==============================================================================
19; Auxiliary functions.
20
21; unlike filter-map from SRFI-1 this function uses separate predicate
22; and mapping functions.
23; Applies proc to  all the elements of source list that satisfy the predicate
24; and return the list of the results.
25(define (filter-and-map pred proc lis)                 
26  (let rpt ((l lis))           
27    (if (null? l)
28      '()
29      (if (pred (car l))
30        (cons (proc (car l)) (rpt (cdr l)))
31        (rpt (cdr l))))))
32     
33; Applies pred to every member of lst and yields #t if all the results
34; are #t
35(define (check-list pred lst) 
36  (cond
37    ((null? lst) #t)
38    ((pred (car lst))
39     (check-list pred (cdr lst)))
40    (else #f)))
41
42; Returns attr-list node for a given obj
43;   or #f if it is absent
44(define (sxml:attr-list-node obj)
45  (if (and (not (null? (cdr obj)))
46            (pair? (cadr obj)) 
47            (eq? '@ (caadr obj)))
48         (cadr obj)
49         #f))
50
51; Returns attr-list wrapped in list
52;   or '((@)) if it is absent and aux-list is present
53;   or '() if both lists are absent
54(define (sxml:attr-as-list obj)
55  (cond
56    ((sxml:attr-list-node obj)
57     => list)
58    ((sxml:aux-list-node obj)
59     '((@)))
60    (else '())))
61
62
63; Returns aux-list node for a given obj
64;   or #f if it is absent
65(define (sxml:aux-list-node obj)
66  (if
67    (or (null? (cdr obj))
68        (null? (cddr obj))
69        (not (pair? (caddr obj)))
70        (not (eq? (caaddr obj) '@@)))
71    #f
72    (caddr obj)))
73
74; Returns aux-list wrapped in list
75;   or '() if it is absent
76(define (sxml:aux-as-list obj)
77  (cond
78    ((sxml:aux-list-node obj)
79     => list)
80    (else '())))
81
82; optimized (string-rindex name #\:)
83; returns position of a separator between namespace-id and LocalName
84(define-macro (sxml:find-name-separator len)
85  `(let rpt ((pos (-- ,len))) 
86     (cond
87       ((negative? pos) #f)     
88       ((char=? #\: (string-ref name pos)) pos)
89       (else (rpt (-- pos))))))
90 
91
92; sxml error message
93(define (sxml:error . messages)
94  (cerr nl "SXML ERROR: ")
95  (apply cerr messages)
96  (cerr nl)
97  (exit -1))
98
99;==============================================================================
100; Predicates
101
102; Predicate which returns #t if given element <obj> is empty.
103; Empty element has no nested elements, text nodes, PIs, Comments or entities
104; but it may contain attributes or namespace-id.
105; It is a SXML counterpart of XML empty-element.
106(define (sxml:empty-element? obj)
107  (not
108    ((select-first-kid 
109     (lambda(x)
110       (or ((ntype-names?? '(*PI* *COMMENT* *ENTITY*)) x)
111           ((ntype?? '*) x)
112           (string? x)))) obj)))
113
114; Returns #t if the given <obj> is shallow-normalized SXML element.
115; The element itself has to be normalised but its nested elements are not tested.
116(define (sxml:shallow-normalized? obj)
117  (or
118    (null? (cdr obj))
119    (and (or
120           (and
121             (pair? (cadr obj)) 
122             (eq? (caadr obj) '@))
123           (not ((select-first-kid (ntype-names?? '(@ @@))) obj)))
124         (or (null? (cddr obj))
125             (and (pair? (caddr obj)) 
126                  (eq? (caaddr obj) '@@))
127             (not ((select-first-kid (ntype?? '@@)) obj))))))
128
129; Returns #t if the given <obj> is normalized SXML element.
130;  The element itself and all its nested elements have to be normalised.
131(define (sxml:normalized? obj)
132    (and
133      (sxml:shallow-normalized? obj)
134    (check-list
135      (lambda(x)
136        (if
137           (sxml:element? x)
138           (sxml:normalized? x)
139           #t))
140       (sxml:content obj))
141    ))
142
143; Returns #t if the given <obj> is shallow-minimized SXML element.
144; The element itself has to be minimised but its nested elements are not tested.
145(define (sxml:shallow-minimized? obj)
146  (and
147    (sxml:shallow-normalized? obj)
148    (not (and (sxml:aux-list-node obj) 
149              (null? (sxml:aux-list obj))))
150    (not (and (sxml:attr-list-node obj)
151              (null? (sxml:attr-list obj))
152              (not (sxml:aux-list-node obj))))))
153
154; Returns #t if the given <obj> is minimized SXML element.
155;  The element itself and all its nested elements have to be minimised.
156(define (sxml:minimized? obj)
157    (and
158      (sxml:shallow-minimized? obj)
159    (check-list
160      (lambda(x)
161        (if
162           (sxml:element? x)
163           (sxml:minimized? x)
164           #t))
165       (sxml:content obj))
166    ))
167
168;==============================================================================
169; Accessors 
170
171; Returns a name of a given SXML node
172; It is introduced for the sake of encapsulation.
173(define sxml:name car)
174
175; A version of sxml:name, which returns #f if the given <obj> is
176; not a SXML element.
177; Otherwise returns its name.
178(define (sxml:element-name obj)
179  (and ((ntype?? '*) obj) 
180       (car obj)))
181
182; Safe version of sxml:name, which returns #f if the given <obj> is
183; not a SXML node.
184; Otherwise returns its name.
185(define (sxml:node-name obj)
186  (and (pair? obj) 
187       (symbol? (car obj))
188    (car obj)))
189
190; Returns Local Part of Qualified Name (Namespaces in XML production [6])
191; for given obj, which is ":"-separated suffix of its Qualified Name
192; If a name of a node given is NCName (Namespaces in XML production [4]), then
193; it is returned as is.
194; Please note that while SXML name is a symbol this function returns a string.
195(define (sxml:ncname obj)
196  (let* ((name (symbol->string (car obj)))
197         (len (string-length name)))
198    (cond
199      ((sxml:find-name-separator len)
200       => (lambda (pos) 
201            (substring name (+ pos 1) len)))
202      (else name))))
203
204; Returns namespace-id part of given name, or #f if it's LocalName
205(define (sxml:name->ns-id sxml-name)
206  (let* ((name (symbol->string sxml-name)))
207    (cond
208      ((sxml:find-name-separator (string-length name))
209       => (lambda (pos) 
210            (substring name  0 pos)))
211      (else #f))))
212   
213
214; Returns the content of given SXML element or nodeset (just text and element
215; nodes) representing it as a list of strings and nested elements in document
216; order.  This list is empty if <obj> is empty element or empty list.
217(define (sxml:content obj)
218  (((if (nodeset? obj) 
219      sxml:filter
220      select-kids) 
221    (lambda(x)
222      (or
223        (string? x)   ;  ((ntype?? '*text*) x)
224       ((ntype?? '*) x)))) 
225   obj))
226
227; Returns a string which combines all the character data
228; from text node childrens of the given SXML element
229; or "" if there is no text node children
230(define (sxml:text obj)
231  (let ((tnodes
232         ((select-kids
233           string?) 
234           obj)))
235    (cond
236      ((null? tnodes) "")
237      ((null? (cdr tnodes))
238       (car tnodes))
239      (else (apply string-append tnodes)))))
240
241;------------------------------------------------------------------------------
242; Normalization-dependent accessors
243;
244;
245; "Universal" accessors are less effective but may be used for non-normalized SXML
246; Safe accessors are named with suffix '-u'
247;
248; "Fast" accessors are optimized for normalized SXML data.
249; They are not applicable to arbitrary non-normalized SXML data
250; Their names has no specific suffixes
251
252; Returns all the content of normalized SXML element except attr-list and
253; aux-list.
254; Thus it includes PI, COMMENT and  ENTITY nodes as well as TEXT and ELEMENT nodes
255; returned by sxml:content.
256; Returns  a list of nodes in document order or empty list if <obj> is empty
257; element or empty list.
258; This function is faster than sxml:content
259(define (sxml:content-raw obj)
260  ((if (and (not (null? (cdr obj))) 
261            (pair? (cadr obj)) (eq? (caadr obj) '@))
262     (if (and (not (null? (cddr obj))) 
263              (pair? (caddr obj)) (eq? (caaddr obj) '@@))
264       cdddr
265       cddr)
266     cdr) obj))
267
268
269; Returns the list of attributes for given element or nodeset.
270; Analog of ((sxpath '(@ *)) obj)
271; Empty list is returned if there is no list of attributes.
272(define (sxml:attr-list-u obj)
273  (cond (((select-first-kid (ntype?? '@)) obj)
274         => cdr)
275        (else '())))
276
277; Returns the list of auxiliary nodes for given element or nodeset.
278; Analog of ((sxpath '(@@ *)) obj)
279; Empty list is returned if a list of auxiliary nodes is absent.
280(define (sxml:aux-list obj)
281  (if
282    (or (null? (cdr obj))
283        (null? (cddr obj))
284        (not (pair? (caddr obj)))
285        (not (eq? (caaddr obj) '@@)))
286    '()
287    (cdaddr obj))) 
288
289; Returns the list of auxiliary nodes for given element or nodeset.
290; Analog of ((sxpath '(@@ *)) obj)
291; Empty list is returned if a list of auxiliary nodes is absent.
292(define (sxml:aux-list-u obj)
293  (cond (((select-first-kid (ntype?? '@@)) obj)
294         => cdr)
295        (else '())))
296
297; Return the first aux-node with <aux-name> given in SXML element <obj>
298; or #f is such a node is absent.
299; NOTE: it returns just the FIRST node found even if multiple nodes are
300; present, so it's mostly intended for nodes with unique names
301(define (sxml:aux-node obj aux-name)
302  (cond
303    ((assq aux-name (sxml:aux-list obj)))
304    (else #f))) 
305
306; Return a list of aux-node with <aux-name> given in SXML element <obj>
307; or '() if such a node is absent.
308(define (sxml:aux-nodes obj aux-name)
309  (filter 
310    (lambda(x) (eq? aux-name (car x)))
311    (sxml:aux-list obj)))
312
313; Accessor for an attribute <attr-name> of given SXML element <obj> which
314; It returns:
315;    the value of the attribute if the attribute is present
316;    #f if there is no such an attribute in the given element
317(define (sxml:attr obj attr-name)
318  (cond
319    ((assq attr-name (sxml:attr-list obj))
320     => cadr)
321    (else #f)))
322
323; Extracts a value of attribute with given name from attr-list
324(define (sxml:attr-from-list attr-list name)
325            (cond
326              ((assq name attr-list) 
327               => cadr)
328              (else #f)))
329
330; Accessor for a numerical attribute <attr-name> of given SXML element <obj>
331; which It returns:
332;    a value of the attribute as the attribute as a number if the attribute
333;    is present and its value may be converted to number using string->number
334;    #f if there is no such an attribute in the given element or
335;    its value can't be converted to a number
336(define (sxml:num-attr obj attr-name)
337  (cond
338    ((assq attr-name (sxml:attr-list obj))
339     => (lambda(x) (string->number (cadr x))))
340    (else #f)))
341
342; Accessor for an attribute <attr-name> of given SXML element <obj> which
343; may also be an attributes-list or nodeset (usually content of SXML element)
344;
345; It returns:
346;    the value of the attribute if the attribute is present
347;    #f if there is no such an attribute in the given element
348(define (sxml:attr-u obj attr-name)
349  (cond
350    ((assq attr-name
351           ; the list of attributes is computed below
352           (cond
353             ((and (not (null? (cdr obj))) 
354                   (pair? (cadr obj))
355                   (eq? '@ (caadr obj)))
356              (cdadr obj))   ; fast track for normalized elements
357             ((eq? '@ (car obj))
358              (cdr obj))     ; if applied to attr-list
359             (else (sxml:attr-list-u obj))))
360     => cadr)
361    (else #f)))
362
363; Returns the list of namespaces for given element.
364; Analog of ((sxpath '(@@ *NAMESPACES* *)) obj)
365; Empty list is returned if there is no list of namespaces.
366(define (sxml:ns-list obj)
367  (cond ((assv '*NAMESPACES* (sxml:aux-list obj))
368         => cdr)
369        (else '())))
370
371; Returns the list of namespace-assoc's for given namespace-id in
372; SXML element <obj>.
373; Analog of ((sxpath '(@@ *NAMESPACES* namespace-id)) obj)
374; Empty list is returned if there is no namespace-assoc with namespace-id
375; given.
376(define (sxml:ns-id->nodes obj namespace-id)
377  (filter 
378    (lambda(x)
379      (eq? (car x) namespace-id))
380    (sxml:ns-list obj)))
381
382; It returns:
383;    A  URI's for namespace-id given
384;    #f if there is no namespace-assoc with namespace-id given
385(define (sxml:ns-id->uri obj namespace-id)
386  (cond
387    ((assq namespace-id (sxml:ns-list obj))
388     => cadr)
389    (else #f)))
390
391; Returns a list of namespace-assocs nodes for NS URI given
392(define (sxml:ns-uri->nodes obj URI)
393  (filter
394    (lambda (ns-assoc) 
395      (string=? (cadr ns-assoc) URI))
396    (sxml:ns-list obj)))
397
398; Returns a namespace-id for NS URI given
399(define (sxml:ns-uri->id obj URI)
400  (let rpt ((ns-assocs (sxml:ns-list obj)))
401  (cond
402      ((null? ns-assocs) #f)
403      ((string=? (cadar ns-assocs) URI)
404       (caar ns-assocs))
405      (else (rpt (cdr ns-assocs)))
406    )))
407
408; Returns namespace-id for given namespace-assoc list
409(define sxml:ns-id car)
410
411; Returns URI for given namespace-assoc list
412(define sxml:ns-uri cadr)
413
414; It returns namespace prefix for given namespace-assoc list
415;  Original (as in XML document) prefix for namespace-id given
416; has to be strored as the third element in namespace-assoc list
417; if it is different from namespace-id.
418;    If original prefix is omitted in namespace-assoc then
419;      namespace-id is used instead
420(define (sxml:ns-prefix ns-assoc)
421      (if (> (length ns-assoc) 2)
422        (caddr ns-assoc)
423        (car ns-assoc))) 
424
425;==============================================================================
426; Data modification functions
427; Constructors and mutators for normalized SXML data
428;
429; This functions are optimized for normalized SXML data.
430; They are not applicable to arbitrary non-normalized SXML data
431;
432; Most of the functions are provided in two variants:
433; 1. side-effect intended functions for linear update of given elements.
434;   Their names are ended with exclamation mark.
435;   An example:
436;      sxml:change-content!
437; 2. pure functions without side-effects which return modified elements.
438;   An example:
439;      sxml:change-content
440 
441; Change the content of given SXML element to <new-content>
442; If <new-content> is an empty list then the <obj> is transformed
443; The resulting SXML element is normalized
444; Former name sxml:content!
445(cond-expand
446 (plt
447  #f  ; set-cdr removed from plt
448  )
449 (else
450  (define (sxml:change-content! obj new-content)
451    (set-cdr! obj 
452              `(
453                ,@(sxml:attr-as-list obj)
454                ,@(sxml:aux-as-list obj)
455                ,@new-content)))
456  ))
457 
458; Change the content of given SXML element to <new-content>
459; If <new-content> is an empty list then the <obj> is transformed
460; to an empty element
461; The resulting SXML element is normalized
462(define (sxml:change-content obj new-content)
463  `(,(sxml:name obj) 
464              ,@(sxml:attr-as-list obj)
465              ,@(sxml:aux-as-list obj)
466        ,@new-content))
467
468; The resulting SXML element is normalized, if <new-attrlist> is empty,
469; the cadr of <obj> is (@)
470(define (sxml:change-attrlist obj new-attrlist)
471  `(,(sxml:name obj) 
472     ,@(cond
473         (new-attrlist
474          `((@ ,@new-attrlist)))
475         ((sxml:aux-list-node obj)
476           '((@)))
477         (else `()))
478     ,@(sxml:aux-as-list obj)
479     ,@(sxml:content obj)))
480
481; The resulting SXML element is normalized, if <new-attrlist> is empty,
482; the cadr of <obj> is (@)
483; Former name sxml:attrlist!
484(cond-expand
485 (plt
486  #f  ; set-cdr removed from plt
487  )
488 (else
489  (define (sxml:change-attrlist! obj new-attrlist)
490    (set-cdr! obj 
491              `(
492                ,@(cond
493                    (new-attrlist
494                     `((@ ,@new-attrlist)))
495                    ((sxml:aux-list-node obj)
496                     '((@)))
497                    (else `()))
498                ,@(sxml:aux-as-list obj)
499                ,@(sxml:content obj))))
500  ))
501     
502; Change a name of SXML element destructively
503; Former name was 'sxml:name!'
504(cond-expand
505 (plt
506  #f  ; set-car removed from plt
507  )
508 (else
509  (define (sxml:change-name! obj new-name)
510    (set-car! obj new-name))
511  ))
512 
513; Returns SXML element with its name changed
514(define (sxml:change-name obj new-name)
515  (cons new-name (cdr obj)))
516
517; Returns SXML element <obj> with attribute <attr> added or #f
518; if the attribute with given name already exists,
519; <attr> is (<attr-name> <attr-value>)
520; Pure functional counterpart to sxml:add-attr!
521(define (sxml:add-attr obj attr)
522  (let ((attr-list (sxml:attr-list obj)))
523    (if (assq (car attr) attr-list) 
524      #f
525      `(,(sxml:name obj)
526        (@ ,@(cons attr attr-list))
527        ,@(sxml:aux-as-list obj)
528        ,@(sxml:content obj)))))
529
530; Add an attribute <attr> for an element <obj>
531; Returns #f if the attribute with given name already exists.
532; The resulting SXML node is normalized.
533; Linear update counterpart to sxml:add-attr
534(cond-expand
535 (plt
536  #f  ; set-cdr removed from plt
537  )
538 (else
539  (define (sxml:add-attr! obj attr)
540    (let ((attr-list (sxml:attr-list obj)))
541      (if (assq (car attr) attr-list) 
542          #f
543          (begin
544            (set-cdr! obj 
545                      `(
546                        (@ ,@(cons attr attr-list))
547                        ,@(sxml:aux-as-list obj)
548                        ,@(sxml:content obj)))
549            obj))))
550  ))
551
552
553; Returns SXML element <obj> with changed value of attribute <attr> or #f
554; if where is no attribute with given name.
555; <attr> is (<attr-name> <attr-value>)
556(define (sxml:change-attr obj attr)
557  (let ((attr-list (sxml:attr-list obj)))
558    (if (null? attr-list)
559      #f
560      (cond
561        ((assv (car attr) attr-list) 
562         => (lambda (y)
563              `(,(sxml:name obj)
564                 (@ ,@(map
565                        (lambda(at)
566                          (if
567                            (eq? at y)
568                            attr
569                            at))
570                        attr-list))
571                 ,@(sxml:aux-as-list obj)
572                 ,@(sxml:content obj)
573                 )))
574        (else #f)))))
575   
576; Change value of the attribute for element <obj>
577; <attr> is (<attr-name> <attr-value>)
578; Returns #f if where is no such attribute
579(cond-expand
580 (plt
581  #f  ; set-cdr removed from plt
582  )
583 (else
584  (define (sxml:change-attr! obj attr)
585    (let ((x (sxml:attr-list obj)))
586      (if (null? x)
587          #f
588          (cond
589            ((assv (car attr) x) => (lambda (y)
590                                      (set-cdr! y (cdr attr)) obj))
591            (else #f)))))
592  ))
593
594; Set attribute <attr> of element <obj>
595; If there is no such attribute the new one is added
596(define (sxml:set-attr obj attr)
597  (let ((attr-list (sxml:attr-list obj)))
598    (cond
599      ((assv (car attr) attr-list) 
600       => (lambda (y)
601            `(,(sxml:name obj)
602               (@ ,@(map
603                      (lambda(at)
604                        (if
605                          (eq? at y)
606                          attr
607                          at))
608                      attr-list))
609               ,@(sxml:aux-as-list obj)
610               ,@(sxml:content obj)
611               )))
612      (else
613        `(,(sxml:name obj)
614           (@ ,@(cons attr attr-list)) 
615           ,@(sxml:aux-as-list obj)
616           ,@(sxml:content obj))))
617    ))
618
619; Set attribute <attr> of element <obj>
620; If there is no such attribute the new one is added
621(cond-expand
622 (plt
623  #f  ; set-cdr removed from plt
624  )
625 (else
626  (define (sxml:set-attr! obj attr)
627    (let ((attr-list (sxml:attr-list obj)))
628      (cond
629        ((assv (car attr) attr-list) 
630         => (lambda (x) (set-cdr! x (cdr attr))))
631        (else (set-cdr! obj
632                        `((@ ,@(cons attr attr-list)) 
633                          ,@(sxml:aux-as-list obj)
634                          ,@(sxml:content obj))))
635        )))
636  ))
637
638; Returns SXML element <obj> with an auxiliary node <aux-node> added
639(define (sxml:add-aux obj aux-node)
640      `(,(sxml:name obj)
641        (@ ,@(sxml:attr-list obj))
642        (@@ ,@(cons aux-node (sxml:aux-list obj)))
643        ,@(sxml:content obj)))
644
645; Add an auxiliary node <aux-node> for an element <obj>
646(cond-expand
647 (plt
648  #f  ; set-cdr removed from plt
649  )
650 (else
651  (define (sxml:add-aux! obj aux-node)
652    (set-cdr! obj 
653              `(
654                (@ ,@(sxml:attr-list obj))
655                (@@ ,@(cons aux-node (sxml:aux-list obj)))
656                ,@(sxml:content obj)))
657    obj)
658  ))
659
660; Eliminates empty lists of attributes and aux-lists for given SXML element
661; <obj> and its descendants ("minimize" it)
662; Returns: minimized and normalized SXML element
663(cond-expand
664 (plt
665  #f  ; set-cdr removed from plt
666  )
667 (else
668  (define (sxml:squeeze! obj)
669    (set-cdr! obj 
670              `(,@(cond
671                    ((sxml:attr-list-node obj)
672                     => (lambda (atl) 
673                          (if (and (null? (cdr atl)) 
674                                   (null? (sxml:aux-list obj)))
675                              '()
676                              (list atl))))     
677                    (else '()))
678                ,@(cond ((sxml:aux-list-node obj)
679                         => (lambda (axl) 
680                              (if (null? (cdr axl))
681                                  '()
682                                  (list axl))))
683                        (else '()))
684                ,@(map
685                   (lambda(x)
686                     (cond
687                       (((ntype?? '*) x)
688                        (sxml:squeeze! x)
689                        x)
690                       (else x)))
691                   (sxml:content obj))
692                ))
693    )
694  ))
695
696             
697; Eliminates empty lists of attributes and aux-lists for given SXML element
698; <obj> and its descendants ("minimize" it)
699; Returns: minimized and normalized SXML element
700(define (sxml:squeeze obj)
701  `(,(sxml:name obj)
702   ,@(cond
703        ((sxml:attr-list-node obj)
704         => (lambda (atl) 
705              (if (and (null? (cdr atl)) 
706                       (null? (sxml:aux-list obj)))
707                 '()
708                 (list atl)))) 
709        (else '()))
710    ,@(cond ((sxml:aux-list-node obj)
711             => (lambda (axl) 
712              (if (null? (cdr axl))
713                '()
714                 (list axl))))
715        (else '()))
716    ,@(map
717        (lambda(x)
718          (cond
719            (((ntype?? '*) x)
720             (sxml:squeeze x))
721            (else x)))
722       (sxml:content obj))))
723
724; Eliminates empty lists of attributes and ALL aux-lists for given SXML element
725; <obj> and its descendants
726; Returns: minimized and normalized SXML element
727(define (sxml:clean obj)
728  `(,(sxml:name obj)
729   ,@(cond
730        ((sxml:attr-list-node obj)
731         => (lambda (atl) 
732              (if (null? (cdr atl)) 
733                 '()
734                 (list atl)))) 
735        (else '()))
736    ,@(map
737        (lambda(x)
738          (cond
739            (((ntype?? '*) x)
740             (sxml:clean x))
741            (else x)))
742       (sxml:content obj))))
743;==============================================================================
744; SXPath-related
745
746;------------------------------------------------------------------------------
747; Extensions
748
749; select-first-kid:: Pred -> Node -> Node
750; Given a Node, return its first child that satisfy
751; the test-pred?
752; Returns #f if there is no such a child
753; select-first-kid:: Pred -> Nodeset -> Node
754; The same as above, but select among children of all the nodes in
755; the Nodeset
756(define (select-first-kid test-pred?)
757 (lambda(obj)
758  (let rpt ((lst (if (symbol? (car obj)) 
759                  (cdr obj)
760                  obj)))
761    (cond
762      ((null? lst) #f)
763      ((and (pair? (car lst))
764            (test-pred? (car lst)))
765        (car lst))
766      (else (rpt (cdr lst)))) 
767    )))
768
769;------------------------------------------------------------------------------
770; Fast node-parent
771
772; Returns a function of one argument - SXML element - which returns its parent
773; node using *PARENT* pointer in aux-list
774; '*TOP-PTR* may be used as a pointer to root node
775; It return an empty list when applyed to root node
776(define (sxml:node-parent rootnode)
777  (lambda(obj)
778  (cond
779    ((sxml:aux-node obj '*PARENT*)
780     => (lambda(x)
781          (if
782            (eq? '*TOP-PTR* (cadr x))
783          rootnode
784          ((cadr x)))))
785    ((and (pair? obj)
786          (eq? (car obj) '*TOP* ))
787     '())           
788     (else (sxml:error nl "PARENT pointer is absent in: " obj nl)
789           ))))
790
791(cond-expand
792 (plt
793  #f  ; set-cdr removed from plt
794  )
795 (else
796  (define (sxml:add-parents obj . top-ptr)
797    (let rpt 
798      ((elt obj)
799       (p '*TOP*)
800       (at-aux (if (eq? (sxml:name obj) '*TOP*)
801                   (list (cons '@@ (sxml:aux-list-u obj)))
802                   (list
803                    (cons '@ (sxml:attr-list obj))
804                    (cons '@@ (cons `(*PARENT* ,(lambda() (car top-ptr))) 
805                                    (sxml:aux-list obj))))))
806       ) ; *TOP* is a parent for top-level element
807      (let* ((h (list (sxml:name elt)))
808             (b  (append
809                  at-aux
810                  (map
811                   (lambda(x)
812                     (cond
813                       (((ntype?? '*) x)
814                        (rpt x h
815                             (list
816                              (cons '@ (sxml:attr-list x))
817                              (cons '@@ (cons `(*PARENT* ,(lambda() h)) 
818                                              (sxml:aux-list x))))
819                             ))
820                       (else x)))
821                   (sxml:content elt)))))
822        (set-cdr! h b)
823        h)))
824  ))
825
826; Lookup an element using its ID
827(define (sxml:lookup id index)
828    (cond
829      ((assoc id index) 
830       => cdr)
831      (else #f)))
832
833;==============================================================================
834; Markup generation
835
836;------------------------------------------------------------------------------
837; XML
838
839; Creates the XML markup for attributes.
840(define (sxml:attr->xml attr)
841   (list " " (sxml:ncname attr)
842         "='" (cadr attr) "'"))
843
844; Return a string or a list of strings where all the occurences of
845; characters < > & " ' in a given string are replaced by corresponding
846; character entity references. See also:  sxml:string->html
847(define sxml:string->xml
848  (make-char-quotator
849   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") 
850                    (#\" . "&quot;") (#\' . "&apos;"))))
851
852; A version of dispatch-node specialized and optimized for SXML->XML
853; transformation.
854(define (sxml:sxml->xml tree)
855  (cond
856    ((nodeset? tree)
857     (map (lambda (a-tree) 
858            (sxml:sxml->xml a-tree)) 
859          tree))
860    ((pair? tree)
861     (let* ((name (sxml:name tree))   ; NS (URI-prefixed) not supported
862            (nm (symbol->string name))
863            (content (sxml:content-raw tree)))
864         `("<" ,nm ,@(map sxml:attr->xml (sxml:attr-list tree))
865           ,@(if (null? content) '("/>")
866               `(">" ,@(sxml:sxml->xml content) "</" ,nm ">")))))
867    ((string? tree) (sxml:string->xml tree)) ; *text*
868    (else (sxml:error "sxml->html - unexpected type of node: " tree))))
869
870
871;------------------------------------------------------------------------------
872; HTML
873
874; Creates the HTML markup for attributes.
875(define (sxml:attr->html attr)
876         (if (equal? "" (cadr attr))
877             (list " " (sxml:ncname attr))
878             (list " " (sxml:ncname attr) "='" (cadr attr) "'")))
879
880
881
882; Given a string, check to make sure it does not contain characters
883; < > & " that require encoding. Return either the original
884; string, or a list of string fragments with special characters
885; replaced by appropriate character entities.
886; Borrowed from Oleg Kiselyov's XML-to-HTML.scm (where its name is
887; string->goodHTML)
888(define sxml:string->html
889  (make-char-quotator
890   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
891
892
893; This predicate yields #t for "unterminated" HTML 4.0 tags
894(define (sxml:non-terminated-html-tag? tag) 
895  (memq tag 
896     '(area base basefont br col frame hr img input isindex link meta param)))
897
898
899; A version of dispatch-node specialized and optimized for SXML->HTML
900; transformation.
901(define (sxml:sxml->html tree)
902  (cond
903    ((nodeset? tree)
904     (map (lambda (a-tree) 
905            (sxml:sxml->html a-tree)) 
906          tree))
907    ((pair? tree)
908     (let* ((name (sxml:name tree))
909            (nm (symbol->string name))
910            (content (sxml:content-raw tree)))
911         `("<" ,nm ,@(map sxml:attr->html (sxml:attr-list tree))
912           ,@(if (null? content)
913               (if (sxml:non-terminated-html-tag? name) '(">") '("/>"))
914               `(">" ,@(sxml:sxml->html content) "</" ,nm ">")))))
915    ((string? tree) (sxml:string->html tree)) ; *text*
916    (else (sxml:error "sxml->html - unexpected type of node: " tree))))
917
Note: See TracBrowser for help on using the repository browser.