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

Last change on this file since 33366 was 33366, checked in by Alex Shinn, 5 years ago

fixing bug in unterminated attributes (reported by alaric)

File size: 27.6 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       ((eof-object? (peek-char in))
234        (reverse res))
235       ((eqv? terminator (peek-char in))
236        (read-char in)  ; discard terminator
237        (reverse res))
238       ((eqv? #\& (peek-char in))
239        (let ((x (read-entity in)))
240          (lp (cons (or (and (eq? 'entity (car x))
241                             (get-entity entities (cdr x)))
242                        (string-append "&" (cdr x)))
243                    res))))
244       (else
245        (lp (cons (read-until (lambda (c) (or (eqv? #\& c) (eqv? terminator c))) in)
246                  res)))))))
247
248(define (read-pi in)
249  (let ((tag (read-identifier in)))
250    (skip-whitespace in)
251    (list
252     (if (equal? tag "") #f (string->symbol (string-downcase tag)))
253     (list->string
254      (reverse
255       (let loop ((res '()))
256         (let ((c (peek-char in)))
257           (cond
258            ((eof-object? c)
259             (read-char in)
260             res)
261            ((eqv? c #\?)
262             (read-char in)
263             (let loop2 ((res res))
264               (cond
265                ((eof-object? (peek-char in))
266                 (cons #\? res))
267                ((eqv? #\> (peek-char in))
268                 (read-char in)
269                 res)
270                ((eqv? #\? (peek-char in))
271                 (read-char in)
272                 (loop2 (cons c res)))
273                (else
274                 (loop (cons c res))))))
275            (else
276             (read-char in)
277             (loop (cons c res)))))))))))
278
279(define read-comment (make-string-reader/ci "-->"))
280
281(define (tag-char? c)
282  (and (char? c)
283       (or (char-alphanumeric? c) (memv c '(#\- #\+ #\* #\_ #\:)))))
284
285(define (read-attrs in entities)
286  (let loop ((attrs '()))
287    (skip-whitespace in)
288    (let ((c (peek-char in)))
289      (cond
290       ((or (eof-object? c) (eqv? c #\>))
291        (read-char in)
292        (list #f (reverse attrs)))
293       ((eqv? c #\/)
294        (read-char in)
295        (skip-whitespace in)
296        (cond
297         ((eqv? #\> (peek-char in))
298          (read-char in)
299          (list #t (reverse attrs)))
300         (else
301          (loop attrs))))
302       ((eqv? c #\")
303        (read-char in)
304        (loop attrs))
305       ((not (tag-char? c))
306        (list #f (reverse attrs)))
307       (else
308        (let ((name (read-while tag-char? in)))
309          (if (string=? name "")
310              (loop attrs)
311              (let ((name (string->symbol (string-downcase name))))
312                (cond
313                 ((eqv? (peek-char in) #\=)
314                  (read-char in)
315                  (let ((value (if (memv (peek-char in) '(#\" #\'))
316                                   (apply string-append
317                                          (read-quoted in entities))
318                                   (read-until
319                                    (lambda (c)
320                                      (or (char-whitespace? c)
321                                          (memv c '(#\' #\" #\< #\>))))
322                                    in))))
323                    (loop (cons (list name value) attrs))))
324                 (else
325                  (loop (cons (list name) attrs))))))))))))
326
327(define (read-start in entities)
328  (let ((tag (string->symbol (string-downcase (read-while tag-char? in)))))
329    (cons tag (read-attrs in entities))))
330
331(define (read-end in)
332  (let ((tag (read-while tag-char? in)))
333    (cond
334     ((equal? tag "")
335      (read-until (lambda (c) (eqv? c #\>)) in)
336      (read-char in)
337      #f)
338     (else
339      ;; discard closing attrs
340      (read-attrs in '())
341      (string->symbol (string-downcase tag))))))
342
343(define (read-decl in entities)
344  (let loop ((res '()))
345    (skip-whitespace in)
346    (let ((c (peek-char in)))
347      (cond
348       ((eof-object? c)
349        (reverse res))
350       ((eqv? c #\")
351        (loop (cons (read-quoted in entities) res)))
352       ((eqv? c #\>)
353        (read-char in)
354        (reverse res))
355       ((eqv? c #\<)
356        (read-char in)
357        (if (eqv? (peek-char in) #\!) (read-char in) #f)
358        (loop (cons (read-decl in entities) res)))
359       ((tag-char? c)
360        (loop (cons (string->symbol (read-while tag-char? in)) res)))
361       (else
362        (read-char in)
363        (loop res))))))
364
365;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
366;; the parser
367
368(define *default-entities*
369  '(("amp" . "&") ("quot" . "\"") ("lt" . "<")
370    ("gt" . ">")  ("apos" . "'")  ("nbsp" . " ")))
371
372(define (get-entity entities name)
373  (cond
374   ((number? name)
375    (##sys#char->utf8-string (integer->char name)))
376   ((string->number name)
377    => (lambda (n) (##sys#char->utf8-string (integer->char n))))
378   ((assoc name entities) => cdr)
379   (else #f)))
380
381;; span's and div's can be used at any level
382(define *tag-levels*
383  '(html (head body) table (thead tbody) tr (th td) p (b i u s)))
384
385(define *unnestables*
386  '(p li td tr))
387
388(define *bodyless*
389  '(img hr br))
390
391(define *literals*
392  '(script xmp))
393
394(define *terminators*
395  '(plaintext))
396
397(define (tag-level tag-levels tag)
398  (let lp ((ls tag-levels) (i 0))
399    (if (null? ls)
400        (+ i 1000)
401        (if (if (pair? (car ls))
402                (memq tag (car ls))
403                (eq? tag (car ls)))
404            i
405            (lp (cdr ls) (+ i 1))))))
406
407(define read-cdata (make-string-reader/ci "]]>"))
408
409(define (read-html-token . o)
410  (let ((in (if (pair? o) (car o) (current-input-port)))
411        (entities (if (and (pair? o) (pair? (cdr o))) (cadr o) '())))
412    (let ((c (peek-char in)))
413      (if (eof-object? c)
414          (cons 'eof c)
415          (case c
416            ((#\<)
417             (read-char in)
418             (case (peek-char in)
419               ((#\!)
420                (read-char in)
421                (cond
422                 ((eqv? #\[ (peek-char in))
423                  (read-char in)
424                  (let lp ((check '(#\C #\D #\A #\T #\A #\[))
425                           (acc '(#\[ #\! #\<)))
426                    (cond
427                     ((null? check)
428                      (cons 'text (read-cdata in)))
429                     ((let ((c (peek-char in)))
430                        (and (not (eof-object? c)) (char-ci=? c (car check))))
431                      (lp (cdr check) (cons (read-char in) acc)))
432                     (else
433                      (cons 'text (list->string (reverse acc)))))))
434                 ((and (eqv? #\- (peek-char in))
435                       (begin (read-char in)
436                              (eqv? #\- (peek-char in))))
437                  (read-char in)
438                  (cons 'comment (read-comment in)))
439                 (else
440                  (cons 'decl (read-decl in entities)))))
441               ((#\?)
442                (read-char in)
443                (cons 'process (read-pi in)))
444               ((#\/)
445                (read-char in)
446                (cons 'end (read-end in)))
447               (else
448                ;; start tags must immediately be followed by an
449                ;; alphabetic charater, or we just treat the < as text
450                (if (and (char? (peek-char in))
451                         (char-alphabetic? (peek-char in)))
452                    (let ((res (read-start in entities)))
453                      (if (cadr res)
454                          (cons 'start/end (cons (car res) (cddr res)))
455                          (cons 'start (cons (car res) (cddr res)))))
456                    (cons 'text "<")))))
457            ((#\&)
458             (read-entity in))
459            (else
460             (cons 'text
461                   (read-until (lambda (c) (or (eqv? c #\<) (eqv? c #\&)))
462                               in))))))))
463
464(define (%key-ref ls key default)
465  (cond ((memq key ls) => cadr) (else default)))
466
467(define (make-html-parser . o)
468  (let* ((start (%key-ref o 'start: (lambda (t a s v) s)))
469         (end (%key-ref o 'end: (lambda (t a p s v) s)))
470         (text (%key-ref o 'text: (lambda (t s) s)))
471         (decl (%key-ref o 'decl: (lambda (t a s) s)))
472         (process (%key-ref o 'process: (lambda (t s) s)))
473         (comment (%key-ref o 'comment: (lambda (t s) s)))
474         (entities (%key-ref o 'entities: *default-entities*))
475         (tag-levels (%key-ref o 'tag-levels: *tag-levels*))
476         (unnestables (%key-ref o 'unnestables: *unnestables*))
477         (bodyless (%key-ref o 'bodyless: *bodyless*))
478         (literals
479          (map (lambda (x)
480                 (cons x (make-string-reader/ci
481                          (string-append "</" (symbol->string x) ">"))))
482               (%key-ref o 'literals: *literals*)))
483         (terminators (%key-ref o 'terminators: *terminators*))
484         (entity (%key-ref o 'entity:
485                           (lambda (t s)
486                             (text (or (get-entity entities t)
487                                       (string-append "&" t ";"))
488                                   s)))))
489    (define (entity->string sxml seed out)
490      (if (pair? sxml)
491          (if (eq? 'entity (car sxml))
492              (entity->string (entity (cdr sxml) seed) seed out)
493              (for-each (lambda (x) (entity->string x seed out)) sxml))
494          (display sxml out)))
495    (define (fix-attrs ls seed)
496      (map
497       (lambda (x)
498         (cons (car x)
499               (if (pair? (cdr x))
500                   (list
501                    (call-with-output-string
502                      (lambda (out) (entity->string (cadr x) seed out))))
503                   (cdr x))))
504       ls))
505    (define (fix-decl ls seed)
506      (map (lambda (x)
507             (if (pair? x)
508                 (call-with-output-string
509                   (lambda (out) (entity->string x seed out)))
510                 x))
511           ls))
512    (lambda (seed . o)
513      (let* ((src (if (pair? o) (car o) (current-input-port)))
514             (in (if (string? src) (open-input-string src) src)))
515        (let lp ((tok (read-html-token in entities))
516                 (seed seed)
517                 (seeds '())
518                 (tags '()))
519          (case (car tok)
520            ((eof)                      ; close all open tags
521             (let lp ((t tags) (s seeds) (seed seed))
522               (if (null? t)
523                   seed
524                   (lp (cdr t) (cdr s)
525                       (end (caar t) (cadar t) (car s) seed 'eof)))))
526            ((start/end)
527             (let* ((tag (cadr tok))
528                    (rest (cons (fix-attrs (caddr tok) seed) (cdddr tok)))
529                    (tok (cons tag rest)))
530               (lp `(end . ,tag)
531                   (start tag (car rest) seed #f)
532                   (cons seed seeds)
533                   (cons tok tags))))
534            ((start)
535             (let* ((tag (cadr tok))
536                    (rest (cons (fix-attrs (caddr tok) seed) (cdddr tok)))
537                    (tok (cons tag rest)))
538               (cond
539                ((memq tag terminators)
540                 (lp `(text . ,(read-until (lambda (c) #f) in))
541                     (start tag (car rest) seed #f)
542                     (cons seed seeds)
543                     (cons tok tags)))
544                ((assq tag literals)
545                 => (lambda (lit)
546                      (let ((body ((cdr lit) in))
547                            (seed2 (start tag (car rest) seed #f)))
548                        (lp `(end . ,tag)
549                            (if (equal? "" body) seed2 (text body seed2))
550                            (cons seed seeds)
551                            (cons tok tags)))))
552                ((memq tag bodyless)
553                 (lp `(end . ,tag)
554                     (start tag (car rest) seed #f)
555                     (cons seed seeds)
556                     (cons tok tags)))
557                ((and (pair? tags) (eq? tag (caar tags))
558                      (memq tag unnestables))
559                 ;; <p> ... <p> implies siblings, not nesting
560                 (let ((seed2
561                        (end tag (cadar tags) (car seeds) seed 'sibling)))
562                   (lp (read-html-token in entities)
563                       (start tag (car rest) seed #f)
564                       (cons seed2 (cdr seeds))
565                       (cons tok (cdr tags)))))
566                (else
567                 (lp (read-html-token in entities)
568                     (start tag (car rest) seed #f)
569                     (cons seed seeds)
570                     (cons tok tags))))))
571            ((end)
572             (cond
573              ((not (cdr tok)) ;; nameless closing tag
574               (lp (read-html-token in entities) seed seeds tags))
575              ((and (pair? tags) (eq? (cdr tok) (caar tags)))
576               (lp (read-html-token in entities)
577                   (end (cdr tok) (fix-attrs (cadar tags) seed)
578                        (car seeds) seed #f)
579                   (cdr seeds)
580                   (cdr tags)))
581              (else
582               (let ((this-level (tag-level tag-levels (cdr tok)))
583                     (expected-level
584                      (if (pair? tags)
585                          (tag-level tag-levels (caar tags))
586                          -1)))
587                 (cond
588                  ((< this-level expected-level)
589                   ;; higher-level tag, forcefully close preceding tags
590                   (lp tok
591                       (end (caar tags) (fix-attrs (cadar tags) seed)
592                            (car seeds) seed 'parent-closed)
593                       (cdr seeds)
594                       (cdr tags)))
595                  ((and (= this-level expected-level) (pair? (cdr tags)))
596                   ;; equal, interleave (close prec tag, close this,
597                   ;; re-open prec)
598                   ;; <b><i></b> => <b><i></i></b><i>
599                   ;;                     ^^^^    ^^^
600                   ;; XXXX handle backups > 1 here
601                   (let* ((seed2 (end (caar tags) (cadar tags)
602                                      (car seeds) seed 'interleave))
603                          (seed3 (end (caadr tags) (cadadr tags)
604                                      (cadr seeds) seed2 #f)))
605                     (let ((tok2 (read-html-token in entities)))
606                       (cond
607                        ((and (eq? 'end (car tok2))
608                              (eq? (caar tags) (cdr tok2)))
609                         ;; simple case where the closing tag
610                         ;; immediately follows
611                         (lp (read-html-token in entities) seed3
612                             (cddr seeds) (cddr tags)))
613                        (else
614                         (lp tok2
615                             (start (caar tags) (cadar tags) seed3
616                                    'interleave)
617                             (cons seed3 (cddr seeds))
618                             (cons (car tags) (cddr tags))))))))
619                  (else
620                   ;; spurious end for a lower-level tag, add
621                   ;; imaginary start
622                   (let* ((seed2 (start (cdr tok) '() seed 'no-start))
623                          (seed3 (end (cdr tok) '() seed seed2 #f)))
624                     (lp (read-html-token in entities) seed3 seeds tags))))))))
625            ((text)
626             (lp (read-html-token in entities) (text (cdr tok) seed) seeds tags))
627            ((entity)
628             (lp (read-html-token in entities) (entity (cdr tok) seed) seeds tags))
629            ((comment)
630             (lp (read-html-token in entities) (comment (cdr tok) seed) seeds tags))
631            ((decl)
632             (lp (read-html-token in entities)
633                 (decl (cadr tok) (fix-decl (cddr tok) seed) seed) seeds tags))
634            ((process)
635             (lp (read-html-token in entities) (process (cdr tok) seed) seeds tags))
636            (else
637             (error "invalid token: " tok))))))))
638
639;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
640;; simple conversions
641
642(define html->sxml
643  (let ((parse
644         (make-html-parser
645          'start: (lambda (tag attrs seed virtual?) '())
646          'end:   (lambda (tag attrs parent-seed seed virtual?)
647                    `((,tag ,@(if (pair? attrs)
648                                  `((@ ,@attrs) ,@(reverse seed))
649                                  (reverse seed)))
650                      ,@parent-seed))
651          'decl:    (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
652          'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
653          'comment: (lambda (text seed) `((*COMMENT* ,text) ,@seed))
654          'text:    (lambda (text seed) (cons text seed))
655          )))
656    (lambda o
657      (cons '*TOP* (reverse (apply parse '() o))))))
658
659(define (html-escape-attr str)
660  (call-with-output-string
661    (lambda (out) (html-display-escaped-string str out))))
662
663(define (html-attr->string attr)
664  (string-append
665   (symbol->string (car attr)) "=\""
666   (html-escape-attr (if (pair? (cdr attr)) (cadr attr) (cdr attr)))
667   "\""))
668
669(define (html-tag->string tag attrs)
670  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
671    (if (null? ls)
672        (apply string-append (reverse (cons ">" res)))
673        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
674
675(define html-character-escapes
676  '((#\< . "&lt;")
677    (#\> . "&gt;")
678    (#\& . "&amp;")
679    (#\" . "&quot;")
680    (#\' . "&#39;")))
681
682(define (html-display-escaped-string str out)
683  (let ((start 0)
684        (end (string-length str)))
685    (let lp ((from start) (to start))
686      (if (>= to end)
687          (display (substring str from to) out)
688          (cond
689           ((assq (string-ref str to) html-character-escapes)
690            => (lambda (esc)
691                 (display (substring str from to) out)
692                 (display (cdr esc) out)
693                 (lp (+ to 1) (+ to 1))))
694           (else
695            (lp from (+ to 1))))))))
696
697(define (html-escape str)
698  (call-with-output-string
699    (lambda (out) (html-display-escaped-string str out))))
700
701(define (sxml-display-as-html sxml . o)
702  (let ((out (if (pair? o) (car o) (current-output-port))))
703    (cond
704     ((pair? sxml)
705      (let ((tag (car sxml)))
706        (if (symbol? tag)
707            (case tag
708              ((*PI* *DECL*)
709               (display (if (eq? tag '*PI*) "<?" "<!") out)
710               (cond
711                ((pair? (cdr sxml))
712                 (display (cadr sxml) out)
713                 (for-each
714                  (lambda (x) (display " " out) (display x out))
715                  (cddr sxml))))
716               (display (if (eq? tag '*PI*) "?>" ">") out))
717              ((*COMMENT*)
718               (display "<!--" out)
719               (for-each (lambda (x) (display x out)) (cdr sxml))
720               (display "-->" out))
721              ((*TOP*)
722               (for-each (lambda (x) (sxml-display-as-html x out)) (cdr sxml)))
723              (else
724               (let ((rest (cdr sxml)))
725                 (cond
726                  ((and (pair? rest)
727                        (pair? (car rest))
728                        (eq? '@ (caar rest)))
729                   (display (html-tag->string tag (cdar rest)) out)
730                   (for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
731                   (display "</" out) (display tag out) (display ">" out))
732                  (else
733                   (display (html-tag->string tag '()) out)
734                   (for-each (lambda (x) (sxml-display-as-html x out)) rest)
735                   (display "</" out) (display tag out) (display ">" out))))))
736            (for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
737     ((null? sxml))
738     (else
739      (html-display-escaped-string
740       (if (string? sxml)
741           sxml
742           (call-with-output-string (lambda (out) (display sxml out))))
743       out)))))
744
745(define (sxml->html sxml . o)
746  (call-with-output-string
747    (lambda (out) (sxml-display-as-html sxml out))))
748
749;; just strips tags, no whitespace handling or formatting
750(define (html-strip . o)
751  (call-with-output-string
752   (lambda (out)
753     (let ((parse
754            (make-html-parser
755             'start: (lambda (tag attrs seed virtual?) seed)
756             'end:   (lambda (tag attrs parent-seed seed virtual?) seed)
757             'text:  (lambda (text seed) (display text out)))))
758       (apply parse (cons #f #f) o)))))
759
760)
Note: See TracBrowser for help on using the repository browser.