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

Last change on this file since 14350 was 14350, checked in by Alex Shinn, 11 years ago

fixing bug in read-decl

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        (read-char in)
325        (loop res))))))
326
327;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328;; the parser
329
330(define *default-entities*
331  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
332    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
333
334(define (get-entity entities name)
335  (cond
336   ((string->number name) => (lambda (n) (string (integer->char n))))
337   ((assoc name entities) => cdr)
338   (else #f)))
339
340;; span's and div's can be used at any level
341(define *tag-levels*
342  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
343
344(define *unnestables*
345  '(p li td tr))
346
347(define *bodyless*
348  '(img hr br))
349
350(define *literals*
351  '(script xmp))
352
353(define *terminators*
354  '(plaintext))
355
356(define (tag-level tag-levels tag)
357  (let lp ((ls tag-levels) (i 0))
358    (if (null? ls)
359        (+ i 1000)
360        (if (if (pair? (car ls))
361                (memq tag (car ls))
362                (eq? tag (car ls)))
363            i
364            (lp (cdr ls) (+ i 1))))))
365
366(define (read-html-token . o)
367  (let ((in (if (pair? o) (car o) (current-input-port))))
368    (let ((c (peek-char in)))
369      (if (eof-object? c)
370          (cons 'eof c)
371          (case c
372            ((#\<)
373             (read-char in)
374             (case (peek-char in)
375               ((#\!)
376                (read-char in)
377                (cond
378                 ((eqv? #\[ (peek-char in))
379                  (read-char in)
380                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
381                           (acc '(#\[ #\! #\<)))
382                    (cond
383                     ((null? check)
384                      (cons 'text (read-until-aab #\] #\> in)))
385                     ((let ((c (peek-char in)))
386                        (and (not (eof-object? c)) (char-ci=? c (car check))))
387                      (lp (cdr check) (cons (read-char in) acc)))
388                     (else
389                      (cons 'text (list->string (reverse acc)))))))
390                 ((and (eqv? #\- (peek-char in))
391                       (begin (read-char in)
392                              (eqv? #\- (peek-char in))))
393                  (read-char in)
394                  (cons 'comment (read-comment in)))
395                 (else
396                  (cons 'decl (read-decl in)))))
397               ((#\?)
398                (read-char in)
399                (cons 'process (read-pi in)))
400               ((#\/)
401                (read-char in)
402                (cons 'end (read-end in)))
403               (else
404                ;; start tags must immediately be followed by an
405                ;; alphabetic charater, or we just treat the < as text
406                (if (and (char? (peek-char in))
407                         (char-alphabetic? (peek-char in)))
408                    (let ((res (read-start in)))
409                      (if (cadr res)
410                          (cons 'start/end (cons (car res) (cddr res)))
411                          (cons 'start (cons (car res) (cddr res)))))
412                    (cons 'text "<")))))
413            ((#\&)
414             (read-char in)
415             (cond
416              ((eqv? (peek-char in) #\#)
417               (read-char in)
418               (cond
419                ((char-numeric? (peek-char in))
420                 (let* ((str (read-integer in))
421                        (num (string->number str)))
422                   (if (eqv? (peek-char in) #\;)
423                       (read-char in))
424                   (cons 'entity num)))
425                ((memv (peek-char in) '(#\x #\X))
426                 (read-char in)
427                 (let* ((str (read-hex-integer in))
428                        (num (string->number str 16)))
429                   (if (eqv? (peek-char in) #\;)
430                       (read-char in))
431                   (cons 'entity num)))
432                (else
433                 (cons 'text "&#"))))
434              ((char-alphabetic? (peek-char in))
435               (let ((name (read-identifier in)))
436                 (if (eqv? (peek-char in) #\;)
437                     (read-char in))
438                 (cons 'entity name)))
439              (else
440               (cons 'text "&"))))
441            (else
442             (cons 'text
443                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
444                               in))))))))
445
446(define (%key-ref ls key default)
447  (cond ((memq key ls) => cadr) (else default)))
448
449(define (make-html-parser . o)
450  (let ((start (%key-ref o 'start: (lambda (t a s v) s)))
451        (end (%key-ref o 'end: (lambda (t a p s v) s)))
452        (text (%key-ref o 'text: (lambda (t s) s)))
453        (decl (%key-ref o 'decl: (lambda (t a s) s)))
454        (process (%key-ref o 'process: (lambda (t s) s)))
455        (comment (%key-ref o 'comment: (lambda (t s) s)))
456        (entities (%key-ref o 'entities: *default-entities*))
457        (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
458        (unnestables (%key-ref o 'unnestables: *unnestables*))
459        (bodyless (%key-ref o 'bodyless: *bodyless*))
460        (literals (%key-ref o 'literals: *literals*))
461        (terminators (%key-ref o 'terminators: *terminators*))
462        (entity (%key-ref o 'entity: #f)))
463    (let ((entity (or entity (lambda (t s)
464                               (text (if (number? t)
465                                         (string (integer->char t))
466                                         (or (get-entity entities t)
467                                             (string-append "&" t ";")))
468                                     s)))))
469      (lambda (seed . o)
470        (let* ((src (if (pair? o) (car o) (current-input-port)))
471               (in (if (string? src) (open-input-string src) src)))
472          (let lp ((tok (read-html-token in))
473                   (seed seed)
474                   (seeds '())
475                   (tags '()))
476            (case (car tok)
477              ((eof)                     ; close all open tags
478               (let lp ((t tags) (s seeds) (seed seed))
479                 (if (null? t)
480                     seed
481                     (lp (cdr t) (cdr s)
482                         (end (caar t) (cadar t) (car s) seed 'eof)))))
483              ((start/end)
484               (let ((tag (cadr tok)))
485                 (lp `(end . ,tag)
486                     (start tag (caddr tok) seed #f)
487                     (cons seed seeds)
488                     (cons (cdr tok) tags))))
489              ((start)
490               (let ((tag (cadr tok)))
491                 (cond
492                  ((memq tag terminators)
493                   (lp `(text . ,(read-until (lambda (c) #f) in))
494                       (start tag (caddr tok) seed #f)
495                       (cons seed seeds)
496                       (cons (cdr tok) tags)))
497                  ((memq tag literals)
498                   (let ((body (read-until-string/ci
499                                (string-append "</" (symbol->string tag) ">")
500                                in))
501                         (seed2 (start tag (caddr tok) seed #f)))
502                     (lp `(end . ,tag)
503                         (if (equal? "" body) seed2 (text body seed2))
504                         (cons seed seeds)
505                         (cons (cdr tok) tags))))
506                  ((memq tag bodyless)
507                   (lp `(end . ,tag)
508                       (start tag (caddr tok) seed #f)
509                       (cons seed seeds)
510                       (cons (cdr tok) tags)))
511                  ((and (pair? tags) (eq? tag (caar tags))
512                        (memq tag unnestables))
513                   ;; <p> ... <p> implies siblings, not nesting
514                   (let ((seed2
515                          (end tag (cadar tags) (car seeds) seed 'sibling)))
516                     (lp (read-html-token in)
517                         (start tag (caddr tok) seed #f)
518                         (cons seed2 (cdr seeds))
519                         (cons (cdr tok) (cdr tags)))))
520                  (else
521                   (lp (read-html-token in)
522                       (start tag (caddr tok) seed #f)
523                       (cons seed seeds)
524                       (cons (cdr tok) tags))))))
525              ((end)
526               (cond
527                ((not (cdr tok)) ;; nameless closing tag
528                 (lp (read-html-token in) seed seeds tags))
529                ((and (pair? tags) (eq? (cdr tok) (caar tags)))
530                 (lp (read-html-token in)
531                     (end (cdr tok) (cadar tags) (car seeds) seed #f)
532                     (cdr seeds)
533                     (cdr tags)))
534                (else
535                 (let ((this-level (tag-level tag-levels (cdr tok)))
536                       (expected-level
537                        (if (pair? tags)
538                            (tag-level tag-levels (caar tags))
539                            -1)))
540                   (cond
541                    ((< this-level expected-level)
542                     ;; higher-level tag, forcefully close preceding tags
543                     (lp tok
544                         (end (caar tags) (cadar tags) (car seeds) seed
545                              'parent-closed)
546                         (cdr seeds)
547                         (cdr tags)))
548                    ((and (= this-level expected-level) (pair? (cdr tags)))
549                     ;; equal, interleave (close prec tag, close this,
550                     ;; re-open prec)
551                     ;; <b><i></b> => <b><i></i></b><i>
552                     ;;                     ^^^^    ^^^
553                     ;; XXXX handle backups > 1 here
554                     (let* ((seed2 (end (caar tags) (cadar tags)
555                                        (car seeds) seed 'interleave))
556                            (seed3 (end (caadr tags) (cadadr tags)
557                                        (cadr seeds) seed2 #f)))
558                       (let ((tok2 (read-html-token in)))
559                         (cond
560                          ((and (eq? 'end (car tok2))
561                                (eq? (caar tags) (cdr tok2)))
562                           ;; simple case where the closing tag
563                           ;; immediately follows
564                           (lp (read-html-token in) seed3
565                               (cddr seeds) (cddr tags)))
566                          (else
567                           (lp tok2
568                               (start (caar tags) (cadar tags) seed3
569                                      'interleave)
570                               (cons seed3 (cddr seeds))
571                               (cons (car tags) (cddr tags))))))))
572                    (else
573                     ;; spurious end for a lower-level tag, add
574                     ;; imaginary start
575                     (let* ((seed2 (start (cdr tok) '() seed 'no-start))
576                            (seed3 (end (cdr tok) '() seed seed2 #f)))
577                       (lp (read-html-token in) seed3 seeds tags))))))))
578              ((text)
579               (lp (read-html-token in) (text (cdr tok) seed) seeds tags))
580              ((entity)
581               (lp (read-html-token in) (entity (cdr tok) seed) seeds tags))
582              ((comment)
583               (lp (read-html-token in) (comment (cdr tok) seed) seeds tags))
584              ((decl)
585               (lp (read-html-token in)
586                   (decl (cadr tok) (cddr tok) seed) seeds tags))
587              ((process)
588               (lp (read-html-token in) (process (cdr tok) seed) seeds tags))
589              (else
590               (error "invalid token: " tok)))))))))
591
592;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
593;; simple conversions
594
595(define html->sxml
596  (let ((parse
597         (make-html-parser
598          'start: (lambda (tag attrs seed virtual?) '())
599          'end:   (lambda (tag attrs parent-seed seed virtual?)
600                    `((,tag ,@(if (pair? attrs)
601                                  `((@ ,@attrs) ,@(reverse seed))
602                                  (reverse seed)))
603                      ,@parent-seed))
604          'decl:    (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
605          'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
606          'comment: (lambda (text seed) `((*COMMENT* ,text) ,@seed))
607          'text:    (lambda (text seed) (cons text seed))
608          )))
609    (lambda o
610      (reverse (apply parse '() o)))))
611
612;; XXXX
613(define (html-escape-attr str)
614  str)
615
616(define (html-attr->string attr)
617  (string-append (symbol->string (car attr))
618                 "=\"" (html-escape-attr (cdr attr)) "\""))
619
620(define (html-tag->string tag attrs)
621  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
622    (if (null? ls)
623        (apply string-append (reverse (cons ">" res)))
624        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
625
626(define (html-display-escaped-string str out)
627  (let ((start 0)
628        (end (string-length str)))
629    (let lp ((from start) (to start))
630      (if (>= to end)
631          (display (substring str from to) out)
632          (let ((c (string-ref str to)))
633            (cond
634             ((eq? c #\<)
635              (display (substring str from to) out)
636              (display "&lt;" out)
637              (let ((next (+ to 1)))
638                (lp next next)))
639             ((eq? c #\&)
640              (display (substring str from to) out)
641              (display "&amp;" out)
642              (let ((next (+ to 1)))
643                (lp next next)))
644             (else
645              (lp from (+ to 1)))))))))
646
647(define (html-escape str)
648  (call-with-output-string
649    (lambda (out) (html-display-escaped-string str out))))
650
651(define (sxml-display-as-html sxml . o)
652  (let ((out (if (pair? o) (car o) (current-output-port))))
653    (cond
654     ((pair? sxml)
655      (let ((tag (car sxml)))
656        (if (symbol? tag)
657            (let ((rest (cdr sxml)))
658              (cond
659               ((and (pair? rest)
660                     (pair? (car rest))
661                     (eq? '@ (caar rest)))
662                (display (html-tag->string tag (cdar rest)) out)
663                (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
664                (display "</" out) (display tag out) (display ">" out))
665               (else
666                (display (html-tag->string tag '()) out)
667                (for-each (lambda (x) (sxml-display-as-html x out)) rest)
668                (display "</" out) (display tag out) (display ">" out))))
669            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
670     ((null? sxml))
671     (else (html-display-escaped-string sxml out)))))
672
673(define (sxml->html sxml . o)
674  (call-with-output-string
675    (lambda (out) (sxml-display-as-html sxml out))))
676
677;; just strips tags, no whitespace handling or formatting
678(define (html-strip . o)
679  (call-with-output-string
680   (lambda (out)
681     (let ((parse
682            (make-html-parser
683             'start: (lambda (tag attrs seed virtual?) seed)
684             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
685             'text:  (lambda (text seed) (display text out)))))
686       (apply parse (cons #f #f) o)))))
687
688)
Note: See TracBrowser for help on using the repository browser.