diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index 6f4b515a..a0033303 100644 --- a/collects/framework/editor.ss +++ b/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))))))] diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss index b991a6a7..8b054a13 100644 --- a/collects/framework/exit.ss +++ b/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) diff --git a/collects/framework/group.ss b/collects/framework/group.ss index d434133d..73adb559 100644 --- a/collects/framework/group.ss +++ b/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 diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 5a5d48a9..5ac5ffb3 100644 --- a/collects/framework/main.ss +++ b/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 () diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index 3cfdb1c5..d5738efc 100644 --- a/collects/tests/framework/exit.ss +++ b/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)))