From 842ce4c2531c9f040494a6bcc5637f214cb12890 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Tue, 10 Jun 2003 16:52:37 +0000 Subject: [PATCH] Some changes from Paul Foley: o Fix a number of spelling errors. o Add EXT:PURGE-FILES (hmm, should that be renamed to purge-backup-files?) to delete old versions of files. o Opening a file with :if-exists :append shouldn't set the Unix append flag, else you can't seek back to a point before you started appending. (Actually from Rudi Schlatte.) o Fix a bug in logical pathname parsing. o Fix FASL-file versioning so we don't create versioned fasl files. --- assembler/assembler.lisp | 6 +-- code/dyncount.lisp | 4 +- code/fd-stream.lisp | 8 ++-- code/filesys.lisp | 90 ++++++++++++++++++++++++++++------------ code/pathname.lisp | 4 +- compiler/dump.lisp | 4 +- docs/doc-diff.lisp | 2 +- tools/setup.lisp | 4 +- 8 files changed, 79 insertions(+), 43 deletions(-) diff --git a/assembler/assembler.lisp b/assembler/assembler.lisp index 7f4377292..ebe8ad70c 100644 --- a/assembler/assembler.lisp +++ b/assembler/assembler.lisp @@ -259,7 +259,7 @@ (open (if (eq output-file t) (make-pathname :defaults input-pathname :type "fasl") output-file) - :if-exists :new-version + :if-exists :rename-and-delete :direction :output :element-type '(unsigned-byte 8)))) (error-file-stream @@ -267,7 +267,7 @@ (open (if (eq error-file t) (make-pathname :defaults input-pathname :type "err") error-file) - :if-exists :new-version + :if-exists :rename-and-delete :direction :output))) (*clc-err-stream* (if error-file @@ -281,7 +281,7 @@ "s" "list")) listing-file) - :if-exists :new-version + :if-exists :rename-and-delete :direction :output))) (error-count 0) (warning-count 0) diff --git a/code/dyncount.lisp b/code/dyncount.lisp index 7369d0732..e0278aa02 100644 --- a/code/dyncount.lisp +++ b/code/dyncount.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/dyncount.lisp,v 1.5 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/dyncount.lisp,v 1.6 2003/06/10 16:52:36 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -74,7 +74,7 @@ VOP classification. (defun write-hash-table (table file &key (comment (format nil "Contents of ~S" table)) (reader 'read) (writer 'prin1) (test 'equal)) - (with-open-file (s file :direction :output :if-exists :new-version) + (with-open-file (s file :direction :output :if-exists :rename-and-delete) (with-standard-io-syntax (let ((*print-readably* nil)) (format s "~A~%Version ~A on ~A~%" diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 0033c6e6f..b4e84878a 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.67 2003/06/07 17:56:28 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.68 2003/06/10 16:52:36 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1328,9 +1328,7 @@ ((:new-version :rename :rename-and-delete) (setf mask (logior mask unix:o_creat))) (:supersede - (setf mask (logior mask unix:o_trunc))) - (:append - (setf mask (logior mask unix:o_append))))) + (setf mask (logior mask unix:o_trunc))))) (t (setf if-exists nil))) ; :ignore-this-arg @@ -1404,6 +1402,8 @@ (unix:unix-open name mask mode) (values nil unix:enoent)) (cond ((fixnump fd) + (when (eq if-exists :append) + (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END (return (values fd name original delete-original))) ((eql errno unix:enoent) (case if-does-not-exist diff --git a/code/filesys.lisp b/code/filesys.lisp index fbe35c8b9..78a236ed1 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.72 2003/02/14 19:47:12 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.73 2003/06/10 16:52:36 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -25,7 +25,7 @@ (in-package "EXTENSIONS") (export '(print-directory complete-file ambiguous-files default-directory - file-writable unix-namestring)) + purge-files file-writable unix-namestring)) (in-package "LISP") @@ -40,7 +40,7 @@ ;;; type := "." [^/.]* ;;; version := ".*" | ".~" ([0-9]+ | "*") "~" ;;; -;;; Note: this grammer is ambiguous. The string foo.bar.~5~ can be parsed +;;; Note: this grammar is ambiguous. The string foo.bar.~5~ can be parsed ;;; as either just the file specified or as specifying the file, type, and ;;; version. Therefore, we use the following rules when confronted with ;;; an ambiguous file.type.version string: @@ -48,7 +48,7 @@ ;;; - If the first character is a dot, it's part of the file. It is not ;;; considered a dot in the following rules. ;;; -;;; - If there is only one dot, it seperates the file and the type. +;;; - If there is only one dot, it separates the file and the type. ;;; ;;; - If there are multiple dots and the stuff following the last dot ;;; is a valid version, then that is the version and the stuff between @@ -65,13 +65,13 @@ ;;; [abc] - matches any of a, b, or c. ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn. ;;; -;;; Any of these special characters can be preceeded by a backslash to +;;; Any of these special characters can be preceded by a backslash to ;;; cause it to be treated as a regular character. ;;; (defun remove-backslashes (namestr start end) - "Remove and occurences of \\ from the string because we've already - checked for whatever they may have been backslashed." + "Remove any occurrences of \\ from the string because we've already + checked for whatever may have been backslashed." (declare (type simple-base-string namestr) (type index start end)) (let* ((result (make-string (- end start))) @@ -199,7 +199,7 @@ (any-version (namestr start end) ;; process end of string looking for a version candidate. (multiple-value-bind (version where) - (explicit-version namestr start end) + (explicit-version namestr start end) (cond ((not (eq version :newest)) (values version where)) ((and (>= (- end 2) start) @@ -221,12 +221,12 @@ (any-name (namestr start end) (declare (ignore namestr)) (values start end))) - (multiple-value-bind - (version vstart)(any-version namestr start end) - (multiple-value-bind - (tstart tend)(any-type namestr start vstart) - (multiple-value-bind - (nstart nend)(any-name namestr start (or tstart vstart)) + (multiple-value-bind (version vstart) + (any-version namestr start end) + (multiple-value-bind (tstart tend) + (any-type namestr start vstart) + (multiple-value-bind (nstart nend) + (any-name namestr start (or tstart vstart)) (values (maybe-make-pattern namestr nstart nend) (and tstart (maybe-make-pattern namestr (1+ tstart) tend)) @@ -242,7 +242,7 @@ (char= (schar namestr start) #\/)))) (when absolute (incf start)) - ;; Next, split the remainder into slash seperated chunks. + ;; Next, split the remainder into slash separated chunks. (collect ((pieces)) (loop (let ((slash (position #\/ namestr :start start :end end))) @@ -279,7 +279,7 @@ nil (let ((first (car pieces))) (multiple-value-bind - (search-list new-start) + (search-list new-start) (maybe-extract-search-list namestr (car first) (cdr first)) (when search-list @@ -425,7 +425,9 @@ (type-supplied (not (or (null type) (eq type :unspecific)))) (logical-p (logical-pathname-p pathname)) (version (%pathname-version pathname)) - (version-supplied (not (or (null version) (member version '(:newest :unspecific)))))) + (version-supplied (not (or (null version) + (member version '(:newest + :unspecific)))))) (when name (strings (unparse-unix-piece name))) (when type-supplied @@ -562,7 +564,7 @@ ;;; %enumerate-directories -- Internal ;;; ;;; The directory node and device numbers are maintained for the current path -;;; during the search for the detection of paths loops upon :wild-inferiors. +;;; during the search for the detection of path loops upon :wild-inferiors. ;;; (defun %enumerate-directories (head tail pathname verify-existance follow-links nodes function) @@ -775,7 +777,7 @@ ;;; (defun probe-file (pathname) "Return a pathname which is the truename of the file if it exists, NIL - otherwise. An error of type file-error is signaled if pathname is wild." + otherwise. An error of type file-error is signalled if pathname is wild." (if (wild-pathname-p pathname) (error 'simple-file-error :pathname pathname @@ -843,6 +845,40 @@ (unix:get-unix-error-msg err)))))) t) +;;; Purge-Files -- Public +;;; +;;; Purge old file versions +;;; +(defun purge-files (pathname &optional (keep 0)) + "Delete old versions of files matching the given Pathname, +optionally keeping some of the most recent old versions." + (declare (type (or pathname string stream) pathname) + (type (integer 0 *) keep)) + (let ((hash (make-hash-table :test 'equal))) + (enumerate-search-list + (path (make-pathname :version :wild :defaults pathname)) + (clrhash hash) + (enumerate-matches (name path nil :follow-links nil) + (let ((dot (position #\. name :from-end t)) + (len (length name))) + (when (and dot + (> len (+ dot 3)) + (char= (char name (1+ dot)) #\~) + (char= (char name (1- len)) #\~) + (eq (unix:unix-file-kind name) :file)) + (multiple-value-bind (version next) + (parse-integer name :start (+ dot 2) :end (1- len) + :junk-allowed t) + (when (and version (= next (1- len))) + (push (cons version name) + (gethash (subseq name 0 dot) hash '()))))))) + (maphash (lambda (key value) + (declare (ignore key)) + (mapc #'unix:unix-unlink + (mapcar #'cdr (nthcdr keep + (sort value #'> :key #'car))))) + hash)))) + ;;; User-Homedir-Pathname -- Public ;;; @@ -858,7 +894,7 @@ ;;; (defun file-write-date (file) "Return file's creation date, or NIL if it doesn't exist. - An error of type file-error is signaled if file is a wild pathname" + An error of type file-error is signalled if file is a wild pathname" (if (wild-pathname-p file) (error 'simple-file-error :pathname file @@ -906,10 +942,10 @@ "Returns a list of pathnames, one for each file that matches the given pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL, - then symblolic links in the result are not expanded which is not the - default because TRUENAME does follow links, and the result pathnames are + then symbolic links in the result are not expanded, which is not the + default because TRUENAME does follow links and the result pathnames are defined to be the TRUENAME of the pathname (the truename of a link may well - be in another directory.) If FOLLOW-LINKS is NIL then symbolic links are + be in another directory). If FOLLOW-LINKS is NIL then symbolic links are not followed." (let ((results nil)) (enumerate-search-list @@ -940,9 +976,9 @@ ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package. ;;; (defun print-directory (pathname &optional stream &key all verbose return-list) - "Like Directory, but prints a terse, multi-coloumn directory listing + "Like Directory, but prints a terse, multi-column directory listing instead of returning a list of pathnames. When :all is supplied and - non-nil, then Unix dot files are included too (as ls -a). When :vervose + non-nil, then Unix dot files are included too (as ls -a). When :verbose is supplied and non-nil, then a long listing of miscellaneous information is output one file per line." (let ((*standard-output* (out-synonym-of stream)) @@ -955,7 +991,7 @@ (let ((contents (directory pathname :all all :check-for-subdirs nil :truenamep nil)) (result nil)) - (format t "Directory of ~A :~%" (namestring pathname)) + (format t "Directory of ~A:~%" (namestring pathname)) (dolist (file contents) (let* ((namestring (unix-namestring file)) (tail (subseq namestring @@ -1059,7 +1095,7 @@ (cols (max (truncate width col-width) 1)) (lines (ceiling cnt cols))) (declare (fixnum cols lines)) - (format t "Directory of ~A :~%" (namestring pathname)) + (format t "Directory of ~A:~%" (namestring pathname)) (dotimes (i lines) (declare (fixnum i)) (dotimes (j cols) diff --git a/code/pathname.lisp b/code/pathname.lisp index 6753fc2c6..48bce66b2 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.61 2003/06/07 17:56:28 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.62 2003/06/10 16:52:36 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1657,7 +1657,7 @@ a host-structure or string." (defun logical-chunkify (namestr start end) (collect ((chunks)) (do ((i start (1+ i)) - (prev 0)) + (prev start)) ((= i end) (when (> end prev) (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 280779361..58c16e764 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.78 2003/03/22 16:15:20 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.79 2003/06/10 16:52:36 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -393,7 +393,7 @@ (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output - :if-exists :new-version + :if-exists :rename-and-delete :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind diff --git a/docs/doc-diff.lisp b/docs/doc-diff.lisp index 7f232bb68..0fb0fd30e 100644 --- a/docs/doc-diff.lisp +++ b/docs/doc-diff.lisp @@ -110,7 +110,7 @@ label old kind)) (setf (gethash label *defined-labels*) kind)))))))) (with-open-file (s output-file :direction :output - :if-exists :new-version) + :if-exists :rename-and-delete) (map-undocumented-hemlock-things *command-names* :command s #'document-command *cmds-to-ignore*) (terpri s) diff --git a/tools/setup.lisp b/tools/setup.lisp index 9c121ff5f..833a584aa 100644 --- a/tools/setup.lisp +++ b/tools/setup.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.33 2003/05/31 23:58:12 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.34 2003/06/10 16:52:37 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -118,7 +118,7 @@ :test #'string=) #'string<)))))))))) - (with-open-file (s file :direction :output :if-exists :new-version) + (with-open-file (s file :direction :output :if-exists :rename-and-delete) (dolist (form (forms)) (write form :stream s :pretty t) (terpri s))))) -- GitLab