diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index a5bcbb56..25de637c 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -266,10 +266,14 @@ "garbage collection.") (autosave:restore-autosave-files/gui - (-> (union false? (is-a?/c top-level-window<%>))) + (-> void?) () "Opens a GUI to ask the user about recovering any autosave files" - "left around from crashes and things.") + "left around from crashes and things." + "" + "This function doesn't return until the user has finished" + "restoring the autosave files. (It uses yield to handle events" + "however).") (exit:frame-exiting (case-> diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index 394e3b94..3aea5f61 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -2,6 +2,7 @@ (module autosave mzscheme (require (lib "unitsig.ss") (lib "class.ss") + (lib "file.ss") "sig.ss" (lib "mred-sig.ss" "mred") (lib "mred.ss" "mred") ;; remove this! @@ -15,7 +16,11 @@ (import mred^ [exit : framework:exit^] [preferences : framework:preferences^] - [frame : framework:frame^]) + [frame : framework:frame^] + [scheme : framework:scheme^] + [editor : framework:editor^] + [text : framework:text^] + [finder : framework:finder^]) (define autosavable<%> (interface () @@ -70,7 +75,6 @@ (let* ([new-filename (send object do-autosave)] [tmp-box (box #f)] [filename (send object get-filename tmp-box)]) - (printf "autosave ~s ~s to ~s\n" object filename new-filename) (loop (cdr orig-objects) (if new-filename (cons (list (and (not (unbox tmp-box)) filename) @@ -99,96 +103,149 @@ ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>)) ;; opens a frame that lists the autosave files that have changed. (define (restore-autosave-files/gui) - (and (file-exists? autosave-toc-filename) - (let* ([table (call-with-input-file autosave-toc-filename read)] - ;; assume that the autosave file was deleted due to the file being saved - [filtered-table - (filter (lambda (x) (file-exists? (cadr x))) table)]) - (and (not (null? filtered-table)) - (let ([f (make-object frame:basic% (string-constant recover-autosave-files-frame-title))]) - (for-each (add-table-line (send f get-area-container)) filtered-table) - f))))) - - ;; add-table-line : (is-a? area-container<%>) - ;; -> (list (union #f string[filename]) string[filename-file-exists?]) - ;; -> void - ;; adds in a line to the overview table showing this pair of files. - (define (add-table-line area-container) - (lambda (table-entry) - (let* ([orig-file (car table-entry)] - [backup-file (cadr table-entry)] - [hp (instantiate horizontal-panel% () - (parent area-container) - (style '(border)) - (stretchable-height #f))] - [vp (instantiate vertical-panel% () - (parent hp))] - [compare - (make-object button% (string-constant autosave-details) hp - (lambda (x y) - (show-differences table-entry)))] - [recover - (make-object button% (string-constant autosave-recover) hp - (lambda (x y) - (recover-file area-container hp table-entry)))] - [msg1-panel (instantiate horizontal-panel% () - (parent vp))] - [msg1-label (instantiate message% () - (parent msg1-panel) - (label (string-constant autosave-original-label:)))] - [msg1 (instantiate message% () - (label (or orig-file (string-constant autosave-unknown-filename))) - (stretchable-width #t) - (parent msg1-panel))] - [msg2-panel (instantiate horizontal-panel% () - (parent vp))] - [msg2-label (instantiate message% () - (parent msg2-panel) - (label (string-constant autosave-autosave-label:)))] - [msg2 (instantiate message% () - (label backup-file) - (stretchable-width #t) - (parent msg2-panel))]) - (let ([w (max (send msg1-label get-width) (send msg2-label get-width))]) - (send msg1-label min-width w) - (send msg2-label min-width w)) - (send compare enable orig-file) - (void)))) - - ;; show-files : (list (union #f string[filename]) string) -> void - (define (show-files table-entry) - (let ([file1 (car table-entry)] - [file2 (cadr table-entry)]) - (define frame (make-object show-files-frame% - (if file1 - (string-constant autosave-compare-files) - (string-constant autosave-show-autosave)) - #f - (if file1 600 300) - 600)) - (define hp (instantiate horizontal-panel% () - (parent (send frame get-area-container)))) - (when file1 - (add-file-viewer file1 (string-constant autosave-original-label) hp)) - (add-file-viewer file2 (string-constant autosave-autosave-label) hp) - (send frame show #t))) - - ;; add-file-viewer : string[filename] -> void - (define (add-file-viewer filename parent label) - (define vp (make-object vertical-panel% parent)) - (define t (make-object show-files-text%)) - (define msg1 (make-object message% label vp)) - (define msg2 (make-object message% filename vp)) - (define ec (make-object editor-canvas% vp t)) - (send t load-file filename) - (send t hide-caret #t) - (send t lock #t)) - - (define show-files-frame% frame:basic%) - (define show-files-text% - (scheme:text-mixin - (editor:keymap-mixin - text:basic%))) - - (define (recover-file parent child table-entry) - (void))))) + + ;; main : -> void + ;; start everything going + (define (main) + (when (file-exists? autosave-toc-filename) + (let* ([table (call-with-input-file autosave-toc-filename read)] + ;; assume that the autosave file was deleted due to the file being saved + [filtered-table + (filter (lambda (x) (file-exists? (cadr x))) table)]) + (unless (null? filtered-table) + (let* ([f (make-object final-frame% (string-constant recover-autosave-files-frame-title))] + [t (instantiate text% () + (auto-wrap #t))] + [ec (instantiate editor-canvas% () + (parent (send f get-area-container)) + (editor t) + (line-count 2) + (style '(no-hscroll)))] + [hp (make-object horizontal-panel% (send f get-area-container))] + [vp (make-object vertical-panel% hp)]) + (make-object grow-box-spacer-pane% hp) + (send t insert (string-constant autosave-explanation)) + (send t hide-caret #t) + (send t set-position 0 0) + (send t lock #t) + + (for-each (add-table-line vp f) filtered-table) + (send f show #t) + (yield done-semaphore) + (void)))))) + + (define done-semaphore (make-semaphore 0)) + + (define final-frame% + (class frame:basic% + (rename [super-on-close on-close]) + (define/override (on-close) + (super-on-close) + (semaphore-post done-semaphore)) + (super-instantiate ()))) + + ;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>)) + ;; -> (list (union #f string[filename]) string[filename-file-exists?]) + ;; -> void + ;; adds in a line to the overview table showing this pair of files. + (define (add-table-line area-container parent) + (lambda (table-entry) + (let* ([orig-file (car table-entry)] + [backup-file (cadr table-entry)] + [hp (instantiate horizontal-panel% () + (parent area-container) + (style '(border)) + (stretchable-height #f))] + [vp (instantiate vertical-panel% () + (parent hp))] + [msg1-panel (instantiate horizontal-panel% () + (parent vp))] + [msg1-label (instantiate message% () + (parent msg1-panel) + (label (string-constant autosave-original-label:)))] + [msg1 (instantiate message% () + (label (or orig-file (string-constant autosave-unknown-filename))) + (stretchable-width #t) + (parent msg1-panel))] + [msg2-panel (instantiate horizontal-panel% () + (parent vp))] + [msg2-label (instantiate message% () + (parent msg2-panel) + (label (string-constant autosave-autosave-label:)))] + [msg2 (instantiate message% () + (label backup-file) + (stretchable-width #t) + (parent msg2-panel))] + [details + (make-object button% (string-constant autosave-details) hp + (lambda (x y) + (show-files table-entry)))] + [recover + (make-object button% (string-constant autosave-recover) hp + (lambda (recover y) + (let ([filename-result (recover-file parent table-entry)]) + (when filename-result + (send recover enable #f) + (send details enable #f) + (send msg2 set-label (string-constant autosave-recovered!)) + (send msg1 set-label filename-result)))))]) + (let ([w (max (send msg1-label get-width) (send msg2-label get-width))]) + (send msg1-label min-width w) + (send msg2-label min-width w)) + (void)))) + + ;; show-files : (list (union #f string[filename]) string) -> void + (define (show-files table-entry) + (let ([file1 (car table-entry)] + [file2 (cadr table-entry)]) + (define frame (make-object show-files-frame% + (if file1 + (string-constant autosave-compare-files) + (string-constant autosave-show-autosave)) + #f + (if file1 600 300) + 600)) + (define hp (instantiate horizontal-panel% () + (parent (send frame get-area-container)))) + (when file1 + (add-file-viewer file1 hp (string-constant autosave-original-label))) + (add-file-viewer file2 hp (string-constant autosave-autosave-label)) + (send frame show #t))) + + ;; add-file-viewer : string[filename] -> void + (define (add-file-viewer filename parent label) + (define vp (make-object vertical-panel% parent)) + (define t (make-object show-files-text%)) + (define msg1 (make-object message% label vp)) + (define msg2 (make-object message% filename vp)) + (define ec (make-object editor-canvas% vp t)) + (send t load-file filename) + (send t hide-caret #t) + (send t lock #t)) + + (define show-files-frame% frame:basic%) + (define show-files-text% + (scheme:text-mixin + (editor:keymap-mixin + text:basic%))) + + (main)) + + ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) + ;; (list (union #f string[filename]) string) + ;; -> (union #f string) + (define (recover-file parent table-entry) + (let ([orig-name (or (car table-entry) + (parameterize ([finder:dialog-parent-parameter parent]) + (finder:put-file)))]) + (and orig-name + (let ([autosave-name (cadr table-entry)]) + (let ([tmp-name (and (file-exists? orig-name) + (make-temporary-file "autosave-repair~a" orig-name))]) + (when (file-exists? orig-name) + (delete-file orig-name)) + (copy-file autosave-name orig-name) + (delete-file autosave-name) + (when tmp-name + (delete-file tmp-name)) + orig-name)))))))) diff --git a/collects/framework/private/path-utils.ss b/collects/framework/private/path-utils.ss index 31ea3ccc..7c3337ab 100644 --- a/collects/framework/private/path-utils.ss +++ b/collects/framework/private/path-utils.ss @@ -14,7 +14,9 @@ (let-values ([(base name dir?) (if name (split-path name) - (values (current-directory) "mredauto" #f))]) + (values (find-system-path 'home-dir) + "mredauto" + #f))]) (let* ([base (if (string? base) base (current-directory))]