..
original commit: 6e2b0ee5bffbf12912fedfc0a0119e6a5b42dd78
This commit is contained in:
Robby Findler
parent
1c94dbf071
commit
c9c0aefebb
|
|
@ -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->
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user