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

Last change on this file since 14619 was 14619, checked in by Mark Evenson, 8 years ago

CL:DIRECTORY semantics for symbolic link resolution inverted and fixed.

The default for the :RESOLVE-SYMLINKS keyword to CL:DIRECTORY has
changed from T to nil, meaning that naked DIRECTORY calls should never
return an error for dangling symlinks.

Thanks to Marco Antoniotti, Alan Ruttenberg, and Alessio Stallo for
clarifying a reasonable position vis a vis ANSI.

Addresses <>.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.3 KB
1;;; directory.lisp
3;;; Copyright (C) 2004-2007 Peter Graves
4;;; Copyright (C) 2008 Ville Voutilainen
5;;; $Id: directory.lisp 14619 2014-01-30 14:10:03Z mevenson $
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.
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; GNU General Public License for more details.
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.
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.
33(in-package "SYSTEM")
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)))
44(defun wild-inferiors-p (component)
45  (eq component :wild-inferiors))
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))))))
99;;; XXX Kludge for compatibilty:  hope no one uses.
100(defun directory-old (pathspec &key (resolve-symlinks t))
101  (warn "Deprecated:  Please use CL:DIRECTORY which has a NIL default for :RESOLVE-SYMLINKS.")
102  (directory pathspec :resolve-symlinks resolve-symlinks))
104(defun directory (pathspec &key (resolve-symlinks nil))
105  "Determines which, if any, files that are present in the file system have names matching PATHSPEC, and returns
106a fresh list of pathnames corresponding to the potential truenames of those files. 
108With :RESOLVE-SYMLINKS set to nil, not all pathnames returned may
109correspond to an existing file.  Symbolic links are considered to be
110be valid entries even if they do not currently have a valid file or
111directory as a target.  Therefore, subsequent CL:TRUENAME call on
112individual pathnames in the list may signal an error, i.e. the
113pathnames have been constructed as truenames, without calling the
114entire resolution routine of CL:TRUENAME.
116If called with :RESOLVE-SYMLINKS set to T, and any of the pathnames
117have truenames which do not exist, this routine will signal a file
118error to its caller."
120  (let ((pathname (merge-pathnames pathspec)))
121    (when (logical-pathname-p pathname)
122      (setq pathname (translate-logical-pathname pathname)))
123    (if (or (position #\* (namestring pathname))
124            (wild-pathname-p pathname))
125        (if (pathname-jar-p pathname)
126            (match-wild-jar-pathname pathname)
127            (let ((namestring (directory-namestring pathname)))
128              (when (and namestring (> (length namestring) 0))
129                (when (featurep :windows)
130                  (let ((device (pathname-device pathname)))
131                    (when device
132                      (setq namestring (concatenate 'string device ":" namestring)))))
133                (let ((entries (list-directories-with-wildcards 
134                                namestring nil resolve-symlinks))
135                      (matching-entries ()))
136                  (dolist (entry entries)
137          (when 
138            (or 
139             (and 
140              (file-directory-p entry)
141              (pathname-match-p (file-namestring (pathname-as-file entry)) 
142                      (file-namestring pathname)))
143             (pathname-match-p (or (file-namestring entry) "") (file-namestring pathname)))
144            (push 
145             (if resolve-symlinks
146               (truename entry) 
147               entry)
148             matching-entries)))
149                  matching-entries))))
150        ;; Not wild.
151        (let ((truename (probe-file pathname)))
152          (if truename
153              (list (pathname truename))
154              nil)))))
Note: See TracBrowser for help on using the repository browser.