[armedbear-cvs] r13230 - trunk/abcl/src/org/armedbear/lisp

[Ville Voutilainen]

Author: vvoutilainen
Date: Wed Mar  2 15:34:38 2011
New Revision: 13230

Log:
Fix ticket #136: ABCL should allow DIRECTORY listings that don't follow symlinks, and/or provide a function for deleting a directory tree.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Pathname.java
   trunk/abcl/src/org/armedbear/lisp/directory.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java	Wed Mar  2 15:34:38 2011
@@ -1475,10 +1475,14 @@
     private static final Primitive LIST_DIRECTORY = new pf_list_directory();
     private static class pf_list_directory extends Primitive {
         pf_list_directory() {
-            super("list-directory", PACKAGE_SYS, true, "directory");
+            super("list-directory", PACKAGE_SYS, true, "directory &optional (resolve-symlinks t)");
         }
         @Override
         public LispObject execute(LispObject arg) {
+            return execute(arg, T);
+        }
+        @Override
+        public LispObject execute(LispObject arg, LispObject arg2) {
             Pathname pathname = coerceToPathname(arg);
             if (pathname instanceof LogicalPathname) {
                 pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname);
@@ -1546,7 +1550,11 @@
                             if (file.isDirectory()) {
                                 p = Utilities.getDirectoryPathname(file);
                             } else {
-                                p = new Pathname(file.getCanonicalPath());
+                                if (arg2 != NIL) {
+                                    p = new Pathname(file.getCanonicalPath());
+                                } else {
+                                    p = new Pathname(file.getAbsolutePath());
+                                }
                             }
                             result = new Cons(p, result);
                         }

Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/directory.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/directory.lisp	Wed Mar  2 15:34:38 2011
@@ -45,7 +45,8 @@
   (eq component :wild-inferiors))
 
 (defun list-directories-with-wildcards (pathname 
-					&optional (wild-inferiors-found nil))
+                                        wild-inferiors-found
+                                        resolve-symlinks)
   (let* ((directory (pathname-directory pathname))
 	 (first-wild-inferior (and (not wild-inferiors-found) 
 				   (position-if #'wild-inferiors-p directory)))
@@ -59,7 +60,7 @@
 		     directory))
 	 (newpath (make-pathname :directory non-wild
 				 :name nil :type nil :defaults pathname))
-	 (entries (list-directory newpath)))
+	 (entries (list-directory newpath resolve-symlinks)))
     (if (not (or wild wild-inferiors-found))
 	entries
 	(let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries)))
@@ -86,11 +87,12 @@
 			   (list-directories-with-wildcards
 			    (make-pathname :directory directory
 					   :defaults newpath)
-			    (or first-wild-inferior wild-inferiors-found))))))
+			    (or first-wild-inferior wild-inferiors-found)
+                            resolve-symlinks)))))
 		   entries))))))
 
 
-(defun directory (pathspec &key)
+(defun directory (pathspec &key (resolve-symlinks t))
   (let ((pathname (merge-pathnames pathspec)))
     (when (logical-pathname-p pathname)
       (setq pathname (translate-logical-pathname pathname)))
@@ -104,7 +106,8 @@
                   (let ((device (pathname-device pathname)))
                     (when device
                       (setq namestring (concatenate 'string device ":" namestring)))))
-                (let ((entries (list-directories-with-wildcards namestring))
+                (let ((entries (list-directories-with-wildcards 
+                                namestring nil resolve-symlinks))
                       (matching-entries ()))
                   (dolist (entry entries)
                     (cond ((file-directory-p entry)