...

original commit: 1f8bf85b3c2d0ca3acdc73575b5dc8f629d942be

collects/framework/editor.ss

@@ -242,29 +242,30 @@
 	      [super-on-close on-close]
 	      [super-set-modified set-modified])
       (private
-	[freshen-backup? #t]
 	[auto-saved-name #f]
 	[auto-save-out-of-date? #t]
-	[auto-save-error? #f])
+	[auto-save-error? #f]
+	[file-old?
+	 (lambda (filename)
+	   (let ([modified-seconds (file-or-directory-modify-seconds filename)]
+		 [old-seconds (- (current-seconds) (* 7 24 60 60))])
+	     (< modified-seconds old-seconds)))])
       (public
 	[backup? (lambda () #t)])
       (override
 	[on-save-file
 	 (lambda (name format)
+	   (super-on-save-file name format)
 	   (set! auto-save-error? #f)
-	   (and (super-on-save-file name format)
-		(begin
-		  (when (and (backup?)
-			     freshen-backup?
-			     (not (eq? format 'copy))
-			     (file-exists? name))
-		    (let ([back-name (path-utils:generate-backup-name name)])
-		      (set! freshen-backup? #f)
-		      (when (file-exists? back-name)
-			(delete-file back-name))
-		      (with-handlers ([(lambda (x) #t) void])
-			(copy-file name back-name))))
-		  #t)))]
+	   (when (and (backup?)
+		      (not (eq? format 'copy))
+		      (file-exists? name))
+	     (let ([back-name (path-utils:generate-backup-name name)])
+	       (when (or (not (file-exists? back-name))
+			 (file-old? back-name))
+		 (delete-file back-name))
+	       (with-handlers ([(lambda (x) #t) void])
+		 (copy-file name back-name)))))]
 	[on-close
 	 (lambda ()
 	   (super-on-close)
@@ -279,9 +280,7 @@
 	   (when auto-saved-name
 	     (if modified?
 		 (set! auto-save-out-of-date? #t)
-		 (begin
-		   (delete-file auto-saved-name)
-		   (set! auto-saved-name #f))))
+		 (remove-autosave)))
 	   (super-set-modified modified?))])
       (public
 	[autosave? (lambda () #t)]
@@ -293,19 +292,20 @@
 		      (or (not auto-saved-name)
 			  auto-save-out-of-date?))
 	     (let* ([orig-name (get-filename)]
+		    [old-auto-name auto-saved-name]
 		    [auto-name (path-utils:generate-autosave-name orig-name)]
 		    [success (save-file auto-name 'copy)])
 	       (if success
 		   (begin
-		     (when auto-saved-name
-		       (delete-file auto-saved-name))
+		     (when old-auto-name
+		       (delete-file old-auto-name))
 		     (set! auto-saved-name auto-name)
 		     (set! auto-save-out-of-date? #f))
 		   (begin
 		     (message-box 
 		      "Warning"
 		      (format "Error autosaving ~s.~n~a~n~a"
-			      (if (null? orig-name) "Untitled" orig-name)
+			      (or orig-name "Untitled")
 			      "Autosaving is turned off"
 			      "until the file is saved."))
 		     (set! auto-save-error? #t))))))]

collects/framework/exit.ss

@@ -30,8 +30,8 @@
   
   (define exiting? #f)
 
-  (define (can-exit?) (and (andmap (lambda (cb) (cb)) can?-callbacks)
-			   (user-oks-exit)))
+  (define (can-exit?) (and (user-oks-exit)
+			   (andmap (lambda (cb) (cb)) can?-callbacks)))
   (define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
 
   (define (user-oks-exit)

collects/framework/group.ss

@@ -179,17 +179,19 @@
 		(begin (set! frames null)
 		       (empty-close-down)
 		       #t)))]
-	[close-all
+	[on-close-all
 	 (lambda ()
-	   (let/ec escape
-	     (for-each (lambda (f)
-			 (let ([frame (frame-frame f)])
-			   (if (send frame can-close?)
-			       (begin (send frame on-close)
-				      (send frame show #f))
-			       (escape #f))))
-		       frames)
-	     #t))]
+	   (for-each (lambda (f)
+		       (let ([frame (frame-frame f)])
+			 (send frame on-close) 
+			 (send frame show #f)))
+		     frames))]
+	[can-close-all?
+	 (lambda ()
+	   (andmap (lambda (f)
+		     (let ([frame (frame-frame f)])
+		       (send frame can-close?)))
+		   frames))]
 	[locate-file
 	 (lambda (name)
 	   (let* ([normalized

collects/framework/main.ss

@@ -197,7 +197,14 @@
        (at-most-one
 	#t
 	(lambda ()
-	  (send (group:get-the-frame-group) close-all))))))
+	  (send (group:get-the-frame-group) can-close-all?)))))    
+
+    (exit:insert-on-callback
+     (lambda ()
+       (at-most-one
+	#t
+	(lambda ()
+	  (send (group:get-the-frame-group) on-close-all))))))
   
   (exit:insert-on-callback 
    (lambda ()

collects/tests/framework/exit.ss

@@ -52,6 +52,7 @@
 	    'failed))))
 
 (define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite"))
+;; need to test "on" callbacks
 (test 'exit-callback-called
       (lambda (x)
 	(begin0 (and (file-exists? tmp-file) (not (mred-running?)))
@@ -63,7 +64,7 @@
 	  (send-sexp-to-mred
 	   `(begin
 	      (preferences:set 'framework:verify-exit #f)
-	      (exit:insert-callback (lambda () (call-with-output-file ,tmp-file void) #t))
+	      (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t))
 	      (exit:exit))))))
 
 (test 'exit-callback-removed
@@ -73,7 +74,7 @@
 	  (send-sexp-to-mred
 	   `(begin
 	      (preferences:set 'framework:verify-exit #f)
-	      ((exit:insert-callback (lambda () (error 'called-exit-callback))))
+	      ((exit:insert-can?-callback (lambda () (error 'called-exit-callback))))
 	      (exit:exit))))))
 
 (test 'exit-callback-stops-exit
@@ -83,7 +84,7 @@
 	 (send-sexp-to-mred
 	  `(begin
 	     (preferences:set 'framework:verify-exit #f)
-	     (let ([rm-callback (exit:insert-callback (lambda () #f))])
+	     (let ([rm-callback (exit:insert-can?-callback (lambda () #f))])
 	       (exit:exit)
 	       (rm-callback)
 	       'passed)))