In POP3:

- consolidate login procedure into POP3-CONNECT
- logging goes to a port, not a file
- fix error-handling bug in pop3-login
- rename POP3-LOGIN/APOP -> POP3-APOP-LOGIN
- replace POSIX regexp for challenge by SRE

scheme/lib/pop3.scm

@@ -45,20 +45,13 @@
 ;; at the beginning of a line by a single decimal point.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;;: [host x logfile] -> connection
 (define (pop3-connect . args)
-  (let-optionals
-      args
-      ((host-arg #f)
-       (logfile #f))
-    (let* ((host (or (getenv "MAILHOST")
-		     host-arg))
-	   (LOG (and logfile
-		     (open-output-file logfile
-				       (if (file-exists? logfile)
-					   (bitwise-ior open/write open/append)
-					   (bitwise-ior open/write open/create))
-				       #o600)))
+  (let-optionals args ((host-arg #f)
+		       (login #f)
+		       (password #f)
+		       (log #f))
+    (let* ((host (or host-arg
+		     (getenv "MAILHOST")))
 	   (hst-info (host-info host))
 	   (hostname (host-info:name hst-info))
 	   (srvc-info (service-info "pop3" "tcp"))
@@ -68,47 +61,57 @@
 				 (service-info:port srvc-info)))
 	   (connection (make-pop3-connection hostname
 					     sock
-					     LOG "" "" #f #f)))
+					     log "" "" #f #f)))
       (pop3-log connection
-		(format #f "~%-- ~a: opened POP3 connection to ~a"
-			;; (date->string (date))
-			"Dummy date"      ; (format-time-zone) is broken in v0.5.1
-			hostname))
+		(string-append "-- "
+			       (date->string (date))
+			       ": opened POP3 connection to "
+			       hostname))
 
       ;; read the challenge the server sends in its welcome banner
       (let* ((banner (pop3-read-response connection))
-	     (match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
+	     (match (regexp-search (rx (: "+OK " (* (~ #\<))
+					  #\< (submatch (+ (~ #\>))) #\>))
+				   banner))
 	     (challenge (and match (match:substring match 1))))
 	(set-pop3-connection-challenge! connection challenge))
       
+      (pop3-login connection login password)
+      
       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-optionals 
-	args
-	((login (or (netrc-lookup-login netrc (pop3-connection-host-name connection) #f)
-		    (call-error "must provide a login" pop3-login args)))
-	 (password (or (netrc-lookup-password netrc 
-					      (pop3-connection-host-name connection) #f)
-		       (call-error "must provide a password" pop3-login args))))
-    (with-handler
-     (lambda (result punt)
-       (if (-ERR? result)
-           (if (pop3-connection-challenge connection)
-               (pop3-login/APOP connection login password)
-               (error "login failed"))))
-     (lambda ()
-       (pop3-send-command connection (format #f "USER ~a" login))
-       (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))))))
 
+(define (pop3-login connection login password)
+  (let* ((netrc-record #f)
+	 (get-netrc-record
+	  (lambda ()
+	    (cond
+	     (netrc-record)
+	     (else
+	      (set! netrc-record (netrc-parse))
+	      netrc-record)))))
+    (let ((login (or login
+		     (netrc-lookup-login (get-netrc-record)
+					 (pop3-connection-host-name connection)
+					 #f)))
+	  (password (or password
+			(netrc-lookup-password (get-netrc-record)
+					       (pop3-connection-host-name connection)
+					       #f))))
+      (with-fatal-error-handler*
+       (lambda (result punt)
+	 (cond
+	  ((not (pop3-error? result)) (punt))
+	  ((pop3-connection-challenge connection)
+	   (pop3-apop-login connection login password))))
+       (lambda ()
+	 (pop3-send-command connection (format #f "USER ~a" login))
+	 (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))))))
 
 ;; Login to the server using APOP authentication (no cleartext
 ;; passwords are sent over the network). The server appends a token to
@@ -133,7 +136,7 @@
 ;;         c4c9334bac560ecc979e58001b3e22fb
 ;;         
 ;;: connection x string x string -> status
-(define (pop3-login/APOP connection login password)
+(define (pop3-apop-login connection login password)
   (let* ((key (string-append (pop3-connection-challenge connection)
                              password))
          (digest (number->string
@@ -145,7 +148,7 @@
   (set-pop3-connection-password! connection password)
   (set-pop3-connection-state! connection 'connected)
   status))
-  
+
 
 ;; return number of messages and number of bytes waiting at the maildrop
 ;;: connection -> integer x integer
@@ -216,10 +219,8 @@
   (challenge pop3-connection-challenge set-pop3-connection-challenge!)
   (state pop3-connection-state set-pop3-connection-state!))
 
-;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm
-(define-condition-type '-ERR '(error))
-(define -ERR? (condition-predicate '-ERR))
-
+(define-condition-type 'pop3-error '(error))
+(define pop3-error? (condition-predicate 'pop3-error))
 
 (define (pop3-check-transaction-state connection caller)
   (if (not (eq? (pop3-connection-state connection) 'connected))

scheme/packages.scm

@@ -127,7 +127,6 @@
 
 (define-interface pop3-interface
   (export pop3-connect
-          pop3-login
           pop3-stat
           pop3-get
           pop3-headers
@@ -448,7 +447,7 @@
 	netrc
         define-record-types
         handle
-        conditions
+        conditions handle-fatal-error
         signals
 	(subset srfi-13 (string-index))
 	let-opt