..
original commit: fc91371c44d07fd7bcd75828317f6c01dffe6e08
This commit is contained in:
Robby Findler
parent
db077574b0
commit
332d616512
|
|
@ -251,7 +251,10 @@
|
|||
"Hides the preferences dialog.")
|
||||
|
||||
(autosave:register
|
||||
((is-a?/c autosave:autosavable<%>) . -> . void?)
|
||||
((and/f (is-a?/c autosave:autosavable<%>)
|
||||
(is-a?/c editor<%>))
|
||||
. -> .
|
||||
void?)
|
||||
(obj)
|
||||
"Adds \\var{obj} to the list of objects to be autosaved. When it is time"
|
||||
"to autosave, the \\rawscm{do-autosave} method of the object is"
|
||||
|
|
@ -261,7 +264,13 @@
|
|||
"de-register an object because the autosaver keeps a ``weak'' pointer"
|
||||
"to the object; i.e., the autosaver does not keep an object from"
|
||||
"garbage collection.")
|
||||
|
||||
|
||||
(autosave:restore-autosave-files/gui
|
||||
(-> void?)
|
||||
()
|
||||
"Opens a GUI to ask the user about recovering any autosave files"
|
||||
"left around from crashes and things.")
|
||||
|
||||
(exit:frame-exiting
|
||||
(case->
|
||||
((union false? (is-a?/c frame%) (is-a?/c dialog%))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,11 @@
|
|||
(require (lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "list.ss")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
;(file "/home/robby/cvs/plt/collects/string-constants/string-constant.ss")
|
||||
)
|
||||
|
||||
(provide autosave@)
|
||||
|
||||
|
|
@ -11,7 +15,8 @@
|
|||
(unit/sig framework:autosave^
|
||||
(import mred^
|
||||
[exit : framework:exit^]
|
||||
[preferences : framework:preferences^])
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
|
||||
(define autosavable<%>
|
||||
(interface ()
|
||||
|
|
@ -19,13 +24,13 @@
|
|||
|
||||
(define objects null)
|
||||
|
||||
(define autosave-toc
|
||||
(define autosave-toc-filename
|
||||
(build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
[(windows unix) ".plt-autosave-toc"]
|
||||
[else "PLT-autosave-toc"])))
|
||||
|
||||
(define autosave-toc-save
|
||||
(define autosave-toc-save-filename
|
||||
(build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
[(windows unix) ".plt-autosave-toc-save"]
|
||||
|
|
@ -37,11 +42,11 @@
|
|||
(define/override (notify)
|
||||
(when (preferences:get 'framework:autosaving-on?)
|
||||
(let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
|
||||
(when (file-exists? autosave-toc-save)
|
||||
(delete-file autosave-toc-save))
|
||||
(when (file-exists? autosave-toc)
|
||||
(copy-file autosave-toc autosave-toc-save))
|
||||
(call-with-output-file autosave-toc
|
||||
(when (file-exists? autosave-toc-save-filename)
|
||||
(delete-file autosave-toc-save-filename))
|
||||
(when (file-exists? autosave-toc-filename)
|
||||
(copy-file autosave-toc-filename autosave-toc-save-filename))
|
||||
(call-with-output-file autosave-toc-filename
|
||||
(lambda (port)
|
||||
(write new-name-mapping port))
|
||||
'truncate
|
||||
|
|
@ -52,9 +57,8 @@
|
|||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t))))
|
||||
|
||||
(define (restore-autosave-files/gui)
|
||||
...)
|
||||
|
||||
;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
|
||||
;; (listof (list (union #f string[filename]) string[filename]))
|
||||
(define (rebuild-object-list)
|
||||
(let loop ([orig-objects objects]
|
||||
[name-mapping null]
|
||||
|
|
@ -64,20 +68,44 @@
|
|||
(let* ([object-wb (car orig-objects)]
|
||||
[object (weak-box-value object-wb)])
|
||||
(if object
|
||||
(let ([new-filename (send object do-autosave)])
|
||||
(let* ([new-filename (send object do-autosave)]
|
||||
[tmp-box (box #f)]
|
||||
[filename (send object get-filename tmp-box)])
|
||||
(printf "autosave ~s to ~s\n" filename new-filename)
|
||||
(loop (cdr orig-objects)
|
||||
(cons (list (send object get-filename)
|
||||
new-filename))
|
||||
(if new-filename
|
||||
(cons (list (and (not (unbox tmp-box)) filename)
|
||||
new-filename)
|
||||
name-mapping)
|
||||
name-mapping)
|
||||
(cons object-wb new-objects)))
|
||||
(loop (cdr orig-objects)
|
||||
name-mapping
|
||||
new-objects))))))
|
||||
|
||||
;; removed-autosave : string[filename] -> void
|
||||
;; cal to indicate to that autosave filename returned from `do-autosave'
|
||||
;; has been deleted (eg, the file was saved, or the user closed the window, etc)
|
||||
(define (removed-autosave filename)
|
||||
(when (file-exists? autosave-toc-filename)
|
||||
(let* ([old-contents (call-with-input-file autosave-toc-filename read)]
|
||||
[new-contents
|
||||
(remove filename
|
||||
old-contents
|
||||
(lambda (filename table-entry)
|
||||
(equal? (cadr table-entry) filename)))])
|
||||
(when (file-exists? autosave-toc-save-filename)
|
||||
(delete-file autosave-toc-save-filename))
|
||||
(copy-file autosave-toc-filename autosave-toc-save-filename)
|
||||
(call-with-output-file autosave-toc-filename
|
||||
(lambda (port)
|
||||
(write new-contents port))
|
||||
'truncate
|
||||
'text))))
|
||||
|
||||
(define timer #f)
|
||||
|
||||
(define (register b)
|
||||
(unless (is-a? b editor<%>)
|
||||
(error 'autosave:register "expected object implemeting editor<%>, got: ~e" b))
|
||||
(unless timer
|
||||
(set! timer (make-object autosave-timer%)))
|
||||
(set! objects
|
||||
|
|
@ -87,6 +115,49 @@
|
|||
[else (let ([weak-box (car objects)])
|
||||
(if (weak-box-value weak-box)
|
||||
(cons weak-box (loop (cdr objects)))
|
||||
(loop (cdr objects))))])))))))
|
||||
|
||||
|
||||
(loop (cdr objects))))]))))
|
||||
|
||||
;; restore-autosave-files/gui : -> void
|
||||
;; opens a frame that lists the autosave files that have changed.
|
||||
(define (restore-autosave-files/gui)
|
||||
(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 frame:basic% (string-constant recover-autosave-files-frame-title) #f 400 400)])
|
||||
(for-each (add-table-line f) filtered-table)
|
||||
(send f show #t))))))
|
||||
|
||||
;; 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)
|
||||
(stretchable-height #f))]
|
||||
[vp (instantiate vertical-panel% ()
|
||||
(parent hp))]
|
||||
[compare
|
||||
(make-object button% (string-constant autosave-details) vp
|
||||
(lambda (x y)
|
||||
(show-differences table-entry)))]
|
||||
[recover
|
||||
(make-object button% (string-constant autosave-recover) vp
|
||||
(lambda (x y)
|
||||
(recover-file area-container hp table-entry)))]
|
||||
[msg1 (make-object message% (or orig-file (string-constant autosave-unknown-filename)) vp)]
|
||||
[msg2 (make-object message% (cadr table-entry) vp)])
|
||||
(send compare enable orig-file)
|
||||
(void))))
|
||||
|
||||
(define (show-differences table-entry)
|
||||
(void))
|
||||
|
||||
(define (recover-file parent child table-entry)
|
||||
(void)))))
|
||||
|
|
|
|||
|
|
@ -454,33 +454,37 @@
|
|||
(public autosave? do-autosave remove-autosave)
|
||||
[define autosave? (lambda () do-autosave?)]
|
||||
[define (do-autosave)
|
||||
(when (and (autosave?)
|
||||
(not auto-save-error?)
|
||||
(is-modified?)
|
||||
(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)])
|
||||
(with-handlers ([not-break-exn?
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
(string-constant warning)
|
||||
(string-append
|
||||
(format (string-constant error-autosaving)
|
||||
(or orig-name (string-constant untitled)))
|
||||
"\n"
|
||||
(string-constant autosaving-turned-off)
|
||||
"\n\n"
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))))
|
||||
(set! auto-save-error? #t))])
|
||||
(save-file auto-name 'copy #f)
|
||||
(when old-auto-name
|
||||
(delete-file old-auto-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))))]
|
||||
(cond
|
||||
[(and (autosave?)
|
||||
(not auto-save-error?)
|
||||
(is-modified?)
|
||||
(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)])
|
||||
(with-handlers ([not-break-exn?
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
(string-constant warning)
|
||||
(string-append
|
||||
(format (string-constant error-autosaving)
|
||||
(or orig-name (string-constant untitled)))
|
||||
"\n"
|
||||
(string-constant autosaving-turned-off)
|
||||
"\n\n"
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))))
|
||||
(set! auto-save-error? #t)
|
||||
#f)])
|
||||
(save-file auto-name 'copy #f)
|
||||
(when old-auto-name
|
||||
(delete-file old-auto-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f)
|
||||
auto-name))]
|
||||
[else auto-saved-name])]
|
||||
[define remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
|
|
|
|||
|
|
@ -193,7 +193,8 @@
|
|||
(define-signature framework:autosave-class^
|
||||
(autosavable<%>))
|
||||
(define-signature framework:autosave-fun^
|
||||
(register))
|
||||
(register
|
||||
restore-autosave-files/gui))
|
||||
(define-signature framework:autosave^
|
||||
((open framework:autosave-class^)
|
||||
(open framework:autosave-fun^)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user