Skip to content

Commit 2bc59f5

Browse files
LiberalArtistLiberalArtist
committed
Reformats things in path-utils to match modern Racket.
Also adds tests for path-utils.
1 parent 780abda commit 2bc59f5

File tree

3 files changed

+169
-75
lines changed

3 files changed

+169
-75
lines changed

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

Lines changed: 73 additions & 75 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,10 @@
1-
#lang scheme/unit
2-
(require "sig.rkt"
3-
"../preferences.rkt")
1+
#lang racket/unit
2+
3+
(require "sig.rkt"
4+
"../preferences.rkt")
45

5-
(import)
6-
(export framework:path-utils^)
6+
(import)
7+
(export framework:path-utils^)
78

89
;; preferences initialized in main.rkt
910

@@ -13,79 +14,76 @@
1314
(define current-autosave-dir
1415
(preferences:get/set 'path-utils:autosave-dir))
1516

16-
; generate-autosave-name : (or/c #f path-string? path-for-some-system?) -> path?
17-
(define (generate-autosave-name maybe-old-path)
18-
(cond
19-
[maybe-old-path
20-
(let*-values ([(base name dir?) (split-path maybe-old-path)]
21-
[(base) (cond
22-
[(not (path? base))
23-
(current-directory)]
24-
[(relative-path? base)
25-
(build-path (current-directory) base)]
26-
[else
27-
base])])
28-
(cond
29-
[(current-autosave-dir)
30-
=>
31-
(λ (dir)
32-
(make-unique-autosave-name dir (encode-as-path-element base name)))]
33-
[else
34-
(make-unique-autosave-name base name)]))]
35-
[else
36-
(make-unique-autosave-name (or (current-autosave-dir)
37-
(find-system-path 'doc-dir))
38-
(bytes->path-element #"mredauto"))]))
17+
; generate-autosave-name : (or/c #f path-string? path-for-some-system?) -> path?
18+
(define (generate-autosave-name maybe-old-path)
19+
(cond
20+
[maybe-old-path
21+
(let*-values ([(base name dir?) (split-path maybe-old-path)]
22+
[(base) (cond
23+
[(not (path? base))
24+
(current-directory)]
25+
[(relative-path? base)
26+
(build-path (current-directory) base)]
27+
[else
28+
base])])
29+
(cond
30+
[(current-autosave-dir)
31+
=>
32+
(λ (dir)
33+
(make-unique-autosave-name dir (encode-as-path-element base name)))]
34+
[else
35+
(make-unique-autosave-name base name)]))]
36+
[else
37+
(make-unique-autosave-name (or (current-autosave-dir)
38+
(find-system-path 'doc-dir))
39+
(bytes->path-element #"mredauto"))]))
3940

4041

41-
; make-unique-autosave-name : dir-path path-element -> path?
42-
(define (make-unique-autosave-name dir name)
43-
(let loop ([n 1])
44-
(let* ([numb (string->bytes/utf-8 (number->string n))]
45-
[new-name
46-
(build-path dir
47-
(if (eq? (system-type) 'windows)
48-
(bytes->path-element
49-
(bytes-append (regexp-replace #rx#"\\..*$"
50-
(path-element->bytes name)
51-
#"")
52-
#"."
53-
numb))
54-
(bytes->path-element
55-
(bytes-append #"#"
56-
(path-element->bytes name)
57-
#"#"
58-
numb
59-
#"#"))))])
60-
(if (file-exists? new-name)
61-
(loop (add1 n))
62-
new-name))))
42+
; make-unique-autosave-name : dir-path path-element -> path?
43+
(define (make-unique-autosave-name dir name)
44+
(define sys
45+
(system-path-convention-type))
46+
(let loop ([n 1])
47+
(let* ([numb (string->bytes/utf-8 (number->string n))]
48+
[new-name
49+
(build-path dir
50+
(case sys
51+
[(windows)
52+
(path-replace-extension name
53+
(bytes-append #"."
54+
numb))]
55+
[else
56+
(bytes->path-element
57+
(bytes-append #"#"
58+
(path-element->bytes name)
59+
#"#"
60+
numb
61+
#"#"))]))])
62+
(if (file-exists? new-name)
63+
(loop (add1 n))
64+
new-name))))
6365

64-
(define (generate-backup-name full-name)
65-
(let-values ([(pre-base name dir?) (split-path full-name)])
66-
(let ([base (if (path? pre-base)
67-
pre-base
68-
(current-directory))])
69-
(define name-element
70-
(let ([name-bytes (path-element->bytes name)])
71-
(bytes->path-element
72-
(cond
73-
[(and (eq? (system-type) 'windows)
74-
(regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
75-
=>
76-
(λ (m)
77-
(bytes-append (cadr m) #".bak"))]
78-
[(eq? (system-type) 'windows)
79-
(bytes-append name-bytes #".bak")]
80-
[else
81-
(bytes-append name-bytes #"~")]))))
82-
(cond
83-
[(current-backup-dir)
84-
=>
85-
(λ (dir)
86-
(build-path dir (encode-as-path-element base name-element)))]
87-
[else
88-
(build-path base name-element)]))))
66+
(define (generate-backup-name full-name)
67+
(define-values (pre-base old-name dir?)
68+
(split-path full-name))
69+
(define base
70+
(if (path? pre-base)
71+
pre-base
72+
(current-directory)))
73+
(define name-element
74+
(case (system-path-convention-type)
75+
[(windows)
76+
(path-replace-extension old-name #".bak")]
77+
[else
78+
(bytes->path-element
79+
(bytes-append (path-element->bytes old-name) #"~"))]))
80+
(cond
81+
[(current-backup-dir)
82+
=>
83+
(λ (dir)
84+
(build-path dir (encode-as-path-element base name-element)))]
85+
[else
86+
(build-path base name-element)]))
8987

9088

9189

‎gui-test/framework/tests/README‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,10 @@ signal failures when there aren't any.
4141
| This tests that preferences are saved and restored correctly, both
4242
| immediately and across reboots of gracket.
4343

44+
- path-utils: path-utils.rkt -- runs directly via raco test
45+
46+
| This tests that paths for autosave and backup files are
47+
| generated correctly and respond correctly to preferences.
4448

4549
- individual object tests:
4650

‎gui-test/framework/tests/path-utils.rkt‎

Lines changed: 92 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,92 @@
1+
#lang racket/base
2+
3+
(require rackunit
4+
(rename-in framework
5+
[path-utils:generate-autosave-name
6+
generate-autosave-name]
7+
[path-utils:generate-backup-name
8+
generate-backup-name])
9+
racket/file
10+
racket/contract/base
11+
framework/preferences)
12+
13+
(define (path-base pth)
14+
(define-values (base name dir?)
15+
(split-path pth))
16+
(path->directory-path base))
17+
18+
(let ([the-prefs-table (make-hash)])
19+
(parameterize ([preferences:low-level-put-preferences
20+
(λ (syms vals)
21+
(for ([sym (in-list syms)]
22+
[val (in-list vals)])
23+
(hash-set! the-prefs-table sym val)))]
24+
[preferences:low-level-get-preference
25+
(λ (sym [fail void])
26+
(hash-ref the-prefs-table sym fail))])
27+
(define current-backup-dir
28+
(preferences:get/set 'path-utils:backup-dir))
29+
(define current-autosave-dir
30+
(preferences:get/set 'path-utils:autosave-dir))
31+
(define elem
32+
(bytes->path-element #"example.rkt"))
33+
(define dir
34+
(path->directory-path
35+
(simplify-path (current-directory))))
36+
(define complete
37+
(build-path dir elem))
38+
;; Tests with #f for directories
39+
(current-backup-dir #f)
40+
(current-autosave-dir #f)
41+
(check-equal? (path-base (simplify-path(generate-autosave-name #f)))
42+
(path->directory-path (find-system-path 'doc-dir)))
43+
(check-equal? (path-base (simplify-path (generate-autosave-name elem)))
44+
dir)
45+
(check-equal? (path-base (generate-autosave-name complete))
46+
dir)
47+
(check-equal? (path-base (simplify-path (generate-backup-name elem)))
48+
dir)
49+
(check-equal? (path-base (generate-backup-name complete))
50+
dir)
51+
;; Tests with designated directories
52+
(define backup-dir
53+
(path->directory-path
54+
(simplify-path
55+
(make-temporary-file "rkt-backup-dir-~a"
56+
'directory))))
57+
(define autosave-dir
58+
(path->directory-path
59+
(simplify-path
60+
(make-temporary-file "rkt-autosave-dir-~a"
61+
'directory))))
62+
(dynamic-wind
63+
void
64+
(λ ()
65+
(current-backup-dir backup-dir)
66+
(current-autosave-dir autosave-dir)
67+
(check-equal? (path-base (generate-autosave-name #f))
68+
autosave-dir)
69+
(check-equal? (path-base (generate-autosave-name elem))
70+
autosave-dir)
71+
(check-equal? (path-base (generate-autosave-name complete))
72+
autosave-dir)
73+
(check-equal? (path-base (generate-backup-name elem))
74+
backup-dir)
75+
(check-equal? (path-base (generate-backup-name complete))
76+
backup-dir)
77+
(define clashing-name
78+
(build-path dir "elsewhere" elem))
79+
(check-false
80+
(equal? (simplify-path (generate-autosave-name complete))
81+
(simplify-path (generate-autosave-name clashing-name))))
82+
(check-false
83+
(equal? (simplify-path (generate-backup-name complete))
84+
(simplify-path (generate-backup-name clashing-name)))))
85+
(λ ()
86+
(delete-directory backup-dir)
87+
(delete-directory autosave-dir)))))
88+
89+
90+
91+
92+

0 commit comments

Comments
 (0)