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

Contents of /src/hemlock/dired.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b
Branch point for: RELENG_18
Changes since 1.2: +1 -3 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: dired -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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 ram 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/dired.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains site dependent code for dired.
13     ;;; Written by Bill Chiles.
14     ;;;
15    
16 ram 1.2 (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 ram 1.1 (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 ram 1.2 (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 ram 1.1 (directory
155     (when (pathname-directory spec1)
156     (funcall *error-function*
157     "Spec1 is just a pattern when supplying directory -- ~S."
158     spec1))
159 ram 1.2 (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
160 ram 1.1 (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 ram 1.2 #|
209 ram 1.1 (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 ram 1.2 |#
220 ram 1.1
221 ram 1.2 (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 ram 1.1 ;;; 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 ram 1.2 (system:deallocate-system-memory data byte-count)))
296 ram 1.1 (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 ram 1.2 (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 ram 1.1 (directory
337     (when (pathname-directory spec1)
338     (funcall *error-function*
339     "Spec1 is just a pattern when supplying directory -- ~S."
340     spec1))
341    
342 ram 1.2 (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
343 ram 1.1 (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 ram 1.2 (let* ((ses-name (ext:unix-namestring spec t))
452 ram 1.1 (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 ram 1.2 (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 ram 1.1 (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 ram 1.2 (unix:unix-open ses-name unix:o_rdonly 0)
579 ram 1.1 (unless fd
580     (funcall *error-function* "Opening ~S failed: ~A." ses-name err))
581     fd))
582    
583     (defun close-file (fd)
584 ram 1.2 (unix:unix-close fd))
585 ram 1.1
586     (defun read-file (fd ses-name)
587     (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)
588 ram 1.2 (unix:unix-fstat fd)
589 ram 1.1 (declare (ignore ino nlink uid gid rdev))
590     (unless winp (funcall *error-function*
591     "Opening ~S failed: ~A." ses-name dev-or-err))
592 ram 1.2 (let ((storage (system:allocate-system-memory size)))
593 ram 1.1 (multiple-value-bind (read-bytes err)
594 ram 1.2 (unix:unix-read fd storage size)
595 ram 1.1 (when (or (null read-bytes) (not (= size read-bytes)))
596 ram 1.2 (system:deallocate-system-memory storage size)
597 ram 1.1 (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 ram 1.2 (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644)
603 ram 1.1 (unless fd
604     (funcall *error-function* "Couldn't create file ~S: ~A"
605 ram 1.2 ses-name (unix:get-unix-error-msg err)))
606     (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count)
607 ram 1.1 (unless winp
608     (funcall *error-function* "Writing file ~S failed: ~A"
609     ses-name
610 ram 1.2 (unix:get-unix-error-msg err))))
611     (unix:unix-fchmod fd (logand mode #o777))
612     (unix:unix-close fd)))
613 ram 1.1
614     (defvar *utimes-buffer* (make-list 4 :initial-element 0))
615    
616     (defun set-write-date (ses-name secs)
617     (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
618 ram 1.2 (unix:unix-stat ses-name)
619 ram 1.1 (declare (ignore ino mode nlink uid gid rdev size))
620     (unless winp (funcall *error-function*
621     "Couldn't stat file ~S failed: ~A." ses-name
622     dev-or-err))
623     (setf (car *utimes-buffer*) atime)
624     (setf (caddr *utimes-buffer*) secs))
625 ram 1.2 (multiple-value-bind (winp err)
626     `(unix:unix-utimes ses-name ,@*utimes-buffer*)
627 ram 1.1 (unless winp
628     (funcall *error-function* "Couldn't set write date of file ~S: ~A"
629     ses-name
630 ram 1.2 (unix:get-unix-error-msg err)))))
631 ram 1.1
632     (defun get-write-date (ses-name)
633     (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size
634     atime mtime)
635 ram 1.2 (unix:unix-stat ses-name)
636 ram 1.1 (declare (ignore ino mode nlink uid gid rdev size atime))
637     (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."
638     ses-name dev-or-err))
639     mtime))
640    
641     ;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE.
642     ;;; This is because it merges the new name with the old name to pick up
643     ;;; defaults, and this conflicts with Unix-oid names. For example, renaming
644     ;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't
645     ;;; have this problem.
646     ;;;
647     (defun sub-rename-file (ses-name1 ses-name2)
648 ram 1.2 (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2)
649 ram 1.1 (unless res
650     (funcall *error-function* "Failed to rename ~A to ~A: ~A."
651 ram 1.2 ses-name1 ses-name2 (unix:get-unix-error-msg err)))))
652 ram 1.1
653     (defun directory-existsp (ses-name)
654 ram 1.2 (eq (unix:unix-file-kind ses-name) :directory))
655 ram 1.1
656     (defun enter-directory (ses-name)
657     (declare (simple-string ses-name))
658     (let* ((length-1 (1- (length ses-name)))
659     (name (if (= (position #\/ ses-name :test #'char= :from-end t)
660     length-1)
661     (subseq ses-name 0 (1- (length ses-name)))
662     ses-name)))
663 ram 1.2 (multiple-value-bind (winp err) (unix:unix-mkdir name #o755)
664 ram 1.1 (unless winp
665     (funcall *error-function* "Couldn't make directory ~S: ~A"
666     name
667 ram 1.2 (unix:get-unix-error-msg err))))))
668 ram 1.1
669     (defun delete-directory (ses-name)
670     (declare (simple-string ses-name))
671     (multiple-value-bind (winp err)
672 ram 1.2 (unix:unix-rmdir (subseq ses-name 0
673 ram 1.1 (1- (length ses-name))))
674     (unless winp
675     (funcall *error-function* "Couldn't delete directory ~S: ~A"
676     ses-name
677 ram 1.2 (unix:get-unix-error-msg err)))))
678 ram 1.1
679    
680    
681     ;;;; Misc. Utility Utilities
682    
683     ;;; NSEPARATE-FILES destructively returns a list of file specs from listing.
684     (defun nseparate-files (listing)
685     (do (files hold)
686     ((null listing) files)
687     (setf hold (cdr listing))
688     (unless (directoryp (car listing))
689     (setf (cdr listing) files)
690     (setf files listing))
691     (setf listing hold)))
692    
693    
694     (defun directoryp (p)
695     (not (or (pathname-name p) (pathname-type p))))

  ViewVC Help
Powered by ViewVC 1.1.5