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

Last change on this file since 14659 was 14659, checked in by mevenson, 3 years ago

Fix Uniform Naming Convention (aka "UNC" or "network") paths under Windows.

DIRECTORY now works again on UNC paths.

UNC paths may be either specified with either back slash (#
) or
forward slash (#\/) doubled as the first character in a Pathname
namestring.

The patterns in

<server>/<share>/[directories-and-files]

are parsed as

<server> is stored as HOST.

<share> is stored as DEVICE.

[directories-and-files] gets parsed as per the normal rules under
Windows.

Mixing namestrings with both backslash and slash characters can lead
to unpredictable results. It is recommended not to use backslash
characters in namestrings if it can be avoided. The pathname printed
representation is always normalized to using forward slash delimiters.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 8.0 KB
Line 
1;;; directory.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves
4;;; Copyright (C) 2008 Ville Voutilainen
5;;; $Id: directory.lisp 14659 2014-03-24 16:39:23Z 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    (when (not (or wild wild-inferiors-found)) ;; no further recursion necessary
65        (return-from list-directories-with-wildcards 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(defun directory (pathspec &key (resolve-symlinks nil))
100  "Determines which, if any, files that are present in the file system have names matching PATHSPEC, and returns a fresh list of pathnames corresponding to the potential truenames of those files. 
101
102With :RESOLVE-SYMLINKS set to nil, not all pathnames returned may
103correspond to an existing file.  Symbolic links are considered to be
104be valid entries even if they do not currently have a valid file or
105directory as a target.  Therefore, subsequent CL:TRUENAME call on
106individual pathnames in the list may signal an error, i.e. the
107pathnames have been constructed as truenames, without calling the
108entire resolution routine of CL:TRUENAME.
109
110If called with :RESOLVE-SYMLINKS set to T, and any of the pathnames
111have truenames which do not exist, this routine will signal a file
112error to its caller."
113
114  (let ((pathname (merge-pathnames pathspec)))
115    (when (logical-pathname-p pathname)
116      (setq pathname (translate-logical-pathname pathname)))
117    (if (or (position #\* (namestring pathname))
118            (wild-pathname-p pathname))
119        (if (pathname-jar-p pathname)
120            (match-wild-jar-pathname pathname)
121            (let ((namestring (directory-namestring pathname)))
122              (when (and namestring (> (length namestring) 0))
123                (when (featurep :windows)
124                  (let ((host (pathname-host pathname))
125                        (device (pathname-device pathname)))
126                    (cond 
127                      ((and host device)
128                       (setq namestring 
129                             (concatenate 'string "//" host "/" device  namestring)))
130                      (device
131                       (setq namestring 
132                             (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) "") 
144                                           (file-namestring pathname)))
145                      (push 
146                       (if resolve-symlinks
147                           (truename entry) 
148                           ;; Normalize nil DEVICE to :UNSPECIFIC under non-Windows
149                           ;; fixes ANSI DIRECTORY.[67]
150                           (if (and (not (find :windows *features*))
151                                    (not (pathname-device entry)))
152                               (make-pathname :defaults entry :device :unspecific)
153                               entry))
154                       matching-entries)))
155                  matching-entries))))
156        ;; Not wild.
157        (let ((truename (probe-file pathname)))
158          (if truename
159              (list (pathname truename))
160              nil)))))
Note: See TracBrowser for help on using the repository browser.