diff --git a/scsh/SPAN/htmldump.scm b/scsh/SPAN/htmldump.scm new file mode 100644 index 0000000..1afebbe --- /dev/null +++ b/scsh/SPAN/htmldump.scm @@ -0,0 +1,53 @@ +;;; load.scm - a scheme SPAN +;;; +;;; Copyright (c) 2012 Johan Ceuppens +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(define (html-dump htmlfile) + (let ((in (open-input-file htmlfile)) + (contents "")) + + (define (f c tagged) + (if (= tagged 0) (string c) "")) + + (define (read-html-file contents) + (let ((tagged 0)) + (do ((c (read-char in) (read-char in))) + ((eof-object? c)contents) + (cond ((and (= tagged 0)(eq? c #\<)) + (set! tagged (+ tagged 1))) + ((and (> tagged 0)(eq? c #\<)) + (set! tagged (+ tagged 1))) + ((and (= tagged 0)(eq? c #\>)) + (set! tagged (- tagged 1))) + ((and (> tagged 0)(eq? c #\>)) + (set! tagged (- tagged 1))) + ((< tagged 0) + (display "html-dump : bad html.")(newline) + (set! tagged 0)) + ) + (set! contents (string-append contents (f c tagged)))))) + (read-html-file contents)))