Changeset 14750 in project


Ignore:
Timestamp:
05/22/09 18:39:17 (11 years ago)
Author:
Alex Shinn
Message:

minor bugfixes, cleanup, generalised utility to search
for a fixed string in a port using KMP

Location:
release/4/html-parser/trunk
Files:
1 added
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/html-parser/trunk/html-parser.scm

    r14350 r14750  
    11;;;; html-parser.scm -- SSAX-like tree-folding html parser
    22;;
    3 ;; Copyright (c) 2003-2008 Alex Shinn.  All rights reserved.
     3;; Copyright (c) 2003-2009 Alex Shinn.  All rights reserved.
    44;; BSD-style license: http://synthcode.com/license.txt
    55
     
    7676
    7777(module html-parser
    78   (make-html-parser html->sxml html-strip
    79    sxml->html sxml-display-as-html) ; ??
     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)
    8081(import scheme
    8182        (only srfi-13 string-downcase)
    82         (only ports call-with-output-string)
     83        (only ports call-with-output-string with-output-to-string)
    8384        (only chicken error open-input-string))
    8485
     
    107108    (call-with-output-string
    108109     (lambda (out)
    109        (let loop ()
     110       (let lp ()
    110111         (let ((c (peek-char in)))
    111112           (cond
    112113            ((and (not (eof-object? c)) (pred c))
    113114             (write-char (read-char in) out)
    114              (loop)))))))))
     115             (lp)))))))))
    115116
    116117(define (read-until pred . o)
     
    118119    (call-with-output-string
    119120     (lambda (out)
    120        (let loop ()
     121       (let lp ()
    121122         (let ((c (peek-char in)))
    122123           (cond
    123124            ((not (or (eof-object? c) (pred c)))
    124125             (write-char (read-char in) out)
    125              (loop)))))))))
    126 
    127 ;; XXXX doesn't account for when the middle of the string can be a
    128 ;; prefix of the string (not needed in the uses below)
    129 (define (read-until-string/ci str . o)
    130   (let ((in (if (pair? o) (car o) (current-input-port)))
    131         (len (string-length str)))
    132     (call-with-output-string
    133      (lambda (out)
    134        (let loop ((i 0))
    135          (let ((c (read-char in)))
    136            (cond
    137             ((eof-object? c)
    138              (display (substring str 0 i) out))
    139             ((char-ci=? c (string-ref str i))
    140              (if (< i (- len 1))
    141                  (loop (+ i 1))))
    142             (else
    143              (display (substring str 0 i) out)
    144              (write-char c out)
    145              (loop 0)))))))))
    146 
    147 ;; simple utility to look for patterns of the form "aab", reads the
    148 ;; whole port if the pattern doesn't occur
    149 (define (read-until-aab a b . o)
    150   (let ((in (if (pair? o) (car o) (current-input-port))))
    151     (call-with-output-string
    152      (lambda (out)
    153        (let scan ()
    154          (let ((ch (read-char in)))
    155            (cond
    156             ((eof-object? ch))
    157             ((not (eqv? ch a))
    158              (write-char ch out)
    159              (scan))
    160             (else ;; scanned one a
    161              (let ((ch (read-char in)))
    162                (cond
    163                 ((not (eqv? ch a))
    164                  (write-char a out)
    165                  (cond ((not (eof-object? ch))
    166                         (write-char ch out)
    167                         (scan))))
    168                 (else ;; scanned two a's
    169                  (let two-a-s ()
    170                    (let ((ch (read-char in)))
    171                      (cond ((not (eqv? ch b))
    172                             (write-char a out)
    173                             (cond ((eqv? ch a)
    174                                    (two-a-s))
    175                                   ((eof-object? ch)
    176                                    (write-char a out))
    177                                   (else
    178                                    (write-char a out)
    179                                    (write-char ch out)
    180                                    (scan))))))))))))))))))
     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))))))))))))))
    181176
    182177(define skip-whitespace (lambda x (apply read-while char-whitespace? x)))
     
    203198    (read-char in)
    204199    res))
    205 
    206 (define (read-name-or-quoted in)
    207   (cond ((or (eqv? #\" (peek-char in)) (eqv? #\' (peek-char in)))
    208          (read-quoted in))
    209         (else
    210          (read-while tag-char? in))))
    211200
    212201(define (read-pi in)
     
    241230             (loop (cons c res)))))))))))
    242231
    243 (define (read-comment . o)
    244   (read-until-aab #\- #\> (if (pair? o) (car o) (current-input-port))))
     232(define read-comment (make-string-reader/ci "-->"))
    245233
    246234(define (tag-char? c)
     
    287275                    (if (or (eqv? #\" (peek-char in))
    288276                            (eqv? #\' (peek-char in)))
    289                         (read-char in))
     277                        (read-char in)
     278                        #f)
    290279                    (loop (cons (list name value) attrs))))
    291280                 (else
     
    314303       ((eof-object? c)
    315304        (reverse res))
     305       ((eqv? c #\")
     306        (loop (cons (read-quoted in) res)))
    316307       ((eqv? c #\>)
    317308        (read-char in)
    318309        (reverse res))
    319        ((eqv? c #\")
    320         (loop (cons (read-quoted in) 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)))
    321314       ((tag-char? c)
    322315        (loop (cons (string->symbol (read-while tag-char? in)) res)))
     
    363356            i
    364357            (lp (cdr ls) (+ i 1))))))
     358
     359(define read-cdata (make-string-reader/ci "]]>"))
    365360
    366361(define (read-html-token . o)
     
    382377                    (cond
    383378                     ((null? check)
    384                       (cons 'text (read-until-aab #\] #\> in)))
     379                      (cons 'text (read-cdata in)))
    385380                     ((let ((c (peek-char in)))
    386381                        (and (not (eof-object? c)) (char-ci=? c (car check))))
     
    420415                 (let* ((str (read-integer in))
    421416                        (num (string->number str)))
    422                    (if (eqv? (peek-char in) #\;)
    423                        (read-char in))
     417                   (cond ((eqv? (peek-char in) #\;)
     418                          (read-char in)))
    424419                   (cons 'entity num)))
    425420                ((memv (peek-char in) '(#\x #\X))
     
    427422                 (let* ((str (read-hex-integer in))
    428423                        (num (string->number str 16)))
    429                    (if (eqv? (peek-char in) #\;)
    430                        (read-char in))
     424                   (cond ((eqv? (peek-char in) #\;)
     425                          (read-char in)))
    431426                   (cons 'entity num)))
    432427                (else
     
    434429              ((char-alphabetic? (peek-char in))
    435430               (let ((name (read-identifier in)))
    436                  (if (eqv? (peek-char in) #\;)
    437                      (read-char in))
     431                 (cond ((eqv? (peek-char in) #\;)
     432                        (read-char in)))
    438433                 (cons 'entity name)))
    439434              (else
     
    458453        (unnestables (%key-ref o 'unnestables: *unnestables*))
    459454        (bodyless (%key-ref o 'bodyless: *bodyless*))
    460         (literals (%key-ref o 'literals: *literals*))
     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*)))
    461460        (terminators (%key-ref o 'terminators: *terminators*))
    462461        (entity (%key-ref o 'entity: #f)))
     
    495494                       (cons seed seeds)
    496495                       (cons (cdr tok) tags)))
    497                   ((memq tag literals)
    498                    (let ((body (read-until-string/ci
    499                                 (string-append "</" (symbol->string tag) ">")
    500                                 in))
    501                          (seed2 (start tag (caddr tok) seed #f)))
    502                      (lp `(end . ,tag)
    503                          (if (equal? "" body) seed2 (text body seed2))
    504                          (cons seed seeds)
    505                          (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)))))
    506504                  ((memq tag bodyless)
    507505                   (lp `(end . ,tag)
     
    610608      (reverse (apply parse '() o)))))
    611609
    612 ;; XXXX
     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
    613633(define (html-escape-attr str)
    614   str)
     634  (with-output-to-string
     635    (lambda () (html-display-escaped-attr str))))
    615636
    616637(define (html-attr->string attr)
    617   (string-append (symbol->string (car attr))
    618                  "=\"" (html-escape-attr (cdr attr)) "\""))
     638  (string-append
     639   (symbol->string (car attr)) "=\""
     640   (html-escape-attr (if (pair? (cdr attr)) (cadr attr) (cdr attr)))
     641   "\""))
    619642
    620643(define (html-tag->string tag attrs)
  • release/4/html-parser/trunk/html-parser.setup

    r14350 r14750  
    55  'html-parser
    66  '("html-parser.so" "html-parser.import.so")
    7   '((version 0.2)
     7  '((version 0.3)
    88    (documentation "html-parser.html")))
Note: See TracChangeset for help on using the changeset viewer.