Implement M-x dired-clean-directory.

diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm
index 383ae662fff7d738ea59bc63d55f725de1620f1f..7dc7b13b109ddce5cf2d1f85774a2533c686ed53 100644 (file)
--- a/v7/src/edwin/dired.scm
+++ b/v7/src/edwin/dired.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: dired.scm,v 1.138 1993/10/26 21:28:19 cph Exp $
+;;;    $Id: dired.scm,v 1.139 1993/10/26 23:15:17 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -393,19 +393,18 @@ Type `h' after entering dired for more info."
    (region->string (dired-filename-region lstart))))
 
 (define (dired-mark char n)
-  (with-read-only-defeated (current-point)
-    (lambda ()
-      (dotimes n
-       (lambda (i)
-         i                             ;ignore
-         (let ((lstart (line-start (current-point) 0)))
-           (guarantee-dired-filename-line lstart)
-           (dired-mark-1 lstart char)
-           (set-dired-point! (line-start lstart 1))))))))
+  (do ((i 0 (fix:+ i 1)))
+      ((fix:= i n) unspecific)
+    (let ((lstart (line-start (current-point) 0)))
+      (guarantee-dired-filename-line lstart)
+      (dired-mark-1 lstart char)
+      (set-dired-point! (line-start lstart 1)))))
 
 (define (dired-mark-1 lstart char)
-  (delete-right-char lstart)
-  (insert-chars char 1 lstart))
+  (with-read-only-defeated lstart
+    (lambda ()
+      (delete-right-char lstart)
+      (insert-chars char 1 lstart))))
 
 (define (dired-file-line? lstart)
   (and (dired-filename-start lstart)
@@ -422,26 +421,79 @@ Type `h' after entering dired for more info."
   "Flag for deletion files whose names suggest they are auto save files."
   ()
   (lambda ()
-    (with-read-only-defeated (current-point)
-      (lambda ()
-       (for-each-file-line (current-buffer)
-         (lambda (lstart)
-           (if (os/auto-save-filename?
-                (region->string (dired-filename-region lstart)))
-               (dired-mark-1 lstart dired-flag-delete-char))))))))
+    (for-each-file-line (current-buffer)
+      (lambda (lstart)
+       (if (os/auto-save-filename?
+            (region->string (dired-filename-region lstart)))
+           (dired-mark-1 lstart dired-flag-delete-char))))))
 
 (define-command dired-flag-backup-files
-  "Flag all backup files (names ending with ~) for deletion."
+  "Flag all backup files for deletion."
   ()
   (lambda ()
-    (with-read-only-defeated (current-point)
-      (lambda ()
-       (for-each-file-line (current-buffer)
-         (lambda (lstart)
-           (if (os/backup-filename?
-                (region->string (dired-filename-region lstart)))
-               (dired-mark-1 lstart dired-flag-delete-char))))))))
-
+    (for-each-file-line (current-buffer)
+      (lambda (lstart)
+       (if (os/backup-filename?
+            (region->string (dired-filename-region lstart)))
+           (dired-mark-1 lstart dired-flag-delete-char))))))
+
+(define-command dired-clean-directory
+  "Flag numerical backups for deletion.
+Spares dired-kept-versions latest versions, and kept-old-versions oldest.
+Positive numeric arg overrides dired-kept-versions;
+negative numeric arg overrides kept-old-versions with minus the arg."
+  "P"
+  (lambda (argument)
+    (let ((argument (command-argument-value argument))
+         (old (ref-variable kept-old-versions))
+         (new (ref-variable dired-kept-versions))
+         (do-it
+          (lambda (old new)
+            (let ((total (+ old new)))
+              (for-each (lambda (file)
+                          (let ((nv (length (cdr file))))
+                            (if (> nv total)
+                                (let ()
+                                  (let ((end (- nv total)))
+                                    (do ((versions
+                                          (list-tail
+                                           (sort (cdr file)
+                                                 (lambda (x y)
+                                                   (< (car x) (car y))))
+                                           old)
+                                          (cdr versions))
+                                         (index 0 (fix:+ index 1)))
+                                        ((fix:= index end))
+                                      (dired-mark-1 (cdar versions) #\D)))))))
+                        (dired-numeric-backup-files))))))
+      (cond ((and argument (> argument 0)) (do-it argument new))
+           ((and argument (< argument 0)) (do-it old (- argument)))
+           (else (do-it old new))))))
+
+(define (dired-numeric-backup-files)
+  (let ((result '()))
+    (let loop ((start (line-start (buffer-start (current-buffer)) 0)))
+      (let ((next (line-start start 1 #f)))
+       (if next
+           (begin
+             (let ((region (dired-filename-region start)))
+               (if region
+                   (let ((filename (region->string region)))
+                     (let ((root.version (numeric-backup-filename? filename)))
+                       (if root.version
+                           (let ((root (car root.version))
+                                 (version.index
+                                  (cons (cdr root.version) start)))
+                             (let ((entry (assoc root result)))
+                               (if entry
+                                   (set-cdr! entry
+                                             (cons version.index (cdr entry)))
+                                   (set! result
+                                         (cons (list root version.index)
+                                               result))))))))))
+             (loop next)))))
+    result))
+\f
 (define (dired-kill-files)
   (let ((filenames (dired-marked-files dired-flag-delete-char)))
     (if (not (null? filenames))
@@ -548,9 +600,7 @@ Type `h' after entering dired for more info."
                       (pathname-new-directory (car filename) destination))
            true))))
     (if copied?
-       (with-read-only-defeated (cdr filename)
-         (lambda ()
-           (dired-mark-1 (cdr filename) #\space))))
+       (dired-mark-1 (cdr filename) #\space))
     copied?))
 \f
 ;;;; List Directory

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index 8c706ffed4c4b33b985638a78935eaef02e4c1a1..df9da490a048038a5facbd6efb44fd1163083d64 100644 (file)
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: dos.scm,v 1.11 1993/07/30 06:26:13 gjr Exp $
+;;;    $Id: dos.scm,v 1.12 1993/10/26 23:15:25 cph Exp $
 ;;;
 ;;;    Copyright (c) 1992-1993 Massachusetts Institute of Technology
 ;;;
@@ -312,6 +312,20 @@ Includes the new backup.  Must be > 0."
     (and (fix:fixnum? version)
         (fix:> version 0))))
 
+(define (os/numeric-backup-filename? filename)
+  (let ((type (pathname-type filename)))
+    (and (string? type)
+        (fix:= (string-length type) 3)
+        (let ((version (string->number type)))
+          (and version
+               (cons (->namestring (pathname-new-type filename #f))
+                     version)))
+        (let ((version (substring->number type 1 3)))
+          (and version
+               (cons (->namestring (pathname-new-type filename
+                                                      (string-head type 1)))
+                     version))))))
+
 (define (os/auto-save-filename? filename)
   (let ((version (filename->version-number filename)))
     (and (fix:fixnum? version)

diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index eeea8ffb6ac8e99851cb3413203f0339f222b5cf..6763c7faea2059f242b2a25b62ff2eac69589948 100644 (file)
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: unix.scm,v 1.38 1993/10/16 10:22:46 cph Exp $
+;;;    $Id: unix.scm,v 1.39 1993/10/26 23:15:31 cph Exp $
 ;;;
 ;;;    Copyright (c) 1989-1993 Massachusetts Institute of Technology
 ;;;
@@ -302,7 +302,7 @@ Includes the new backup.  Must be > 0."
          filename))))
 \f
 (define unix/encoding-pathname-types
-  '("Z" "gz"))
+  '("Z" "gz" "KY"))
 
 (define unix/backup-suffixes
   (cons "~"
@@ -310,10 +310,35 @@ Includes the new backup.  Must be > 0."
             unix/encoding-pathname-types)))
 
 (define (os/backup-filename? filename)
-  (let loop ((suffixes unix/backup-suffixes))
-    (and (not (null? suffixes))
-        (or (string-suffix? (car suffixes) filename)
-            (loop (cdr suffixes))))))
+  (let ((end (string-length filename)))
+    (let loop ((suffixes unix/backup-suffixes))
+      (and (not (null? suffixes))
+          (or (let ((suffix (car suffixes)))
+                (let ((start (fix:- end (string-length suffix))))
+                  (and (fix:> start 0)
+                       (let loop ((suffix-index 0) (index start))
+                         (if (fix:= index end)
+                             start
+                             (and (char=? (string-ref suffix suffix-index)
+                                          (string-ref filename index))
+                                  (loop (fix:+ suffix-index 1)
+                                        (fix:+ index 1))))))))
+              (loop (cdr suffixes)))))))
+
+(define (os/numeric-backup-filename? filename)
+  (let ((suffix (os/backup-filename? filename)))
+    (and suffix
+        (fix:>= suffix 4)
+        (let loop ((index (fix:- suffix 2)))
+          (and (fix:>= index 2)
+               (if (char-numeric? (string-ref filename index))
+                   (loop (fix:- index 1))
+                   (and (char=? (string-ref filename index) #\~)
+                        (char=? (string-ref filename (fix:- index 1)) #\.)
+                        (cons (string-head filename (fix:- index 1))
+                              (substring->number filename
+                                                 (fix:+ index 1)
+                                                 suffix)))))))))
 
 (define (os/pathname-type-for-mode pathname)
   (let ((type (pathname-type pathname)))