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

Last change on this file since 13243 was 13243, checked in by vvoutilainen, 11 years ago

This patch fixes
1) recursion with wild-inferiors for paths like "/usr/share//ui/*.xml"
The previous code didn't recurse into directories not named "ui" at
all in that case.
2) symlinks that point to the current directory
3) the listing returned by list-directories-with-wildcards can
return paths for which file-namestring is nil, protect the filtering
from barfing on those.
4) tabs in the file. Sure, this should be done separately but
we have reviewed the changes without the tab change so we'll do
it with the same patch.

  • 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 13243 2011-03-12 19:18:05Z vvoutilainen $
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 entry matching-entries)))
121                          ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname))
122                           (push 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.