From 9b272be2b74aee6bc0a9a9d27709822995e29f12 Mon Sep 17 00:00:00 2001 From: sperber Date: Tue, 3 Dec 2002 10:50:26 +0000 Subject: [PATCH] Use DEFINE-RECORD-TYPES instead of DEFREC-PACKAGE in NETRC. --- scheme/lib/ftp.scm | 6 +- scheme/lib/netrc.scm | 156 ++++++++++++++++++++++--------------------- scheme/lib/pop3.scm | 6 +- scheme/packages.scm | 12 ++-- 4 files changed, 93 insertions(+), 87 deletions(-) diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm index fff7c37..88eec85 100644 --- a/scheme/lib/ftp.scm +++ b/scheme/lib/ftp.scm @@ -224,13 +224,13 @@ ;; default to login "anonymous" with password user@host. ;;: connection [ x string x password ] -> status (define (ftp-login connection . args) - (let ((netrc-record (netrc:parse))) + (let ((netrc-record (netrc-parse))) (let-optionals* args ((login - (netrc:lookup-login netrc-record + (netrc-lookup-login netrc-record (ftp-connection-host-name connection))) (password - (netrc:lookup-password netrc-record + (netrc-lookup-password netrc-record (ftp-connection-host-name connection)))) (set-ftp-connection-login! connection login) (set-ftp-connection-password! connection password) diff --git a/scheme/lib/netrc.scm b/scheme/lib/netrc.scm index aa5bfb1..2e10860 100644 --- a/scheme/lib/netrc.scm +++ b/scheme/lib/netrc.scm @@ -37,12 +37,12 @@ ;; What you probably want, is to read out the default netrc-file. Do the ;; following: ;; -;; (let ((netrc-record (netrc:parse))) -;; (netrc:lookup netrc-record "name of the machine")) +;; (let ((netrc-record (netrc-parse))) +;; (netrc-lookup netrc-record "name of the machine")) ;; ;; and you will receive three values: login-name, password and account-name. -;; If you only want the login-name or the password, use netrc:lookup-login -;; or netrc:lookup-password resp. +;; If you only want the login-name or the password, use netrc-lookup-login +;; or netrc-lookup-password resp. ;; ;; You will get either the login / password for the specified machine, ;; or a default login / password if the machine is unknown. @@ -54,7 +54,7 @@ ;; REPLYTO, if set. Otherwise the mail-address will look like ;; user@hostname. ;; -;; (netrc:parse [filename [fallback-password [fallback-login]]]) +;; (netrc-parse [filename [fallback-password [fallback-login]]]) ;; -> netrc-record ;; * parses the netrc file and returns a netrc-record, containing all ;; necessary information for the following procedures. @@ -72,38 +72,38 @@ ;; printed to current error port and a netrc-record filled with default ;; values is returned. ;; -;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record +;; (netrc-try-parse filename fallback-password fallback-login) -> netrc-record ;; parses the netrc file and returns a netrc-record, containing all ;; necessary information for the following procedures. ;; if there is no file called FILENAME, the according error will be raised ;; if the specified file does not have the correct permissions set, ;; a netrc-refuse-warning will be signalled. -;; so if you don't like the error handling of netrc:parse, use -;; netrc:try-parse and catch the signalled conditions. +;; so if you don't like the error handling of netrc-parse, use +;; netrc-try-parse and catch the signalled conditions. ;; -;; (netrc:lookup netrc-record machine [default?]) -> string x string x string +;; (netrc-lookup netrc-record machine [default?]) -> string x string x string ;; Return the login,password,account information for MACHINE ;; specified by the netrc file. ;; If DEFAULT? is #t, default values are returned if no such ;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f ;; is returned ;; -;; (netrc:lookup-password netrc-record machine [default?]) -> string +;; (netrc-lookup-password netrc-record machine [default?]) -> string ;; Return the password information for MACHINE specified by the ;; netrc file. ;; If DEFAULT? is #t, the default password is returned if no such ;; MACHINE is specified. Otherwise, #f is returned. ;; -;; (netrc:lookup-login netrc-record machine [default?]) -> string +;; (netrc-lookup-login netrc-record machine [default?]) -> string ;; Return the login information for MACHINE specified by the ;; netrc file. ;; If DEFAULT? is #t, the default login is returned if no such ;; MACHINE is specified. Otherwise, #f is returned. ;; -;; (netrc:default-login netrc-record) -> string +;; (netrc-default-login netrc-record) -> string ;; Return the default login specified by the netrc file or "anonymous" ;; -;; (netrc:default-password netrc-record) -> string +;; (netrc-default-password netrc-record) -> string ;; Return the default password specified by the netrc file or ;; the mail-addres (result of (user-mail-address)) @@ -141,44 +141,44 @@ ; if lookup-default? is #t ; following three values are returned: default-login default-password #f ; otherwise #f #f #f is returned. -(define (netrc:lookup netrc-record machine . lookup-default?) +(define (netrc-lookup netrc-record machine . lookup-default?) (let-optionals lookup-default? ((lookup-default? #t)) (let ((record (find-record netrc-record machine))) (if record - (values (netrc-entry:login record) - (netrc-entry:password record) - (netrc-entry:account record)) + (values (netrc-entry-login record) + (netrc-entry-password record) + (netrc-entry-account record)) (if lookup-default? - (values (netrc:default-login netrc-record) - (netrc:default-password netrc-record) + (values (netrc-default-login netrc-record) + (netrc-default-password netrc-record) #f) (values #f #f #f)))))) -; does the same as netrc:lookup, but returns only the password (or #f) -(define (netrc:lookup-password netrc-record machine . lookup-default?) +; does the same as netrc-lookup, but returns only the password (or #f) +(define (netrc-lookup-password netrc-record machine . lookup-default?) (let-optionals lookup-default? ((lookup-default? #t)) (let ((record (find-record netrc-record machine))) (if record - (netrc-entry:password record) + (netrc-entry-password record) (and lookup-default? - (netrc:default-password netrc-record)))))) + (netrc-default-password netrc-record)))))) -; does the same as netrc:lookup, but returns only the login (or #f) -(define (netrc:lookup-login netrc-record machine . lookup-default?) +; does the same as netrc-lookup, but returns only the login (or #f) +(define (netrc-lookup-login netrc-record machine . lookup-default?) (let-optionals lookup-default? ((lookup-default? #t)) (let ((record (find-record netrc-record machine))) (if record - (netrc-entry:login record) + (netrc-entry-login record) (and lookup-default? - (netrc:default-login netrc-record)))))) + (netrc-default-login netrc-record)))))) -; does the work for netrc:parse +; does the work for netrc-parse ; file-name has to be resolved -(define (netrc:try-parse file-name default-password default-login) - (netrc:check-permissions file-name) +(define (netrc-try-parse file-name default-password default-login) + (netrc-check-permissions file-name) (let ((fd (open-input-file file-name)) (netrc-record (make-netrc '() default-password default-login file-name))) (for-each-line (parse-line netrc-record) fd))) @@ -194,15 +194,15 @@ ; default login in netrc-file overwrites this setting ; * (default-login is expected after default-password as users usually want ; to change the default-password (to something else than their mail-address) -; rather than the login-name)(define (netrc:parse . args) +; rather than the login-name)(define (netrc-parse . args) ; * if the given file does not exist or it has the wrong permissions, ; than a default netrc-record is returned -; * if you don't want expected errors to be captured, use netrc:try-parse; +; * if you don't want expected errors to be captured, use netrc-try-parse; ; note that you have to resolve the file-name on your own (define-condition-type 'netrc-refuse '(warning)) (define netrc-refuse? (condition-predicate 'netrc-refuse)) -(define (netrc:parse . args) +(define (netrc-parse . args) (let-optionals args ((file-name "~/.netrc") (default-password #f) ; both ... @@ -224,10 +224,10 @@ (lambda (error more) (if (netrc-refuse? error) (format (current-error-port) - "netrc: Warning: ~a~%" + "netrc- Warning: ~a~%" (car (condition-stuff error))) (format (current-error-port) - "netrc: Warning: Unexpected error encountered: ~s~%" + "netrc- Warning: Unexpected error encountered: ~s~%" error)) (exit (local-default-netrc-record))) (lambda () @@ -235,15 +235,15 @@ (lambda (errno packet) (if (= errno errno/noent) (format (current-error-port) - "netrc: Warning: no such file or directory: ~a~%" + "netrc- Warning: no such file or directory: ~a~%" file-name) (format (current-error-port) - "netrc: Warning: Error accessing file ~s~%" + "netrc- Warning: Error accessing file ~s~%" file-name)) (exit (local-default-netrc-record))) (lambda () (let ((netrc-record - (netrc:try-parse file-name default-password default-login))) + (netrc-try-parse file-name default-password default-login))) ; If we get a netrc-record, we return it after ; checking default login and default password settings. ; Otherwise, we return the default record with @@ -253,39 +253,45 @@ ; checking mechanism. (if (netrc? netrc-record) (begin - (if (eq? (netrc:default-login netrc-record) #f) - (set-netrc:default-login (local-default-login))) - (if (eq? (netrc:default-password netrc-record) #f) - (set-netrc:default-password (local-default-password))) + (if (eq? (netrc-default-login netrc-record) #f) + (set-netrc-default-login! (local-default-login))) + (if (eq? (netrc-default-password netrc-record) #f) + (set-netrc-default-password! (local-default-password))) netrc-record) (let ((default-netrc-record (local-default-netrc-record))) - (set-netrc:file-name default-netrc-record file-name) + (set-netrc-file-name! default-netrc-record file-name) default-netrc-record)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; nothing exported below ;; except -;; netrc:default-password -;; netrc:default-login +;; netrc-default-password +;; netrc-default-login -(define-record netrc-entry - machine - login - password - account) +(define-record-type netrc-entry :netrc-entry + (make-netrc-entry machine login password account) + netrc-entry? + (machine netrc-entry-machine) + (login netrc-entry-login) + (password netrc-entry-password) + (account netrc-entry-account)) -(define-record netrc - entries ; list of netrc-entrys - default-login ; default-values (either library-default or netrc-file-default) - default-password - file-name) ; debug-purpose +(define-record-type netrc :netrc + (make-netrc entries default-login default-password file-name) + netrc? + ;; list of netrc-entrys + (entries netrc-entries set-netrc-entries!) + ;; default-values (either library-default or netrc-file-default) + (default-login netrc-default-login set-netrc-default-login!) + (default-password netrc-default-password set-netrc-default-password!) + (file-name netrc-file-name set-netrc-file-name!)) -(define-record-discloser type/netrc-entry +(define-record-discloser :netrc-entry (lambda (netrc-entry) (list 'netrc-entry))) ; perhaps something else later on -(define-record-discloser type/netrc +(define-record-discloser :netrc (lambda (netrc) (list 'netrc))) ; perhaps something else later on @@ -294,13 +300,13 @@ ; returns the netrc-entry-record if found, otherwise #f (define (find-record netrc-record machine) (find-first (lambda (rec) - (and (equal? (netrc-entry:machine rec) machine) + (and (equal? (netrc-entry-machine rec) machine) rec)) - (netrc:entries netrc-record))) + (netrc-entries netrc-record))) ;; raise error if any permissions are set for group or others. -(define (netrc:check-permissions file-name) +(define (netrc-check-permissions file-name) (let ((perms (- (file-mode file-name) 32768))) (if (positive? (bitwise-and #b000111111 perms)) (signal 'netrc-refuse @@ -320,9 +326,9 @@ (let ((login (try-match "login[ \t]+([^ \t]+)" line)) (password (try-match "password[ \t]+([^ \t]+)" line))) (if login - (set-netrc:default-login netrc-record login)) + (set-netrc-default-login! netrc-record login)) (if password - (set-netrc:default-password netrc-record password)) + (set-netrc-default-password! netrc-record password)) netrc-record)) ; parses a line of the netrc-file @@ -345,24 +351,24 @@ ; adds machine login password account stored in a netrc-entry-record ; to the entries-list of a netrc-record (define (add netrc-record machine login password account) - (set-netrc:entries netrc-record - (cons (make-netrc-entry machine login password account) - (netrc:entries netrc-record))) + (set-netrc-entries! netrc-record + (cons (make-netrc-entry machine login password account) + (netrc-entries netrc-record))) netrc-record) ;; for testing -(define (netrc:dump netrc-record) - (format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record)) +(define (netrc-dump netrc-record) + (format #t "~%--- Dumping ~s contents ---" (netrc-file-name netrc-record)) (for-each (lambda (rec) (format #t "~% machine ~a login ~a password ~a account ~a" - (netrc-entry:machine rec) - (netrc-entry:login rec) - (netrc-entry:password rec) - (netrc-entry:account rec))) - (netrc:entries netrc-record)) - (format #t "~% default login: ~s" (netrc:default-login netrc-record)) - (format #t "~% default password: ~s" (netrc:default-password netrc-record)) - (format #t "~%--- End of ~s contents ---~%" (netrc:file-name netrc-record))) + (netrc-entry-machine rec) + (netrc-entry-login rec) + (netrc-entry-password rec) + (netrc-entry-account rec))) + (netrc-entries netrc-record)) + (format #t "~% default login: ~s" (netrc-default-login netrc-record)) + (format #t "~% default password: ~s" (netrc-default-password netrc-record)) + (format #t "~%--- End of ~s contents ---~%" (netrc-file-name netrc-record))) ; runs proc for each line of fd (line is argument to proc) diff --git a/scheme/lib/pop3.scm b/scheme/lib/pop3.scm index 220f03d..b05c9cb 100644 --- a/scheme/lib/pop3.scm +++ b/scheme/lib/pop3.scm @@ -169,12 +169,12 @@ ;; 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)))) (let-optionals args - ((login (or (netrc:lookup-login netrc (pop3-connection:host-name connection) #f) + ((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 + (password (or (netrc-lookup-password netrc (pop3-connection:host-name connection) #f) (call-error "must provide a password" pop3-login args)))) (with-handler diff --git a/scheme/packages.scm b/scheme/packages.scm index b7fe797..aaa96f5 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -132,11 +132,11 @@ (define-interface netrc-interface (export user-mail-address - netrc:lookup - netrc:lookup-password - netrc:lookup-login - netrc:parse - netrc:try-parse + netrc-lookup + netrc-lookup-password + netrc-lookup-login + netrc-parse + netrc-try-parse netrc-refuse?)) (define-interface pop3-interface @@ -509,7 +509,7 @@ (define-structure netrc netrc-interface (open scheme-with-scsh - defrec-package + define-record-types records error-package srfi-13