From: Chris Hanson Date: Wed, 12 Nov 1997 08:40:05 +0000 (+0000) Subject: Rewrite OS/2 and NT versions of CURRENT-USER-NAME, X-Git-Tag: 20090517-FFI~4935 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f8cd1e5ede57573b1d28f03fa2bb95dd6b5d2196;p=mit-scheme.git Rewrite OS/2 and NT versions of CURRENT-USER-NAME, CURRENT-HOME-DIRECTORY, and USER-HOME-DIRECTORY to use the same heuristics in both systems. Improve the heuristics so that these procedures will work with a minimum number of environment bindings. --- diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index 8c6a4102d..2384b7e0b 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.14 1997/11/11 13:20:21 cph Exp $ +$Id: ntprm.scm,v 1.15 1997/11/12 08:40:05 cph Exp $ Copyright (c) 1992-97 Massachusetts Institute of Technology @@ -241,43 +241,86 @@ MIT in each case. |# ) ; End LET -(define (current-home-directory) - (or (nt/current-home-directory) - (user-home-directory (current-user-name)))) - -(define (current-user-name) - (or (get-environment-variable "USERNAME") - (get-environment-variable "USER") - (let ((homedir (nt/current-home-directory))) - (and homedir - (pathname-name - (directory-pathname-as-file (directory-pathname homedir))))) - (error "Unable to determine current user name."))) - -(define (user-home-directory user-name) - (let ((try - (lambda (directory) - (pathname-as-directory - (merge-pathnames user-name directory))))) - (cond ((get-environment-variable "USERDIR") - => (lambda (userdir) - (try (pathname-as-directory (merge-pathnames userdir))))) - ((nt/current-home-directory) - => (lambda (homedir) - (if (string=? user-name (current-user-name)) - homedir - (try (directory-pathname-as-file homedir))))) - (else - (error "Can't find user's home directory:" user-name))))) - -(define (nt/current-home-directory) - (let ((homedrive (get-environment-variable "HOMEDRIVE")) - (homepath (get-environment-variable "HOMEPATH")) - (home (get-environment-variable "HOME"))) - (and (or homepath home) - (pathname-as-directory - (merge-pathnames (or homepath home) homedrive))))) - +(define current-user-name) +(define current-home-directory) +(define user-home-directory) +(letrec + ((trydir + (lambda (directory) + (and directory + (file-directory? directory) + (pathname-as-directory directory)))) + (%current-user-name + (lambda () + (or (get-environment-variable "USERNAME") + (get-environment-variable "USER")))) + (%current-home-directory + (lambda () + (or (let ((homedrive (get-environment-variable "HOMEDRIVE")) + (homepath (get-environment-variable "HOMEPATH"))) + (and homedrive + homepath + (trydir (merge-pathnames homepath homedrive)))) + (trydir (get-environment-variable "HOME"))))) + (%users-directory + (lambda () + (trydir (get-environment-variable "USERDIR")))) + (%system-root-directory + (lambda () + (let ((sysdrive (get-environment-variable "SYSTEM_DRIVE"))) + (if (not sysdrive) + (error "Unable to find Windows system drive.")) + (trydir (string-append sysdrive "\\")))))) + + (set! current-user-name + (lambda () + (or (%current-user-name) + ;; If the home directory is defined, use the last part of the + ;; path as the user's name. If the home directory is the root + ;; of a drive, this won't do anything. + (let ((homedir (%current-home-directory))) + (and homedir + (pathname-name (directory-pathname-as-file homedir)))) + (error "Unable to determine current user name.")))) + + (set! current-home-directory + (lambda () + (or (%current-home-directory) + (let ((user-name (%current-user-name))) + ;; If home directory not defined, look for directory + ;; with user's name in users directory and in root + ;; directory of system drive. If still nothing, use + ;; root directory of system drive. + (or (let ((usersdir (%users-directory))) + (and usersdir + (trydir (merge-pathnames user-name usersdir)))) + (let ((rootdir (%system-root-directory))) + (or (trydir (merge-pathnames user-name rootdir)) + rootdir))))))) + + (set! user-home-directory + (lambda (user-name) + (let ((homedir (%current-home-directory))) + ;; If USER-NAME is current user, use current home + ;; directory. + (or (let ((user-name* (%current-user-name))) + (and user-name* + (string=? user-name user-name*) + homedir)) + ;; Look for USER-NAME in users directory. + (let ((usersdir (%users-directory))) + (and usersdir + (trydir (merge-pathnames user-name usersdir)))) + ;; Look for USER-NAME in same directory as current + ;; user's home directory. + (and homedir + (trydir (merge-pathnames user-name homedir))) + ;; Look for USER-NAME in root directory of system + ;; drive. Failing that, use root directory itself. + (let ((rootdir (%system-root-directory))) + (or (trydir (merge-pathnames user-name rootdir)) + rootdir))))))) + (define dos/user-home-directory user-home-directory) (define dos/current-user-name current-user-name) (define dos/current-home-directory current-home-directory) diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm index 7075fb3ca..c529c1f83 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.33 1997/11/11 13:20:29 cph Exp $ +$Id: os2prm.scm,v 1.34 1997/11/12 08:39:57 cph Exp $ Copyright (c) 1994-97 Massachusetts Institute of Technology @@ -204,31 +204,81 @@ MIT in each case. |# (define-integrable os2/current-pid (ucode-primitive current-pid 0)) - -(define (current-home-directory) - (let ((home (get-environment-variable "HOME"))) - (if home - (pathname-as-directory (merge-pathnames home)) - (user-home-directory (current-user-name))))) - -(define (current-user-name) - (or (get-environment-variable "USER") - (error "Unable to determine current user name."))) - -(define (user-home-directory user-name) - (let ((try - (lambda (directory) - (pathname-as-directory (merge-pathnames user-name directory))))) - (cond ((get-environment-variable "USERDIR") - => (lambda (userdir) - (try (pathname-as-directory (merge-pathnames userdir))))) - ((get-environment-variable "HOME") - => (lambda (homedir) - (if (string=? user-name (current-user-name)) - homedir - (try (directory-pathname-as-file homedir))))) - (else - (error "Can't find user's home directory:" user-name))))) + +(define current-user-name) +(define current-home-directory) +(define user-home-directory) +(letrec + ((trydir + (lambda (directory) + (and directory + (file-directory? directory) + (pathname-as-directory directory)))) + (%current-user-name + (lambda () + (get-environment-variable "USER"))) + (%current-home-directory + (lambda () + (trydir (get-environment-variable "HOME")))) + (%users-directory + (lambda () + (trydir (get-environment-variable "USERDIR")))) + (%system-root-directory + (lambda () + (let ((system.ini (get-environment-variable "SYSTEM_INI"))) + (if (not (file-exists? system.ini)) + (error "Unable to find OS/2 system.ini file:" system.ini)) + (pathname-new-directory (directory-pathname system.ini) + '(ABSOLUTE)))))) + + (set! current-user-name + (lambda () + (or (%current-user-name) + ;; If the home directory is defined, use the last part of the + ;; path as the user's name. If the home directory is the root + ;; of a drive, this won't do anything. + (let ((homedir (%current-home-directory))) + (and homedir + (pathname-name (directory-pathname-as-file homedir)))) + (error "Unable to determine current user name.")))) + + (set! current-home-directory + (lambda () + (or (%current-home-directory) + (let ((user-name (%current-user-name))) + ;; If home directory not defined, look for directory + ;; with user's name in users directory and in root + ;; directory of system drive. If still nothing, use + ;; root directory of system drive. + (or (let ((usersdir (%users-directory))) + (and usersdir + (trydir (merge-pathnames user-name usersdir)))) + (let ((rootdir (%system-root-directory))) + (or (trydir (merge-pathnames user-name rootdir)) + rootdir))))))) + + (set! user-home-directory + (lambda (user-name) + (let ((homedir (%current-home-directory))) + ;; If USER-NAME is current user, use current home + ;; directory. + (or (let ((user-name* (%current-user-name))) + (and user-name* + (string=? user-name user-name*) + homedir)) + ;; Look for USER-NAME in users directory. + (let ((usersdir (%users-directory))) + (and usersdir + (trydir (merge-pathnames user-name usersdir)))) + ;; Look for USER-NAME in same directory as current + ;; user's home directory. + (and homedir + (trydir (merge-pathnames user-name homedir))) + ;; Look for USER-NAME in root directory of system + ;; drive. Failing that, use root directory itself. + (let ((rootdir (%system-root-directory))) + (or (trydir (merge-pathnames user-name rootdir)) + rootdir))))))) (define (dos/fs-drive-type pathname) (let ((type