scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

* removed STRING-HAX library from sunet. (now using SRFI 13 & 14 from 

scsh)
This commit is contained in:
interp 2002-04-21 18:55:18 +00:00
parent ef253e072a
commit 1689c545c8
13 changed files with 68 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cgi-server.scm
View File

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

2
doc/latex/man.tex
View File

@ -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}

79
doc/latex/stringhax.tex
View File

@ -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}

15
ftpd.scm
View File

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

42
htmlout.scm
View File

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

2
httpd-access-control.scm
View File

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

4
httpd-core.scm
View File

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

4
info-gateway.scm
View File

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

46
modules.scm
View File

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

10
rfc822.scm
View File

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

3
seval.scm
View File

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

91
stringhax.scm
View File

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

23
uri.scm
View File

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