/[cmucl]/src/hemlock/dired.lisp
ViewVC logotype

Contents of /src/hemlock/dired.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Thu Jul 6 08:25:15 2000 UTC (13 years, 9 months ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +8 -13 lines
Fix set-write-date, which wasn't working at all.
1 ;;; -*- Log: hemlock.log; Package: dired -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/dired.lisp,v 1.4 2000/07/06 08:25:15 dtc Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains site dependent code for dired.
13 ;;; Written by Bill Chiles.
14 ;;;
15
16 (defpackage "DIRED"
17 (:shadow "RENAME-FILE" "DELETE-FILE")
18 (:export "COPY-FILE" "RENAME-FILE" "FIND-FILE" "DELETE-FILE"
19 "MAKE-DIRECTORY"
20 "*UPDATE-DEFAULT*" "*CLOBBER-DEFAULT*" "*RECURSIVE-DEFAULT*"
21 "*REPORT-FUNCTION*" "*ERROR-FUNCTION*" "*YESP-FUNCTION*"
22 "PATHNAMES-FROM-PATTERN"))
23
24 (in-package "DIRED")
25
26
27 ;;;; Exported parameters.
28
29 (defparameter *update-default* nil
30 "Update arguments to utilities default to this value.")
31
32 (defparameter *clobber-default* t
33 "Clobber arguments to utilities default to this value.")
34
35 (defparameter *recursive-default* nil
36 "Recursive arguments to utilities default to this value.")
37
38
39
40 ;;;; WILDCARDP
41
42 (defconstant wildcard-char #\*
43 "Wildcard designator for file names will match any substring.")
44
45 (defmacro wildcardp (file-namestring)
46 `(position wildcard-char (the simple-string ,file-namestring) :test #'char=))
47
48
49
50 ;;;; User interaction functions, variable declarations, and their defaults.
51
52 (defun default-error-function (string &rest args)
53 (apply #'error string args))
54 ;;;
55 (defvar *error-function* #'default-error-function
56 "This function is called when an error is encountered in dired code.")
57
58 (defun default-report-function (string &rest args)
59 (apply #'format t string args))
60 ;;;
61 (defvar *report-function* #'default-report-function
62 "This function is called when the user needs to be informed of something.")
63
64 (defun default-yesp-function (string &rest args)
65 (apply #'format t string args)
66 (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line)))))
67 (declare (simple-string answer))
68 (or (string= answer "")
69 (string= answer "y")
70 (string= answer "yes")
71 (string= answer "ye"))))
72 ;;;
73 (defvar *yesp-function* #'default-yesp-function
74 "Function to query the user about clobbering an already existent file.")
75
76
77
78 ;;;; Copy-File
79
80 ;;; WILD-MATCH objects contain information about wildcard matches. File is the
81 ;;; Sesame namestring of the file matched, and substitute is a substring of the
82 ;;; file-namestring of file.
83 ;;;
84 (defstruct (wild-match (:print-function print-wild-match)
85 (:constructor make-wild-match (file substitute)))
86 file
87 substitute)
88
89 (defun print-wild-match (obj str n)
90 (declare (ignore n))
91 (format str "#<Wild-Match ~S ~S>"
92 (wild-match-file obj) (wild-match-substitute obj)))
93
94
95 (defun copy-file (spec1 spec2 &key (update *update-default*)
96 (clobber *clobber-default*)
97 (directory () directoryp))
98 "Copy file spec1 to spec2. A single wildcard is acceptable, and directory
99 names may be used. If spec1 and spec2 are both directories, then a
100 recursive copy is done of the files and subdirectory structure of spec1;
101 if spec2 is in the subdirectory structure of spec1, the recursion will
102 not descend into it. Use spec1/* to copy only the files in spec1 to
103 directory spec2. If spec2 is a directory, and spec1 is a file, then
104 spec1 is copied into spec2 with the same pathname-name. Files are
105 copied maintaining the source's write date. If :update is non-nil, then
106 files are only copied if the source is newer than the destination, still
107 maintaining the source's write date; the user is not warned if the
108 destination is newer (not the same write date) than the source. If
109 :clobber and :update are nil, then if any file spec2 already exists, the
110 user will be asked whether it should be overwritten or not."
111 (cond
112 ((not directoryp)
113 (let* ((ses-name1 (ext:unix-namestring spec1 t))
114 (exists1p (unix:unix-file-kind ses-name1))
115 (ses-name2 (ext:unix-namestring spec2 nil))
116 (pname1 (pathname ses-name1))
117 (pname2 (pathname ses-name2))
118 (dirp1 (directoryp pname1))
119 (dirp2 (directoryp pname2))
120 (wildp1 (wildcardp (file-namestring pname1)))
121 (wildp2 (wildcardp (file-namestring pname2))))
122 (when (and dirp1 wildp1)
123 (funcall *error-function*
124 "Cannot have wildcards in directory names -- ~S." pname1))
125 (when (and dirp2 wildp2)
126 (funcall *error-function*
127 "Cannot have wildcards in directory names -- ~S." pname2))
128 (when (and dirp1 (not dirp2))
129 (funcall *error-function*
130 "Cannot handle spec1 being a directory and spec2 a file."))
131 (when (and wildp2 (not wildp1))
132 (funcall *error-function*
133 "Cannot handle destination having wildcards without ~
134 source having wildcards."))
135 (when (and wildp1 (not wildp2) (not dirp2))
136 (funcall *error-function*
137 "Cannot handle source with wildcards and destination ~
138 without, unless destination is a directory."))
139 (cond ((and dirp1 dirp2)
140 (unless (directory-existsp ses-name1)
141 (funcall *error-function*
142 "Directory does not exist -- ~S." pname1))
143 (unless (directory-existsp ses-name2)
144 (enter-directory ses-name2))
145 (recursive-copy pname1 pname2 update clobber pname2
146 ses-name1 ses-name2))
147 (dirp2
148 ;; merge pname2 with pname1 to pick up a similar file-namestring.
149 (copy-file-1 pname1 wildp1 exists1p
150 (merge-pathnames pname2 pname1)
151 wildp1 update clobber))
152 (t (copy-file-1 pname1 wildp1 exists1p
153 pname2 wildp2 update clobber)))))
154 (directory
155 (when (pathname-directory spec1)
156 (funcall *error-function*
157 "Spec1 is just a pattern when supplying directory -- ~S."
158 spec1))
159 (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
160 (dirp2 (directoryp pname2))
161 (wildp1 (wildcardp spec1))
162 (wildp2 (wildcardp (file-namestring pname2))))
163 (unless wildp1
164 (funcall *error-function*
165 "Pattern, ~S, does not contain a wildcard."
166 spec1))
167 (when (and (not wildp2) (not dirp2))
168 (funcall *error-function*
169 "Cannot handle source with wildcards and destination ~
170 without, unless destination is a directory."))
171 (copy-wildcard-files spec1 wildp1
172 (if dirp2 (merge-pathnames pname2 spec1) pname2)
173 (if dirp2 wildp1 wildp2)
174 update clobber directory))))
175 (values))
176
177 ;;; RECURSIVE-COPY takes two pathnames that represent directories, and
178 ;;; the files in pname1 are copied into pname2, recursively descending into
179 ;;; subdirectories. If a subdirectory of pname1 does not exist in pname2,
180 ;;; it is created. Pname1 is known to exist. Forbidden-dir is originally
181 ;;; the same as pname2; this keeps us from infinitely recursing if pname2
182 ;;; is in the subdirectory structure of pname1. Returns t if some file gets
183 ;;; copied.
184 ;;;
185 (defun recursive-copy (pname1 pname2 update clobber
186 forbidden-dir ses-name1 ses-name2)
187 (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)
188 (dolist (spec (directory (directory-namestring pname1)))
189 (let ((spec-ses-name (namestring spec)))
190 (if (directoryp spec)
191 (unless (equal (pathname spec-ses-name) forbidden-dir)
192 (let* ((dir2-pname (merge-dirs spec pname2))
193 (dir2-ses-name (namestring dir2-pname)))
194 (unless (directory-existsp dir2-ses-name)
195 (enter-directory dir2-ses-name))
196 (recursive-copy spec dir2-pname update clobber forbidden-dir
197 spec-ses-name dir2-ses-name)
198 (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1
199 ses-name2)))
200 (copy-file-2 spec-ses-name
201 (namestring (merge-pathnames pname2 spec))
202 update clobber)))))
203
204 ;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and
205 ;;; adds it to the end of the sequence of directory names from pname2, returning
206 ;;; a pathname.
207 ;;;
208 #|
209 (defun merge-dirs (pname1 pname2)
210 (let* ((dirs1 (pathname-directory pname1))
211 (dirs2 (pathname-directory pname2))
212 (dirs2-len (length dirs2))
213 (new-dirs2 (make-array (1+ dirs2-len))))
214 (declare (simple-vector dirs1 dirs2 new-dirs2))
215 (replace new-dirs2 dirs2)
216 (setf (svref new-dirs2 dirs2-len)
217 (svref dirs1 (1- (length dirs1))))
218 (make-pathname :directory new-dirs2 :device :absolute)))
219 |#
220
221 (defun merge-dirs (pname1 pname2)
222 (let* ((dirs1 (pathname-directory pname1))
223 (dirs2 (pathname-directory pname2))
224 (dirs2-len (length dirs2))
225 (new-dirs2 (make-list (1+ dirs2-len))))
226 (replace new-dirs2 dirs2)
227 (setf (nth dirs2-len new-dirs2)
228 (nth (1- (length dirs1)) dirs1))
229 (make-pathname :directory new-dirs2 :device :unspecific)))
230
231 ;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard
232 ;;; or none. Wildp1 and Wildp2 are either nil or indexes into the
233 ;;; file-namestring of pname1 and pname2, respectively, indicating the position
234 ;;; of the wildcard character. If there is no wildcard, then simply call
235 ;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files.
236 ;;;
237 (defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber)
238 (if wildp1
239 (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber)
240 (let ((ses-name1 (namestring pname1)))
241 (unless exists1p (funcall *error-function*
242 "~S does not exist." ses-name1))
243 (copy-file-2 ses-name1 (namestring pname2) update clobber))))
244
245 (defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber
246 &optional directory)
247 (multiple-value-bind (dst-before dst-after)
248 (before-wildcard-after (file-namestring pname2) wildp2)
249 (dolist (match (resolve-wildcard pname1 wildp1 directory))
250 (copy-file-2 (wild-match-file match)
251 (namestring (concatenate 'simple-string
252 (directory-namestring pname2)
253 dst-before
254 (wild-match-substitute match)
255 dst-after))
256 update clobber))))
257
258 ;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update
259 ;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2
260 ;;; doesn't exist, then just copy it; otherwise, if update, then only copy it
261 ;;; if the destination's write date precedes the source's, and if not clobber
262 ;;; and not update, then ask the user before doing the copy.
263 ;;;
264 (defun copy-file-2 (ses-name1 ses-name2 update clobber)
265 (let ((secs1 (get-write-date ses-name1)))
266 (cond ((not (probe-file ses-name2))
267 (do-the-copy ses-name1 ses-name2 secs1))
268 (update
269 (let ((secs2 (get-write-date ses-name2)))
270 (cond (clobber
271 (do-the-copy ses-name1 ses-name2 secs1))
272 ((and (> secs2 secs1)
273 (funcall *yesp-function*
274 "~&~S ==> ~S~% ~
275 ** Destination is newer than source. ~
276 Overwrite it? "
277 ses-name1 ses-name2))
278 (do-the-copy ses-name1 ses-name2 secs1))
279 ((< secs2 secs1)
280 (do-the-copy ses-name1 ses-name2 secs1)))))
281 ((not clobber)
282 (when (funcall *yesp-function*
283 "~&~S ==> ~S~% ** Destination already exists. ~
284 Overwrite it? "
285 ses-name1 ses-name2)
286 (do-the-copy ses-name1 ses-name2 secs1)))
287 (t (do-the-copy ses-name1 ses-name2 secs1)))))
288
289 (defun do-the-copy (ses-name1 ses-name2 secs1)
290 (let* ((fd (open-file ses-name1)))
291 (unwind-protect
292 (multiple-value-bind (data byte-count mode)
293 (read-file fd ses-name1)
294 (unwind-protect (write-file ses-name2 data byte-count mode)
295 (system:deallocate-system-memory data byte-count)))
296 (close-file fd)))
297 (set-write-date ses-name2 secs1)
298 (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))
299
300
301 ;;;; Rename-File
302
303 (defun rename-file (spec1 spec2 &key (clobber *clobber-default*)
304 (directory () directoryp))
305 "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may
306 be a directory with the result spec being the merging of spec2 with spec1.
307 If clobber is nil and spec2 exists, then the user will be asked to confirm
308 the renaming. As with Unix mv, if you are renaming a directory, don't
309 specify the trailing slash."
310 (cond
311 ((not directoryp)
312 (let* ((ses-name1 (ext:unix-namestring spec1 t))
313 (exists1p (unix:unix-file-kind ses-name1))
314 (ses-name2 (ext:unix-namestring spec2 nil))
315 (pname1 (pathname ses-name1))
316 (pname2 (pathname ses-name2))
317 (dirp2 (directoryp pname2))
318 (wildp1 (wildcardp (file-namestring pname1)))
319 (wildp2 (wildcardp (file-namestring pname2))))
320 (if (and dirp2 wildp2)
321 (funcall *error-function*
322 "Cannot have wildcards in directory names -- ~S." pname2))
323 (if (and wildp2 (not wildp1))
324 (funcall *error-function*
325 "Cannot handle destination having wildcards without ~
326 source having wildcards."))
327 (if (and wildp1 (not wildp2) (not dirp2))
328 (funcall *error-function*
329 "Cannot handle source with wildcards and destination ~
330 without, unless destination is a directory."))
331 (if dirp2
332 (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2
333 pname1)
334 wildp1 clobber)
335 (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber))))
336 (directory
337 (when (pathname-directory spec1)
338 (funcall *error-function*
339 "Spec1 is just a pattern when supplying directory -- ~S."
340 spec1))
341
342 (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
343 (dirp2 (directoryp pname2))
344 (wildp1 (wildcardp spec1))
345 (wildp2 (wildcardp (file-namestring pname2))))
346 (unless wildp1
347 (funcall *error-function*
348 "Pattern, ~S, does not contain a wildcard."
349 spec1))
350 (when (and (not wildp2) (not dirp2))
351 (funcall *error-function*
352 "Cannot handle source with wildcards and destination ~
353 without, unless destination is a directory."))
354 (rename-wildcard-files spec1 wildp1
355 (if dirp2 (merge-pathnames pname2 spec1) pname2)
356 (if dirp2 wildp1 wildp2)
357 clobber directory))))
358 (values))
359
360 ;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard
361 ;;; or none. Wildp1 and Wildp2 are either nil or indexes into the
362 ;;; file-namestring of pname1 and pname2, respectively, indicating the position
363 ;;; of the wildcard character. If there is no wildcard, then simply call
364 ;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files.
365 ;;;
366 (defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber)
367 (if wildp1
368 (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber)
369 (let ((ses-name1 (namestring pname1)))
370 (unless exists1p (funcall *error-function*
371 "~S does not exist." ses-name1))
372 (rename-file-2 ses-name1 (namestring pname2) clobber))))
373
374 (defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber
375 &optional directory)
376 (multiple-value-bind (dst-before dst-after)
377 (before-wildcard-after (file-namestring pname2) wildp2)
378 (dolist (match (resolve-wildcard pname1 wildp1 directory))
379 (rename-file-2 (wild-match-file match)
380 (namestring (concatenate 'simple-string
381 (directory-namestring pname2)
382 dst-before
383 (wild-match-substitute match)
384 dst-after))
385 clobber))))
386
387 (defun rename-file-2 (ses-name1 ses-name2 clobber)
388 (cond ((and (probe-file ses-name2) (not clobber))
389 (when (funcall *yesp-function*
390 "~&~S ==> ~S~% ** Destination already exists. ~
391 Overwrite it? "
392 ses-name1 ses-name2)
393 (sub-rename-file ses-name1 ses-name2)
394 (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))
395 (t (sub-rename-file ses-name1 ses-name2)
396 (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))))
397
398
399
400 ;;;; Find-File
401
402 (defun find-file (file-name &optional (directory "")
403 (find-all-p nil find-all-suppliedp))
404 "Find the file with file-namestring file recursively looking in directory.
405 If find-all-p is non-nil, then do not stop searching upon finding the first
406 occurance of file. File may contain a single wildcard, which causes
407 find-all-p to default to t instead of nil."
408 (let* ((file (coerce file-name 'simple-string))
409 (wildp (wildcardp file))
410 (find-all-p (if find-all-suppliedp find-all-p wildp)))
411 (declare (simple-string file))
412 (catch 'found-file
413 (if wildp
414 (multiple-value-bind (before after)
415 (before-wildcard-after file wildp)
416 (find-file-aux file directory find-all-p before after))
417 (find-file-aux file directory find-all-p))))
418 (values))
419
420 (defun find-file-aux (the-file directory find-all-p &optional before after)
421 (declare (simple-string the-file))
422 (dolist (spec (directory directory))
423 (let* ((spec-ses-name (namestring spec))
424 (spec-file-name (file-namestring spec-ses-name)))
425 (declare (simple-string spec-ses-name spec-file-name))
426 (if (directoryp spec)
427 (find-file-aux the-file spec find-all-p before after)
428 (when (if before
429 (find-match before after spec-file-name :no-cons)
430 (string-equal the-file spec-file-name))
431 (print spec-ses-name)
432 (unless find-all-p (throw 'found-file t)))))))
433
434
435
436 ;;;; Delete-File
437
438 ;;; DELETE-FILE
439 ;;; If spec is a directory, but recursive is nil, just pass the directory
440 ;;; down through, letting LISP:DELETE-FILE signal an error if the directory
441 ;;; is not empty.
442 ;;;
443 (defun delete-file (spec &key (recursive *recursive-default*)
444 (clobber *clobber-default*))
445 "Delete spec asking confirmation on each file if clobber is nil. A single
446 wildcard is acceptable. If recursive is non-nil, then a directory spec may
447 be given to recursively delete the entirety of the directory and its
448 subdirectory structure. An empty directory may be specified without
449 recursive being non-nil. When specifying a directory, the trailing slash
450 must be included."
451 (let* ((ses-name (ext:unix-namestring spec t))
452 (pname (pathname ses-name))
453 (wildp (wildcardp (file-namestring pname)))
454 (dirp (directoryp pname)))
455 (if dirp
456 (if recursive
457 (recursive-delete pname ses-name clobber)
458 (delete-file-2 ses-name clobber))
459 (delete-file-1 pname ses-name wildp clobber)))
460 (values))
461
462 (defun recursive-delete (directory dir-ses-name clobber)
463 (dolist (spec (directory (directory-namestring directory)))
464 (let ((spec-ses-name (namestring spec)))
465 (if (directoryp spec)
466 (recursive-delete (pathname spec-ses-name) spec-ses-name clobber)
467 (delete-file-2 spec-ses-name clobber))))
468 (delete-file-2 dir-ses-name clobber))
469
470 (defun delete-file-1 (pname ses-name wildp clobber)
471 (if wildp
472 (dolist (match (resolve-wildcard pname wildp))
473 (delete-file-2 (wild-match-file match) clobber))
474 (delete-file-2 ses-name clobber)))
475
476 (defun delete-file-2 (ses-name clobber)
477 (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name))
478 (if (directoryp ses-name)
479 (delete-directory ses-name)
480 (lisp:delete-file ses-name))
481 (funcall *report-function* "~&~A~%" ses-name)))
482
483
484
485 ;;;; Wildcard resolution
486
487 (defun pathnames-from-pattern (pattern files)
488 "Return a list of pathnames from files whose file-namestrings match
489 pattern. Pattern must be a non-empty string and contains only one
490 asterisk. Files contains no directories."
491 (declare (simple-string pattern))
492 (when (string= pattern "")
493 (funcall *error-function* "Must be a non-empty pattern."))
494 (unless (= (count wildcard-char pattern :test #'char=) 1)
495 (funcall *error-function* "Pattern must contain one asterisk."))
496 (multiple-value-bind (before after)
497 (before-wildcard-after pattern (wildcardp pattern))
498 (let ((result nil))
499 (dolist (f files result)
500 (let* ((ses-namestring (namestring f))
501 (f-namestring (file-namestring ses-namestring))
502 (match (find-match before after f-namestring)))
503 (when match (push f result)))))))
504
505
506 ;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the
507 ;;; wildcard character in the file-namestring and returns a list of wild-match
508 ;;; objects. When directory is supplied, pname is just a pattern, or a
509 ;;; file-namestring. It is an error for directory to be anything other than
510 ;;; absolute pathnames in the same directory. Each wild-match object contains
511 ;;; the Sesame namestring of a file in the same directory as pname, or
512 ;;; directory, and a simple-string representing what the wildcard matched.
513 ;;;
514 (defun resolve-wildcard (pname wild-pos &optional directory)
515 (multiple-value-bind (before after)
516 (before-wildcard-after (if directory
517 pname
518 (file-namestring pname))
519 wild-pos)
520 (let (result)
521 (dolist (f (or directory (directory (directory-namestring pname)))
522 (nreverse result))
523 (unless (directoryp f)
524 (let* ((ses-namestring (namestring f))
525 (f-namestring (file-namestring ses-namestring))
526 (match (find-match before after f-namestring)))
527 (if match
528 (push (make-wild-match ses-namestring match) result))))))))
529
530 ;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a
531 ;;; file-namestring. If before and after match a substring of file-namestring
532 ;;; and are respectively left bound and right bound, then anything left in
533 ;;; between is the match returned. If no match is found, nil is returned.
534 ;;; NOTE: if version numbers ever really exist, then this code will have to be
535 ;;; changed since the file-namestring of a pathname contains the version number.
536 ;;;
537 (defun find-match (before after file-namestring &optional no-cons)
538 (declare (simple-string before after file-namestring))
539 (let ((before-len (length before))
540 (after-len (length after))
541 (name-len (length file-namestring)))
542 (if (>= name-len (+ before-len after-len))
543 (let* ((start (if (string= before file-namestring
544 :end1 before-len :end2 before-len)
545 before-len))
546 (end (- name-len after-len))
547 (matchp (and start
548 (string= after file-namestring :end1 after-len
549 :start2 end :end2 name-len))))
550 (if matchp
551 (if no-cons
552 t
553 (subseq file-namestring start end)))))))
554
555 (defun before-wildcard-after (file-namestring wild-pos)
556 (declare (simple-string file-namestring))
557 (values (subseq file-namestring 0 wild-pos)
558 (subseq file-namestring (1+ wild-pos) (length file-namestring))))
559
560
561
562 ;;;; Miscellaneous Utilities (e.g., MAKEDIR).
563
564 (defun make-directory (name)
565 "Creates directory name. If name exists, then an error is signaled."
566 (let ((ses-name (ext:unix-namestring name nil)))
567 (when (unix:unix-file-kind ses-name)
568 (funcall *error-function* "Name already exists -- ~S" ses-name))
569 (enter-directory ses-name))
570 t)
571
572
573
574 ;;;; Mach Operations
575
576 (defun open-file (ses-name)
577 (multiple-value-bind (fd err)
578 (unix:unix-open ses-name unix:o_rdonly 0)
579 (unless fd
580 (funcall *error-function* "Opening ~S failed: ~A." ses-name err))
581 fd))
582
583 (defun close-file (fd)
584 (unix:unix-close fd))
585
586 (defun read-file (fd ses-name)
587 (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)
588 (unix:unix-fstat fd)
589 (declare (ignore ino nlink uid gid rdev))
590 (unless winp (funcall *error-function*
591 "Opening ~S failed: ~A." ses-name dev-or-err))
592 (let ((storage (system:allocate-system-memory size)))
593 (multiple-value-bind (read-bytes err)
594 (unix:unix-read fd storage size)
595 (when (or (null read-bytes) (not (= size read-bytes)))
596 (system:deallocate-system-memory storage size)
597 (funcall *error-function*
598 "Reading file ~S failed: ~A." ses-name err)))
599 (values storage size mode))))
600
601 (defun write-file (ses-name data byte-count mode)
602 (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644)
603 (unless fd
604 (funcall *error-function* "Couldn't create file ~S: ~A"
605 ses-name (unix:get-unix-error-msg err)))
606 (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count)
607 (unless winp
608 (funcall *error-function* "Writing file ~S failed: ~A"
609 ses-name
610 (unix:get-unix-error-msg err))))
611 (unix:unix-fchmod fd (logand mode #o777))
612 (unix:unix-close fd)))
613
614 (defun set-write-date (ses-name secs)
615 (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
616 (unix:unix-stat ses-name)
617 (declare (ignore ino mode nlink uid gid rdev size))
618 (unless winp
619 (funcall *error-function* "Couldn't stat file ~S failed: ~A."
620 ses-name dev-or-err))
621 (multiple-value-bind (winp err)
622 (unix:unix-utimes ses-name atime 0 secs 0)
623 (unless winp
624 (funcall *error-function* "Couldn't set write date of file ~S: ~A"
625 ses-name (unix:get-unix-error-msg err))))))
626
627 (defun get-write-date (ses-name)
628 (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size
629 atime mtime)
630 (unix:unix-stat ses-name)
631 (declare (ignore ino mode nlink uid gid rdev size atime))
632 (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."
633 ses-name dev-or-err))
634 mtime))
635
636 ;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE.
637 ;;; This is because it merges the new name with the old name to pick up
638 ;;; defaults, and this conflicts with Unix-oid names. For example, renaming
639 ;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't
640 ;;; have this problem.
641 ;;;
642 (defun sub-rename-file (ses-name1 ses-name2)
643 (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2)
644 (unless res
645 (funcall *error-function* "Failed to rename ~A to ~A: ~A."
646 ses-name1 ses-name2 (unix:get-unix-error-msg err)))))
647
648 (defun directory-existsp (ses-name)
649 (eq (unix:unix-file-kind ses-name) :directory))
650
651 (defun enter-directory (ses-name)
652 (declare (simple-string ses-name))
653 (let* ((length-1 (1- (length ses-name)))
654 (name (if (= (position #\/ ses-name :test #'char= :from-end t)
655 length-1)
656 (subseq ses-name 0 (1- (length ses-name)))
657 ses-name)))
658 (multiple-value-bind (winp err) (unix:unix-mkdir name #o755)
659 (unless winp
660 (funcall *error-function* "Couldn't make directory ~S: ~A"
661 name
662 (unix:get-unix-error-msg err))))))
663
664 (defun delete-directory (ses-name)
665 (declare (simple-string ses-name))
666 (multiple-value-bind (winp err)
667 (unix:unix-rmdir (subseq ses-name 0
668 (1- (length ses-name))))
669 (unless winp
670 (funcall *error-function* "Couldn't delete directory ~S: ~A"
671 ses-name
672 (unix:get-unix-error-msg err)))))
673
674
675
676 ;;;; Misc. Utility Utilities
677
678 ;;; NSEPARATE-FILES destructively returns a list of file specs from listing.
679 (defun nseparate-files (listing)
680 (do (files hold)
681 ((null listing) files)
682 (setf hold (cdr listing))
683 (unless (directoryp (car listing))
684 (setf (cdr listing) files)
685 (setf files listing))
686 (setf listing hold)))
687
688
689 (defun directoryp (p)
690 (not (or (pathname-name p) (pathname-type p))))

  ViewVC Help
Powered by ViewVC 1.1.5