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

netrc:parse handles following conditions correctly by returning 

a default netrc-record:
* the specified file does not exist
* the file does exist but does not have the correct permissions
In both cases a warning is printed on (current-error-port)
So, netrc:parse always returns a usable record.
If you want to catch the errors use netrc:try-parse
This commit is contained in:
interp 2001-12-27 16:45:32 +00:00
parent 89bb20c63e
commit f9dc21c767
2 changed files with 125 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
modules.scm
View File

@ -533,7 +533,8 @@
netrc:lookup-password netrc:lookup-password
netrc:lookup-login netrc:lookup-login
netrc:parse netrc:parse
netrc:try-parse)) netrc:try-parse
netrc-refuse?))
(define-structure netrc netrc-interface (define-structure netrc netrc-interface
(open defrec-package (open defrec-package
@ -542,7 +543,7 @@
error-package error-package
ecm-utilities ecm-utilities
string-lib string-lib
conditions signals conditions signals handle
let-opt let-opt
scheme) scheme)
(files netrc)) (files netrc))

141
netrc.scm
View File

@ -1,6 +1,6 @@
;;; netrc.scm -- parse authentication information contained in ~/.netrc ;;; netrc.scm -- parse authentication information contained in ~/.netrc
;; ;;
;; $Id: netrc.scm,v 1.3 2001/12/18 18:08:08 interp Exp $ ;; $Id: netrc.scm,v 1.4 2001/12/27 16:45:32 interp Exp $
;; ;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr> ;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
@ -27,7 +27,7 @@
;; * The macdef statement (defining macros) is not supported. ;; * The macdef statement (defining macros) is not supported.
;; * The settings for one machine must be on a single line. ;; * The settings for one machine must be on a single line.
;; * The is no error proof while reading the file. ;; * The is no error proof while reading the file.
;; * default must not be the last line of the netrc-file ;; * default need not be the last line of the netrc-file
@ -36,22 +36,61 @@
;; (user-mail-address) -> string ;; (user-mail-address) -> string
;; Calculate the user's email address, as per the Emacs function of ;; Calculate the user's email address, as per the Emacs function of
;; the same name. Will take into account the environment variable ;; the same name. Will take into account the environment variable
;; REPLYTO, if set. ;; REPLYTO, if set. Otherwise the mail-address will look like
;; user@hostname.
;; ;;
;; (netrc:default-login) -> string ;; (netrc:parse [filename [fallback-password [fallback-login]]])
;; Return the default login specified by the ~/.netrc file or "anonymous" ;; -> netrc-record
;; * parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures.
;; * FILENAME defaults to "~/.netrc"
;; FALLBACK-PASSWORD defaults to the result of (user-mail-address)
;; FALLBACK-LOGIN defaults to "anonymous"
;; * if the netrc file does not provide a default password or a default
;; login (stated by the "default" statement), FALLBACK-PASSWORD and
;; FALLBACK-LOGIN will be used as default password or login, respectively.
;; (thus, user-mail-address is only called if the netrc file does not
;; contain a default specification)
;; * if the netrc file does not exist, a netrc-record filled with
;; default values is returned.
;; * if the netrc file does not have the correct permissions, a message is
;; printed to current error port and a netrc-record filled with default
;; values is returned.
;; ;;
;; (netrc:default-password) -> string ;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record
;; Return the default password specified by the ~/.netrc file or ;; parses the netrc file and returns a netrc-record, containing all
;; to the mail-addres (result of (user-mail-address)) ;; 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.
;; ;;
;; (netrc:lookup machine) -> 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 there is no such machine specified, the condition 'netrc:no-such-entry ;; If DEFAULT? is #t, default values are returned if no such
;; is signalled, that can be caught with with-handler. ;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f
;; If you catch this signal, you probably want to use netrc:default-login ;; is returned
;; and netrc:default-password, that are always set to usable values. ;;
;; (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
;; 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
;; Return the default login specified by the netrc file or "anonymous"
;;
;; (netrc:default-password netrc-record) -> string
;; Return the default password specified by the netrc file or
;; the mail-addres (result of (user-mail-address))
@ -61,7 +100,7 @@
;; Netrc.pm ;; Netrc.pm
;; ;;
;; * ange-ftp.el (transparent remote file access for Emacs) parses the ;; * ange-ftp.el (transparent remote file access for Emacs) parses the
;; user's ~/.netrc file ;; user's netrc file
;;; Portability ================================================== ;;; Portability ==================================================
@ -74,9 +113,12 @@
;; ;;
;; * Remove restrictions (as stated in 'Overview') and behave like ;; * Remove restrictions (as stated in 'Overview') and behave like
;; /usr/bin/ftp behaves ;; /usr/bin/ftp behaves
;; * perhaps: adding case-insensitivity ;; * perhaps: adding case-insensitivity (for host names)
;; * perhaps: better record-disclosers for netrc-entry- and netrc-records ;; * perhaps: better record-disclosers for netrc-entry- and netrc-records
; return the user's mail address, either specified by the environment
; variable REPLYTO or "user@hostname".
(define (user-mail-address) (define (user-mail-address)
(or (getenv "REPLYTO") (or (getenv "REPLYTO")
(string-append (user-login-name) "@" (system-fqdn)))) (string-append (user-login-name) "@" (system-fqdn))))
@ -98,7 +140,7 @@
(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))
(and 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)
@ -141,38 +183,70 @@
; default-login: default login name for any not specified machine ; default-login: default login name for any not specified machine
; defaults to "anonymous" ; defaults to "anonymous"
; 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, than a default netrc-record is returned ; * if the given file does not exist or it has the wrong permissions,
; if you don't want this, use netrc:try-parse; note that you have to ; than a default netrc-record is returned
; resolve the file-name on your own ; * 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 (let-optionals
args ((file-name "~/.netrc") args ((file-name "~/.netrc")
(default-password #f) ; both ... (default-password #f) ; both ...
(default-login #f)) ; ... are set if netrc-file does not provide default-values (default-login #f)) ; ... are set if netrc-file does
(let ((file-name (resolve-file-name file-name))) ; not provide default-values
(let* ((file-name (resolve-file-name file-name))
(local-default-login (lambda () "anonymous"))
(local-default-password (lambda () (user-mail-address)))
(local-default-netrc-record
(lambda ()
(make-netrc '()
(or default-login (local-default-login))
(or default-password (local-default-password))
#f))))
; i know, this double-handler sucks; has anyone a better idea?
(call-with-current-continuation (call-with-current-continuation
(lambda (exit) (lambda (exit)
(with-handler
(lambda (error more)
(if (netrc-refuse? error)
(begin
(format (current-error-port)
"netrc: Warning: ~a~%"
(car (condition-stuff error)))
(exit (local-default-netrc-record)))))
(lambda ()
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(if (= errno errno/noent) (if (= errno errno/noent)
(exit (make-netrc '() (begin
(or default-login "anonymous") (format (current-error-port)
(or default-password (user-mail-address)) "netrc: Warning: no such file or directory: ~a~%"
#f)))) file-name)
(exit (local-default-netrc-record)))))
(lambda () (lambda ()
(let ((netrc-record (netrc:try-parse file-name default-password default-login))) (let ((netrc-record
(netrc:try-parse file-name default-password default-login)))
(if netrc-record (if netrc-record
netrc-record netrc-record
(begin (begin
(set-netrc:default-password netrc-record (or default-password (user-mail-address))) (set-netrc:default-password
(set-netrc:default-login netrc-record (or default-login "anonymous")) netrc-record
netrc-record)))))))))) (or default-password (local-default-password)))
(set-netrc:default-login
netrc-record
(or default-login (local-default-login)))
netrc-record))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below ;; nothing exported below
;; except
;; netrc:default-password
;; netrc:default-login
(define-record netrc-entry (define-record netrc-entry
machine machine
@ -209,7 +283,10 @@
(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))
(error "Not parsing ~/.netrc file; dangerous permissions.")))) (signal 'netrc-refuse
(format #f
"Not parsing ~s (netrc file); dangerous permissions."
file-name)))))
; tries to match target on line and returns the first group, ; tries to match target on line and returns the first group,
; or #f if there is no match ; or #f if there is no match