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

Last change on this file since 31191 was 31191, checked in by Alex Shinn, 7 years ago

Fixing read-quoted on incomplete and unescaped &.

File size: 27.5 KB
Line 
1;; html-parser.scm -- SSAX-like tree-folding html parser
2;; Copyright (c) 2003-2014 Alex Shinn.  All rights reserved.
3;; BSD-style license: http://synthcode.com/license.txt
4
5;;> A permissive HTML parser supporting scalable streaming with a
6;;> folding interface.  This copies the interface of Oleg Kiselyov's
7;;> SSAX parser, as well as providing simple convenience utilities.
8;;> It correctly handles all invalid HTML, inserting "virtual"
9;;> starting and closing tags as needed to maintain the proper tree
10;;> structure needed for the foldts down/up logic.  A major goal of
11;;> this parser is bug-for-bug compatibility with the way common web
12;;> 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;;   ENTITY: NAME-OR-NUM SEED
54;;       convert an entity with a given name, or number via &#NNNN;
55;;       to a string
56;;       
57;;   In addition, entity-mappings may be overriden with the ENTITIES:
58;;   keyword.
59
60;; Procedure: html->sxml [port]
61;;   Returns the SXML representation of the document from PORT, using
62;;   the default parsing options.
63
64;; Procedure: html-strip [port]
65;;   Returns a string representation of the document from PORT with all
66;;   tags removed.  No whitespace reduction or other rendering is done.
67
68;; Example:
69;;
70;;   The parser for html-strip could be defined as:
71;;
72;; (make-html-parser
73;;   'start: (lambda (tag attrs seed virtual?) seed)
74;;   'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
75;;   'text:  (lambda (text seed) (display text)))
76;;
77;;   Also see the parser for html->sxml.
78
79(require-library srfi-13)
80
81(module html-parser
82  (make-html-parser make-string-reader/ci
83   html->sxml html-strip html-escape html-display-escaped-string
84   html-tag->string html-attr->string
85   sxml->html sxml-display-as-html)
86(import scheme
87        (only srfi-13 string-downcase)
88        (only ports call-with-output-string with-output-to-string)
89        (only chicken error open-input-string))
90
91;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92;; ;; from SRFI-13
93
94;; (define (string-downcase str)
95;;   (let lp ((i (- (string-length str) 1)) (res '()))
96;;     (if (negative? i)
97;;         (list->string res)
98;;         (lp (- i 1) (cons (char-downcase (string-ref str i)) res)))))
99
100;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
101;; ;; SRFI-6 extension if not defined
102
103;; (define (call-with-output-string proc)
104;;   (let ((out (open-output-string)))
105;;     (proc out)
106;;     (get-output-string out)))
107
108;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
109;; text parsing utils
110
111(define (read-while pred . o)
112  (let ((in (if (pair? o) (car o) (current-input-port))))
113    (call-with-output-string
114     (lambda (out)
115       (let lp ()
116         (let ((c (peek-char in)))
117           (cond
118            ((and (not (eof-object? c)) (pred c))
119             (write-char (read-char in) out)
120             (lp)))))))))
121
122(define (read-until pred . o)
123  (let ((in (if (pair? o) (car o) (current-input-port))))
124    (call-with-output-string
125     (lambda (out)
126       (let lp ()
127         (let ((c (peek-char in)))
128           (cond
129            ((not (or (eof-object? c) (pred c)))
130             (write-char (read-char in) out)
131             (lp)))))))))
132
133;; Generates a KMP reader that works on ports, returning the text read
134;; up until the search string (or the entire port if the search string
135;; isn't found).  This is O(n) in the length of the string returned,
136;; as opposed to the find-string-from-port? in SSAX which uses
137;; backtracking for an O(nm) algorithm.  This is hard-coded to
138;; case-insensitively match, since that's what we need for HTML.  A
139;; more general utility would abstract the character matching
140;; predicate and possibly provide a limit on the length of the string
141;; read.
142(define (make-string-reader/ci str)
143  (let* ((len (string-length str))
144         (vec (make-vector len 0)))
145    (cond ((> len 0)
146            (vector-set! vec 0 -1)
147           (cond ((> len 1) (vector-set! vec 1 0)))))
148    (let lp ((i 2) (j 0))
149      (cond
150       ((< i len)
151        (let ((c (string-ref str i)))
152          (cond
153           ((char-ci=? (string-ref str (- i 1)) (string-ref str j))
154            (vector-set! vec i (+ j 1))
155            (lp (+ i 1) (+ j 1)))
156           ((> j 0)
157            (lp i (vector-ref vec j)))
158           (else
159            (vector-set! vec i 0)
160            (lp (+ i 1) j)))))))
161    (lambda o
162      (let ((in (if (pair? o) (car o) (current-input-port))))
163        (call-with-output-string
164          (lambda (out)
165            (let lp ((i 0))
166              (cond
167               ((< i len)
168                (let ((c (peek-char in)))
169                  (cond
170                   ((eof-object? c)
171                    (display (substring str 0 i) out))
172                   ((char-ci=? c (string-ref str i))
173                    (read-char in)
174                    (lp (+ i 1)))
175                   (else
176                    (let* ((i2 (vector-ref vec i))
177                           (i3 (if (= -1 i2) 0 i2)))
178                      (if (> i i3) (display (substring str 0 (- i i3)) out) #f)
179                      (if (= -1 i2) (write-char (read-char in) out) #f)
180                      (lp i3))))))))))))))
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-entity in)
201  (read-char in)
202  (cond
203   ((eqv? (peek-char in) #\#)
204    (read-char in)
205    (cond
206     ((char-numeric? (peek-char in))
207      (let* ((str (read-integer in))
208             (num (string->number str)))
209        (cond ((eqv? (peek-char in) #\;)
210               (read-char in)))
211        (cons 'entity num)))
212     ((memv (peek-char in) '(#\x #\X))
213      (read-char in)
214      (let* ((str (read-hex-integer in))
215             (num (string->number str 16)))
216        (cond ((eqv? (peek-char in) #\;)
217               (read-char in)))
218        (cons 'entity num)))
219     (else
220      (cons 'text "&#"))))
221   ((char-alphabetic? (peek-char in))
222    (let ((name (read-identifier in)))
223      (cond ((eqv? (peek-char in) #\;)
224             (read-char in)))
225      (cons 'entity name)))
226   (else
227    (cons 'text "&"))))
228
229(define (read-quoted in entities)
230  (let ((terminator (read-char in)))
231    (let lp ((res '()))
232      (cond
233       ((eqv? terminator (peek-char in))
234        (read-char in)  ; discard terminator
235        (reverse res))
236       ((eqv? #\& (peek-char in))
237        (let ((x (read-entity in)))
238          (lp (cons (or (and (eq? 'entity (car x))
239                             (get-entity entities (cdr x)))
240                        (string-append "&" (cdr x)))
241                    res))))
242       (else
243        (lp (cons (read-until (lambda (c) (or (eqv? #\& c) (eqv? terminator c))) in)
244                  res)))))))
245
246(define (read-pi in)
247  (let ((tag (read-identifier in)))
248    (skip-whitespace in)
249    (list
250     (if (equal? tag "") #f (string->symbol (string-downcase tag)))
251     (list->string
252      (reverse
253       (let loop ((res '()))
254         (let ((c (peek-char in)))
255           (cond
256            ((eof-object? c)
257             (read-char in)
258             res)
259            ((eqv? c #\?)
260             (read-char in)
261             (let loop2 ((res res))
262               (cond
263                ((eof-object? (peek-char in))
264                 (cons #\? res))
265                ((eqv? #\> (peek-char in))
266                 (read-char in)
267                 res)
268                ((eqv? #\? (peek-char in))
269                 (read-char in)
270                 (loop2 (cons c res)))
271                (else
272                 (loop (cons c res))))))
273            (else
274             (read-char in)
275             (loop (cons c res)))))))))))
276
277(define read-comment (make-string-reader/ci "-->"))
278
279(define (tag-char? c)
280  (and (char? c)
281       (or (char-alphanumeric? c) (memv c '(#\- #\+ #\* #\_ #\:)))))
282
283(define (read-attrs in entities)
284  (let loop ((attrs '()))
285    (skip-whitespace in)
286    (let ((c (peek-char in)))
287      (cond
288       ((or (eof-object? c) (eqv? c #\>))
289        (read-char in)
290        (list #f (reverse attrs)))
291       ((eqv? c #\/)
292        (read-char in)
293        (skip-whitespace in)
294        (cond
295         ((eqv? #\> (peek-char in))
296          (read-char in)
297          (list #t (reverse attrs)))
298         (else
299          (loop attrs))))
300       ((eqv? c #\")
301        (read-char in)
302        (loop attrs))
303       ((not (tag-char? c))
304        (list #f (reverse attrs)))
305       (else
306        (let ((name (read-while tag-char? in)))
307          (if (string=? name "")
308              (loop attrs)
309              (let ((name (string->symbol (string-downcase name))))
310                (cond
311                 ((eqv? (peek-char in) #\=)
312                  (read-char in)
313                  (let ((value (if (memv (peek-char in) '(#\" #\'))
314                                   (apply string-append
315                                          (read-quoted in entities))
316                                   (read-until
317                                    (lambda (c)
318                                      (or (char-whitespace? c)
319                                          (memv c '(#\' #\" #\< #\>))))
320                                    in))))
321                    (loop (cons (list name value) attrs))))
322                 (else
323                  (loop (cons (list name) attrs))))))))))))
324
325(define (read-start in entities)
326  (let ((tag (string->symbol (string-downcase (read-while tag-char? in)))))
327    (cons tag (read-attrs in entities))))
328
329(define (read-end in)
330  (let ((tag (read-while tag-char? in)))
331    (cond
332     ((equal? tag "")
333      (read-until (lambda (c) (eqv? c #\>)) in)
334      (read-char in)
335      #f)
336     (else
337      ;; discard closing attrs
338      (read-attrs in '())
339      (string->symbol (string-downcase tag))))))
340
341(define (read-decl in entities)
342  (let loop ((res '()))
343    (skip-whitespace in)
344    (let ((c (peek-char in)))
345      (cond
346       ((eof-object? c)
347        (reverse res))
348       ((eqv? c #\")
349        (loop (cons (read-quoted in entities) res)))
350       ((eqv? c #\>)
351        (read-char in)
352        (reverse res))
353       ((eqv? c #\<)
354        (read-char in)
355        (if (eqv? (peek-char in) #\!) (read-char in) #f)
356        (loop (cons (read-decl in entities) res)))
357       ((tag-char? c)
358        (loop (cons (string->symbol (read-while tag-char? in)) res)))
359       (else
360        (read-char in)
361        (loop res))))))
362
363;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
364;; the parser
365
366(define *default-entities*
367  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
368    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
369
370(define (get-entity entities name)
371  (cond
372   ((number? name)
373    (##sys#char->utf8-string (integer->char name)))
374   ((string->number name)
375    => (lambda (n) (##sys#char->utf8-string (integer->char n))))
376   ((assoc name entities) => cdr)
377   (else #f)))
378
379;; span's and div's can be used at any level
380(define *tag-levels*
381  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
382
383(define *unnestables*
384  '(p li td tr))
385
386(define *bodyless*
387  '(img hr br))
388
389(define *literals*
390  '(script xmp))
391
392(define *terminators*
393  '(plaintext))
394
395(define (tag-level tag-levels tag)
396  (let lp ((ls tag-levels) (i 0))
397    (if (null? ls)
398        (+ i 1000)
399        (if (if (pair? (car ls))
400                (memq tag (car ls))
401                (eq? tag (car ls)))
402            i
403            (lp (cdr ls) (+ i 1))))))
404
405(define read-cdata (make-string-reader/ci "]]>"))
406
407(define (read-html-token . o)
408  (let ((in (if (pair? o) (car o) (current-input-port)))
409        (entities (if (and (pair? o) (pair? (cdr o))) (cadr o) '())))
410    (let ((c (peek-char in)))
411      (if (eof-object? c)
412          (cons 'eof c)
413          (case c
414            ((#\<)
415             (read-char in)
416             (case (peek-char in)
417               ((#\!)
418                (read-char in)
419                (cond
420                 ((eqv? #\[ (peek-char in))
421                  (read-char in)
422                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
423                           (acc '(#\[ #\! #\<)))
424                    (cond
425                     ((null? check)
426                      (cons 'text (read-cdata in)))
427                     ((let ((c (peek-char in)))
428                        (and (not (eof-object? c)) (char-ci=? c (car check))))
429                      (lp (cdr check) (cons (read-char in) acc)))
430                     (else
431                      (cons 'text (list->string (reverse acc)))))))
432                 ((and (eqv? #\- (peek-char in))
433                       (begin (read-char in)
434                              (eqv? #\- (peek-char in))))
435                  (read-char in)
436                  (cons 'comment (read-comment in)))
437                 (else
438                  (cons 'decl (read-decl in entities)))))
439               ((#\?)
440                (read-char in)
441                (cons 'process (read-pi in)))
442               ((#\/)
443                (read-char in)
444                (cons 'end (read-end in)))
445               (else
446                ;; start tags must immediately be followed by an
447                ;; alphabetic charater, or we just treat the < as text
448                (if (and (char? (peek-char in))
449                         (char-alphabetic? (peek-char in)))
450                    (let ((res (read-start in entities)))
451                      (if (cadr res)
452                          (cons 'start/end (cons (car res) (cddr res)))
453                          (cons 'start (cons (car res) (cddr res)))))
454                    (cons 'text "<")))))
455            ((#\&)
456             (read-entity in))
457            (else
458             (cons 'text
459                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
460                               in))))))))
461
462(define (%key-ref ls key default)
463  (cond ((memq key ls) => cadr) (else default)))
464
465(define (make-html-parser . o)
466  (let* ((start (%key-ref o 'start: (lambda (t a s v) s)))
467         (end (%key-ref o 'end: (lambda (t a p s v) s)))
468         (text (%key-ref o 'text: (lambda (t s) s)))
469         (decl (%key-ref o 'decl: (lambda (t a s) s)))
470         (process (%key-ref o 'process: (lambda (t s) s)))
471         (comment (%key-ref o 'comment: (lambda (t s) s)))
472         (entities (%key-ref o 'entities: *default-entities*))
473         (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
474         (unnestables (%key-ref o 'unnestables: *unnestables*))
475         (bodyless (%key-ref o 'bodyless: *bodyless*))
476         (literals
477          (map (lambda (x)
478                 (cons x (make-string-reader/ci
479                          (string-append "</" (symbol->string x) ">"))))
480               (%key-ref o 'literals: *literals*)))
481         (terminators (%key-ref o 'terminators: *terminators*))
482         (entity (%key-ref o 'entity:
483                           (lambda (t s)
484                             (text (or (get-entity entities t)
485                                       (string-append "&" t ";"))
486                                   s)))))
487    (define (entity->string sxml seed out)
488      (if (pair? sxml)
489          (if (eq? 'entity (car sxml))
490              (entity->string (entity (cdr sxml) seed) seed out)
491              (for-each (lambda (x) (entity->string x seed out)) sxml))
492          (display sxml out)))
493    (define (fix-attrs ls seed)
494      (map
495       (lambda (x)
496         (cons (car x)
497               (if (pair? (cdr x))
498                   (list
499                    (call-with-output-string
500                      (lambda (out) (entity->string (cadr x) seed out))))
501                   (cdr x))))
502       ls))
503    (define (fix-decl ls seed)
504      (map (lambda (x)
505             (if (pair? x)
506                 (call-with-output-string
507                   (lambda (out) (entity->string x seed out)))
508                 x))
509           ls))
510    (lambda (seed . o)
511      (let* ((src (if (pair? o) (car o) (current-input-port)))
512             (in (if (string? src) (open-input-string src) src)))
513        (let lp ((tok (read-html-token in entities))
514                 (seed seed)
515                 (seeds '())
516                 (tags '()))
517          (case (car tok)
518            ((eof)                      ; close all open tags
519             (let lp ((t tags) (s seeds) (seed seed))
520               (if (null? t)
521                   seed
522                   (lp (cdr t) (cdr s)
523                       (end (caar t) (cadar t) (car s) seed 'eof)))))
524            ((start/end)
525             (let* ((tag (cadr tok))
526                    (rest (cons (fix-attrs (caddr tok) seed) (cdddr tok)))
527                    (tok (cons tag rest)))
528               (lp `(end . ,tag)
529                   (start tag (car rest) seed #f)
530                   (cons seed seeds)
531                   (cons tok tags))))
532            ((start)
533             (let* ((tag (cadr tok))
534                    (rest (cons (fix-attrs (caddr tok) seed) (cdddr tok)))
535                    (tok (cons tag rest)))
536               (cond
537                ((memq tag terminators)
538                 (lp `(text . ,(read-until (lambda (c) #f) in))
539                     (start tag (car rest) seed #f)
540                     (cons seed seeds)
541                     (cons tok tags)))
542                ((assq tag literals)
543                 => (lambda (lit)
544                      (let ((body ((cdr lit) in))
545                            (seed2 (start tag (car rest) seed #f)))
546                        (lp `(end . ,tag)
547                            (if (equal? "" body) seed2 (text body seed2))
548                            (cons seed seeds)
549                            (cons tok tags)))))
550                ((memq tag bodyless)
551                 (lp `(end . ,tag)
552                     (start tag (car rest) seed #f)
553                     (cons seed seeds)
554                     (cons tok tags)))
555                ((and (pair? tags) (eq? tag (caar tags))
556                      (memq tag unnestables))
557                 ;; <p> ... <p> implies siblings, not nesting
558                 (let ((seed2
559                        (end tag (cadar tags) (car seeds) seed 'sibling)))
560                   (lp (read-html-token in entities)
561                       (start tag (car rest) seed #f)
562                       (cons seed2 (cdr seeds))
563                       (cons tok (cdr tags)))))
564                (else
565                 (lp (read-html-token in entities)
566                     (start tag (car rest) seed #f)
567                     (cons seed seeds)
568                     (cons tok tags))))))
569            ((end)
570             (cond
571              ((not (cdr tok)) ;; nameless closing tag
572               (lp (read-html-token in entities) seed seeds tags))
573              ((and (pair? tags) (eq? (cdr tok) (caar tags)))
574               (lp (read-html-token in entities)
575                   (end (cdr tok) (fix-attrs (cadar tags) seed)
576                        (car seeds) seed #f)
577                   (cdr seeds)
578                   (cdr tags)))
579              (else
580               (let ((this-level (tag-level tag-levels (cdr tok)))
581                     (expected-level
582                      (if (pair? tags)
583                          (tag-level tag-levels (caar tags))
584                          -1)))
585                 (cond
586                  ((< this-level expected-level)
587                   ;; higher-level tag, forcefully close preceding tags
588                   (lp tok
589                       (end (caar tags) (fix-attrs (cadar tags) seed)
590                            (car seeds) seed 'parent-closed)
591                       (cdr seeds)
592                       (cdr tags)))
593                  ((and (= this-level expected-level) (pair? (cdr tags)))
594                   ;; equal, interleave (close prec tag, close this,
595                   ;; re-open prec)
596                   ;; <b><i></b> => <b><i></i></b><i>
597                   ;;                     ^^^^    ^^^
598                   ;; XXXX handle backups > 1 here
599                   (let* ((seed2 (end (caar tags) (cadar tags)
600                                      (car seeds) seed 'interleave))
601                          (seed3 (end (caadr tags) (cadadr tags)
602                                      (cadr seeds) seed2 #f)))
603                     (let ((tok2 (read-html-token in entities)))
604                       (cond
605                        ((and (eq? 'end (car tok2))
606                              (eq? (caar tags) (cdr tok2)))
607                         ;; simple case where the closing tag
608                         ;; immediately follows
609                         (lp (read-html-token in entities) seed3
610                             (cddr seeds) (cddr tags)))
611                        (else
612                         (lp tok2
613                             (start (caar tags) (cadar tags) seed3
614                                    'interleave)
615                             (cons seed3 (cddr seeds))
616                             (cons (car tags) (cddr tags))))))))
617                  (else
618                   ;; spurious end for a lower-level tag, add
619                   ;; imaginary start
620                   (let* ((seed2 (start (cdr tok) '() seed 'no-start))
621                          (seed3 (end (cdr tok) '() seed seed2 #f)))
622                     (lp (read-html-token in entities) seed3 seeds tags))))))))
623            ((text)
624             (lp (read-html-token in entities) (text (cdr tok) seed) seeds tags))
625            ((entity)
626             (lp (read-html-token in entities) (entity (cdr tok) seed) seeds tags))
627            ((comment)
628             (lp (read-html-token in entities) (comment (cdr tok) seed) seeds tags))
629            ((decl)
630             (lp (read-html-token in entities)
631                 (decl (cadr tok) (fix-decl (cddr tok) seed) seed) seeds tags))
632            ((process)
633             (lp (read-html-token in entities) (process (cdr tok) seed) seeds tags))
634            (else
635             (error "invalid token: " tok))))))))
636
637;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
638;; simple conversions
639
640(define html->sxml
641  (let ((parse
642         (make-html-parser
643          'start: (lambda (tag attrs seed virtual?) '())
644          'end:   (lambda (tag attrs parent-seed seed virtual?)
645                    `((,tag ,@(if (pair? attrs)
646                                  `((@ ,@attrs) ,@(reverse seed))
647                                  (reverse seed)))
648                      ,@parent-seed))
649          'decl:    (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
650          'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
651          'comment: (lambda (text seed) `((*COMMENT* ,text) ,@seed))
652          'text:    (lambda (text seed) (cons text seed))
653          )))
654    (lambda o
655      (cons '*TOP* (reverse (apply parse '() o))))))
656
657(define (html-escape-attr str)
658  (call-with-output-string
659    (lambda (out) (html-display-escaped-string str out))))
660
661(define (html-attr->string attr)
662  (string-append
663   (symbol->string (car attr)) "=\""
664   (html-escape-attr (if (pair? (cdr attr)) (cadr attr) (cdr attr)))
665   "\""))
666
667(define (html-tag->string tag attrs)
668  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
669    (if (null? ls)
670        (apply string-append (reverse (cons ">" res)))
671        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
672
673(define html-character-escapes
674  '((#\< . "&lt;")
675    (#\> . "&gt;")
676    (#\& . "&amp;")
677    (#\" . "&quot;")
678    (#\' . "&#39;")))
679
680(define (html-display-escaped-string str out)
681  (let ((start 0)
682        (end (string-length str)))
683    (let lp ((from start) (to start))
684      (if (>= to end)
685          (display (substring str from to) out)
686          (cond
687           ((assq (string-ref str to) html-character-escapes)
688            => (lambda (esc)
689                 (display (substring str from to) out)
690                 (display (cdr esc) out)
691                 (lp (+ to 1) (+ to 1))))
692           (else
693            (lp from (+ to 1))))))))
694
695(define (html-escape str)
696  (call-with-output-string
697    (lambda (out) (html-display-escaped-string str out))))
698
699(define (sxml-display-as-html sxml . o)
700  (let ((out (if (pair? o) (car o) (current-output-port))))
701    (cond
702     ((pair? sxml)
703      (let ((tag (car sxml)))
704        (if (symbol? tag)
705            (case tag
706              ((*PI* *DECL*)
707               (display (if (eq? tag '*PI*) "<?" "<!") out)
708               (cond
709                ((pair? (cdr sxml))
710                 (display (cadr sxml) out)
711                 (for-each
712                  (lambda (x) (display " " out) (display x out))
713                  (cddr sxml))))
714               (display (if (eq? tag '*PI*) "?>" ">") out))
715              ((*COMMENT*)
716               (display "<!--" out)
717               (for-each (lambda (x) (display x out)) (cdr sxml))
718               (display "-->" out))
719              ((*TOP*)
720               (for-each (lambda (x) (sxml-display-as-html x out)) (cdr sxml)))
721              (else
722               (let ((rest (cdr sxml)))
723                 (cond
724                  ((and (pair? rest)
725                        (pair? (car rest))
726                        (eq? '@ (caar rest)))
727                   (display (html-tag->string tag (cdar rest)) out)
728                   (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
729                   (display "</" out) (display tag out) (display ">" out))
730                  (else
731                   (display (html-tag->string tag '()) out)
732                   (for-each (lambda (x) (sxml-display-as-html x out)) rest)
733                   (display "</" out) (display tag out) (display ">" out))))))
734            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
735     ((null? sxml))
736     (else
737      (html-display-escaped-string
738       (if (string? sxml)
739           sxml
740           (call-with-output-string (lambda (out) (display sxml out))))
741       out)))))
742
743(define (sxml->html sxml . o)
744  (call-with-output-string
745    (lambda (out) (sxml-display-as-html sxml out))))
746
747;; just strips tags, no whitespace handling or formatting
748(define (html-strip . o)
749  (call-with-output-string
750   (lambda (out)
751     (let ((parse
752            (make-html-parser
753             'start: (lambda (tag attrs seed virtual?) seed)
754             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
755             'text:  (lambda (text seed) (display text out)))))
756       (apply parse (cons #f #f) o)))))
757
758)
Note: See TracBrowser for help on using the repository browser.