;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:10; Patch-File:T -*-
;;; Private patches made by NICK
;;; Reason:
;;;  Added  *ignore-noncontiguous-versions* variable.  If T, "h" in dired will delete *all* old
;;; Reason:
;;;  versions, even if they are not contiguous.
;;; Written 7-Nov-85 13:32:00 by NICK,
;;; while running on Lambda A from band 3
;;; with System 102.158, Local-File 56.11, FILE-Server 13.2, Unix-Interface 5.6, MagTape 40.22, ZMail 57.10, Tiger 20.6, KERMIT 26.20, MEDIUM-RESOLUTION-COLOR 17.4, Experimental Sited 1.0, Experimental window-maker 1.0, Experimental TCP-Kernel 30.0, Experimental TCP-User 57.0, Experimental TCP-Server 33.0, microcode 768, chaos/tcp loaded.



; From file DIRED.LISP#> QL.ZWEI; LMI: (308)
#8R ZWEI#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER#:PATCH-SOURCE-FILE "LMI: QL.ZWEI; DIRED.#"

(defvar *ignore-noncontiguous-versions* nil "Ignore non-contiguous file version numbers in 'h' in dired")

))



; From file DIRED.LISP#> QL.ZWEI; LMI: (308)
#8R ZWEI#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER#:PATCH-SOURCE-FILE "LMI: QL.ZWEI; DIRED.#"

(DEFCOM COM-DIRED-AUTOMATIC "Mark superfluous versions of current file for deletion
Superfluous files are those with more numbered versions than the value
of *FILE-VERSIONS-KEPT* (not counting noncontiguous versions),
and files with type in the list *TEMP-FILE-TYPE-LIST*.
Files marked with a $ are always exempted.
With numeric argument, processes whole directory." ()
  (IF *NUMERIC-ARG-P* (COM-DIRED-AUTOMATIC-ALL)
      ;; Start by making FIRST-LINE and LAST-LINE bracket all of this file,
      ;; and make VERSIONS be a list of the numeric versions of it
      (LET ((FIRST-LINE (BP-LINE (POINT)))
	    (LAST-LINE)
	    (STOP-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
	    VERSIONS)
	(DO ((LINE FIRST-LINE (LINE-NEXT LINE))
	     (NAME (SEND (DIRED-LINE-PATHNAME-OR-BARF FIRST-LINE) :NAME))
	     (TYPE (SEND (DIRED-LINE-PATHNAME FIRST-LINE) :TYPE))
	     (PATHNAME))
	    ((EQ LINE STOP-LINE) (SETQ LAST-LINE LINE))
	  (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE))
	  (OR (AND (EQUAL (SEND PATHNAME :NAME) NAME)
		   (OR (EQUAL (SEND PATHNAME :TYPE) TYPE)
		       (MEMQ (SEND PATHNAME :VERSION) '(:NEWEST :UNSPECIFIC))))
	      (RETURN (SETQ LAST-LINE LINE)))
	  (LET ((VERS (SEND PATHNAME :VERSION)))
	    (AND (NOT (MEMQ VERS '(:NEWEST :UNSPECIFIC)))
		 (PUSH VERS VERSIONS))))
	;; Now sort the versions into decreasing order and drop any nonconsecutive old ones.
	(SETQ VERSIONS (SORT VERSIONS #'>))
	(unless *ignore-noncontiguous-versions*
	  (DO ((V VERSIONS (CDR V)))
	    ((NULL (CDR V)))
	  (IF ( (CAR V) (1+ (CADR V)))
	      (RETURN (SETF (CDR V) NIL)))))
	;; Now remove the last N of them from the list to be flushed.
	(SETQ VERSIONS (NTHCDR *FILE-VERSIONS-KEPT* VERSIONS))
	;; Now scan through, and mark for deletion all the versions still in VERSIONS.
	;; Also mark temp types.
	(DO ((LINE FIRST-LINE (LINE-NEXT LINE))
	     PATHNAME TYPE VERS)
	    ((EQ LINE LAST-LINE))
	  (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE)
		VERS (SEND PATHNAME :VERSION)
		TYPE (SEND PATHNAME :TYPE))
	  (COND ((OR (MEMQ VERS VERSIONS)
		     (SYS:MEMBER-EQUAL TYPE *TEMP-FILE-TYPE-LIST*))
		 (OR (GET (LOCF (LINE-PLIST LINE)) :DONT-REAP)
		     (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
		        (MUNG-LINE LINE)
			(SETF (CLI:AREF LINE 0) #/D))))))))
  DIS-TEXT)

))