source: trunk/abcl/src/org/armedbear/lisp/directory.lisp @ 14176

Last change on this file since 14176 was 14176, checked in by mevenson, 6 years ago

Refactor PATHNAME implementation details to tighten existing semantics.

None of this should change the behavior of CL:PATHNAME, but it
prepares for that in subsequent patches to address problems in merging
when the defaults points to a JAR-PATHNAME.

Fix COMPILE-FILE to work with source located in jar archive.

Moved Utilities.getFile() to instance method of Pathname which makes
more logical sense. Moved Utilities.getPathnameDirectory() to static
instance classes. These functions no longer merge their argument with
*DEFAULT-PATHNAME-DEFAULTS*, as this should be done explictly at a
higher level in the Lisp calling into Java abstraction.

RENAME-FILE no longer on namestrings, but instead use the result of
TRUENAME invocation, as namestrings will not always roundtrip
exactly back to PATHNAMES.

POPULATE-ZIP-FASL no longer forms its argumentes by merging paths,
instead using MAKE-PATHNAME with controlled defaults.

SYSTEM:NEXT-CLASSFILE-NAME and SYSTEM:COMPUTE-CLASSFILE-NAME changed
to NEXT-CLASSFILE and COMPUTE-CLASSFILE returning PATHNAME objects
rather than namestrings.

Compiler now dumps pathname in alternate form that preserves DEVICE
:UNSPECIFIC.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.3 KB
Line 
1;;; directory.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves
4;;; Copyright (C) 2008 Ville Voutilainen
5;;; $Id: directory.lisp 14176 2012-10-11 11:33:19Z mevenson $
6;;;
7;;; This program is free software; you can redistribute it and/or
8;;; modify it under the terms of the GNU General Public License
9;;; as published by the Free Software Foundation; either version 2
10;;; of the License, or (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
20;;;
21;;; As a special exception, the copyright holders of this library give you
22;;; permission to link this library with independent modules to produce an
23;;; executable, regardless of the license terms of these independent
24;;; modules, and to copy and distribute the resulting executable under
25;;; terms of your choice, provided that you also meet, for each linked
26;;; independent module, the terms and conditions of the license of that
27;;; module.  An independent module is a module which is not derived from
28;;; or based on this library.  If you modify this library, you may extend
29;;; this exception to your version of the library, but you are not
30;;; obligated to do so.  If you do not wish to do so, delete this
31;;; exception statement from your version.
32
33(in-package "SYSTEM")
34
35(defun pathname-as-file (pathname)
36  (let ((directory (pathname-directory pathname)))
37    (make-pathname :host nil
38                   :device (pathname-device pathname)
39                   :directory (butlast directory)
40                   :name (car (last directory))
41                   :type nil
42                   :version nil)))
43
44(defun wild-inferiors-p (component)
45  (eq component :wild-inferiors))
46
47(defun list-directories-with-wildcards (pathname 
48                                        wild-inferiors-found
49                                        resolve-symlinks)
50  (let* ((directory (pathname-directory pathname))
51         (first-wild-inferior (and (not wild-inferiors-found) 
52                                   (position-if #'wild-inferiors-p directory)))
53         (first-wild (position-if #'wild-p directory))
54         (wild (when (or first-wild-inferior first-wild)
55                 (nthcdr (or first-wild-inferior first-wild) directory)))
56         (non-wild (if (or first-wild-inferior first-wild)
57                       (nbutlast directory
58                                 (- (length directory) 
59                                    (or first-wild-inferior first-wild)))
60                     directory))
61         (newpath (make-pathname :directory non-wild
62                                 :name nil :type nil :defaults pathname))
63         (entries (list-directory newpath resolve-symlinks)))
64    (if (not (or wild wild-inferiors-found))
65        entries
66        (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries)))
67          (nconc 
68           (mapcan (lambda (entry) 
69                     (when (pathname-match-p (pathname entry) pathname)
70                       (list entry)))
71                   inferior-entries)
72           (mapcan (lambda (entry)
73                     (let* ((pathname (pathname entry))
74                            (directory (pathname-directory pathname))
75                            (rest-wild (cdr wild)))
76                       (unless (pathname-name pathname)
77                         (when (pathname-match-p (first (last directory))
78                                    (cond ((eql (car wild) :wild)
79                                           "*")
80                                          ((eql (car wild) :wild-inferiors)
81                                           "*")
82                                          (wild 
83                                           (car wild))
84                                          (t "")))
85                           (when (and 
86                                  (not (or first-wild-inferior 
87                                           wild-inferiors-found)) 
88                                  rest-wild)
89                             (setf directory (nconc directory rest-wild)))
90                           (let ((recurse (make-pathname :directory directory
91                                                  :defaults newpath)))
92                             (when (not (equal recurse newpath))
93                               (list-directories-with-wildcards
94                                recurse
95                                (or first-wild-inferior wild-inferiors-found)
96                                resolve-symlinks)))))))
97                   entries))))))
98
99
100(defun directory (pathspec &key (resolve-symlinks t))
101  (let ((pathname (merge-pathnames pathspec)))
102    (when (logical-pathname-p pathname)
103      (setq pathname (translate-logical-pathname pathname)))
104    (if (or (position #\* (namestring pathname))
105            (wild-pathname-p pathname))
106        (if (pathname-jar-p pathname)
107            (match-wild-jar-pathname pathname)
108            (let ((namestring (directory-namestring pathname)))
109              (when (and namestring (> (length namestring) 0))
110                (when (featurep :windows)
111                  (let ((device (pathname-device pathname)))
112                    (when device
113                      (setq namestring (concatenate 'string device ":" namestring)))))
114                (let ((entries (list-directories-with-wildcards 
115                                namestring nil resolve-symlinks))
116                      (matching-entries ()))
117                  (dolist (entry entries)
118                    (cond ((file-directory-p entry)
119                           (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname))
120                             (push (truename entry) matching-entries)))
121                          ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname))
122                           (push (truename entry) matching-entries))))
123                  matching-entries))))
124        ;; Not wild.
125        (let ((truename (probe-file pathname)))
126          (if truename
127              (list (pathname truename))
128              nil)))))
Note: See TracBrowser for help on using the repository browser.