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 @@ ;;; ;;; ;;; 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)))))