suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 8fc78559fbe423b2819a87d72924ed5b003af0da
This commit is contained in:
Robby Findler 2004-08-08 23:25:49 +00:00
parent 1039313a04
commit aa5fa1a2c1
1 changed files with 51 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/framework/private/path-utils.ss
View File

@ -9,57 +9,54 @@
(unit/sig framework:path-utils^ (unit/sig framework:path-utils^
(import) (import)
(define generate-autosave-name (define (generate-autosave-name name)
(lambda (name)
(let-values ([(base name dir?) (let-values ([(base name dir?)
(if name (if name
(split-path name) (split-path name)
(values (find-system-path 'home-dir) (values (find-system-path 'home-dir)
"mredauto" (bytes->path #"mredauto")
#f))]) #f))])
(let* ([base (if (string? base) (let* ([base (if (path? base)
base base
(current-directory))] (current-directory))]
[path (if (relative-path? base) [path (if (relative-path? base)
(build-path (current-directory) base) (build-path (current-directory) base)
base)] base)])
[without-ext
(if (eq? (system-type) 'windows)
(list->string
(let loop ([list (string->list name)])
(if (or (null? list)
(char=? (car list) #\.))
()
(cons (car list)
(loop (cdr list))))))
name)])
(let loop ([n 1]) (let loop ([n 1])
(let ([new-name (let* ([numb (string->bytes/utf-8 (number->string n))]
[new-name
(build-path path (build-path path
(if (eq? (system-type) 'windows) (if (eq? (system-type) 'windows)
(string-append without-ext (bytes->path
"." (bytes-append (regexp-replace #rx#"\\..*$"
(number->string n)) (path->bytes name)
(string-append "#" #"")
name #"."
"#" numb))
(number->string n) (bytes->path
"#")))]) (bytes-append #"#"
(path->bytes name)
#"#"
numb
#"#"))))])
(if (file-exists? new-name) (if (file-exists? new-name)
(loop (add1 n)) (loop (add1 n))
new-name))))))) new-name))))))
(define (generate-backup-name full-name) (define (generate-backup-name full-name)
(let-values ([(base name dir?) (split-path full-name)]) (let-values ([(pre-base name dir?) (split-path full-name)])
(let ([name-str (path->string name)]) (let ([base (if (path? pre-base)
pre-base
(current-directory))])
(let ([name-bytes (path->bytes name)])
(cond (cond
[(and (eq? (system-type) 'windows) [(and (eq? (system-type) 'windows)
(regexp-match #rx"(.*)\\.[^.]*" name-str)) (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
=> =>
(lambda (m) (lambda (m)
(build-path base (string-append (cadr m) ".bak")))] (build-path base (bytes->path (bytes-append (cadr m) #".bak"))))]
[(eq? (system-type) 'windows) [(eq? (system-type) 'windows)
(build-path base (string-append name-str ".bak"))] (build-path base (bytes->path (bytes-append name-bytes #".bak")))]
[else [else
(build-path base (string-append name-str "~"))]))))))) (build-path base (bytes->path (bytes-append name-bytes #"~")))]))))))))