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 | |
---|
102 | With :RESOLVE-SYMLINKS set to nil, not all pathnames returned may |
---|
103 | correspond to an existing file. Symbolic links are considered to be |
---|
104 | be valid entries even if they do not currently have a valid file or |
---|
105 | directory as a target. Therefore, subsequent CL:TRUENAME call on |
---|
106 | individual pathnames in the list may signal an error, i.e. the |
---|
107 | pathnames have been constructed as truenames, without calling the |
---|
108 | entire resolution routine of CL:TRUENAME. |
---|
109 | |
---|
110 | If called with :RESOLVE-SYMLINKS set to T, and any of the pathnames |
---|
111 | have truenames which do not exist, this routine will signal a file |
---|
112 | error 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))))) |
---|