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

Last change on this file since 14752 was 14752, checked in by Alex Shinn, 12 years ago

simplifying escapes

File size: 25.4 KB
Line 
1;;;; html-parser.scm -- SSAX-like tree-folding html parser
2;;
3;; Copyright (c) 2003-2009 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 make-string-reader/ci
79   html->sxml html-strip html-escape html-display-escaped-string
80   html-tag->string html-attr->string
81   sxml->html sxml-display-as-html)
82(import scheme
83        (only srfi-13 string-downcase)
84        (only ports call-with-output-string with-output-to-string)
85        (only chicken error open-input-string))
86
87;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88;; ;; from SRFI-13
89
90;; (define (string-downcase str)
91;;   (let lp ((i (- (string-length str) 1)) (res '()))
92;;     (if (negative? i)
93;;         (list->string res)
94;;         (lp (- i 1) (cons (char-downcase (string-ref str i)) res)))))
95
96;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97;; ;; SRFI-6 extension if not defined
98
99;; (define (call-with-output-string proc)
100;;   (let ((out (open-output-string)))
101;;     (proc out)
102;;     (get-output-string out)))
103
104;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105;; text parsing utils
106
107(define (read-while pred . o)
108  (let ((in (if (pair? o) (car o) (current-input-port))))
109    (call-with-output-string
110     (lambda (out)
111       (let lp ()
112         (let ((c (peek-char in)))
113           (cond
114            ((and (not (eof-object? c)) (pred c))
115             (write-char (read-char in) out)
116             (lp)))))))))
117
118(define (read-until pred . o)
119  (let ((in (if (pair? o) (car o) (current-input-port))))
120    (call-with-output-string
121     (lambda (out)
122       (let lp ()
123         (let ((c (peek-char in)))
124           (cond
125            ((not (or (eof-object? c) (pred c)))
126             (write-char (read-char in) out)
127             (lp)))))))))
128
129;; Generates a KMP reader that works on ports, returning the text read
130;; up until the search string (or the entire port if the search string
131;; isn't found).  This is O(n) in the length of the string returned,
132;; as opposed to the find-string-from-port? in SSAX which uses
133;; backtracking for an O(nm) algorithm.  This is hard-coded to
134;; case-insensitively match, since that's what we need for HTML.  A
135;; more general utility would abstract the character matching
136;; predicate and possibly provide a limit on the length of the string
137;; read.
138(define (make-string-reader/ci str)
139  (let* ((len (string-length str))
140         (vec (make-vector len 0)))
141    (cond ((> len 0)
142            (vector-set! vec 0 -1)
143           (cond ((> len 1) (vector-set! vec 1 0)))))
144    (let lp ((i 2) (j 0))
145      (cond
146       ((< i len)
147        (let ((c (string-ref str i)))
148          (cond
149           ((char-ci=? (string-ref str (- i 1)) (string-ref str j))
150            (vector-set! vec i (+ j 1))
151            (lp (+ i 1) (+ j 1)))
152           ((> j 0)
153            (lp i (vector-ref vec j)))
154           (else
155            (vector-set! vec i 0)
156            (lp (+ i 1) j)))))))
157    (lambda o
158      (let ((in (if (pair? o) (car o) (current-input-port))))
159        (call-with-output-string
160          (lambda (out)
161            (let lp ((i 0))
162              (cond
163               ((< i len)
164                (let ((c (peek-char in)))
165                  (cond
166                   ((eof-object? c)
167                    (display (substring str 0 i) out))
168                   ((char-ci=? c (string-ref str i))
169                    (read-char in)
170                    (lp (+ i 1)))
171                   (else
172                    (let* ((i2 (vector-ref vec i))
173                           (i3 (if (= -1 i2) 0 i2)))
174                      (if (> i i3) (display (substring str 0 (- i i3)) out) #f)
175                      (if (= -1 i2) (write-char (read-char in) out) #f)
176                      (lp i3))))))))))))))
177
178(define skip-whitespace (lambda x (apply read-while char-whitespace? x)))
179
180;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
181;; html-specific readers
182
183(define (char-alphanumeric? c)
184  (or (char-alphabetic? c) (char-numeric? c)))
185
186(define (char-hex-numeric? c)
187  (or (char-numeric? c)
188      (memv (char-downcase c) '(#\a #\b #\c #\d #\e #\f))))
189
190(define read-identifier (lambda x (apply read-while char-alphanumeric? x)))
191
192(define read-integer (lambda x (apply read-while char-numeric? x)))
193
194(define read-hex-integer (lambda x (apply read-while char-hex-numeric? x)))
195
196(define (read-quoted in)
197  (let* ((terminator (read-char in))
198         (res (read-until (lambda (c) (eqv? c terminator)) in)))
199    (read-char in)
200    res))
201
202(define (read-pi in)
203  (let ((tag (read-identifier in)))
204    (skip-whitespace in)
205    (list
206     (if (equal? tag "") #f (string->symbol (string-downcase tag)))
207     (list->string
208      (reverse
209       (let loop ((res '()))
210         (let ((c (peek-char in)))
211           (cond
212            ((eof-object? c)
213             (read-char in)
214             res)
215            ((eqv? c #\?)
216             (read-char in)
217             (let loop2 ((res res))
218               (cond
219                ((eof-object? (peek-char in))
220                 (cons #\? res))
221                ((eqv? #\> (peek-char in))
222                 (read-char in)
223                 res)
224                ((eqv? #\? (peek-char in))
225                 (read-char in)
226                 (loop2 (cons c res)))
227                (else
228                 (loop (cons c res))))))
229            (else
230             (read-char in)
231             (loop (cons c res)))))))))))
232
233(define read-comment (make-string-reader/ci "-->"))
234
235(define (tag-char? c)
236  (and (char? c)
237       (or (char-alphanumeric? c) (memv c '(#\- #\+ #\* #\_ #\:)))))
238
239(define (read-attrs in)
240  (let loop ((attrs '()))
241    (skip-whitespace in)
242    (let ((c (peek-char in)))
243      (cond
244       ((or (eof-object? c) (eqv? c #\>))
245        (read-char in)
246        (list #f (reverse attrs)))
247       ((eqv? c #\/)
248        (read-char in)
249        (skip-whitespace in)
250        (cond
251         ((eqv? #\> (peek-char in))
252          (read-char in)
253          (list #t (reverse attrs)))
254         (else
255          (loop attrs))))
256       ((eqv? c #\")
257        (read-char in)
258        (loop attrs))
259       ((not (tag-char? c))
260        (list #f (reverse attrs)))
261       (else
262        (let ((name (read-while tag-char? in)))
263          (if (string=? name "")
264              (loop attrs)
265              (let ((name (string->symbol (string-downcase name))))
266                (cond
267                 ((eqv? (peek-char in) #\=)
268                  (read-char in)
269                  (let ((value (if (memv (peek-char in) '(#\" #\'))
270                                   (read-quoted in)
271                                   (read-until
272                                    (lambda (c)
273                                      (or (char-whitespace? c)
274                                          (memv c '(#\' #\" #\< #\>))))
275                                    in))))
276                    (if (or (eqv? #\" (peek-char in))
277                            (eqv? #\' (peek-char in)))
278                        (read-char in)
279                        #f)
280                    (loop (cons (list name value) attrs))))
281                 (else
282                  (loop (cons (list name) attrs))))))))))))
283
284(define (read-start in)
285  (let ((tag (string->symbol (string-downcase (read-while tag-char? in)))))
286    (cons tag (read-attrs in))))
287
288(define (read-end in)
289  (let ((tag (read-while tag-char? in)))
290    (cond
291     ((equal? tag "")
292      (read-until (lambda (c) (eqv? c #\>)) in)
293      (read-char in)
294      #f)
295     (else
296      (read-attrs in)
297      (string->symbol (string-downcase tag))))))
298
299(define (read-decl in)
300  (let loop ((res '()))
301    (skip-whitespace in)
302    (let ((c (peek-char in)))
303      (cond
304       ((eof-object? c)
305        (reverse res))
306       ((eqv? c #\")
307        (loop (cons (read-quoted in) res)))
308       ((eqv? c #\>)
309        (read-char in)
310        (reverse res))
311       ((eqv? c #\<)
312        (read-char in)
313        (if (eqv? (peek-char in) #\!) (read-char in) #f)
314        (loop (cons (read-decl in) res)))
315       ((tag-char? c)
316        (loop (cons (string->symbol (read-while tag-char? in)) res)))
317       (else
318        (read-char in)
319        (loop res))))))
320
321;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322;; the parser
323
324(define *default-entities*
325  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
326    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
327
328(define (get-entity entities name)
329  (cond
330   ((string->number name) => (lambda (n) (string (integer->char n))))
331   ((assoc name entities) => cdr)
332   (else #f)))
333
334;; span's and div's can be used at any level
335(define *tag-levels*
336  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
337
338(define *unnestables*
339  '(p li td tr))
340
341(define *bodyless*
342  '(img hr br))
343
344(define *literals*
345  '(script xmp))
346
347(define *terminators*
348  '(plaintext))
349
350(define (tag-level tag-levels tag)
351  (let lp ((ls tag-levels) (i 0))
352    (if (null? ls)
353        (+ i 1000)
354        (if (if (pair? (car ls))
355                (memq tag (car ls))
356                (eq? tag (car ls)))
357            i
358            (lp (cdr ls) (+ i 1))))))
359
360(define read-cdata (make-string-reader/ci "]]>"))
361
362(define (read-html-token . o)
363  (let ((in (if (pair? o) (car o) (current-input-port))))
364    (let ((c (peek-char in)))
365      (if (eof-object? c)
366          (cons 'eof c)
367          (case c
368            ((#\<)
369             (read-char in)
370             (case (peek-char in)
371               ((#\!)
372                (read-char in)
373                (cond
374                 ((eqv? #\[ (peek-char in))
375                  (read-char in)
376                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
377                           (acc '(#\[ #\! #\<)))
378                    (cond
379                     ((null? check)
380                      (cons 'text (read-cdata in)))
381                     ((let ((c (peek-char in)))
382                        (and (not (eof-object? c)) (char-ci=? c (car check))))
383                      (lp (cdr check) (cons (read-char in) acc)))
384                     (else
385                      (cons 'text (list->string (reverse acc)))))))
386                 ((and (eqv? #\- (peek-char in))
387                       (begin (read-char in)
388                              (eqv? #\- (peek-char in))))
389                  (read-char in)
390                  (cons 'comment (read-comment in)))
391                 (else
392                  (cons 'decl (read-decl in)))))
393               ((#\?)
394                (read-char in)
395                (cons 'process (read-pi in)))
396               ((#\/)
397                (read-char in)
398                (cons 'end (read-end in)))
399               (else
400                ;; start tags must immediately be followed by an
401                ;; alphabetic charater, or we just treat the < as text
402                (if (and (char? (peek-char in))
403                         (char-alphabetic? (peek-char in)))
404                    (let ((res (read-start in)))
405                      (if (cadr res)
406                          (cons 'start/end (cons (car res) (cddr res)))
407                          (cons 'start (cons (car res) (cddr res)))))
408                    (cons 'text "<")))))
409            ((#\&)
410             (read-char in)
411             (cond
412              ((eqv? (peek-char in) #\#)
413               (read-char in)
414               (cond
415                ((char-numeric? (peek-char in))
416                 (let* ((str (read-integer in))
417                        (num (string->number str)))
418                   (cond ((eqv? (peek-char in) #\;)
419                          (read-char in)))
420                   (cons 'entity num)))
421                ((memv (peek-char in) '(#\x #\X))
422                 (read-char in)
423                 (let* ((str (read-hex-integer in))
424                        (num (string->number str 16)))
425                   (cond ((eqv? (peek-char in) #\;)
426                          (read-char in)))
427                   (cons 'entity num)))
428                (else
429                 (cons 'text "&#"))))
430              ((char-alphabetic? (peek-char in))
431               (let ((name (read-identifier in)))
432                 (cond ((eqv? (peek-char in) #\;)
433                        (read-char in)))
434                 (cons 'entity name)))
435              (else
436               (cons 'text "&"))))
437            (else
438             (cons 'text
439                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
440                               in))))))))
441
442(define (%key-ref ls key default)
443  (cond ((memq key ls) => cadr) (else default)))
444
445(define (make-html-parser . o)
446  (let ((start (%key-ref o 'start: (lambda (t a s v) s)))
447        (end (%key-ref o 'end: (lambda (t a p s v) s)))
448        (text (%key-ref o 'text: (lambda (t s) s)))
449        (decl (%key-ref o 'decl: (lambda (t a s) s)))
450        (process (%key-ref o 'process: (lambda (t s) s)))
451        (comment (%key-ref o 'comment: (lambda (t s) s)))
452        (entities (%key-ref o 'entities: *default-entities*))
453        (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
454        (unnestables (%key-ref o 'unnestables: *unnestables*))
455        (bodyless (%key-ref o 'bodyless: *bodyless*))
456        (literals
457         (map (lambda (x)
458                (cons x (make-string-reader/ci
459                         (string-append "</" (symbol->string x) ">"))))
460              (%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                  ((assq tag literals)
498                   => (lambda (lit)
499                        (let ((body ((cdr lit) 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(define (html-escape-attr str)
612  (call-with-output-string
613    (lambda (out) (html-display-escaped-string str out))))
614
615(define (html-attr->string attr)
616  (string-append
617   (symbol->string (car attr)) "=\""
618   (html-escape-attr (if (pair? (cdr attr)) (cadr attr) (cdr attr)))
619   "\""))
620
621(define (html-tag->string tag attrs)
622  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
623    (if (null? ls)
624        (apply string-append (reverse (cons ">" res)))
625        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
626
627(define html-character-escapes
628  '((#\< . "&lt;")
629    (#\> . "&gt;")
630    (#\& . "&amp;")
631    (#\" . "&quot;")
632    (#\' . "&#39;")))
633
634(define (html-display-escaped-string str out)
635  (let ((start 0)
636        (end (string-length str)))
637    (let lp ((from start) (to start))
638      (if (>= to end)
639          (display (substring str from to) out)
640          (cond
641           ((assq (string-ref str to) html-character-escapes)
642            => (lambda (esc)
643                 (display (substring str from to) out)
644                 (display (cdr esc) out)
645                 (lp (+ to 1) (+ to 1))))
646           (else
647            (lp from (+ to 1))))))))
648
649(define (html-escape str)
650  (call-with-output-string
651    (lambda (out) (html-display-escaped-string str out))))
652
653(define (sxml-display-as-html sxml . o)
654  (let ((out (if (pair? o) (car o) (current-output-port))))
655    (cond
656     ((pair? sxml)
657      (let ((tag (car sxml)))
658        (if (symbol? tag)
659            (let ((rest (cdr sxml)))
660              (cond
661               ((and (pair? rest)
662                     (pair? (car rest))
663                     (eq? '@ (caar rest)))
664                (display (html-tag->string tag (cdar rest)) out)
665                (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
666                (display "</" out) (display tag out) (display ">" out))
667               (else
668                (display (html-tag->string tag '()) out)
669                (for-each (lambda (x) (sxml-display-as-html x out)) rest)
670                (display "</" out) (display tag out) (display ">" out))))
671            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
672     ((null? sxml))
673     (else (html-display-escaped-string sxml out)))))
674
675(define (sxml->html sxml . o)
676  (call-with-output-string
677    (lambda (out) (sxml-display-as-html sxml out))))
678
679;; just strips tags, no whitespace handling or formatting
680(define (html-strip . o)
681  (call-with-output-string
682   (lambda (out)
683     (let ((parse
684            (make-html-parser
685             'start: (lambda (tag attrs seed virtual?) seed)
686             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
687             'text:  (lambda (text seed) (display text out)))))
688       (apply parse (cons #f #f) o)))))
689
690)
Note: See TracBrowser for help on using the repository browser.