Import Upstream version 3a1upstream/3a1

1 files changed, 240 insertions, 0 deletions

diff --git a/html4each.scm b/html4each.scm
new file mode 100644
index 0000000..02e666e
--- /dev/null
+++ b/html4each.scm
@@ -0,0 +1,240 @@
+;;;; HTML scan calls procedures for word, tag, whitespac, and newline.
+;;; Copyright 2002 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'line-i/o)
+(require 'string-port)
+(require 'scanf)
+(require-if 'compiling 'string-case)
+
+;;@code{(require 'html-for-each)}
+;;@ftindex html-for-each
+
+;;@body
+;;@1 is an input port or a string naming an existing file containing
+;;HTML text.
+;;@2 is a procedure of one argument or #f.
+;;@3 is a procedure of one argument or #f.
+;;@4 is a procedure of one argument or #f.
+;;@5 is a procedure of no arguments or #f.
+;;
+;;@0 opens and reads characters from port @1 or the file named by
+;;string @1.  Sequential groups of characters are assembled into
+;;strings which are either
+;;
+;;@itemize @bullet
+;;@item
+;;enclosed by @samp{<} and @samp{>} (hypertext markups or comments);
+;;@item
+;;end-of-line;
+;;@item
+;;whitespace; or
+;;@item
+;;none of the above (words).
+;;@end itemize
+;;
+;;Procedures are called according to these distinctions in order of
+;;the string's occurrence in @1.
+;;
+;;@5 is called with no arguments for end-of-line @emph{not within a
+;;markup or comment}.
+;;
+;;@4 is called with strings of non-newline whitespace.
+;;
+;;@3 is called with hypertext markup strings (including @samp{<} and
+;;@samp{>}).
+;;
+;;@2 is called with the remaining strings.
+;;
+;;@0 returns an unspecified value.
+(define (html-for-each file word-proc markup-proc white-proc newline-proc)
+  (define nl (string #\newline))
+  (define (string-index str . chrs)
+    (define len (string-length str))
+    (do ((pos 0 (+ 1 pos)))
+	((or (>= pos len) (memv (string-ref str pos) chrs))
+	 (and (< pos len) pos))))
+  (define (proc-words line edx)
+    (let loop ((idx 0))
+      (define ldx idx)
+      (do ((idx idx (+ 1 idx)))
+	  ((or (>= idx edx)
+	       (not (char-whitespace? (string-ref line idx))))
+	   (do ((jdx idx (+ 1 jdx)))
+	       ((or (>= jdx edx)
+		    (char-whitespace? (string-ref line jdx)))
+		(and white-proc (not (= ldx idx))
+		     (white-proc (substring line ldx idx)))
+		(and word-proc (not (= idx jdx))
+		     (word-proc (substring line idx jdx)))
+		(if (< jdx edx) (loop jdx))))))))
+  ((if (input-port? file) call-with-open-ports call-with-input-file)
+   file
+   (lambda (iport)
+     (do ((line (read-line iport) (read-line iport)))
+	 ((eof-object? line))
+       (do ((idx (string-index line #\<) (string-index line #\<)))
+	   ((not idx) (proc-words line (string-length line)))
+					; seen '<'
+	 (proc-words line idx)
+	 (let ((trm (if (and (<= (+ 4 idx) (string-length line))
+			     (string=? "<!--" (substring line idx (+ 4 idx))))
+			"-->" #\>)))
+	   (let loop ((lne (substring line idx (string-length line)))
+		      (tag "")
+		      (quot #f))
+	     (define edx (or (eof-object? lne)
+			     (if quot
+				 (string-index lne quot)
+				 (if (char? trm)
+				     (string-index lne #\" #\' #\>)
+				     (string-index lne #\>)))))
+	     (cond
+	      ((not edx)		; still inside tag
+	       ;;(print quot trm 'within-tag lne)
+	       (loop (read-line iport)
+		     (and markup-proc (string-append tag lne nl))
+		     quot))
+	      ((eqv? #t edx)		; EOF
+	       ;;(print quot trm 'eof lne)
+	       (slib:error 'unterminated 'HTML 'entity file)
+	       (and markup-proc (markup-proc tag)))
+	      ((eqv? quot (string-ref lne edx))	; end of quoted string
+	       ;;(print quot trm 'end-quote lne)
+	       (set! edx (+ 1 edx))
+	       (loop (substring lne edx (string-length lne))
+		     (and markup-proc
+			  (string-append tag (substring lne 0 edx)))
+		     #f))
+	      ((not (eqv? #\> (string-ref lne edx))) ; start of quoted
+	       ;;(print quot trm 'start-quote lne)
+	       (set! edx (+ 1 edx))
+	       (loop (substring lne edx (string-length lne))
+		     (and markup-proc
+			  (string-append tag (substring lne 0 edx)))
+		     (string-ref lne (+ -1 edx))))
+	      ((or (and (string? trm)	; found matching '>' or '-->'
+			(<= 2 edx)
+			(equal? trm (substring lne (+ -2 edx) (+ 1 edx))))
+		   (eqv? (string-ref lne edx) trm))
+	       ;;(print quot trm 'end-> lne)
+	       (set! edx (+ 1 edx))
+	       (and markup-proc
+		    (markup-proc (string-append tag (substring lne 0 edx))))
+					; process words after '>'
+	       (set! line (substring lne edx (string-length lne))))
+	      (else
+	       ;;(print quot trm 'within-comment lne)
+	       (set! edx (+ 1 edx))
+	       (loop (substring lne edx (string-length lne))
+		     (and markup-proc
+			  (string-append tag (substring lne 0 edx)))
+		     #f))))))
+       (and newline-proc (newline-proc))))))
+
+;;@args file limit
+;;@args file
+;;@1 is an input port or a string naming an existing file containing
+;;HTML text.  If supplied, @2 must be an integer.  @2 defaults to
+;;1000.
+;;
+;;@0 opens and reads HTML from port @1 or the file named by string @1,
+;;until reaching the (mandatory) @samp{TITLE} field.  @0 returns the
+;;title string with adjacent whitespaces collapsed to one space.  @0
+;;returns #f if the title field is empty, absent, if the first
+;;character read from @1 is not @samp{#\<}, or if the end of title is
+;;not found within the first (approximately) @2 words.
+(define (html:read-title file . limit)
+  (set! limit (if (null? limit) 1000 (* 2 (car limit))))
+  ((if (input-port? file) call-with-open-ports call-with-input-file)
+   file
+   (lambda (port)
+     (and (eqv? #\< (peek-char port))
+	  (call-with-current-continuation
+	   (lambda (return)
+	     (define (cnt . args)
+	       (if (negative? limit)
+		   (return #f)
+		   (set! limit (+ -1 limit))))
+	     (define capturing? #f)
+	     (define text '())
+	     (html-for-each
+	      port
+	      (lambda (str)
+		(cnt)
+		(if capturing? (set! text (cons " " (cons str text)))))
+	      (lambda (str)
+		(cnt)
+		(cond ((prefix-ci? "<title" str)
+		       (set! capturing? #t))
+		      ((prefix-ci? "</title" str)
+		       (return (and (not (null? text))
+				    (apply string-append
+					   (reverse (cdr text))))))
+		      ((or (prefix-ci? "</head" str)
+			   (prefix-ci? "<body" str))
+		       (return #f))))
+	      cnt
+	      cnt)
+	     #f))))))
+
+(define (prefix-ci? pre str)
+  (define prelen (string-length pre))
+  (and (< prelen (string-length str))
+       (string-ci=? pre (substring str 0 prelen))))
+
+;;@body
+;;@1 is a hypertext markup string.
+;;
+;;If @1 is a (hypertext) comment, then @0 returns #f.
+;;Otherwise @0 returns the hypertext element symbol (created by
+;;@code{string-ci->symbol}) consed onto an association list of the
+;;attribute name-symbols and values.  Each value is a number or
+;;string; or #t if the name had no value assigned within the markup.
+(define (htm-fields htm)
+  (require 'string-case)
+  (and
+   (not (and (> (string-length htm) 4) (equal? "<!--" (substring htm 0 4))))
+   (call-with-input-string htm
+     (lambda (port)
+       (define element #f)
+       (define fields '())
+       (cond ((not (eqv? 1 (fscanf port "<%s" element)))
+	      (slib:error 'htm-fields 'strange htm)))
+       (let loop ((chr (peek-char port)))
+	 (define name #f)
+	 (define junk #f)
+	 (define value #t)
+	 (cond
+	  ((eof-object? chr) (slib:warn 'htm-fields 'missing '> htm)
+	   (reverse fields))
+	  ((eqv? #\> chr) (cons element (reverse fields)))
+	  ((char-whitespace? chr) (read-char port) (loop (peek-char port)))
+	  ((case (fscanf port "%[a-zA-Z0-9]%[=]%[-.a-zA-Z0-9]" name junk value)
+	     ((3 1) #t)
+	     ((2)
+	      (case (peek-char port)
+		((#\") (eqv? 1 (fscanf port "\"%[^\"]\"" value)))
+		((#\') (eqv? 1 (fscanf port "'%[^']'" value)))
+		(else #f)))
+	     (else #f))
+	   (set! fields (cons (cons (string-ci->symbol name)
+				    (or (string->number value) value))
+			      fields))
+	   (loop (peek-char port)))
+	  (else (slib:warn 'htm-fields 'bad 'field htm) (reverse fields))))))))