From 1689c545c81f831a1646b60214a077a468fd6422 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Sun, 21 Apr 2002 18:55:18 +0000
Subject: [PATCH] * removed STRING-HAX library from sunet. (now using SRFI 13 &
 14 from scsh)

---
 cgi-server.scm           |  2 +-
 doc/latex/man.tex        |  2 +-
 doc/latex/stringhax.tex  | 79 ----------------------------------
 ftpd.scm                 | 15 +++----
 htmlout.scm              | 42 +++++++++----------
 httpd-access-control.scm |  2 +-
 httpd-core.scm           |  4 +-
 info-gateway.scm         |  4 +-
 modules.scm              | 46 +++++++-------------
 rfc822.scm               | 10 ++---
 seval.scm                |  3 +-
 stringhax.scm            | 91 ----------------------------------------
 uri.scm                  | 23 +++++-----
 13 files changed, 68 insertions(+), 255 deletions(-)
 delete mode 100644 doc/latex/stringhax.tex
 delete mode 100644 stringhax.scm

diff --git a/cgi-server.scm b/cgi-server.scm
index 1a49a32..d10e4c1 100644
--- a/cgi-server.scm
+++ b/cgi-server.scm
@@ -208,7 +208,7 @@
 
 	  ,@(cond ((get-header headers 'content-length) =>
 		   (lambda (cl)	; Skip initial whitespace (& other non-digits).
-		     (let ((first-digit (char-set-index cl char-set:numeric))
+		     (let ((first-digit (string-index cl char-set:numeric))
 			   (cl-len (string-length cl)))
 		       (if first-digit
 			   `(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
diff --git a/doc/latex/man.tex b/doc/latex/man.tex
index ceafc69..0868463 100644
--- a/doc/latex/man.tex
+++ b/doc/latex/man.tex
@@ -29,7 +29,7 @@ the sunet package.
 \include{ntp}
 \include{smtp}
 \include{pop3}
-\include{stringhax}
+%\include{stringhax}
 \include{toothless}
 %\FIXME{Is there a possibility to get rid of the overfull \\hboxes?}
 \end{document}
diff --git a/doc/latex/stringhax.tex b/doc/latex/stringhax.tex
deleted file mode 100644
index 23bee2c..0000000
--- a/doc/latex/stringhax.tex
+++ /dev/null
@@ -1,79 +0,0 @@
-\section{Manipulating strings}\label{sec:stringhax}
-
-
-\begin{description}
-\item[Used files:] stringhax.scm
-\item[Name of the package:] strings
-\end{description}
-
-
-\subsection{Overview}
-
-This module provides several procedures to manipulate strings.
-
-\begin{defundesc}{string-map} {procedure string} {string}
-  Does a map on each character of \semvar{string} and returns the
-  result, a newly allocated string. \semvar{procedure} takes a
-  character and should return a character.
-\end{defundesc}
-
-\defun{downcase-string} {string} {string}
-\begin{defundescx}{upcase-string} {string} {string}
-  Do what you expect: convert \semvar{string} to downcase or upcase
-  using char-downcase or char-upcase, respectively. The result is a
-  newly allocated string.
-\end{defundescx}
-
-\defun{char-set-index} {string char-set \ovar{start}} {number}
-\begin{defundescx}{char-set-rindex} {string char-set \ovar{start}} {number}
-  Returns the index of the first character that is in
-  \semvar{char\=set}.  \ex{char\=set\=index} searches from left to
-  right, \ex{char\=set\=rindex} from right to left. \semvar{start} is
-  the index from where to start from and defaults to 0 in
-  \ex{char\=set\=index} and \ex{(string-length \semvar{string})} in
-  \ex{char\=set\=rindex}. If the search fails, \sharpf{} is returned.
-\end{defundescx}
-
-\begin{defundesc}{string-reduce} {default construct string} {string}
-  Does a ``fold-right'' on \semvar{string}. It applies
-  \semvar{construct} on every character of \semvar{string}.
-  \semvar{construct} is initially invoked with the last character of
-  string and \semvar{default}. In subsequent invocations, the last
-  argument is the return value from the previous invocation of
-  \semvar{construct} while the first argument is the character of
-  \semvar{string} leading the previous used character. So, the string
-  is traversed from right to left. The result of the application of
-  \semvar{string-reduce} is the result of the last application of
-  \semvar{construct}.
-  
-  Example:
-\begin{code}
-(string-reduce 
- "" 
- (lambda (char str) 
-   (string-append str (string (char-downcase char)))) 
- "DOWNCASE")\end{code}
-
-results to ``downcase''.
-\end{defundesc}
-
-\defun{string-prefix?} {prefix string} {boolean}
-\begin{defundescx}{string-suffix?} {suffix string} {boolean}
-  Return \sharpt{} if \semvar{prefix}/\semvar{suffix} is a real
-  \semvar{prefix}/\semvar{suffix} of \semvar{string}, otherwise return
-  \sharpf. Real prefix/suffix means that \semvar{string} may not be a
-  prefix/suffix of \semvar{prefix}/\semvar{suffix} (in other words:
-  \semvar{prefix} and \semvar{suffix} have to be real shorter than
-  \semvar{string} to be a real prefix or suffix.
-\end{defundescx}
-
-\begin{defundesc}{skip-whitespace} {string} {number}
-  Returns the index of the first character in \semvar{string} that is
-  not a whitespace (as defined in \ex{char-set:whitespace}). If there
-  isn't such a character, \sharpf{} is returned.
-\end{defundesc}
-
-\begin{defundesc}{trim-spaces} {string} {string}
-  Returns a newly allocated string being \semvar{string} without
-  leading or trailing spaces (not whitespaces!).
-\end{defundesc}
diff --git a/ftpd.scm b/ftpd.scm
index 574dbeb..7a3f370 100644
--- a/ftpd.scm
+++ b/ftpd.scm
@@ -1140,14 +1140,15 @@
 (define (parse-command-line line)
   (if (eof-object? line) ; Netscape does this
       (signal 'ftpd-irregular-quit)
-      (let* ((line (trim-spaces line))
+      (let* ((line (string-trim-both line char-set:whitespace))
 	     (split-position (string-index line #\space)))
 	(if split-position
-	    (values (upcase-string (substring line 0 split-position))
-		    (trim-spaces (substring line
-					    (+ 1 split-position)
-					    (string-length line))))
-	    (values (upcase-string line) "")))))
+	    (values (string-map char-upcase (substring line 0 split-position))
+		    (string-trim-both (substring line
+						 (+ 1 split-position)
+						 (string-length line))
+				      char-set:whitespace))
+	    (values (string-map char-upcase line) "")))))
 
 ; Path names
 
@@ -1216,7 +1217,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.35 $")
+(define *ftpd-version* "$Revision: 1.36 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))
diff --git a/htmlout.scm b/htmlout.scm
index 1e4a636..f20b5bb 100644
--- a/htmlout.scm
+++ b/htmlout.scm
@@ -163,30 +163,30 @@
 
 (define (escape-html s)
   (let ((target-length
-	 (string-reduce 0
-			(lambda (c i)
-			  (+ i
-			     (if (char-set-contains? *html-entities* c)
-				 (string-length 
-				  (vector-ref *html-entity-table*
-					      (char->ascii c)))
-				 1)))
-			s)))
+	 (string-fold-right (lambda (c i)
+			      (+ i
+				 (if (char-set-contains? *html-entities* c)
+				     (string-length 
+				      (vector-ref *html-entity-table*
+						  (char->ascii c)))
+				     1)))
+			    0
+			    s)))
     (if (= target-length (string-length s))
 	s
 	(let ((target (make-string target-length)))
-	  (string-reduce
-	    0
-	    (lambda (c i)
-	      (+ i
-		 (if (char-set-contains? *html-entities* c)
-		     (let ((entity (vector-ref *html-entity-table* (char->ascii c))))
-		       (string-set-substring! target i entity)
-		       (string-length entity))
-		      (begin 
-			(string-set! target i c)
-			1))))
-	    s)
+	  (string-fold-right
+	   (lambda (c i)
+	     (+ i
+		(if (char-set-contains? *html-entities* c)
+		    (let ((entity (vector-ref *html-entity-table* (char->ascii c))))
+		      (string-set-substring! target i entity)
+		      (string-length entity))
+		    (begin 
+		      (string-set! target i c)
+		      1))))
+	   0
+	   s)
 	  target))))
 
 (define (emit-text s . maybe-port)
diff --git a/httpd-access-control.scm b/httpd-access-control.scm
index aea2d8e..7623635 100644
--- a/httpd-access-control.scm
+++ b/httpd-access-control.scm
@@ -50,7 +50,7 @@
 	    (host-info:addresses info))))
    (else ; (string? host)
     (any? (lambda (name)
-	    (string-match host (downcase-string name)))
+	    (string-match host (string-map char-downcase name)))
 	  (cons (host-info:name info)
 		(host-info:aliases info))))))
 
diff --git a/httpd-core.scm b/httpd-core.scm
index 60963c4..c41aa5e 100644
--- a/httpd-core.scm
+++ b/httpd-core.scm
@@ -402,9 +402,9 @@
 
 (define (string->words s)
   (let recur ((start 0))
-    (cond ((char-set-index s non-whitespace start) =>
+    (cond ((string-index s non-whitespace start) =>
         (lambda (start)
-	  (cond ((char-set-index s char-set:whitespace start) => 
+	  (cond ((string-index s char-set:whitespace start) => 
 	      (lambda (end)
 		(cons (substring s start end)
 		      (recur end))))
diff --git a/info-gateway.scm b/info-gateway.scm
index eed9497..61facb1 100644
--- a/info-gateway.scm
+++ b/info-gateway.scm
@@ -312,7 +312,7 @@
 	 (node-name (match:substring match 2))
 	 (node-name (if (string=? "" node-name) note node-name))
 	 (node-name (substring node-name
-			       (skip-whitespace node-name)
+			       (string-skip node-name char-set:whitespace)
 			       (string-length node-name))))
     (emit-text "See ")
     (display-reference file node-name note)))
@@ -612,7 +612,7 @@
 		   => (lambda (match)
 			(match:substring match 1)))
 		  (else base)))
-	   (base-ci (downcase-string base))
+	   (base-ci (string-map char-downcase base))
 	   (alts-1 (if (string=? base base-ci)
 		       (list base)
 		       (list base base-ci)))
diff --git a/modules.scm b/modules.scm
index 224559a..c81a2d4 100644
--- a/modules.scm
+++ b/modules.scm
@@ -87,32 +87,14 @@
 	scsh-utilities	; index
 	string-lib
 	let-opt         ; let-optionals
-	strings		; lowercase-string uppercase-string
 	crlf-io		; read-crlf-line
 	ascii		; ascii->char
 	error-package	; error
-	scsh		; join-strings
+	scsh		; string-join
 	scheme)
   (files rfc822))
 
 
-(define-interface strings-interface
-  (export string-map
-	  downcase-string
-	  upcase-string
-	  char-set-index
-	  char-set-rindex
-	  string-reduce
-	  skip-whitespace
-	  string-prefix?
-	  string-suffix?
-	  trim-spaces))
-
-(define-structure strings strings-interface
-  (open char-set-lib let-opt scheme) 
-  (files stringhax))
-
-
 (define-interface uri-interface 
   (export parse-uri
 	  uri-escaped-chars
@@ -130,7 +112,6 @@
 	receiving
 	
 	ascii
-	strings
 	char-set-lib
 	bitwise
 	field-reader-package
@@ -309,7 +290,6 @@
 	receiving
 	crlf-io
 	rfc822
-	strings
 	char-set-lib
 	defrec-package
 	define-record-types
@@ -341,9 +321,12 @@
   (export parse-html-form-query unescape-uri+))
 
 (define-structure parse-html-forms parse-html-forms-interface
-  (open scsh scsh-utilities let-opt string-lib
-	receiving uri strings 
-	 
+  (open scsh 
+	scsh-utilities 
+	let-opt 
+	string-lib
+	receiving 
+	uri
 	scheme)
   (files parse-forms))
 
@@ -365,8 +348,7 @@
 	  initialise-request-invariant-cgi-env))
 
 (define-structure cgi-server cgi-server-interface
-  (open strings
-	string-lib
+  (open	string-lib
 	rfc822
 	crlf-io			; WRITE-CRLF
 	uri
@@ -399,7 +381,7 @@
 	  emit-text))
 
 (define-structure htmlout htmlout-interface
-  (open scsh scsh-utilities strings formats ascii receiving scheme)
+  (open scsh scsh-utilities string-lib formats ascii receiving scheme)
   (files htmlout))
 
 
@@ -446,10 +428,10 @@
 	htmlout		; Formatted HTML output
 	error-package	; ERROR
 	pp		; Pretty-printer
-	strings rfc822
+	string-lib      ; STRING-SKIP
+	rfc822
 	toothless-eval	; EVAL-SAFELY
 	handle		; IGNORE-ERROR
-	strings		; SKIP-WHITESPACE
 	parse-html-forms ; PARSE-HTML-FORM-QUERY
 	threads         ; SLEEP
 	scheme)
@@ -464,9 +446,9 @@
 
 (define-structure httpd-access-control httpd-access-control-interface
   (open big-scheme
-	strings
 	httpd-core
 	httpd-error
+	string-lib    ; STRING-MAP
 	scsh
 	scheme)
   (files httpd-access-control))
@@ -481,7 +463,6 @@
   (open big-scheme
 	string-lib
 	conditions signals handle
-	strings
 	htmlout
 	httpd-core
 	httpd-error
@@ -549,7 +530,8 @@
 	string-lib
 	big-util
 	defrec-package
-	crlf-io strings ls
+	crlf-io
+	ls
 	let-opt
 	receiving                   ; RECEIVE
 	format-net)                 ; pretty print of internet-addresses
diff --git a/rfc822.scm b/rfc822.scm
index e729128..10d0868 100644
--- a/rfc822.scm
+++ b/rfc822.scm
@@ -3,14 +3,14 @@
 ;;; <shivers@lcs.mit.edu>
 ;;;
 ;;; Imports and non-R4RS'isms
-;;;     downcase-string upcase-string		(string->symbol conversion)
+;;;     string conversions
 ;;;	read-crlf-line
 ;;;	let-optionals, :optional
 ;;;	receive values				(MV return)
 ;;;     "\r\n" in string for cr/lf
 ;;;     ascii->char				(defining the tab char)
 ;;;	index
-;;;     join-strings				(reassembling body lines)
+;;;     string-join				(reassembling body lines)
 ;;;	error
 ;;;     ?					(COND)
 
@@ -94,8 +94,8 @@
 ;;; so we can compare these things against quoted constants.
 (define string->symbol-pref
   (if (char=? #\a (string-ref (symbol->string 'a) 0))	; Is it #\a or #\A?
-      (lambda (s) (string->symbol (downcase-string s)))
-      (lambda (s) (string->symbol (upcase-string s)))))
+      (lambda (s) (string->symbol (string-map char-downcase s)))
+      (lambda (s) (string->symbol (string-map char-upcase s)))))
 
 (define (read-rfc822-field . maybe-port)
   (let-optionals maybe-port ((port (current-input-port)))
@@ -167,7 +167,7 @@
 ;;; string used to join these elements together; it defaults to a single
 ;;; space " ", but can usefully be "\n" or "\r\n".
 ;;;
-;;; To rejoin a single body list, use scsh's JOIN-STRINGS procedure.
+;;; To rejoin a single body list, use scsh's STRING-JOIN procedure.
 
 (define (rejoin-header-lines alist . maybe-separator)
   (let-optionals maybe-separator ((sep " "))
diff --git a/seval.scm b/seval.scm
index c4b24d5..1d775de 100644
--- a/seval.scm
+++ b/seval.scm
@@ -16,7 +16,6 @@
 ;;;	ERROR
 ;;;	INDEX
 ;;;	URI decoding
-;;;     string hacks (SKIP-WHITESPACE)
 
 ;;; HTML forms
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -99,7 +98,7 @@
   (cond 
    ((get-header (request:headers req) 'content-length) =>
     (lambda (cl-str)		 ; Take the first Content-length: header,
-      (let* ((cl-start (skip-whitespace cl-str))	   ; skip whitespace,
+      (let* ((cl-start (string-skip cl-str char-set:whitespace))	   ; skip whitespace,
 	     (cl (if cl-start			   	   ; & convert to
 		     (string->number (substring cl-str   ;     a number.
 						cl-start
diff --git a/stringhax.scm b/stringhax.scm
deleted file mode 100644
index 8f53724..0000000
--- a/stringhax.scm
+++ /dev/null
@@ -1,91 +0,0 @@
-;;; Random string-hacking procs -*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers.
-;;; Copyright (c) 1997 by Mike Sperber
-
-; do a 'map' on each character of the string
-(define (string-map f s)
-  (let* ((slen (string-length s))
-	 (ns (make-string slen)))
-    (do ((i (- slen 1) (- i 1)))
-	((< i 0) ns)
-      (string-set! ns i (f (string-ref s i))))))
-
-; convert string to down-/uppercase
-(define (downcase-string s)
-  (string-map char-downcase s))
-
-(define (upcase-string s)
-  (string-map char-upcase s))
-
-
-;return index of first character contained in char-set
-(define (char-set-index str cset . maybe-start)
-  (let-optionals maybe-start ((start 0))
-    (let ((len (string-length str)))
-      (do ((i start (+ 1 i)))
-	  ((or (>= i len)
-	       (char-set-contains? cset (string-ref str i)))
-	   (and (< i len) i))))))
-
-;return index of last character contained in char-set
-;NOTE: character defined by maybe-start is not looked up
-(define (char-set-rindex str cset . maybe-start)
-  (let ((len (string-length str)))
-    (let-optionals maybe-start ((start len))
-      (do ((i (- start 1) (- i 1)))
-	  ((or (< i 0)
-	       (char-set-contains? cset (string-ref str i)))
-	   (and (>= i 0) i))))))
-
-;do a "fold-right" on string
-;(string-reduce nil cons s) ==> (cons ... (cons s[1] (cons s[0] nil)) ...)
-(define (string-reduce nil cons s)
-  (let ((slen (string-length s)))
-    (do ((ans nil (cons (string-ref s i) ans))
-	 (i 0 (+ i 1)))
-	((= i slen) ans))))
-
-;is PREFIX a prefix of STRING?
-(define (string-prefix? prefix string)
-  (let ((plen (string-length prefix))
-	(slen (string-length string)))
-    (and (<= plen slen)
-	 (let lp ((i 0))
-	   (or (= i plen)
-	       (and (char=? (string-ref prefix i)
-			    (string-ref string i))
-		    (lp (+ i 1))))))))
-
-;is SUFFIX a suffix of STRING?
-(define (string-suffix? suffix string)
-  (let ((slen (string-length suffix))
-	(len (string-length string)))
-    (and (<= slen len)
-	 (let lp ((i (- slen 1))
-		  (j (-  len 1)))
-	   (or (< i 0)
-	       (and (char=? (string-ref suffix i)
-			    (string-ref string j))
-		    (lp (- i 1) (- j 1))))))))
-
-;return index of first non-whitespace character in S, #f otherwise
-(define skip-whitespace
-  (let ((non-whitespace (char-set-complement char-set:whitespace)))
-    (lambda (s) (char-set-index s non-whitespace))))
-
-; Why is this so complicated?
-; I hope it isn't anymore *g*  Andreas
-
-(define (trim-spaces string)  ; trims spaces from left and right 
-  (if (string=? "" string)
-      string
-      (let* ((the-loop 
-	      (lambda (start incr)    ; start-point and increment (+1 or -1)
-		(let lp ((i start))
-		  (if (char=? #\space (string-ref string i))
-		      (lp (+ i incr)) ; still spaces, go ahead
-		      i))))           ; first non-space-character
-	     (start (the-loop 0 1))   ; from left
-	     (end (+ 1 (the-loop (- (string-length string) 1) -1)))) ; from right
-	(substring string start end)))) ; in the middle
-  
diff --git a/uri.scm b/uri.scm
index 7a0334e..86e79d8 100644
--- a/uri.scm
+++ b/uri.scm
@@ -59,17 +59,17 @@
 (define (parse-uri s)
   (let* ((slen (string-length s))
 	 ;; Search forwards for colon (or intervening reserved char).
-	 (rs1 (char-set-index s uri-reserved))	; 1st reserved char
+	 (rs1 (string-index s uri-reserved))	; 1st reserved char
 	 (colon (and rs1 (char=? (string-ref s rs1) #\:) rs1))
 	 (path-start (if colon (+ colon 1) 0))
 
 	 ;; Search backwards for # (or intervening reserved char).
-	 (rs-last (char-set-rindex s uri-reserved))
+	 (rs-last (string-index-right s uri-reserved))
 	 (sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last))
 
 	 ;; Search backwards for ? (or intervening reserved char).
 	 ;; (NB: #\= may be after #\? and before #\#)
-	 (rs-penult (char-set-rindex 
+	 (rs-penult (string-index-right
 		     s                      
 		     (char-set-delete uri-reserved #\=)
 		     (or sharp slen))) 
@@ -161,16 +161,16 @@
 
 (define (escape-uri s . maybe-escaped-chars)
   (let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars))
-    (let ((nlen (string-reduce 0
-			       (lambda (c i)
-				 (+ i
-				    (if (char-set-contains? escaped-chars c)
-					3 1)))
-			       s)))    ; new length of escaped string
+    (let ((nlen (string-fold-right
+		 (lambda (c i)
+		   (+ i
+		      (if (char-set-contains? escaped-chars c)
+			  3 1)))
+		 0
+		 s)))    ; new length of escaped string
       (if (= nlen (string-length s)) s
 	  (let ((ns (make-string nlen))) 
-	    (string-reduce
-	     0
+	    (string-fold-right
 	     (lambda (c i)     ; replace each occurance of an
 			       ; character to escape with %ff where ff
 			       ; is the ascii-code in hexadecimal
@@ -188,6 +188,7 @@
 		      3)
 		     (else (string-set! ns i c)
 			   1))))
+	     0
 	     s)
 	    ns)))))