source: project/release/4/html-parser/trunk/html-parser.scm @ 13095

Last change on this file since 13095 was 13095, checked in by Jim Ursetto, 12 years ago

Add html-parser egg to release/4

File size: 25.2 KB
Line 
1;;;; html-parser.scm -- SSAX-like tree-folding html parser
2;;
3;; Copyright (c) 2003-2008 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;; This is intended as a permissive HTML parser for people who prefer
7;; the scalable interface described in Oleg Kiselyov's SSAX parser, as
8;; well as providing simple convenience utilities.  It correctly
9;; handles all invalid HTML, inserting "virtual" starting and closing
10;; tags as needed to maintain the proper tree structure needed for the
11;; foldts down/up logic.  A major goal of this parser is bug-for-bug
12;; compatibility with the way common web browsers parse HTML.
13
14;; Procedure: make-html-parser . keys
15
16;;   Returns a procedure of two arguments, and initial seed and an
17;;   optional input port, which parses the HTML document from the port
18;;   with the callbacks specified in the plist KEYS (using normal,
19;;   quoted symbols, for portability and to avoid making this a
20;;   macro).  The following callbacks are recognized:
21;;
22;;   START: TAG ATTRS SEED VIRTUAL?
23;;       fdown in foldts, called when a start-tag is encountered.
24;;     TAG:         tag name
25;;     ATTRS:       tag attributes as a alist
26;;     SEED:        current seed value
27;;     VIRTUAL?:    #t iff this start tag was inserted to fix the HTML tree
28;;
29;;   END: TAG ATTRS PARENT-SEED SEED VIRTUAL?
30;;       fup in foldts, called when an end-tag is encountered.
31;;     TAG:         tag name
32;;     ATTRS:       tag attributes of the corresponding start tag
33;;     PARENT-SEED: parent seed value (i.e. seed passed to the start tag)
34;;     SEED:        current seed value
35;;     VIRTUAL?:    #t iff this end tag was inserted to fix the HTML tree
36;;
37;;   TEXT: TEXT SEED
38;;       fhere in foldts, called when any text is encountered.  May be
39;;       called multiple times between a start and end tag, so you need
40;;       to string-append yourself if desired.
41;;     TEXT:        entity-decoded text
42;;     SEED:        current seed value
43;;
44;;   COMMENT: TEXT SEED
45;;       fhere on comment data
46;;
47;;   DECL: NAME ATTRS SEED
48;;       fhere on declaration data
49;;       
50;;   PROCESS: LIST SEED
51;;       fhere on process-instruction data
52;;
53;;   In addition, entity-mappings may be overriden with the ENTITIES:
54;;   keyword.
55
56;; Procedure: html->sxml [port]
57;;   Returns the SXML representation of the document from PORT, using
58;;   the default parsing options.
59
60;; Procedure: html-strip [port]
61;;   Returns a string representation of the document from PORT with all
62;;   tags removed.  No whitespace reduction or other rendering is done.
63
64;; Example:
65;;
66;;   The parser for html-strip could be defined as:
67;;
68;; (make-html-parser
69;;   'start: (lambda (tag attrs seed virtual?) seed)
70;;   'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
71;;   'text:  (lambda (text seed) (display text)))
72;;
73;;   Also see the parser for html->sxml.
74
75(require-library srfi-13)
76
77(module html-parser
78  (make-html-parser html->sxml html-strip
79   sxml->html sxml-display-as-html) ; ??
80(import scheme
81        (only srfi-13 string-downcase)
82        (only ports call-with-output-string)
83        (only chicken error open-input-string))
84
85;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86;; ;; from SRFI-13
87
88;; (define (string-downcase str)
89;;   (let lp ((i (- (string-length str) 1)) (res '()))
90;;     (if (negative? i)
91;;         (list->string res)
92;;         (lp (- i 1) (cons (char-downcase (string-ref str i)) res)))))
93
94;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95;; ;; SRFI-6 extension if not defined
96
97;; (define (call-with-output-string proc)
98;;   (let ((out (open-output-string)))
99;;     (proc out)
100;;     (get-output-string out)))
101
102;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103;; text parsing utils
104
105(define (read-while pred . o)
106  (let ((in (if (pair? o) (car o) (current-input-port))))
107    (call-with-output-string
108     (lambda (out)
109       (let loop ()
110         (let ((c (peek-char in)))
111           (cond
112            ((and (not (eof-object? c)) (pred c))
113             (write-char (read-char in) out)
114             (loop)))))))))
115
116(define (read-until pred . o)
117  (let ((in (if (pair? o) (car o) (current-input-port))))
118    (call-with-output-string
119     (lambda (out)
120       (let loop ()
121         (let ((c (peek-char in)))
122           (cond
123            ((not (or (eof-object? c) (pred c)))
124             (write-char (read-char in) out)
125             (loop)))))))))
126
127;; XXXX doesn't account for when the middle of the string can be a
128;; prefix of the string (not needed in the uses below)
129(define (read-until-string/ci str . o)
130  (let ((in (if (pair? o) (car o) (current-input-port)))
131        (len (string-length str)))
132    (call-with-output-string
133     (lambda (out)
134       (let loop ((i 0))
135         (let ((c (read-char in)))
136           (cond
137            ((eof-object? c)
138             (display (substring str 0 i) out))
139            ((char-ci=? c (string-ref str i))
140             (if (< i (- len 1))
141                 (loop (+ i 1))))
142            (else
143             (display (substring str 0 i) out)
144             (write-char c out)
145             (loop 0)))))))))
146
147;; simple utility to look for patterns of the form "aab", reads the
148;; whole port if the pattern doesn't occur
149(define (read-until-aab a b . o)
150  (let ((in (if (pair? o) (car o) (current-input-port))))
151    (call-with-output-string
152     (lambda (out)
153       (let scan ()
154         (let ((ch (read-char in)))
155           (cond
156            ((eof-object? ch))
157            ((not (eqv? ch a))
158             (write-char ch out)
159             (scan))
160            (else ;; scanned one a
161             (let ((ch (read-char in)))
162               (cond
163                ((not (eqv? ch a))
164                 (write-char a out)
165                 (cond ((not (eof-object? ch))
166                        (write-char ch out)
167                        (scan))))
168                (else ;; scanned two a's
169                 (let two-a-s ()
170                   (let ((ch (read-char in)))
171                     (cond ((not (eqv? ch b))
172                            (write-char a out)
173                            (cond ((eqv? ch a)
174                                   (two-a-s))
175                                  ((eof-object? ch)
176                                   (write-char a out))
177                                  (else
178                                   (write-char a out)
179                                   (write-char ch out)
180                                   (scan))))))))))))))))))
181
182(define skip-whitespace (lambda x (apply read-while char-whitespace? x)))
183
184;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
185;; html-specific readers
186
187(define (char-alphanumeric? c)
188  (or (char-alphabetic? c) (char-numeric? c)))
189
190(define (char-hex-numeric? c)
191  (or (char-numeric? c)
192      (memv (char-downcase c) '(#\a #\b #\c #\d #\e #\f))))
193
194(define read-identifier (lambda x (apply read-while char-alphanumeric? x)))
195
196(define read-integer (lambda x (apply read-while char-numeric? x)))
197
198(define read-hex-integer (lambda x (apply read-while char-hex-numeric? x)))
199
200(define (read-quoted in)
201  (let* ((terminator (read-char in))
202         (res (read-until (lambda (c) (eqv? c terminator)) in)))
203    (read-char in)
204    res))
205
206(define (read-name-or-quoted in)
207  (cond ((or (eqv? #\" (peek-char in)) (eqv? #\' (peek-char in)))
208         (read-quoted in))
209        (else
210         (read-while tag-char? in))))
211
212(define (read-pi in)
213  (let ((tag (read-identifier in)))
214    (skip-whitespace in)
215    (list
216     (if (equal? tag "") #f (string->symbol (string-downcase tag)))
217     (list->string
218      (reverse
219       (let loop ((res '()))
220         (let ((c (peek-char in)))
221           (cond
222            ((eof-object? c)
223             (read-char in)
224             res)
225            ((eqv? c #\?)
226             (read-char in)
227             (let loop2 ((res res))
228               (cond
229                ((eof-object? (peek-char in))
230                 (cons #\? res))
231                ((eqv? #\> (peek-char in))
232                 (read-char in)
233                 res)
234                ((eqv? #\? (peek-char in))
235                 (read-char in)
236                 (loop2 (cons c res)))
237                (else
238                 (loop (cons c res))))))
239            (else
240             (read-char in)
241             (loop (cons c res)))))))))))
242
243(define (read-comment . o)
244  (read-until-aab #\- #\> (if (pair? o) (car o) (current-input-port))))
245
246(define (tag-char? c)
247  (and (char? c)
248       (or (char-alphanumeric? c) (memv c '(#\- #\+ #\* #\_ #\:)))))
249
250(define (read-attrs in)
251  (let loop ((attrs '()))
252    (skip-whitespace in)
253    (let ((c (peek-char in)))
254      (cond
255       ((or (eof-object? c) (eqv? c #\>))
256        (read-char in)
257        (list #f (reverse attrs)))
258       ((eqv? c #\/)
259        (read-char in)
260        (skip-whitespace in)
261        (cond
262         ((eqv? #\> (peek-char in))
263          (read-char in)
264          (list #t (reverse attrs)))
265         (else
266          (loop attrs))))
267       ((eqv? c #\")
268        (read-char in)
269        (loop attrs))
270       ((not (tag-char? c))
271        (list #f (reverse attrs)))
272       (else
273        (let ((name (read-while tag-char? in)))
274          (if (string=? name "")
275              (loop attrs)
276              (let ((name (string->symbol (string-downcase name))))
277                (cond
278                 ((eqv? (peek-char in) #\=)
279                  (read-char in)
280                  (let ((value (if (memv (peek-char in) '(#\" #\'))
281                                   (read-quoted in)
282                                   (read-until
283                                    (lambda (c)
284                                      (or (char-whitespace? c)
285                                          (memv c '(#\' #\" #\< #\>))))
286                                    in))))
287                    (if (or (eqv? #\" (peek-char in))
288                            (eqv? #\' (peek-char in)))
289                        (read-char in))
290                    (loop (cons (list name value) attrs))))
291                 (else
292                  (loop (cons (list name) attrs))))))))))))
293
294(define (read-start in)
295  (let ((tag (string->symbol (string-downcase (read-while tag-char? in)))))
296    (cons tag (read-attrs in))))
297
298(define (read-end in)
299  (let ((tag (read-while tag-char? in)))
300    (cond
301     ((equal? tag "")
302      (read-until (lambda (c) (eqv? c #\>)) in)
303      (read-char in)
304      #f)
305     (else
306      (read-attrs in)
307      (string->symbol (string-downcase tag))))))
308
309(define (read-decl in)
310  (let loop ((res '()))
311    (skip-whitespace in)
312    (let ((c (peek-char in)))
313      (cond
314       ((eof-object? c)
315        (reverse res))
316       ((eqv? c #\>)
317        (read-char in)
318        (reverse res))
319       ((eqv? c #\")
320        (loop (cons (read-quoted in) res)))
321       ((tag-char? c)
322        (loop (cons (string->symbol (read-while tag-char? in)) res)))
323       (else
324        (loop res))))))
325
326;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
327;; the parser
328
329(define *default-entities*
330  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
331    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
332
333(define (get-entity entities name)
334  (cond
335   ((string->number name) => (lambda (n) (string (integer->char n))))
336   ((assoc name entities) => cdr)
337   (else #f)))
338
339;; span's and div's can be used at any level
340(define *tag-levels*
341  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
342
343(define *unnestables*
344  '(p li td tr))
345
346(define *bodyless*
347  '(img hr br))
348
349(define *literals*
350  '(script xmp))
351
352(define *terminators*
353  '(plaintext))
354
355(define (tag-level tag-levels tag)
356  (let lp ((ls tag-levels) (i 0))
357    (if (null? ls)
358        (+ i 1000)
359        (if (if (pair? (car ls))
360                (memq tag (car ls))
361                (eq? tag (car ls)))
362            i
363            (lp (cdr ls) (+ i 1))))))
364
365(define (read-html-token . o)
366  (let ((in (if (pair? o) (car o) (current-input-port))))
367    (let ((c (peek-char in)))
368      (if (eof-object? c)
369          (cons 'eof c)
370          (case c
371            ((#\<)
372             (read-char in)
373             (case (peek-char in)
374               ((#\!)
375                (read-char in)
376                (cond
377                 ((eqv? #\[ (peek-char in))
378                  (read-char in)
379                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
380                           (acc '(#\[ #\! #\<)))
381                    (cond
382                     ((null? check)
383                      (cons 'text (read-until-aab #\] #\> in)))
384                     ((let ((c (peek-char in)))
385                        (and (not (eof-object? c)) (char-ci=? c (car check))))
386                      (lp (cdr check) (cons (read-char in) acc)))
387                     (else
388                      (cons 'text (list->string (reverse acc)))))))
389                 ((and (eqv? #\- (peek-char in))
390                       (begin (read-char in)
391                              (eqv? #\- (peek-char in))))
392                  (read-char in)
393                  (cons 'comment (read-comment in)))
394                 (else
395                  (cons 'decl (read-decl in)))))
396               ((#\?)
397                (read-char in)
398                (cons 'process (read-pi in)))
399               ((#\/)
400                (read-char in)
401                (cons 'end (read-end in)))
402               (else
403                ;; start tags must immediately be followed by an
404                ;; alphabetic charater, or we just treat the < as text
405                (if (and (char? (peek-char in))
406                         (char-alphabetic? (peek-char in)))
407                    (let ((res (read-start in)))
408                      (if (cadr res)
409                          (cons 'start/end (cons (car res) (cddr res)))
410                          (cons 'start (cons (car res) (cddr res)))))
411                    (cons 'text "<")))))
412            ((#\&)
413             (read-char in)
414             (cond
415              ((eqv? (peek-char in) #\#)
416               (read-char in)
417               (cond
418                ((char-numeric? (peek-char in))
419                 (let* ((str (read-integer in))
420                        (num (string->number str)))
421                   (if (eqv? (peek-char in) #\;)
422                       (read-char in))
423                   (cons 'entity num)))
424                ((memv (peek-char in) '(#\x #\X))
425                 (read-char in)
426                 (let* ((str (read-hex-integer in))
427                        (num (string->number str 16)))
428                   (if (eqv? (peek-char in) #\;)
429                       (read-char in))
430                   (cons 'entity num)))
431                (else
432                 (cons 'text "&#"))))
433              ((char-alphabetic? (peek-char in))
434               (let ((name (read-identifier in)))
435                 (if (eqv? (peek-char in) #\;)
436                     (read-char in))
437                 (cons 'entity name)))
438              (else
439               (cons 'text "&"))))
440            (else
441             (cons 'text
442                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
443                               in))))))))
444
445(define (%key-ref ls key default)
446  (cond ((memq key ls) => cadr) (else default)))
447
448(define (make-html-parser . o)
449  (let ((start (%key-ref o 'start: (lambda (t a s v) s)))
450        (end (%key-ref o 'end: (lambda (t a p s v) s)))
451        (text (%key-ref o 'text: (lambda (t s) s)))
452        (decl (%key-ref o 'decl: (lambda (t a s) s)))
453        (process (%key-ref o 'process: (lambda (t s) s)))
454        (comment (%key-ref o 'comment: (lambda (t s) s)))
455        (entities (%key-ref o 'entities: *default-entities*))
456        (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
457        (unnestables (%key-ref o 'unnestables: *unnestables*))
458        (bodyless (%key-ref o 'bodyless: *bodyless*))
459        (literals (%key-ref o 'literals: *literals*))
460        (terminators (%key-ref o 'terminators: *terminators*))
461        (entity (%key-ref o 'entity: #f)))
462    (let ((entity (or entity (lambda (t s)
463                               (text (if (number? t)
464                                         (string (integer->char t))
465                                         (or (get-entity entities t)
466                                             (string-append "&" t ";")))
467                                     s)))))
468      (lambda (seed . o)
469        (let* ((src (if (pair? o) (car o) (current-input-port)))
470               (in (if (string? src) (open-input-string src) src)))
471          (let lp ((tok (read-html-token in))
472                   (seed seed)
473                   (seeds '())
474                   (tags '()))
475            (case (car tok)
476              ((eof)                     ; close all open tags
477               (let lp ((t tags) (s seeds) (seed seed))
478                 (if (null? t)
479                     seed
480                     (lp (cdr t) (cdr s)
481                         (end (caar t) (cadar t) (car s) seed 'eof)))))
482              ((start/end)
483               (let ((tag (cadr tok)))
484                 (lp `(end . ,tag)
485                     (start tag (caddr tok) seed #f)
486                     (cons seed seeds)
487                     (cons (cdr tok) tags))))
488              ((start)
489               (let ((tag (cadr tok)))
490                 (cond
491                  ((memq tag terminators)
492                   (lp `(text . ,(read-until (lambda (c) #f) in))
493                       (start tag (caddr tok) seed #f)
494                       (cons seed seeds)
495                       (cons (cdr tok) tags)))
496                  ((memq tag literals)
497                   (let ((body (read-until-string/ci
498                                (string-append "</" (symbol->string tag) ">")
499                                in))
500                         (seed2 (start tag (caddr tok) seed #f)))
501                     (lp `(end . ,tag)
502                         (if (equal? "" body) seed2 (text body seed2))
503                         (cons seed seeds)
504                         (cons (cdr tok) tags))))
505                  ((memq tag bodyless)
506                   (lp `(end . ,tag)
507                       (start tag (caddr tok) seed #f)
508                       (cons seed seeds)
509                       (cons (cdr tok) tags)))
510                  ((and (pair? tags) (eq? tag (caar tags))
511                        (memq tag unnestables))
512                   ;; <p> ... <p> implies siblings, not nesting
513                   (let ((seed2
514                          (end tag (cadar tags) (car seeds) seed 'sibling)))
515                     (lp (read-html-token in)
516                         (start tag (caddr tok) seed #f)
517                         (cons seed2 (cdr seeds))
518                         (cons (cdr tok) (cdr tags)))))
519                  (else
520                   (lp (read-html-token in)
521                       (start tag (caddr tok) seed #f)
522                       (cons seed seeds)
523                       (cons (cdr tok) tags))))))
524              ((end)
525               (cond
526                ((not (cdr tok)) ;; nameless closing tag
527                 (lp (read-html-token in) seed seeds tags))
528                ((and (pair? tags) (eq? (cdr tok) (caar tags)))
529                 (lp (read-html-token in)
530                     (end (cdr tok) (cadar tags) (car seeds) seed #f)
531                     (cdr seeds)
532                     (cdr tags)))
533                (else
534                 (let ((this-level (tag-level tag-levels (cdr tok)))
535                       (expected-level
536                        (if (pair? tags)
537                            (tag-level tag-levels (caar tags))
538                            -1)))
539                   (cond
540                    ((< this-level expected-level)
541                     ;; higher-level tag, forcefully close preceding tags
542                     (lp tok
543                         (end (caar tags) (cadar tags) (car seeds) seed
544                              'parent-closed)
545                         (cdr seeds)
546                         (cdr tags)))
547                    ((and (= this-level expected-level) (pair? (cdr tags)))
548                     ;; equal, interleave (close prec tag, close this,
549                     ;; re-open prec)
550                     ;; <b><i></b> => <b><i></i></b><i>
551                     ;;                     ^^^^    ^^^
552                     ;; XXXX handle backups > 1 here
553                     (let* ((seed2 (end (caar tags) (cadar tags)
554                                        (car seeds) seed 'interleave))
555                            (seed3 (end (caadr tags) (cadadr tags)
556                                        (cadr seeds) seed2 #f)))
557                       (let ((tok2 (read-html-token in)))
558                         (cond
559                          ((and (eq? 'end (car tok2))
560                                (eq? (caar tags) (cdr tok2)))
561                           ;; simple case where the closing tag
562                           ;; immediately follows
563                           (lp (read-html-token in) seed3
564                               (cddr seeds) (cddr tags)))
565                          (else
566                           (lp tok2
567                               (start (caar tags) (cadar tags) seed3
568                                      'interleave)
569                               (cons seed3 (cddr seeds))
570                               (cons (car tags) (cddr tags))))))))
571                    (else
572                     ;; spurious end for a lower-level tag, add
573                     ;; imaginary start
574                     (let* ((seed2 (start (cdr tok) '() seed 'no-start))
575                            (seed3 (end (cdr tok) '() seed seed2 #f)))
576                       (lp (read-html-token in) seed3 seeds tags))))))))
577              ((text)
578               (lp (read-html-token in) (text (cdr tok) seed) seeds tags))
579              ((entity)
580               (lp (read-html-token in) (entity (cdr tok) seed) seeds tags))
581              ((comment)
582               (lp (read-html-token in) (comment (cdr tok) seed) seeds tags))
583              ((decl)
584               (lp (read-html-token in)
585                   (decl (cadr tok) (cddr tok) seed) seeds tags))
586              ((process)
587               (lp (read-html-token in) (process (cdr tok) seed) seeds tags))
588              (else
589               (error "invalid token: " tok)))))))))
590
591;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
592;; simple conversions
593
594(define html->sxml
595  (let ((parse
596         (make-html-parser
597          'start: (lambda (tag attrs seed virtual?) '())
598          'end:   (lambda (tag attrs parent-seed seed virtual?)
599                    `((,tag ,@(if (pair? attrs)
600                                  `((@ ,@attrs) ,@(reverse seed))
601                                  (reverse seed)))
602                      ,@parent-seed))
603          'decl:    (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
604          'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
605          'comment: (lambda (text seed) `((*COMMENT* ,text) ,@seed))
606          'text:    (lambda (text seed) (cons text seed))
607          )))
608    (lambda o
609      (reverse (apply parse '() o)))))
610
611;; XXXX
612(define (html-escape-attr str)
613  str)
614
615(define (html-attr->string attr)
616  (string-append (symbol->string (car attr))
617                 "=\"" (html-escape-attr (cdr attr)) "\""))
618
619(define (html-tag->string tag attrs)
620  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
621    (if (null? ls)
622        (apply string-append (reverse (cons ">" res)))
623        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
624
625(define (html-display-escaped-string str out)
626  (let ((start 0)
627        (end (string-length str)))
628    (let lp ((from start) (to start))
629      (if (>= to end)
630          (display (substring str from to) out)
631          (let ((c (string-ref str to)))
632            (cond
633             ((eq? c #\<)
634              (display (substring str from to) out)
635              (display "&lt;" out)
636              (let ((next (+ to 1)))
637                (lp next next)))
638             ((eq? c #\&)
639              (display (substring str from to) out)
640              (display "&amp;" out)
641              (let ((next (+ to 1)))
642                (lp next next)))
643             (else
644              (lp from (+ to 1)))))))))
645
646(define (html-escape str)
647  (call-with-output-string
648    (lambda (out) (html-display-escaped-string str out))))
649
650(define (sxml-display-as-html sxml . o)
651  (let ((out (if (pair? o) (car o) (current-output-port))))
652    (cond
653     ((pair? sxml)
654      (let ((tag (car sxml)))
655        (if (symbol? tag)
656            (let ((rest (cdr sxml)))
657              (cond
658               ((and (pair? rest)
659                     (pair? (car rest))
660                     (eq? '@ (caar rest)))
661                (display (html-tag->string tag (cdar rest)) out)
662                (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
663                (display "</" out) (display tag out) (display ">" out))
664               (else
665                (display (html-tag->string tag '()) out)
666                (for-each (lambda (x) (sxml-display-as-html x out)) rest)
667                (display "</" out) (display tag out) (display ">" out))))
668            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
669     ((null? sxml))
670     (else (html-display-escaped-string sxml out)))))
671
672(define (sxml->html sxml . o)
673  (call-with-output-string
674    (lambda (out) (sxml-display-as-html sxml out))))
675
676;; just strips tags, no whitespace handling or formatting
677(define (html-strip . o)
678  (call-with-output-string
679   (lambda (out)
680     (let ((parse
681            (make-html-parser
682             'start: (lambda (tag attrs seed virtual?) seed)
683             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
684             'text:  (lambda (text seed) (display text out)))))
685       (apply parse (cons #f #f) o)))))
686
687)
Note: See TracBrowser for help on using the repository browser.