source: project/release/4/html-parser/tags/0.4/html-parser.scm @ 15231

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

tagging new release

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