[Openmcl-cvs-notifications] r9048 - in /trunk/source/level-1: l1-files.lisp l1-pathnames.lisp l1-sysio.lisp

[gz at clozure.com]

Author: gz
Date: Mon Apr  7 23:12:55 2008
New Revision: 9048

Log:
Make make-file-stream rejected wildcarded pathnames.

Various tweaks to make meta-. work when using pathnames relative to the fil=
e system's "current directory".

Modified:
    trunk/source/level-1/l1-files.lisp
    trunk/source/level-1/l1-pathnames.lisp
    trunk/source/level-1/l1-sysio.lisp

Modified: trunk/source/level-1/l1-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-files.lisp (original)
+++ trunk/source/level-1/l1-files.lisp Mon Apr  7 23:12:55 2008
@@ -151,12 +151,16 @@
   (or (probe-file path)
       (signal-file-error $err-no-file path)))
 =

+(defun check-pathname-not-wild (path)
+  (when (wild-pathname-p path)
+    (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
+	   :pathname path))
+  path)
+
 (defun probe-file (path)
   "Return a pathname which is the truename of the file if it exists, or NIL
   otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
-  (when (wild-pathname-p path)
-    (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
-	   :pathname path))
+  (check-pathname-not-wild path)
   (let* ((native (native-translated-namestring path))
          (realpath (%realpath native))
          (kind (if realpath (%unix-file-kind realpath))))
@@ -267,7 +271,7 @@
 ; I thought I wanted to call this from elsewhere but perhaps not
 (defun absolute-directory-list (dirlist)
   ; just make relative absolute and remove ups where possible
-  (when (eq (car dirlist) :relative)
+  (when (or (null dirlist) (eq (car dirlist) :relative))
     (let ((default (mac-default-directory)) default-dir)
       (when default
         (setq default-dir (%pathname-directory default))
@@ -1087,6 +1091,8 @@
   (let ((full-name (full-pathname file-name :no-error nil))
         (kind nil))
     (when full-name
+      (when (eq (pathname-host file-name) :unspecific) ;; if physical path=
name to begin with, force absolute
+	(setq file-name full-name))
       (let ((file-type (pathname-type full-name)))
         (if (and file-type (neq file-type :unspecific))
           (values (probe-file full-name) file-name file-name)

Modified: trunk/source/level-1/l1-pathnames.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-pathnames.lisp (original)
+++ trunk/source/level-1/l1-pathnames.lisp Mon Apr  7 23:12:55 2008
@@ -381,8 +381,11 @@
 (defun %host-component-match-p (path-host wild-host)
   ;; Note that %component-match-p is case sensitive.  Need a
   ;; case-insensitive version for hosts. =

-  (or (string-equal path-host wild-host)
-      (%component-match-p path-host wild-host)))
+  ;; In addition, host components do not support wildcards.
+  (or (eq path-host wild-host)
+      (and (stringp path-host)
+	   (stringp wild-host)
+	   (string-equal path-host wild-host))))
 =

 (defun pathname-match-p (pathname wildname)
   "Pathname matches the wildname template?"

Modified: trunk/source/level-1/l1-sysio.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-sysio.lisp (original)
+++ trunk/source/level-1/l1-sysio.lisp Mon Apr  7 23:12:55 2008
@@ -753,6 +753,7 @@
 	(:input (setq if-exists :ignored))
 	((:io :output) nil)
 	(t (report-bad-arg direction '(member :input :output :io :probe))))
+      (check-pathname-not-wild filename) ;; probe-file-x misses wild versi=
ons....
       (multiple-value-bind (native-truename kind)(probe-file-x filename)
 	(if native-truename
 	  (if (eq kind :directory)