From 186e9de56cabdf54a9a26abc66532ec59193d912 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Tue, 7 Jan 2003 12:16:33 +0000
Subject: [PATCH] Streamline structure declarations - remove some more uses of
 Olin records - remove uses of BIG-SCHEME/BIG-UTIL - subset all uses of SRFI
 1, 13, 14

---
 scheme/ftpd/ftpd.scm            |  8 +--
 scheme/httpd/access-control.scm | 30 ++++++------
 scheme/httpd/info-gateway.scm   |  2 +-
 scheme/httpd/logging.scm        | 49 +++++++++++++------
 scheme/httpd/response.scm       |  9 ++--
 scheme/packages.scm             | 87 +++++++++++++++------------------
 6 files changed, 97 insertions(+), 88 deletions(-)

diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm
index a6e489d..07c4fcd 100644
--- a/scheme/ftpd/ftpd.scm
+++ b/scheme/ftpd/ftpd.scm
@@ -893,9 +893,9 @@
 		       (string->number
 			(match:substring match match-index)))
 		     '(1 2 3 4 5 6))))
-	   (if (any? (lambda (component)
-		       (> component 255))
-		     components)
+	   (if (any (lambda (component)
+		      (> component 255))
+		    components)
 	       (begin
 		 (log (syslog-level debug)
 		      "rejecting PORT-command because of invalid arguments (port-component > 255) (501)")
@@ -1012,7 +1012,7 @@
      (let ((args (split-arguments arg)))
        (call-with-values
 	(lambda ()
-	  (partition-list
+	  (partition
 	   (lambda (arg)
 	     (and (not (string=? "" arg))
 		  (char=? #\- (string-ref arg 0))))
diff --git a/scheme/httpd/access-control.scm b/scheme/httpd/access-control.scm
index 860db47..014d80b 100644
--- a/scheme/httpd/access-control.scm
+++ b/scheme/httpd/access-control.scm
@@ -12,16 +12,16 @@
 
 (define (access-denier . hosts)
   (lambda (info)
-    (and (any? (lambda (host)
-		 (host-matches? info host))
-	       hosts)
+    (and (any (lambda (host)
+		(host-matches? info host))
+	      hosts)
 	 'deny)))
 
 (define (access-allower . hosts)
   (lambda (info)
-    (and (any? (lambda (host)
+    (and (any (lambda (host)
 		 (host-matches? info host))
-	       hosts)
+	      hosts)
 	 'allow)))
 
 (define (access-controller . controls)
@@ -49,23 +49,23 @@
   (cond
    ((list? host)
     (let ((len (length host)))
-      (any? (lambda (address)
-	      (equal? (take len (address->list address)) host))
-	    (host-info:addresses info))))
+      (any (lambda (address)
+	     (equal? (take len (address->list address)) host))
+	   (host-info:addresses info))))
    (else ; (string? host)
-    (any? (lambda (name)
-	    (string-match host (string-map char-downcase name)))
-	  (cons (host-info:name info)
-		(host-info:aliases info))))))
+    (any (lambda (name)
+	   (string-match host (string-map char-downcase name)))
+	 (cons (host-info:name info)
+	       (host-info:aliases info))))))
 
 (define normalize-host
   (let ((split (infix-splitter (make-regexp "\\.")))
 	(number (make-regexp "[0-9]+")))
     (lambda (host)
       (let ((components (split host)))
-	(if (every? (lambda (component)
-		      (regexp-exec number component))
-		    components)
+	(if (every (lambda (component)
+		     (regexp-exec number component))
+		   components)
 	    (map string->number components)
 	    host)))))
 
diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm
index f28c9ab..ccf2785 100644
--- a/scheme/httpd/info-gateway.scm
+++ b/scheme/httpd/info-gateway.scm
@@ -179,7 +179,7 @@
 	  
 	(define (search-field regexp)
 	  (cond
-	   ((any (lambda (field)
+	   ((find (lambda (field)
 		   (string-match regexp (car field)))
 		 fields)
 	    => cadr)
diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm
index 003edd4..62421f1 100644
--- a/scheme/httpd/logging.scm
+++ b/scheme/httpd/logging.scm
@@ -9,12 +9,29 @@
 ;;; the distribution.
 
 (define do-nothing-proc (lambda a #f))
-(define-record logging
-  (http-log-port #f)			;port to perform CLF-logging
-  (http-log-proc do-nothing-proc)	;proc to run for CLF-logging (req status-code)
-  (http-syslog? #f)			;do syslogging?
-  (http-syslog-proc do-nothing-proc)	;proc to run for syslog (level fmt . args)
-  (dns-lookup? #f))			;perform dns-lookups?
+
+(define-record-type logging :logging
+  (really-make-logging log-port log-proc
+		       syslog? syslog-proc
+		       dns-lookup?)
+  logging?
+  ;; port to perform CLF-logging
+  (log-port logging-log-port set-logging-log-port!)
+  ;; proc to run for CLF-logging (req status-code)
+  (log-proc logging-log-proc set-logging-log-proc!)
+  ;; do syslogging?
+  (syslog? logging-syslog? set-logging-syslog?!)
+  ;; proc to run for syslog (level fmt . args)
+  (syslog-proc logging-syslog-proc set-logging-syslog-proc!)
+  ;; perform dns lookups?
+  (dns-lookup? logging-dns-lookup? set-logging-dns-lookup?!))
+
+(define (make-logging)
+  (really-make-logging #f
+		       do-nothing-proc
+		       #f
+		       do-nothing-proc
+		       #f))
 
 (define logging (make-preserved-thread-fluid #f))
 
@@ -25,17 +42,17 @@
   (lambda (value)
     (setter (thread-fluid logging) value)))
 
-(define logging-http-log-proc (make-fluid-selector logging:http-log-proc))
-(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc))
-(define logging-http-syslog? (make-fluid-selector logging:http-syslog?))
-(define logging-http-log-port (make-fluid-selector logging:http-log-port))
-(define logging-dns-lookup? (make-fluid-selector logging:dns-lookup?))
+(define logging-http-log-proc (make-fluid-selector logging-log-proc))
+(define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc))
+(define logging-http-syslog? (make-fluid-selector logging-syslog?))
+(define logging-http-log-port (make-fluid-selector logging-log-port))
+(define logging-dns-lookup? (make-fluid-selector logging-dns-lookup?))
 
-(define set-logging-http-log-proc (make-fluid-setter set-logging:http-log-proc))
-(define set-logging-http-syslog-proc (make-fluid-setter set-logging:http-syslog-proc))
-(define set-logging-http-syslog? (make-fluid-setter set-logging:http-syslog?))
-(define set-logging-http-log-port (make-fluid-setter set-logging:http-log-port))
-(define set-logging-dns-lookup? (make-fluid-setter set-logging:dns-lookup?))
+(define set-logging-http-log-proc (make-fluid-setter set-logging-log-proc!))
+(define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!))
+(define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!))
+(define set-logging-http-log-port (make-fluid-setter set-logging-log-port!))
+(define set-logging-dns-lookup? (make-fluid-setter set-logging-dns-lookup?!))
 
 (define http-syslog
   (lambda a
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index 6172673..7ad6c1f 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -5,7 +5,7 @@
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
-(define-record-type :http-response
+(define-record-type http-response :http-response
   (make-response code message seconds mime extras body)
   response?
   (code response-code)
@@ -15,21 +15,20 @@
   (extras response-extras)
   (body response-body))
 
-(define-record-type :http-writer-body
+(define-record-type http-writer-body :http-writer-body
   (make-writer-body proc)
   writer-body?
   (proc writer-body-proc))
 
-(define-record-type :http-reader-writer-body
+(define-record-type http-reader-writer-body :http-reader-writer-body
   (make-reader-writer-body proc)
   reader-writer-body?
   (proc reader-writer-body-proc))
 
-(define-record-type :http-redirect-body
+(define-record-type http-redirect-body :http-redirect-body
   (make-redirect-body location)
   redirect-body?
   (location redirect-body-location))
-			   
 
 (define (display-http-body body iport oport options)
   (cond
diff --git a/scheme/packages.scm b/scheme/packages.scm
index b5b3cad..9d5758d 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -366,7 +366,7 @@
 	  rooted-file-or-directory-handler))
 
 (define-interface httpd-seval-handlers-interface
-  (export httpd-seval-handler))
+  (export seval-handler))
 
 (define-interface httpd-info-gateway-interface
   (export info-handler
@@ -404,17 +404,15 @@
 
 (define-structure parse-html-forms parse-html-forms-interface
   (open scheme-with-scsh 
-	scsh-utilities 
 	let-opt 
-	srfi-13
+	(subset srfi-13 (string-index string-map))
 	receiving 
 	uri)
   (files (lib parse-forms)))
 
 (define-structure htmlout htmlout-interface
   (open scheme-with-scsh
-	scsh-utilities
-	srfi-13
+	(subset srfi-13 (string-fold))
 	formats
 	ascii
 	receiving)
@@ -436,9 +434,8 @@
 (define-structure rfc822 rfc822-interface
   (open scheme-with-scsh
 	receiving	; MV return (RECEIVE and VALUES)
-	scsh-utilities	; index
-	srfi-13
-	srfi-1		; fold
+	(subset srfi-13 (string-map string-index string-join))
+	(subset srfi-1 (fold))
 	let-opt         ; let-optionals
 	crlf-io		; read-crlf-line
 	ascii		; ascii->char
@@ -448,22 +445,19 @@
 
 (define-structure uri uri-interface
   (open scheme-with-scsh
-	srfi-13
+	(subset srfi-13 (string-index string-index-right string-fold string-join))
 	let-opt
 	receiving
 	ascii
-	srfi-14
 	bitwise
 	field-reader-package)
   (files (lib uri)))
 
 (define-structure url url-interface
   (open scheme-with-scsh
-	scsh-utilities
 	define-record-types
 	receiving
-	srfi-13
-	srfi-14
+	(subset srfi-13 (string-index))
 	uri
 	httpd-error)
   (files (lib url)))
@@ -477,7 +471,7 @@
         conditions
         signals
         error-package
-	srfi-13
+	(subset srfi-13 (string-join))
 	let-opt
 	sunet-utilities
 	crlf-io)
@@ -526,7 +520,7 @@
         handle
         conditions
         signals
-	srfi-13
+	(subset srfi-13 (string-index))
 	let-opt
 	crlf-io)
   (files (lib pop3)))
@@ -600,7 +594,8 @@
 (define-structure ls ls-interface
   (open scheme-with-scsh
 	handle
-	big-scheme bitwise
+	(subset srfi-1 (filter))
+	bitwise
 	fluids
 	crlf-io)
   (files (lib ls)))
@@ -615,7 +610,7 @@
 	format-net
 	sigevents
 	let-opt
-	srfi-13
+	(subset srfi-13 (string-join))
 	dns
 	let-opt				; :optional
 	locks
@@ -637,14 +632,14 @@
 	fluids thread-fluids
 	locks
 	(subset srfi-13 (string-map string-trim-both string-index))
-	(subset big-util (any? partition-list))
+	(subset srfi-1 (any partition))
 	crlf-io
 	ls
 	dns
 	sunet-version
 	sunet-utilities
-	receiving                   ; RECEIVE
-	format-net)                 ; pretty print of internet-addresses
+	receiving
+	format-net)
   (files (ftpd ftpd)))
 
 ;; Web server
@@ -652,18 +647,16 @@
 (define-structure httpd-core httpd-core-interface
   (open scheme-with-scsh
 	thread-fluids			; fork-thread
-	receiving			; receive
+	receiving
 	crlf-io				; write-crlf, read-crlf-line
 	rfc822				; read-rfc822-headers
-	srfi-14				; char-set-complement, char-set:whitespace 
 	handle				; ignore-errors
 	conditions			; condition-stuff
 	uri
 	url
-	formats				; format
-	format-net			; format-internet-host-address
+	format-net
 	rate-limit			; rate-limiting stuff
-	srfi-13				; STRING-INDEX
+	(subset srfi-13 (string-index))
 	dns				; dns-lookup-ip
 	sunet-utilities                 ; socket-address->string 
 	locks				; make-lock et al.
@@ -679,7 +672,7 @@
 	httpd-responses
 
 	sunet-version
-	srfi-1)				; find
+	)
   (files (httpd core)))
 
 (define-structures ((httpd-make-options httpd-make-options-interface)
@@ -690,11 +683,11 @@
 
 (define-structure httpd-access-control httpd-access-control-interface
   (open scheme-with-scsh
-	big-scheme
+	(subset srfi-1 (any every))
 	httpd-responses
 	httpd-requests
 	httpd-error
-	srfi-13    ; STRING-MAP
+	(subset srfi-13 (string-map))
 	)
   (files (httpd access-control)))
 
@@ -706,19 +699,19 @@
   (open scheme-with-scsh
 	httpd-read-options
 	i/o				; make-null-output-port
-	locks				; make-lock obtain-lock release-lock
-	receiving			; receive
+	locks
+	receiving
 	uri				; uri-path-list->path
 	url				; http-url-path
 	httpd-requests			; request record
-	formats				; format
+	formats
 	format-net			; format-internet-host-address
-	srfi-13				; string-join, string-trim
+	(subset srfi-13 (string-join string-trim))
 	rfc822				; get-header
 	sunet-utilities			; on-interrupt
 	threads				; spawn
 	dns				; dns-lookup-ip
-	defrec-package			; define-record
+	define-record-types
 	thread-fluids			; make-preserved-fluid et al.
 	handle-fatal-error
 	)
@@ -733,7 +726,7 @@
   (open scheme
 	(subset scsh (format-date write-string time date))
 	syslog
-	srfi-9
+	define-record-types
 	defenum-package
 	formats
 	httpd-requests
@@ -745,8 +738,8 @@
   (open scheme-with-scsh
 	rfc822
 	httpd-requests			; REQUEST record type, v0.9-request
-	srfi-1				; FOLD-RIGHT
-	srfi-13				; STRING-TRIM
+	(subset srfi-1 (fold-right))
+	(subset srfi-13 (string-trim))
 	httpd-responses
 	)
   (files (httpd handlers)))
@@ -762,7 +755,7 @@
 	url
 	htmlout
 	crlf-io
-	srfi-13 ; STRING-JOIN
+	(subset srfi-13 (string-join))
 	sunet-utilities			; dotdot-check, copy-inport->outport
 	conditions
 	handle-fatal-error
@@ -777,9 +770,9 @@
 	httpd-logging			; http-log
 	uri				; UNESCAPE-URI
 	htmlout				; Formatted HTML output
-	error-package			; ERROR
-	pp				; Pretty-printer
-	srfi-13				; STRING-SKIP
+	error-package			; ERROR ####
+	pp
+	(subset srfi-13 (string-skip))
 	rfc822
 	toothless-eval			; EVAL-SAFELY
 	handle				; IGNORE-ERROR
@@ -790,8 +783,8 @@
 
 (define-structure httpd-info-gateway httpd-info-gateway-interface
   (open scheme-with-scsh
-	big-scheme
-	srfi-13
+	(subset srfi-1 (find))
+	(subset srfi-13 (string-map string-skip string-index))
 	conditions signals handle
 	htmlout
 	httpd-requests
@@ -815,12 +808,13 @@
 	handle-fatal-error
 	let-opt
 	sunet-utilities
-	srfi-13)
+	(subset srfi-13 (string-join))
+	)
   (files (httpd rman-gateway)))
 
 (define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
   (open	scheme-with-scsh
-	srfi-13
+	(subset srfi-13 (string-prefix? string-index string-trim substring/shared))
 	rfc822
 	crlf-io			; WRITE-CRLF
 	uri
@@ -832,9 +826,8 @@
 	httpd-error		; HTTP-ERROR
 	httpd-file-directory-handlers		; dot-dot-check, copy-inport->outport
 	sunet-version
-	scsh-utilities		; INDEX
-	formats			; format
-	format-net              ; FORMAT-INTERNET-HOST-ADDRESS
+	formats
+	format-net
 	sunet-utilities         ; host-name-or-empty
 	let-opt                 ; let-optionals
 	handle-fatal-error