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

99
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) (bytes->path #"mredauto")
"mredauto" #f))])
#f))]) (let* ([base (if (path? base)
(let* ([base (if (string? 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)] (let loop ([n 1])
[without-ext (let* ([numb (string->bytes/utf-8 (number->string n))]
(if (eq? (system-type) 'windows) [new-name
(list->string (build-path path
(let loop ([list (string->list name)]) (if (eq? (system-type) 'windows)
(if (or (null? list) (bytes->path
(char=? (car list) #\.)) (bytes-append (regexp-replace #rx#"\\..*$"
() (path->bytes name)
(cons (car list) #"")
(loop (cdr list)))))) #"."
name)]) numb))
(let loop ([n 1]) (bytes->path
(let ([new-name (bytes-append #"#"
(build-path path (path->bytes name)
(if (eq? (system-type) 'windows) #"#"
(string-append without-ext numb
"." #"#"))))])
(number->string n)) (if (file-exists? new-name)
(string-append "#" (loop (add1 n))
name new-name))))))
"#"
(number->string n)
"#")))])
(if (file-exists? new-name)
(loop (add1 n))
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)
(cond pre-base
[(and (eq? (system-type) 'windows) (current-directory))])
(regexp-match #rx"(.*)\\.[^.]*" name-str)) (let ([name-bytes (path->bytes name)])
=> (cond
(lambda (m) [(and (eq? (system-type) 'windows)
(build-path base (string-append (cadr m) ".bak")))] (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
[(eq? (system-type) 'windows) =>
(build-path base (string-append name-str ".bak"))] (lambda (m)
[else (build-path base (bytes->path (bytes-append (cadr m) #".bak"))))]
(build-path base (string-append name-str "~"))]))))))) [(eq? (system-type) 'windows)
(build-path base (bytes->path (bytes-append name-bytes #".bak")))]
[else
(build-path base (bytes->path (bytes-append name-bytes #"~")))]))))))))