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

Use DEFINE-RECORD-TYPES instead of DEFREC-PACKAGE in NETRC.

This commit is contained in:
sperber 2002-12-03 10:50:26 +00:00
parent fe96c5f2b2
commit 9b272be2b7
4 changed files with 93 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scheme/lib/ftp.scm
View File

@ -224,13 +224,13 @@
;; default to login "anonymous" with password user@host. ;; default to login "anonymous" with password user@host.
;;: connection [ x string x password ] -> status ;;: connection [ x string x password ] -> status
(define (ftp-login connection . args) (define (ftp-login connection . args)
(let ((netrc-record (netrc:parse))) (let ((netrc-record (netrc-parse)))
(let-optionals* args (let-optionals* args
((login ((login
(netrc:lookup-login netrc-record (netrc-lookup-login netrc-record
(ftp-connection-host-name connection))) (ftp-connection-host-name connection)))
(password (password
(netrc:lookup-password netrc-record (netrc-lookup-password netrc-record
(ftp-connection-host-name connection)))) (ftp-connection-host-name connection))))
(set-ftp-connection-login! connection login) (set-ftp-connection-login! connection login)
(set-ftp-connection-password! connection password) (set-ftp-connection-password! connection password)

154
scheme/lib/netrc.scm
View File

@ -37,12 +37,12 @@
;; What you probably want, is to read out the default netrc-file. Do the ;; What you probably want, is to read out the default netrc-file. Do the
;; following: ;; following:
;; ;;
;; (let ((netrc-record (netrc:parse))) ;; (let ((netrc-record (netrc-parse)))
;; (netrc:lookup netrc-record "name of the machine")) ;; (netrc-lookup netrc-record "name of the machine"))
;; ;;
;; and you will receive three values: login-name, password and account-name. ;; 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 ;; If you only want the login-name or the password, use netrc-lookup-login
;; or netrc:lookup-password resp. ;; or netrc-lookup-password resp.
;; ;;
;; You will get either the login / password for the specified machine, ;; You will get either the login / password for the specified machine,
;; or a default login / password if the machine is unknown. ;; or a default login / password if the machine is unknown.
@ -54,7 +54,7 @@
;; REPLYTO, if set. Otherwise the mail-address will look like ;; REPLYTO, if set. Otherwise the mail-address will look like
;; user@hostname. ;; user@hostname.
;; ;;
;; (netrc:parse [filename [fallback-password [fallback-login]]]) ;; (netrc-parse [filename [fallback-password [fallback-login]]])
;; -> netrc-record ;; -> netrc-record
;; * parses the netrc file and returns a netrc-record, containing all ;; * parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures. ;; necessary information for the following procedures.
@ -72,38 +72,38 @@
;; printed to current error port and a netrc-record filled with default ;; printed to current error port and a netrc-record filled with default
;; values is returned. ;; 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 ;; parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures. ;; necessary information for the following procedures.
;; if there is no file called FILENAME, the according error will be raised ;; if there is no file called FILENAME, the according error will be raised
;; if the specified file does not have the correct permissions set, ;; if the specified file does not have the correct permissions set,
;; a netrc-refuse-warning will be signalled. ;; a netrc-refuse-warning will be signalled.
;; so if you don't like the error handling of netrc:parse, use ;; so if you don't like the error handling of netrc-parse, use
;; netrc:try-parse and catch the signalled conditions. ;; 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 ;; Return the login,password,account information for MACHINE
;; specified by the netrc file. ;; specified by the netrc file.
;; If DEFAULT? is #t, default values are returned if no such ;; If DEFAULT? is #t, default values are returned if no such
;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f ;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f
;; is returned ;; 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 ;; Return the password information for MACHINE specified by the
;; netrc file. ;; netrc file.
;; If DEFAULT? is #t, the default password is returned if no such ;; If DEFAULT? is #t, the default password is returned if no such
;; MACHINE is specified. Otherwise, #f is returned. ;; 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 ;; Return the login information for MACHINE specified by the
;; netrc file. ;; netrc file.
;; If DEFAULT? is #t, the default login is returned if no such ;; If DEFAULT? is #t, the default login is returned if no such
;; MACHINE is specified. Otherwise, #f is returned. ;; 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" ;; 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 ;; Return the default password specified by the netrc file or
;; the mail-addres (result of (user-mail-address)) ;; the mail-addres (result of (user-mail-address))
@ -141,44 +141,44 @@
; if lookup-default? is #t ; if lookup-default? is #t
; following three values are returned: default-login default-password #f ; following three values are returned: default-login default-password #f
; otherwise #f #f #f is returned. ; 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? (let-optionals lookup-default?
((lookup-default? #t)) ((lookup-default? #t))
(let ((record (find-record netrc-record machine))) (let ((record (find-record netrc-record machine)))
(if record (if record
(values (netrc-entry:login record) (values (netrc-entry-login record)
(netrc-entry:password record) (netrc-entry-password record)
(netrc-entry:account record)) (netrc-entry-account record))
(if lookup-default? (if lookup-default?
(values (netrc:default-login netrc-record) (values (netrc-default-login netrc-record)
(netrc:default-password netrc-record) (netrc-default-password netrc-record)
#f) #f)
(values #f #f #f)))))) (values #f #f #f))))))
; does the same as netrc:lookup, but returns only the password (or #f) ; does the same as netrc-lookup, but returns only the password (or #f)
(define (netrc:lookup-password netrc-record machine . lookup-default?) (define (netrc-lookup-password netrc-record machine . lookup-default?)
(let-optionals lookup-default? (let-optionals lookup-default?
((lookup-default? #t)) ((lookup-default? #t))
(let ((record (find-record netrc-record machine))) (let ((record (find-record netrc-record machine)))
(if record (if record
(netrc-entry:password record) (netrc-entry-password record)
(and lookup-default? (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) ; does the same as netrc-lookup, but returns only the login (or #f)
(define (netrc:lookup-login netrc-record machine . lookup-default?) (define (netrc-lookup-login netrc-record machine . lookup-default?)
(let-optionals lookup-default? (let-optionals lookup-default?
((lookup-default? #t)) ((lookup-default? #t))
(let ((record (find-record netrc-record machine))) (let ((record (find-record netrc-record machine)))
(if record (if record
(netrc-entry:login record) (netrc-entry-login record)
(and lookup-default? (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 ; file-name has to be resolved
(define (netrc:try-parse file-name default-password default-login) (define (netrc-try-parse file-name default-password default-login)
(netrc:check-permissions file-name) (netrc-check-permissions file-name)
(let ((fd (open-input-file file-name)) (let ((fd (open-input-file file-name))
(netrc-record (make-netrc '() default-password default-login file-name))) (netrc-record (make-netrc '() default-password default-login file-name)))
(for-each-line (parse-line netrc-record) fd))) (for-each-line (parse-line netrc-record) fd)))
@ -194,15 +194,15 @@
; default login in netrc-file overwrites this setting ; default login in netrc-file overwrites this setting
; * (default-login is expected after default-password as users usually want ; * (default-login is expected after default-password as users usually want
; to change the default-password (to something else than their mail-address) ; 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, ; * if the given file does not exist or it has the wrong permissions,
; than a default netrc-record is returned ; 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 ; note that you have to resolve the file-name on your own
(define-condition-type 'netrc-refuse '(warning)) (define-condition-type 'netrc-refuse '(warning))
(define netrc-refuse? (condition-predicate 'netrc-refuse)) (define netrc-refuse? (condition-predicate 'netrc-refuse))
(define (netrc:parse . args) (define (netrc-parse . args)
(let-optionals (let-optionals
args ((file-name "~/.netrc") args ((file-name "~/.netrc")
(default-password #f) ; both ... (default-password #f) ; both ...
@ -224,10 +224,10 @@
(lambda (error more) (lambda (error more)
(if (netrc-refuse? error) (if (netrc-refuse? error)
(format (current-error-port) (format (current-error-port)
"netrc: Warning: ~a~%" "netrc- Warning: ~a~%"
(car (condition-stuff error))) (car (condition-stuff error)))
(format (current-error-port) (format (current-error-port)
"netrc: Warning: Unexpected error encountered: ~s~%" "netrc- Warning: Unexpected error encountered: ~s~%"
error)) error))
(exit (local-default-netrc-record))) (exit (local-default-netrc-record)))
(lambda () (lambda ()
@ -235,15 +235,15 @@
(lambda (errno packet) (lambda (errno packet)
(if (= errno errno/noent) (if (= errno errno/noent)
(format (current-error-port) (format (current-error-port)
"netrc: Warning: no such file or directory: ~a~%" "netrc- Warning: no such file or directory: ~a~%"
file-name) file-name)
(format (current-error-port) (format (current-error-port)
"netrc: Warning: Error accessing file ~s~%" "netrc- Warning: Error accessing file ~s~%"
file-name)) file-name))
(exit (local-default-netrc-record))) (exit (local-default-netrc-record)))
(lambda () (lambda ()
(let ((netrc-record (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 ; If we get a netrc-record, we return it after
; checking default login and default password settings. ; checking default login and default password settings.
; Otherwise, we return the default record with ; Otherwise, we return the default record with
@ -253,39 +253,45 @@
; checking mechanism. ; checking mechanism.
(if (netrc? netrc-record) (if (netrc? netrc-record)
(begin (begin
(if (eq? (netrc:default-login netrc-record) #f) (if (eq? (netrc-default-login netrc-record) #f)
(set-netrc:default-login (local-default-login))) (set-netrc-default-login! (local-default-login)))
(if (eq? (netrc:default-password netrc-record) #f) (if (eq? (netrc-default-password netrc-record) #f)
(set-netrc:default-password (local-default-password))) (set-netrc-default-password! (local-default-password)))
netrc-record) netrc-record)
(let ((default-netrc-record (local-default-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)))))))))))) default-netrc-record))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below ;; nothing exported below
;; except ;; except
;; netrc:default-password ;; netrc-default-password
;; netrc:default-login ;; netrc-default-login
(define-record netrc-entry (define-record-type netrc-entry :netrc-entry
machine (make-netrc-entry machine login password account)
login netrc-entry?
password (machine netrc-entry-machine)
account) (login netrc-entry-login)
(password netrc-entry-password)
(account netrc-entry-account))
(define-record netrc (define-record-type netrc :netrc
entries ; list of netrc-entrys (make-netrc entries default-login default-password file-name)
default-login ; default-values (either library-default or netrc-file-default) netrc?
default-password ;; list of netrc-entrys
file-name) ; debug-purpose (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) (lambda (netrc-entry)
(list 'netrc-entry))) ; perhaps something else later on (list 'netrc-entry))) ; perhaps something else later on
(define-record-discloser type/netrc (define-record-discloser :netrc
(lambda (netrc) (lambda (netrc)
(list 'netrc))) ; perhaps something else later on (list 'netrc))) ; perhaps something else later on
@ -294,13 +300,13 @@
; returns the netrc-entry-record if found, otherwise #f ; returns the netrc-entry-record if found, otherwise #f
(define (find-record netrc-record machine) (define (find-record netrc-record machine)
(find-first (lambda (rec) (find-first (lambda (rec)
(and (equal? (netrc-entry:machine rec) machine) (and (equal? (netrc-entry-machine rec) machine)
rec)) rec))
(netrc:entries netrc-record))) (netrc-entries netrc-record)))
;; raise error if any permissions are set for group or others. ;; 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))) (let ((perms (- (file-mode file-name) 32768)))
(if (positive? (bitwise-and #b000111111 perms)) (if (positive? (bitwise-and #b000111111 perms))
(signal 'netrc-refuse (signal 'netrc-refuse
@ -320,9 +326,9 @@
(let ((login (try-match "login[ \t]+([^ \t]+)" line)) (let ((login (try-match "login[ \t]+([^ \t]+)" line))
(password (try-match "password[ \t]+([^ \t]+)" line))) (password (try-match "password[ \t]+([^ \t]+)" line)))
(if login (if login
(set-netrc:default-login netrc-record login)) (set-netrc-default-login! netrc-record login))
(if password (if password
(set-netrc:default-password netrc-record password)) (set-netrc-default-password! netrc-record password))
netrc-record)) netrc-record))
; parses a line of the netrc-file ; parses a line of the netrc-file
@ -345,24 +351,24 @@
; adds machine login password account stored in a netrc-entry-record ; adds machine login password account stored in a netrc-entry-record
; to the entries-list of a netrc-record ; to the entries-list of a netrc-record
(define (add netrc-record machine login password account) (define (add netrc-record machine login password account)
(set-netrc:entries netrc-record (set-netrc-entries! netrc-record
(cons (make-netrc-entry machine login password account) (cons (make-netrc-entry machine login password account)
(netrc:entries netrc-record))) (netrc-entries netrc-record)))
netrc-record) netrc-record)
;; for testing ;; for testing
(define (netrc:dump netrc-record) (define (netrc-dump netrc-record)
(format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record)) (format #t "~%--- Dumping ~s contents ---" (netrc-file-name netrc-record))
(for-each (lambda (rec) (for-each (lambda (rec)
(format #t "~% machine ~a login ~a password ~a account ~a" (format #t "~% machine ~a login ~a password ~a account ~a"
(netrc-entry:machine rec) (netrc-entry-machine rec)
(netrc-entry:login rec) (netrc-entry-login rec)
(netrc-entry:password rec) (netrc-entry-password rec)
(netrc-entry:account rec))) (netrc-entry-account rec)))
(netrc:entries netrc-record)) (netrc-entries netrc-record))
(format #t "~% default login: ~s" (netrc:default-login netrc-record)) (format #t "~% default login: ~s" (netrc-default-login netrc-record))
(format #t "~% default password: ~s" (netrc:default-password netrc-record)) (format #t "~% default password: ~s" (netrc-default-password netrc-record))
(format #t "~%--- End of ~s contents ---~%" (netrc:file-name 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) ; runs proc for each line of fd (line is argument to proc)

6
scheme/lib/pop3.scm
View File

@ -169,12 +169,12 @@
;; authentication if the server prefers. ;; authentication if the server prefers.
;;: [string x string] -> status ;;: [string x string] -> status
(define (pop3-login connection . args) (define (pop3-login connection . args)
(let ((netrc (and (< (length args) 2) (netrc:parse)))) (let ((netrc (and (< (length args) 2) (netrc-parse))))
(let-optionals (let-optionals
args 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))) (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) (pop3-connection:host-name connection) #f)
(call-error "must provide a password" pop3-login args)))) (call-error "must provide a password" pop3-login args))))
(with-handler (with-handler

12
scheme/packages.scm
View File

@ -132,11 +132,11 @@
(define-interface netrc-interface (define-interface netrc-interface
(export user-mail-address (export user-mail-address
netrc:lookup netrc-lookup
netrc:lookup-password netrc-lookup-password
netrc:lookup-login netrc-lookup-login
netrc:parse netrc-parse
netrc:try-parse netrc-try-parse
netrc-refuse?)) netrc-refuse?))
(define-interface pop3-interface (define-interface pop3-interface
@ -509,7 +509,7 @@
(define-structure netrc netrc-interface (define-structure netrc netrc-interface
(open scheme-with-scsh (open scheme-with-scsh
defrec-package define-record-types
records records
error-package error-package
srfi-13 srfi-13