Changeset 6634

Timestamp:

May 31, 2007, 5:09:33 PM (17 years ago)

Author:

Gary Byers

Message:

Define UID-FROM-NAME, TILDE-EXPAND. Use TILDE-EXPAND in %REALPATH, but
any leading tildes should probably have been caught earlier.

File:

• trunk/ccl/level-1/linux-files.lisp (modified) (3 diffs)

trunk/ccl/level-1/linux-files.lisp

@@ -344 +344 @@
       (fd-set-flags fd (logandc2 old mask)))))
 
+
+;;; Assume that any quoting's been removed already.
+(defun tilde-expand (namestring)
+  (let* ((len (length namestring)))
+    (if (or (zerop len)
+            (not (eql (schar namestring 0) #\~)))
+      namestring
+      (if (or (= len 1)
+              (eql (schar namestring 1) #\/))
+        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
+        (let* ((slash-pos (position #\/ namestring))
+               (user-name (subseq namestring 1 slash-pos))
+               (uid (or (get-uid-from-name user-name)
+                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
+          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
+
+                     
+    
 ;;; This doesn't seem to exist on VxWorks.  It's a POSIX
 ;;; function AFAIK, so the source should be somewhere ...
@@ -351 +369 @@
     (setq namestring (current-directory-name)))
   (%stack-block ((resultbuf #$PATH_MAX))
-    (with-cstrs ((name namestring))
+    (with-cstrs ((name (tilde-expand namestring)))
       (let* ((result (#_realpath name resultbuf)))
         (declare (dynamic-extent result))
@@ -417 +435 @@
          
 
+(defun get-uid-from-name (name)
+  (with-cstrs ((name name))
+    (let* ((pwent (#_getpwnam name)))
+      (unless (%null-ptr-p pwent)
+        (pref pwent :passwd.pw_uid)))))
+
+    
 (defun isatty (fd)
   (= 1 (#_isatty fd)))