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

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

@ -2,64 +2,61 @@
(require (lib "unitsig.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
(provide path-utils@)
(define path-utils@
(unit/sig framework:path-utils^
(import)
(define generate-autosave-name
(lambda (name)
(let-values ([(base name dir?)
(if name
(split-path name)
(values (find-system-path 'home-dir)
"mredauto"
#f))])
(let* ([base (if (string? base)
base
(current-directory))]
[path (if (relative-path? base)
(build-path (current-directory) 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 ([new-name
(build-path path
(if (eq? (system-type) 'windows)
(string-append without-ext
"."
(number->string n))
(string-append "#"
name
"#"
(number->string n)
"#")))])
(if (file-exists? new-name)
(loop (add1 n))
new-name)))))))
(define (generate-autosave-name name)
(let-values ([(base name dir?)
(if name
(split-path name)
(values (find-system-path 'home-dir)
(bytes->path #"mredauto")
#f))])
(let* ([base (if (path? base)
base
(current-directory))]
[path (if (relative-path? base)
(build-path (current-directory) base)
base)])
(let loop ([n 1])
(let* ([numb (string->bytes/utf-8 (number->string n))]
[new-name
(build-path path
(if (eq? (system-type) 'windows)
(bytes->path
(bytes-append (regexp-replace #rx#"\\..*$"
(path->bytes name)
#"")
#"."
numb))
(bytes->path
(bytes-append #"#"
(path->bytes name)
#"#"
numb
#"#"))))])
(if (file-exists? new-name)
(loop (add1 n))
new-name))))))
(define (generate-backup-name full-name)
(let-values ([(base name dir?) (split-path full-name)])
(let ([name-str (path->string name)])
(cond
[(and (eq? (system-type) 'windows)
(regexp-match #rx"(.*)\\.[^.]*" name-str))
=>
(lambda (m)
(build-path base (string-append (cadr m) ".bak")))]
[(eq? (system-type) 'windows)
(build-path base (string-append name-str ".bak"))]
[else
(build-path base (string-append name-str "~"))])))))))
(let-values ([(pre-base name dir?) (split-path full-name)])
(let ([base (if (path? pre-base)
pre-base
(current-directory))])
(let ([name-bytes (path->bytes name)])
(cond
[(and (eq? (system-type) 'windows)
(regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
=>
(lambda (m)
(build-path base (bytes->path (bytes-append (cadr m) #".bak"))))]
[(eq? (system-type) 'windows)
(build-path base (bytes->path (bytes-append name-bytes #".bak")))]
[else
(build-path base (bytes->path (bytes-append name-bytes #"~")))]))))))))