[Sbcl-commits] CVS: sbcl/src/code filesys.lisp,1.33,1.34 target-pathname.lisp,1.26,1.27 unix.lisp,1.28,1.29

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv24158/src/code

Modified Files:
	filesys.lisp target-pathname.lisp unix.lisp 
Log Message:
0.7.2.16:
	Fix bug 160 (USER-HOMEDIR-PATHNAME)
	... new uid_homedir function in wrap.c
	... wrap it up some more in unix.lisp
	... actually use it in filesys.lisp
	Also fixes to namestring parsing
	... treat potentially logical pathname namestrings correctly
	... remove last vestiges of search-list parsing from 
		unix-namestring parsing


Index: filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -C2 -d -r1.33 -r1.34
*** filesys.lisp	20 Mar 2002 21:44:04 -0000	1.33
--- filesys.lisp	18 Apr 2002 21:58:56 -0000	1.34
***************
*** 216,313 ****
        (values absolute (pieces)))))
  
- ;;; the thing before a colon in a logical path
- (def!struct (logical-hostname (:make-load-form-fun
- 			       (lambda (x)
- 				 (values `(make-logical-hostname
- 					   ,(logical-hostname-name x))
- 					 nil)))
- 			      (:copier nil)
- 			      (:constructor make-logical-hostname (name)))
-   (name (missing-arg) :type simple-string))
- 
- (defun maybe-extract-logical-hostname (namestr start end)
-   (declare (type simple-base-string namestr)
- 	   (type index start end))
-   (let ((quoted nil))
-     (do ((index start (1+ index)))
- 	((= index end)
- 	 (values nil start))
-       (if quoted
- 	  (setf quoted nil)
- 	  (case (schar namestr index)
- 	    (#\\
- 	     (setf quoted t))
- 	    (#\:
- 	     (return (values (make-logical-hostname
- 			      (remove-backslashes namestr start index))
- 			     (1+ index)))))))))
- 
  (defun parse-unix-namestring (namestr start end)
    (declare (type simple-base-string namestr)
             (type index start end))
    (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
!     (let ((logical-hostname
! 	   (if absolute
! 	       nil
! 	       (let ((first (car pieces)))
! 		 (multiple-value-bind (logical-hostname new-start)
! 		     (maybe-extract-logical-hostname namestr
! 						     (car first)
! 						     (cdr first))
! 		   (when logical-hostname
! 		     (setf absolute t)
! 		     (setf (car first) new-start))
! 		   logical-hostname)))))
!       (declare (type (or null logical-hostname) logical-hostname))
!       (multiple-value-bind (name type version)
!           (let* ((tail (car (last pieces)))
!                  (tail-start (car tail))
!                  (tail-end (cdr tail)))
!             (unless (= tail-start tail-end)
!               (setf pieces (butlast pieces))
!               (extract-name-type-and-version namestr tail-start tail-end)))
  
! 	(when (stringp name)
! 	  (let ((position (position-if (lambda (char)
! 					 (or (char= char (code-char 0))
! 					     (char= char #\/)))
! 				       name)))
! 	    (when position
! 	      (error 'namestring-parse-error
! 		     :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
! 		     :namestring namestr
! 		     :offset position))))
!         
!         ;; Now we have everything we want. So return it.
!         (values nil ; no host for Unix namestrings
!                 nil ; no device for Unix namestrings
!                 (collect ((dirs))
!                   (when logical-hostname
!                     (dirs logical-hostname))
!                   (dolist (piece pieces)
!                     (let ((piece-start (car piece))
!                           (piece-end (cdr piece)))
!                       (unless (= piece-start piece-end)
!                         (cond ((string= namestr ".."
! 					:start1 piece-start
!                                         :end1 piece-end)
!                                (dirs :up))
!                               ((string= namestr "**"
! 					:start1 piece-start
!                                         :end1 piece-end)
!                                (dirs :wild-inferiors))
!                               (t
!                                (dirs (maybe-make-pattern namestr
!                                                          piece-start
!                                                          piece-end)))))))
!                   (cond (absolute
!                          (cons :absolute (dirs)))
!                         ((dirs)
!                          (cons :relative (dirs)))
!                         (t
!                          nil)))
!                 name
!                 type
!                 version)))))
  
  (/show0 "filesys.lisp 300")
--- 216,270 ----
        (values absolute (pieces)))))
  
  (defun parse-unix-namestring (namestr start end)
    (declare (type simple-base-string namestr)
             (type index start end))
    (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
!     (multiple-value-bind (name type version)
! 	(let* ((tail (car (last pieces)))
! 	       (tail-start (car tail))
! 	       (tail-end (cdr tail)))
! 	  (unless (= tail-start tail-end)
! 	    (setf pieces (butlast pieces))
! 	    (extract-name-type-and-version namestr tail-start tail-end)))
  
!       (when (stringp name)
! 	(let ((position (position-if (lambda (char)
! 				       (or (char= char (code-char 0))
! 					   (char= char #\/)))
! 				     name)))
! 	  (when position
! 	    (error 'namestring-parse-error
! 		   :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
! 		   :namestring namestr
! 		   :offset position))))
!       ;; Now we have everything we want. So return it.
!       (values nil ; no host for Unix namestrings
! 	      nil ; no device for Unix namestrings
! 	      (collect ((dirs))
!  	        (dolist (piece pieces)
! 		  (let ((piece-start (car piece))
! 			(piece-end (cdr piece)))
! 		    (unless (= piece-start piece-end)
! 		      (cond ((string= namestr ".."
! 				      :start1 piece-start
! 				      :end1 piece-end)
! 			     (dirs :up))
! 			    ((string= namestr "**"
! 				      :start1 piece-start
! 				      :end1 piece-end)
! 			     (dirs :wild-inferiors))
! 			    (t
! 			     (dirs (maybe-make-pattern namestr
! 						       piece-start
! 						       piece-end)))))))
! 		(cond (absolute
! 		       (cons :absolute (dirs)))
! 		      ((dirs)
! 		       (cons :relative (dirs)))
! 		      (t
! 		       nil)))
! 	      name
! 	      type
! 	      version))))
  
  (/show0 "filesys.lisp 300")
***************
*** 369,383 ****
        (ecase (pop directory)
  	(:absolute
! 	 (cond ((logical-hostname-p (car directory))
! 		;; FIXME: The old CMU CL "search list" extension is
! 		;; gone, but the old machinery is still being used
! 		;; clumsily here and elsewhere, to represent anything
! 		;; which belongs before a colon prefix in the ANSI
! 		;; pathname machinery. This should be cleaned up,
! 		;; using simpler machinery with more mnemonic names.
! 		(pieces (logical-hostname-name (pop directory)))
! 		(pieces ":"))
! 	       (t
! 		(pieces "/"))))
  	(:relative
  	 ;; nothing special
--- 326,330 ----
        (ecase (pop directory)
  	(:absolute
! 	 (pieces "/"))
  	(:relative
  	 ;; nothing special
***************
*** 830,848 ****
  
  ;;; (This is an ANSI Common Lisp function.) 
- ;;;
- ;;; This is obtained from the logical name \"home:\", which is set
- ;;; up for us at initialization time.
  (defun user-homedir-pathname (&optional host)
    "Return the home directory of the user as a pathname."
    (declare (ignore host))
!   ;; Note: CMU CL did #P"home:" here instead of using a call to
!   ;; PATHNAME. Delaying construction of the pathname until we're
!   ;; running in a target Lisp lets us avoid figuring out how to dump
!   ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
!   ;; object file. It also might have a small positive effect on
!   ;; efficiency, in that we don't allocate a PATHNAME we don't need,
!   ;; but it it could also have a larger negative effect. Hopefully
!   ;; it'll be OK. -- WHN 19990714
!   (pathname "home:"))
  
  (defun file-write-date (file)
--- 777,784 ----
  
  ;;; (This is an ANSI Common Lisp function.) 
  (defun user-homedir-pathname (&optional host)
    "Return the home directory of the user as a pathname."
    (declare (ignore host))
!   (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))
  
  (defun file-write-date (file)

Index: target-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** target-pathname.lisp	16 Jan 2002 02:10:42 -0000	1.26
--- target-pathname.lisp	18 Apr 2002 21:58:57 -0000	1.27
***************
*** 606,609 ****
--- 606,644 ----
  ;;;; namestrings
  
+ ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
+ ;;; syntactically valid logical namestring with an explicit host.
+ ;;;
+ ;;; This then isn't fully general -- we are relying on the fact that
+ ;;; we will only pass to parse-namestring namestring with an explicit
+ ;;; logical host, so that we can pass the host return from
+ ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
+ ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
+ (defun parseable-logical-namestring-p (namestr start end)
+   (catch 'exit
+     (handler-bind
+ 	((namestring-parse-error (lambda (c)
+ 				   (declare (ignore c))
+ 				   (throw 'exit nil))))
+       (let ((colon (position #\: namestr :start start :end end)))
+ 	(when colon
+ 	  (let ((potential-host
+ 		 (logical-word-or-lose (subseq namestr start colon))))
+ 	    ;; depending on the outcome of CSR comp.lang.lisp post
+ 	    ;; "can PARSE-NAMESTRING create logical hosts, we may need
+ 	    ;; to do things with potential-host (create it
+ 	    ;; temporarily, parse the namestring and unintern the
+ 	    ;; logical host potential-host on failure.
+ 	    (declare (ignore potential-host))
+ 	    (let ((result
+ 		   (handler-bind
+ 		       ((simple-type-error (lambda (c)
+ 					     (declare (ignore c))
+ 					     (throw 'exit nil))))
+ 		     (parse-logical-namestring namestr start end))))
+ 	      ;; if we got this far, we should have an explicit host
+ 	      ;; (first return value of parse-logical-namestring)
+ 	      (aver result)
+ 	      result)))))))
+ 
  ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
  ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
***************
*** 619,632 ****
  	(namestring-parse-error (condition)
  	  (values nil (namestring-parse-error-offset condition))))
!       (let* ((end (or end (length namestr)))
! 	     (parse-host (or host
! 			     (extract-logical-host-prefix namestr start end)
! 			     (pathname-host defaults))))
! 	(unless parse-host
! 	  (error "When no HOST argument is supplied, the DEFAULTS argument ~
! 		  must have a non-null PATHNAME-HOST."))
! 
  	(multiple-value-bind (new-host device directory file type version)
! 	    (funcall (host-parse parse-host) namestr start end)
  	  (when (and host new-host (not (eq new-host host)))
  	    (error 'simple-type-error
--- 654,693 ----
  	(namestring-parse-error (condition)
  	  (values nil (namestring-parse-error-offset condition))))
!       (let* ((end (or end (length namestr))))
  	(multiple-value-bind (new-host device directory file type version)
! 	    ;; Comments below are quotes from the HyperSpec
! 	    ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
! 	    ;; that we actually have to do things this way rather than
! 	    ;; some possibly more logical way. - CSR, 2002-04-18
! 	    (cond
! 	      ;; "If host is a logical host then thing is parsed as a
! 	      ;; logical pathname namestring on the host."
! 	      (host (funcall (host-parse host) namestr start end))
! 	      ;; "If host is nil and thing is a syntactically valid
! 	      ;; logical pathname namestring containing an explicit
! 	      ;; host, then it is parsed as a logical pathname
! 	      ;; namestring."
! 	      ((parseable-logical-namestring-p namestr start end)
! 	       (parse-logical-namestring namestr start end))
! 	      ;; "If host is nil, default-pathname is a logical
! 	      ;; pathname, and thing is a syntactically valid logical
! 	      ;; pathname namestring without an explicit host, then it
! 	      ;; is parsed as a logical pathname namestring on the
! 	      ;; host that is the host component of default-pathname."
! 	      ;;
! 	      ;; "Otherwise, the parsing of thing is
! 	      ;; implementation-defined."
! 	      ;;
! 	      ;; Both clauses are handled here, as the default
! 	      ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
! 	      ;; for a host.
! 	      ((pathname-host defaults)
! 	       (funcall (host-parse (pathname-host defaults)) namestr start end))
! 	      ;; I don't think we should ever get here, as the default
! 	      ;; host will always have a non-null HOST, given that we
! 	      ;; can't create a new pathname without going through
! 	      ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
! 	      ;; host...
! 	      (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
  	  (when (and host new-host (not (eq new-host host)))
  	    (error 'simple-type-error
***************
*** 644,648 ****
  		    does not match the explicit HOST argument, ~S."
  		   :format-arguments (list new-host host)))
! 	  (let ((pn-host (or new-host parse-host)))
  	    (values (%make-maybe-logical-pathname
  		     pn-host device directory file type version)
--- 705,709 ----
  		    does not match the explicit HOST argument, ~S."
  		   :format-arguments (list new-host host)))
! 	  (let ((pn-host (or new-host host (pathname-host defaults))))
  	    (values (%make-maybe-logical-pathname
  		     pn-host device directory file type version)

Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -C2 -d -r1.28 -r1.29
*** unix.lisp	25 Mar 2002 18:25:03 -0000	1.28
--- unix.lisp	18 Apr 2002 21:58:57 -0000	1.29
***************
*** 349,352 ****
--- 349,360 ----
        (error "found no match for Unix uid=~S" uid)))
  
+ ;;; Return the namestring of the home directory, being careful to
+ ;;; include a trailing #\/
+ (defun uid-homedir (uid)
+   (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
+ 						       (function (* char) int))
+ 					 uid))
+       (error "failed to resolve home directory for Unix uid=~S" uid)))
+ 
  ;;; Invoke readlink(2) on the file name specified by PATH. Return
  ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on