source: project/release/4/html-parser/tags/0.3/html-parser.scm @ 14751

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

tagging new release

File size: 26.1 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   sxml->html sxml-display-as-html)
81(import scheme
82        (only srfi-13 string-downcase)
83        (only ports call-with-output-string with-output-to-string)
84        (only chicken error open-input-string))
85
86;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87;; ;; from SRFI-13
88
89;; (define (string-downcase str)
90;;   (let lp ((i (- (string-length str) 1)) (res '()))
91;;     (if (negative? i)
92;;         (list->string res)
93;;         (lp (- i 1) (cons (char-downcase (string-ref str i)) res)))))
94
95;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96;; ;; SRFI-6 extension if not defined
97
98;; (define (call-with-output-string proc)
99;;   (let ((out (open-output-string)))
100;;     (proc out)
101;;     (get-output-string out)))
102
103;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104;; text parsing utils
105
106(define (read-while pred . o)
107  (let ((in (if (pair? o) (car o) (current-input-port))))
108    (call-with-output-string
109     (lambda (out)
110       (let lp ()
111         (let ((c (peek-char in)))
112           (cond
113            ((and (not (eof-object? c)) (pred c))
114             (write-char (read-char in) out)
115             (lp)))))))))
116
117(define (read-until pred . o)
118  (let ((in (if (pair? o) (car o) (current-input-port))))
119    (call-with-output-string
120     (lambda (out)
121       (let lp ()
122         (let ((c (peek-char in)))
123           (cond
124            ((not (or (eof-object? c) (pred c)))
125             (write-char (read-char in) out)
126             (lp)))))))))
127
128;; Generates a KMP reader that works on ports, returning the text read
129;; up until the search string (or the entire port if the search string
130;; isn't found).  This is O(n) in the length of the string returned,
131;; as opposed to the find-string-from-port? in SSAX which uses
132;; backtracking for an O(nm) algorithm.  This is hard-coded to
133;; case-insensitively match, since that's what we need for HTML.  A
134;; more general utility would abstract the character matching
135;; predicate and possibly provide a limit on the length of the string
136;; read.
137(define (make-string-reader/ci str)
138  (let* ((len (string-length str))
139         (vec (make-vector len 0)))
140    (cond ((> len 0)
141            (vector-set! vec 0 -1)
142           (cond ((> len 1) (vector-set! vec 1 0)))))
143    (let lp ((i 2) (j 0))
144      (cond
145       ((< i len)
146        (let ((c (string-ref str i)))
147          (cond
148           ((char-ci=? (string-ref str (- i 1)) (string-ref str j))
149            (vector-set! vec i (+ j 1))
150            (lp (+ i 1) (+ j 1)))
151           ((> j 0)
152            (lp i (vector-ref vec j)))
153           (else
154            (vector-set! vec i 0)
155            (lp (+ i 1) j)))))))
156    (lambda o
157      (let ((in (if (pair? o) (car o) (current-input-port))))
158        (call-with-output-string
159          (lambda (out)
160            (let lp ((i 0))
161              (cond
162               ((< i len)
163                (let ((c (peek-char in)))
164                  (cond
165                   ((eof-object? c)
166                    (display (substring str 0 i) out))
167                   ((char-ci=? c (string-ref str i))
168                    (read-char in)
169                    (lp (+ i 1)))
170                   (else
171                    (let* ((i2 (vector-ref vec i))
172                           (i3 (if (= -1 i2) 0 i2)))
173                      (if (> i i3) (display (substring str 0 (- i i3)) out) #f)
174                      (if (= -1 i2) (write-char (read-char in) out) #f)
175                      (lp i3))))))))))))))
176
177(define skip-whitespace (lambda x (apply read-while char-whitespace? x)))
178
179;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
180;; html-specific readers
181
182(define (char-alphanumeric? c)
183  (or (char-alphabetic? c) (char-numeric? c)))
184
185(define (char-hex-numeric? c)
186  (or (char-numeric? c)
187      (memv (char-downcase c) '(#\a #\b #\c #\d #\e #\f))))
188
189(define read-identifier (lambda x (apply read-while char-alphanumeric? x)))
190
191(define read-integer (lambda x (apply read-while char-numeric? x)))
192
193(define read-hex-integer (lambda x (apply read-while char-hex-numeric? x)))
194
195(define (read-quoted in)
196  (let* ((terminator (read-char in))
197         (res (read-until (lambda (c) (eqv? c terminator)) in)))
198    (read-char in)
199    res))
200
201(define (read-pi in)
202  (let ((tag (read-identifier in)))
203    (skip-whitespace in)
204    (list
205     (if (equal? tag "") #f (string->symbol (string-downcase tag)))
206     (list->string
207      (reverse
208       (let loop ((res '()))
209         (let ((c (peek-char in)))
210           (cond
211            ((eof-object? c)
212             (read-char in)
213             res)
214            ((eqv? c #\?)
215             (read-char in)
216             (let loop2 ((res res))
217               (cond
218                ((eof-object? (peek-char in))
219                 (cons #\? res))
220                ((eqv? #\> (peek-char in))
221                 (read-char in)
222                 res)
223                ((eqv? #\? (peek-char in))
224                 (read-char in)
225                 (loop2 (cons c res)))
226                (else
227                 (loop (cons c res))))))
228            (else
229             (read-char in)
230             (loop (cons c res)))))))))))
231
232(define read-comment (make-string-reader/ci "-->"))
233
234(define (tag-char? c)
235  (and (char? c)
236       (or (char-alphanumeric? c) (memv c '(#\- #\+ #\* #\_ #\:)))))
237
238(define (read-attrs in)
239  (let loop ((attrs '()))
240    (skip-whitespace in)
241    (let ((c (peek-char in)))
242      (cond
243       ((or (eof-object? c) (eqv? c #\>))
244        (read-char in)
245        (list #f (reverse attrs)))
246       ((eqv? c #\/)
247        (read-char in)
248        (skip-whitespace in)
249        (cond
250         ((eqv? #\> (peek-char in))
251          (read-char in)
252          (list #t (reverse attrs)))
253         (else
254          (loop attrs))))
255       ((eqv? c #\")
256        (read-char in)
257        (loop attrs))
258       ((not (tag-char? c))
259        (list #f (reverse attrs)))
260       (else
261        (let ((name (read-while tag-char? in)))
262          (if (string=? name "")
263              (loop attrs)
264              (let ((name (string->symbol (string-downcase name))))
265                (cond
266                 ((eqv? (peek-char in) #\=)
267                  (read-char in)
268                  (let ((value (if (memv (peek-char in) '(#\" #\'))
269                                   (read-quoted in)
270                                   (read-until
271                                    (lambda (c)
272                                      (or (char-whitespace? c)
273                                          (memv c '(#\' #\" #\< #\>))))
274                                    in))))
275                    (if (or (eqv? #\" (peek-char in))
276                            (eqv? #\' (peek-char in)))
277                        (read-char in)
278                        #f)
279                    (loop (cons (list name value) attrs))))
280                 (else
281                  (loop (cons (list name) attrs))))))))))))
282
283(define (read-start in)
284  (let ((tag (string->symbol (string-downcase (read-while tag-char? in)))))
285    (cons tag (read-attrs in))))
286
287(define (read-end in)
288  (let ((tag (read-while tag-char? in)))
289    (cond
290     ((equal? tag "")
291      (read-until (lambda (c) (eqv? c #\>)) in)
292      (read-char in)
293      #f)
294     (else
295      (read-attrs in)
296      (string->symbol (string-downcase tag))))))
297
298(define (read-decl in)
299  (let loop ((res '()))
300    (skip-whitespace in)
301    (let ((c (peek-char in)))
302      (cond
303       ((eof-object? c)
304        (reverse res))
305       ((eqv? c #\")
306        (loop (cons (read-quoted in) res)))
307       ((eqv? c #\>)
308        (read-char in)
309        (reverse res))
310       ((eqv? c #\<)
311        (read-char in)
312        (if (eqv? (peek-char in) #\!) (read-char in) #f)
313        (loop (cons (read-decl in) res)))
314       ((tag-char? c)
315        (loop (cons (string->symbol (read-while tag-char? in)) res)))
316       (else
317        (read-char in)
318        (loop res))))))
319
320;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321;; the parser
322
323(define *default-entities*
324  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
325    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
326
327(define (get-entity entities name)
328  (cond
329   ((string->number name) => (lambda (n) (string (integer->char n))))
330   ((assoc name entities) => cdr)
331   (else #f)))
332
333;; span's and div's can be used at any level
334(define *tag-levels*
335  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
336
337(define *unnestables*
338  '(p li td tr))
339
340(define *bodyless*
341  '(img hr br))
342
343(define *literals*
344  '(script xmp))
345
346(define *terminators*
347  '(plaintext))
348
349(define (tag-level tag-levels tag)
350  (let lp ((ls tag-levels) (i 0))
351    (if (null? ls)
352        (+ i 1000)
353        (if (if (pair? (car ls))
354                (memq tag (car ls))
355                (eq? tag (car ls)))
356            i
357            (lp (cdr ls) (+ i 1))))))
358
359(define read-cdata (make-string-reader/ci "]]>"))
360
361(define (read-html-token . o)
362  (let ((in (if (pair? o) (car o) (current-input-port))))
363    (let ((c (peek-char in)))
364      (if (eof-object? c)
365          (cons 'eof c)
366          (case c
367            ((#\<)
368             (read-char in)
369             (case (peek-char in)
370               ((#\!)
371                (read-char in)
372                (cond
373                 ((eqv? #\[ (peek-char in))
374                  (read-char in)
375                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
376                           (acc '(#\[ #\! #\<)))
377                    (cond
378                     ((null? check)
379                      (cons 'text (read-cdata in)))
380                     ((let ((c (peek-char in)))
381                        (and (not (eof-object? c)) (char-ci=? c (car check))))
382                      (lp (cdr check) (cons (read-char in) acc)))
383                     (else
384                      (cons 'text (list->string (reverse acc)))))))
385                 ((and (eqv? #\- (peek-char in))
386                       (begin (read-char in)
387                              (eqv? #\- (peek-char in))))
388                  (read-char in)
389                  (cons 'comment (read-comment in)))
390                 (else
391                  (cons 'decl (read-decl in)))))
392               ((#\?)
393                (read-char in)
394                (cons 'process (read-pi in)))
395               ((#\/)
396                (read-char in)
397                (cons 'end (read-end in)))
398               (else
399                ;; start tags must immediately be followed by an
400                ;; alphabetic charater, or we just treat the < as text
401                (if (and (char? (peek-char in))
402                         (char-alphabetic? (peek-char in)))
403                    (let ((res (read-start in)))
404                      (if (cadr res)
405                          (cons 'start/end (cons (car res) (cddr res)))
406                          (cons 'start (cons (car res) (cddr res)))))
407                    (cons 'text "<")))))
408            ((#\&)
409             (read-char in)
410             (cond
411              ((eqv? (peek-char in) #\#)
412               (read-char in)
413               (cond
414                ((char-numeric? (peek-char in))
415                 (let* ((str (read-integer in))
416                        (num (string->number str)))
417                   (cond ((eqv? (peek-char in) #\;)
418                          (read-char in)))
419                   (cons 'entity num)))
420                ((memv (peek-char in) '(#\x #\X))
421                 (read-char in)
422                 (let* ((str (read-hex-integer in))
423                        (num (string->number str 16)))
424                   (cond ((eqv? (peek-char in) #\;)
425                          (read-char in)))
426                   (cons 'entity num)))
427                (else
428                 (cons 'text "&#"))))
429              ((char-alphabetic? (peek-char in))
430               (let ((name (read-identifier in)))
431                 (cond ((eqv? (peek-char in) #\;)
432                        (read-char in)))
433                 (cons 'entity name)))
434              (else
435               (cons 'text "&"))))
436            (else
437             (cons 'text
438                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
439                               in))))))))
440
441(define (%key-ref ls key default)
442  (cond ((memq key ls) => cadr) (else default)))
443
444(define (make-html-parser . o)
445  (let ((start (%key-ref o 'start: (lambda (t a s v) s)))
446        (end (%key-ref o 'end: (lambda (t a p s v) s)))
447        (text (%key-ref o 'text: (lambda (t s) s)))
448        (decl (%key-ref o 'decl: (lambda (t a s) s)))
449        (process (%key-ref o 'process: (lambda (t s) s)))
450        (comment (%key-ref o 'comment: (lambda (t s) s)))
451        (entities (%key-ref o 'entities: *default-entities*))
452        (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
453        (unnestables (%key-ref o 'unnestables: *unnestables*))
454        (bodyless (%key-ref o 'bodyless: *bodyless*))
455        (literals
456         (map (lambda (x)
457                (cons x (make-string-reader/ci
458                         (string-append "</" (symbol->string x) ">"))))
459              (%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                  ((assq tag literals)
497                   => (lambda (lit)
498                        (let ((body ((cdr lit) in))
499                             (seed2 (start tag (caddr tok) seed #f)))
500                         (lp `(end . ,tag)
501                             (if (equal? "" body) seed2 (text body seed2))
502                             (cons seed seeds)
503                             (cons (cdr tok) tags)))))
504                  ((memq tag bodyless)
505                   (lp `(end . ,tag)
506                       (start tag (caddr tok) seed #f)
507                       (cons seed seeds)
508                       (cons (cdr tok) tags)))
509                  ((and (pair? tags) (eq? tag (caar tags))
510                        (memq tag unnestables))
511                   ;; <p> ... <p> implies siblings, not nesting
512                   (let ((seed2
513                          (end tag (cadar tags) (car seeds) seed 'sibling)))
514                     (lp (read-html-token in)
515                         (start tag (caddr tok) seed #f)
516                         (cons seed2 (cdr seeds))
517                         (cons (cdr tok) (cdr tags)))))
518                  (else
519                   (lp (read-html-token in)
520                       (start tag (caddr tok) seed #f)
521                       (cons seed seeds)
522                       (cons (cdr tok) tags))))))
523              ((end)
524               (cond
525                ((not (cdr tok)) ;; nameless closing tag
526                 (lp (read-html-token in) seed seeds tags))
527                ((and (pair? tags) (eq? (cdr tok) (caar tags)))
528                 (lp (read-html-token in)
529                     (end (cdr tok) (cadar tags) (car seeds) seed #f)
530                     (cdr seeds)
531                     (cdr tags)))
532                (else
533                 (let ((this-level (tag-level tag-levels (cdr tok)))
534                       (expected-level
535                        (if (pair? tags)
536                            (tag-level tag-levels (caar tags))
537                            -1)))
538                   (cond
539                    ((< this-level expected-level)
540                     ;; higher-level tag, forcefully close preceding tags
541                     (lp tok
542                         (end (caar tags) (cadar tags) (car seeds) seed
543                              'parent-closed)
544                         (cdr seeds)
545                         (cdr tags)))
546                    ((and (= this-level expected-level) (pair? (cdr tags)))
547                     ;; equal, interleave (close prec tag, close this,
548                     ;; re-open prec)
549                     ;; <b><i></b> => <b><i></i></b><i>
550                     ;;                     ^^^^    ^^^
551                     ;; XXXX handle backups > 1 here
552                     (let* ((seed2 (end (caar tags) (cadar tags)
553                                        (car seeds) seed 'interleave))
554                            (seed3 (end (caadr tags) (cadadr tags)
555                                        (cadr seeds) seed2 #f)))
556                       (let ((tok2 (read-html-token in)))
557                         (cond
558                          ((and (eq? 'end (car tok2))
559                                (eq? (caar tags) (cdr tok2)))
560                           ;; simple case where the closing tag
561                           ;; immediately follows
562                           (lp (read-html-token in) seed3
563                               (cddr seeds) (cddr tags)))
564                          (else
565                           (lp tok2
566                               (start (caar tags) (cadar tags) seed3
567                                      'interleave)
568                               (cons seed3 (cddr seeds))
569                               (cons (car tags) (cddr tags))))))))
570                    (else
571                     ;; spurious end for a lower-level tag, add
572                     ;; imaginary start
573                     (let* ((seed2 (start (cdr tok) '() seed 'no-start))
574                            (seed3 (end (cdr tok) '() seed seed2 #f)))
575                       (lp (read-html-token in) seed3 seeds tags))))))))
576              ((text)
577               (lp (read-html-token in) (text (cdr tok) seed) seeds tags))
578              ((entity)
579               (lp (read-html-token in) (entity (cdr tok) seed) seeds tags))
580              ((comment)
581               (lp (read-html-token in) (comment (cdr tok) seed) seeds tags))
582              ((decl)
583               (lp (read-html-token in)
584                   (decl (cadr tok) (cddr tok) seed) seeds tags))
585              ((process)
586               (lp (read-html-token in) (process (cdr tok) seed) seeds tags))
587              (else
588               (error "invalid token: " tok)))))))))
589
590;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
591;; simple conversions
592
593(define html->sxml
594  (let ((parse
595         (make-html-parser
596          'start: (lambda (tag attrs seed virtual?) '())
597          'end:   (lambda (tag attrs parent-seed seed virtual?)
598                    `((,tag ,@(if (pair? attrs)
599                                  `((@ ,@attrs) ,@(reverse seed))
600                                  (reverse seed)))
601                      ,@parent-seed))
602          'decl:    (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
603          'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
604          'comment: (lambda (text seed) `((*COMMENT* ,text) ,@seed))
605          'text:    (lambda (text seed) (cons text seed))
606          )))
607    (lambda o
608      (reverse (apply parse '() o)))))
609
610(define (html-display-escaped-attr str)
611  (let ((start 0)
612        (end (string-length str)))
613    (let lp ((from start) (to start))
614      (if (>= to end)
615        (display (substring str from to))
616        (let ((c (string-ref str to)))
617          (cond
618            ((eq? c #\<)
619             (display (substring str from to))
620             (display "&lt;")
621             (lp (+ to 1) (+ to 1)))
622            ((eq? c #\&)
623             (display (substring str from to))
624             (display "&amp;")
625             (lp (+ to 1) (+ to 1)))
626            ((eq? c #\")
627             (display (substring str from to))
628             (display "&quot;")
629             (lp (+ to 1) (+ to 1)))
630            (else
631             (lp from (+ to 1)))))))))
632
633(define (html-escape-attr str)
634  (with-output-to-string
635    (lambda () (html-display-escaped-attr str))))
636
637(define (html-attr->string attr)
638  (string-append
639   (symbol->string (car attr)) "=\""
640   (html-escape-attr (if (pair? (cdr attr)) (cadr attr) (cdr attr)))
641   "\""))
642
643(define (html-tag->string tag attrs)
644  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
645    (if (null? ls)
646        (apply string-append (reverse (cons ">" res)))
647        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
648
649(define (html-display-escaped-string str out)
650  (let ((start 0)
651        (end (string-length str)))
652    (let lp ((from start) (to start))
653      (if (>= to end)
654          (display (substring str from to) out)
655          (let ((c (string-ref str to)))
656            (cond
657             ((eq? c #\<)
658              (display (substring str from to) out)
659              (display "&lt;" out)
660              (let ((next (+ to 1)))
661                (lp next next)))
662             ((eq? c #\&)
663              (display (substring str from to) out)
664              (display "&amp;" out)
665              (let ((next (+ to 1)))
666                (lp next next)))
667             (else
668              (lp from (+ to 1)))))))))
669
670(define (html-escape str)
671  (call-with-output-string
672    (lambda (out) (html-display-escaped-string str out))))
673
674(define (sxml-display-as-html sxml . o)
675  (let ((out (if (pair? o) (car o) (current-output-port))))
676    (cond
677     ((pair? sxml)
678      (let ((tag (car sxml)))
679        (if (symbol? tag)
680            (let ((rest (cdr sxml)))
681              (cond
682               ((and (pair? rest)
683                     (pair? (car rest))
684                     (eq? '@ (caar rest)))
685                (display (html-tag->string tag (cdar rest)) out)
686                (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
687                (display "</" out) (display tag out) (display ">" out))
688               (else
689                (display (html-tag->string tag '()) out)
690                (for-each (lambda (x) (sxml-display-as-html x out)) rest)
691                (display "</" out) (display tag out) (display ">" out))))
692            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
693     ((null? sxml))
694     (else (html-display-escaped-string sxml out)))))
695
696(define (sxml->html sxml . o)
697  (call-with-output-string
698    (lambda (out) (sxml-display-as-html sxml out))))
699
700;; just strips tags, no whitespace handling or formatting
701(define (html-strip . o)
702  (call-with-output-string
703   (lambda (out)
704     (let ((parse
705            (make-html-parser
706             'start: (lambda (tag attrs seed virtual?) seed)
707             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
708             'text:  (lambda (text seed) (display text out)))))
709       (apply parse (cons #f #f) o)))))
710
711)
Note: See TracBrowser for help on using the repository browser.