eliminating ecm-utilities, code partial moved to sunet-utilities

scheme/lib/ecm-utilities.scm

@@ -1,57 +0,0 @@
-;; ecm-utilities.scm -- Utility procedures for ecm-net code
-;;
-;; $Id: ecm-utilities.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
-;;
-;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
-
-
-;; please tell me if this doesn't work on your system.
-(define (system-fqdn)
-  (let ((sysname (system-name)))
-    (if (string-index sysname #\.)
-        sysname
-        (nslookup-fqdn))))
-
-;; This doesn't work on my system. Probably it is not configured well.
-;; Nevertheless, the alternative seems better to me
-;(define (nslookup-fqdn)
-;  (let* ((cmd (format #f "nslookup ~a" (system-name)))
-;         (raw (string-join (run/strings (nslookup ,(system-name)))))
-;         (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
-;    (display raw)
-;    (match:substring match 1)))
-
-(define (nslookup-fqdn)
-  (host-info:name (host-info (system-name))))
-; another easy alternative:
-;  (car (run/strings (hostname "--long"))))
-
-
-;; prefer this to :optional
-(define (safe-first x) (and (not (null? x)) (car x)))
-(define (safe-second x) (and (not (null? x)) (not (null? (cdr x))) (cadr x)))
-
-(define (write-crlf port)
-  (write-string "\r\n" port)
-  (force-output port))
-
-
-(define (dump fd)
-  (let loop ((c (read-char fd)))
-    (cond ((not (eof-object? c))
-           (write-char c)
-           (loop (read-char fd))))))
-
-  
-(define-syntax when
-  (syntax-rules ()
-    ((when bool body1 body2 ...)
-     (if bool (begin body1 body2 ...)))))
-
-
-(define-syntax unless
-  (syntax-rules ()
-    ((unless bool body1 body2 ...)
-     (if (not bool) (begin body1 body2 ...)))))
-
-;; EOF

scheme/lib/pop3.scm

@@ -1,6 +1,6 @@
 ;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
 ;;
-;; $Id: pop3.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
+;; $Id: pop3.scm,v 1.2 2002/08/26 14:49:17 interp Exp $
 ;;
 ;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
 
@@ -127,9 +127,12 @@
 
 ;;: [host x logfile] -> connection
 (define (pop3-connect . args)
+  (let-optionals
+      args
+      ((host-arg #f)
+       (logfile #f))
     (let* ((host (or (getenv "MAILHOST")
-                   (safe-first args)))
+		     host-arg))
-         (logfile (safe-second args))
 	   (LOG (and logfile
 		     (open-output-file logfile
 				       (if (file-exists? logfile)
@@ -158,19 +161,20 @@
 	     (challenge (and match (match:substring match 1))))
 	(set-pop3-connection:challenge connection challenge))
       
-    connection))
+      connection)))
 
 
 ;; first try standard USER/PASS authentication, and switch to APOP
 ;; authentication if the server prefers.
 ;;: [string x string] -> status
 (define (pop3-login connection . args)
-  (let* ((netrc (and (< (length args) 2) (netrc:parse)))
+  (let ((netrc (and (< (length args) 2) (netrc:parse))))
-	 (login (or (safe-first args)
+    (let-optionals 
-		    (netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
+	args
+	((login (or (netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
 		    (call-error "must provide a login" pop3-login args)))
-	 (password (or (safe-second args)
+	 (password (or (netrc:lookup-password netrc 
-		       (netrc:lookup-password netrc (pop3-connection:host-name connection) #f)
+					      (pop3-connection:host-name connection) #f)
 		       (call-error "must provide a password" pop3-login args))))
     (with-handler
      (lambda (result punt)
@@ -183,7 +187,7 @@
        (pop3-send-command connection (format #f "PASS ~a" password))
        (set-pop3-connection:login connection login)
        (set-pop3-connection:password connection password)
-       (set-pop3-connection:state connection 'connected)))))
+       (set-pop3-connection:state connection 'connected))))))
 
 
 ;; Login to the server using APOP authentication (no cleartext

scheme/lib/sunet-utilities.scm

@@ -26,3 +26,31 @@
 		 (format #f "~A"
 			 (format-internet-host-address host-address))))))
 
+
+(define (dump fd)
+  (let loop ((c (read-char fd)))
+    (cond ((not (eof-object? c))
+           (write-char c)
+           (loop (read-char fd))))))
+
+;; out from ecm-utilities.scm
+;; please tell me if this doesn't work on your system.
+(define (system-fqdn)
+  (let ((sysname (system-name)))
+    (if (string-index sysname #\.)
+        sysname
+        (nslookup-fqdn))))
+
+;; This doesn't work on my system. Probably it is not configured well.
+;; Nevertheless, the alternative seems better to me
+;(define (nslookup-fqdn)
+;  (let* ((cmd (format #f "nslookup ~a" (system-name)))
+;         (raw (string-join (run/strings (nslookup ,(system-name)))))
+;         (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
+;    (display raw)
+;    (match:substring match 1)))
+
+(define (nslookup-fqdn)
+  (host-info:name (host-info (system-name))))
+; another easy alternative:
+;  (car (run/strings (hostname "--long"))))

scheme/packages.scm

@@ -214,13 +214,6 @@
 	  read-crlf-line-timeout
 	  write-crlf))
 
-(define-interface ecm-utilities-interface
-  (export system-fqdn
-          safe-first
-          safe-second
-          write-crlf
-          dump))
-
 (define-interface ls-interface 
   (export ls-crlf?
 	  ls
@@ -233,7 +226,9 @@
 (define-interface sunet-utilities-interface
   (export host-name-or-ip
 	  on-interrupt
-	  socket-address->string))
+	  socket-address->string
+	  dump
+	  system-fqdn))
 
 (define-interface handle-fatal-error-interface
   (export with-fatal-error-handler*
@@ -454,7 +449,6 @@
 	srfi-13
 	let-opt
 	receiving
-	
 	ascii
 	srfi-14
 	bitwise
@@ -465,7 +459,6 @@
 (define-structure url url-interface
   (open defrec-package
 	receiving
-	
 	srfi-13
 	srfi-14
 	uri
@@ -483,9 +476,10 @@
         conditions
         signals
         error-package
-        ecm-utilities
 	srfi-13
 	let-opt
+	sunet-utilities
+	crlf-io
         scheme)
   (files (lib ftp)))
 
@@ -522,9 +516,9 @@
 	records
         scsh        
         error-package
-        ecm-utilities
 	srfi-13
 	conditions signals handle
+	sunet-utilities
 	let-opt
         scheme)
   (files (lib netrc)))
@@ -536,8 +530,9 @@
         handle
         conditions
         signals
-        ecm-utilities
 	srfi-13
+	let-opt
+	crlf-io
         scheme)
   (files (lib pop3)))
 
@@ -612,12 +607,6 @@
 	scheme)	
   (files (lib crlf-io)))
 
-(define-structure ecm-utilities ecm-utilities-interface
-  (open scsh
-	srfi-13
-        scheme)
-  (files (lib ecm-utilities)))
-
 (define-structure ls ls-interface
   (open scheme handle
 	big-scheme bitwise
@@ -638,6 +627,7 @@
 	format-net
 	sigevents
 	let-opt
+	srfi-13
 	handle-fatal-error)
   (files (lib sunet-utilities)))