Skip to content

Commit 49e5b0f

Browse files
rfindlerrfindler
committed
improve autosave tracking
specifically handle the situation where there are multiple eventspaces containing files being edited (by tracking the set of objects that can be autosaved in an eventspace-specific way, using multiple timer% objects) and multiple applications (by using filesystem locking for the toc file)
1 parent 3f0037c commit 49e5b0f

4 files changed

Lines changed: 165 additions & 109 deletions

File tree

‎gui-lib/framework/main.rkt‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -647,7 +647,9 @@ was never saved, then the first element of the list is @racket[#f].
647647
path-utils:generate-autosave-name
648648
(-> (or/c #f path-string? path-for-some-system?) path?)
649649
(filename)
650-
@{Generates a name for an autosave file from @racket[filename].})
650+
@{Generates a name for an autosave file from @racket[filename] and
651+
registers the mapping from @racket[filename] to the result in the autosave table of contents,
652+
@racket[autosave:current-toc-path].})
651653

652654
(proc-doc/names
653655
path-utils:generate-backup-name

‎gui-lib/framework/private/autosave.rkt‎

Lines changed: 106 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
racket/unit
55
racket/file
66
racket/match
7+
racket/list
78
"sig.rkt"
89
"text-sig.rkt"
910
"../gui-utils.rkt"
@@ -24,14 +25,12 @@
2425
[prefix group: framework:group^]
2526
[prefix canvas: framework:canvas^])
2627

27-
(export framework:autosave^)
28+
(export framework:autosave/int^)
2829

2930
(define autosavable<%>
3031
(interface ()
3132
do-autosave))
3233

33-
(define objects null)
34-
3534
(define current-toc-path
3635
(make-parameter
3736
(build-path (find-system-path 'pref-dir)
@@ -40,98 +39,132 @@
4039
[else "PLT-autosave-toc.rktd"]))))
4140
(define toc-path (current-toc-path))
4241

43-
(define (get-autosave-toc-save-filename)
44-
(define toc-path (current-toc-path))
45-
(define-values (base name dir) (split-path toc-path))
46-
(define save-filename-path
47-
(case (system-type)
48-
[(unix) ".plt-autosave-toc-save.rktd"]
49-
[else "PLT-autosave-toc-save.rktd"]))
50-
(make-directory* base)
51-
(build-path base save-filename-path))
52-
42+
#|
43+
44+
The toc files contain `autosave-toc` entries
45+
46+
autosave-toc ::= (listof autosave-to-entry)
47+
autosave-toc-entry ::=
48+
(list/c (or/c #f bytes[filename]) -- filename of the edited file (#f if not yet saved)
49+
bytes[filename])) -- filename of the autosave file
50+
51+
|#
52+
53+
(define (with-autosave-filesystem-lock thunk)
54+
(define autosave-toc-save-filename (current-toc-path))
55+
(call-with-file-lock/timeout
56+
autosave-toc-save-filename
57+
'exclusive
58+
thunk
59+
(λ ()
60+
((autosave-lockfile-failure) autosave-toc-save-filename))))
61+
62+
;; -> autosave-toc
63+
;; assumes in the dynamic-extent of the thunk passed to with-autosave-filesystem-lock
64+
(define (get-autosave-toc-content)
65+
(call-with-input-file (current-toc-path)
66+
(λ (port)
67+
(read port))))
68+
69+
;; autosave-toc -> void
70+
;; assumes in the dynamic-extent of the thunk passed to with-autosave-filesystem-lock
71+
(define (put-autosave-toc-content toc-content)
72+
(call-with-output-file (current-toc-path)
73+
(λ (port)
74+
(write toc-content port)
75+
(newline port))
76+
#:exists 'truncate
77+
#:mode 'text))
78+
79+
(define-local-member-name add-object)
5380
(define autosave-timer%
5481
(class timer%
5582
(inherit start)
56-
(field [last-name-mapping #f])
83+
(define objects '())
84+
(define last-name-mapping '())
5785
(define/override (notify)
5886
(when (preferences:get 'framework:autosaving-on?)
59-
(let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
60-
(define toc-path (current-toc-path))
61-
(define autosave-toc-save-filename (get-autosave-toc-save-filename))
62-
(set! objects new-objects)
63-
(unless (equal? last-name-mapping new-name-mapping)
64-
(set! last-name-mapping new-name-mapping)
65-
(when (file-exists? autosave-toc-save-filename)
66-
(delete-file autosave-toc-save-filename))
67-
(when (file-exists? toc-path)
68-
(copy-file toc-path autosave-toc-save-filename))
69-
(call-with-output-file toc-path
70-
(λ (port)
71-
(write new-name-mapping port))
72-
#:exists 'truncate
73-
#:mode 'text))))
87+
(define-values (new-objects new-name-mapping) (rebuild-object-list))
88+
(define toc-path (current-toc-path))
89+
(set! objects new-objects)
90+
(unless (equal? last-name-mapping new-name-mapping)
91+
(define added (remove* last-name-mapping new-name-mapping))
92+
(define removed (remove* new-name-mapping last-name-mapping))
93+
(set! last-name-mapping new-name-mapping)
94+
(with-autosave-filesystem-lock
95+
(λ ()
96+
(define old (get-autosave-toc-content))
97+
(define new (remove-duplicates (append (remove* removed old) added)))
98+
(put-autosave-toc-content new)))))
7499
(cond
75-
[(null? objects) (set! timer #f)]
100+
[(null? objects) (hash-set! timers (current-eventspace) #f)]
76101
[else
77102
(let ([seconds (preferences:get 'framework:autosave-delay)])
78103
(start (* 1000 seconds) #t))]))
104+
105+
;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
106+
;; autosave-toc)
107+
(define/private (rebuild-object-list)
108+
(let loop ([orig-objects objects]
109+
[name-mapping null]
110+
[new-objects null])
111+
(if (null? orig-objects)
112+
(values new-objects name-mapping)
113+
(let* ([object-wb (car orig-objects)]
114+
[object (weak-box-value object-wb)])
115+
(if object
116+
(let* ([new-filename (send object do-autosave)]
117+
[tmp-box (box #f)]
118+
[filename (send object get-filename tmp-box)])
119+
(loop (cdr orig-objects)
120+
(if new-filename
121+
(cons (list (and (not (unbox tmp-box))
122+
filename
123+
(path->bytes filename))
124+
(and new-filename
125+
(path->bytes new-filename)))
126+
name-mapping)
127+
name-mapping)
128+
(cons object-wb new-objects)))
129+
(loop (cdr orig-objects)
130+
name-mapping
131+
new-objects))))))
132+
133+
(define/public (add-object b)
134+
(set! objects
135+
(let loop ([objects objects])
136+
(cond
137+
[(null? objects) (list (make-weak-box b))]
138+
[else (let ([weak-box (car objects)])
139+
(if (weak-box-value weak-box)
140+
(cons weak-box (loop (cdr objects)))
141+
(loop (cdr objects))))]))))
142+
79143
(super-new)
80144
(let ([seconds (preferences:get 'framework:autosave-delay)])
81145
(start (* 1000 seconds) #t))))
146+
147+
(define (autosave-lockfile-failure path)
148+
(message-box "" (format "Unable to claim lockfile ~a" path)))
82149

83-
;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
84-
;; (listof (list (union #f string[filename]) string[filename]))
85-
(define (rebuild-object-list)
86-
(let loop ([orig-objects objects]
87-
[name-mapping null]
88-
[new-objects null])
89-
(if (null? orig-objects)
90-
(values new-objects name-mapping)
91-
(let* ([object-wb (car orig-objects)]
92-
[object (weak-box-value object-wb)])
93-
(if object
94-
(let* ([new-filename (send object do-autosave)]
95-
[tmp-box (box #f)]
96-
[filename (send object get-filename tmp-box)])
97-
(loop (cdr orig-objects)
98-
(if new-filename
99-
(cons (list (and (not (unbox tmp-box))
100-
filename
101-
(path->bytes filename))
102-
(and new-filename
103-
(path->bytes new-filename)))
104-
name-mapping)
105-
name-mapping)
106-
(cons object-wb new-objects)))
107-
(loop (cdr orig-objects)
108-
name-mapping
109-
new-objects))))))
110-
111-
(define timer #f)
150+
(define timers (make-weak-hash))
112151
;; when the autosave delay is changed then we
113152
;; trigger an autosave right away and let the
114153
;; callback trigger the next one at the right interval
115154
(preferences:add-callback
116155
'framework:autosave-delay
117156
(λ (k v)
118-
(when timer
119-
(send timer stop)
120-
(send timer start 0 #t))))
121-
122-
157+
(for ([(_ timer) (in-hash timers)])
158+
(when timer
159+
(send timer stop)
160+
(send timer start 0 #t)))))
123161

124162
(define (register b)
163+
(define timer (hash-ref timers (current-eventspace) #f))
125164
(unless timer
126-
(set! timer (make-object autosave-timer%)))
127-
(set! objects
128-
(let loop ([objects objects])
129-
(cond
130-
[(null? objects) (list (make-weak-box b))]
131-
[else (let ([weak-box (car objects)])
132-
(if (weak-box-value weak-box)
133-
(cons weak-box (loop (cdr objects)))
134-
(loop (cdr objects))))]))))
165+
(set! timer (make-object autosave-timer%))
166+
(hash-set! timers (current-eventspace) timer))
167+
(send timer add-object b))
135168

136169
;; restore-autosave-files/gui : -> void?
137170
;; opens a frame that lists the autosave files that have changed.

‎gui-lib/framework/private/path-utils.rkt‎

Lines changed: 52 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,42 +1,59 @@
11
#lang scheme/unit
2-
(require "sig.rkt")
2+
(require "sig.rkt"
3+
racket/file)
34

4-
(import)
5+
(import framework:autosave/int^)
56
(export framework:path-utils^)
67

7-
(define (generate-autosave-name name)
8-
(let-values ([(base name dir?)
9-
(if name
10-
(split-path name)
11-
(values (find-system-path 'doc-dir)
12-
(bytes->path-element #"mredauto")
13-
#f))])
14-
(let* ([base (if (path? base)
15-
base
16-
(current-directory))]
17-
[path (if (relative-path? base)
18-
(build-path (current-directory) base)
19-
base)])
20-
(let loop ([n 1])
21-
(let* ([numb (string->bytes/utf-8 (number->string n))]
22-
[new-name
23-
(build-path path
24-
(if (eq? (system-type) 'windows)
25-
(bytes->path-element
26-
(bytes-append (regexp-replace #rx#"\\..*$"
27-
(path-element->bytes name)
28-
#"")
29-
#"."
30-
numb))
31-
(bytes->path-element
32-
(bytes-append #"#"
33-
(path-element->bytes name)
34-
#"#"
35-
numb
36-
#"#"))))])
37-
(if (file-exists? new-name)
38-
(loop (add1 n))
39-
new-name))))))
8+
(define (generate-autosave-name orig-name)
9+
(define-values (base name dir?)
10+
(if orig-name
11+
(split-path orig-name)
12+
(values (find-system-path 'doc-dir)
13+
(bytes->path-element #"mredauto")
14+
#f)))
15+
(define path
16+
(let ([base (if (path? base)
17+
base
18+
(current-directory))])
19+
(if (relative-path? base)
20+
(build-path (current-directory) base)
21+
base)))
22+
(with-autosave-filesystem-lock
23+
(λ ()
24+
(define autosave-toc (get-autosave-toc-content))
25+
(define autosave-filename
26+
(let loop ([n 1])
27+
(define numb (string->bytes/utf-8 (number->string n)))
28+
(define new-name
29+
(build-path path
30+
(if (eq? (system-type) 'windows)
31+
(bytes->path-element
32+
(bytes-append (regexp-replace #rx#"\\..*$"
33+
(path-element->bytes name)
34+
#"")
35+
#"."
36+
numb))
37+
(bytes->path-element
38+
(bytes-append #"#"
39+
(path-element->bytes name)
40+
#"#"
41+
numb
42+
#"#")))))
43+
(define new-name-bytes (path->bytes new-name))
44+
(cond
45+
[(or (used-in-autosave-toc? new-name-bytes autosave-toc)
46+
(file-exists? new-name))
47+
(loop (add1 n))]
48+
[else new-name])))
49+
(put-autosave-toc-content (cons (list (and orig-name (path->bytes orig-name))
50+
(path->bytes autosave-filename))
51+
autosave-toc))
52+
autosave-filename)))
53+
54+
(define (used-in-autosave-toc? new-name autosave-toc)
55+
(for/or ([mapping-entry (in-list autosave-toc)])
56+
(equal? new-name (list-ref mapping-entry 1))))
4057

4158
(define (generate-backup-name full-name)
4259
(let-values ([(pre-base name dir?) (split-path full-name)])

‎gui-lib/framework/private/sig.rkt‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -123,6 +123,10 @@
123123
toc-path
124124
register
125125
restore-autosave-files/gui))
126+
(define-signature autosave/int^ extends autosave^
127+
(with-autosave-filesystem-lock
128+
put-autosave-toc-content
129+
get-autosave-toc-content))
126130

127131
(define-signature exit-class^
128132
())

0 commit comments

Comments
 (0)