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

fix scribble to place different images with the same source name in different destination filenames

Browse Source 
svn: r13052

original commit: 1edd3544d70cc002fad9bf74b9137a070769ae7a
This commit is contained in:
Matthew Flatt 2009-01-09 21:30:43 +00:00
parent 322be283e3
commit 8686fbf81c
1 changed files with 59 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
collects/scribble/base-render.ss
View File

@ -405,33 +405,70 @@
;; ---------------------------------------- ;; ----------------------------------------
(define copied-srcs (make-hash))
(define copied-dests (make-hash))
(define/public (install-file fn) (define/public (install-file fn)
(if refer-to-existing-files (if refer-to-existing-files
(if (string? fn) (if (string? fn)
(string->path fn) (string->path fn)
fn) fn)
(let ([src-dir (path-only fn)] (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
[dest-dir (get-dest-directory #t)] (or (hash-ref copied-srcs normalized #f)
[fn (file-name-from-path fn)]) (let ([src-dir (path-only fn)]
(let ([src-file (build-path (or src-dir (current-directory)) fn)] [dest-dir (get-dest-directory #t)]
[dest-file (build-path (or dest-dir (current-directory)) fn)]) [fn (file-name-from-path fn)])
(unless (and (file-exists? dest-file) (let ([src-file (build-path (or src-dir (current-directory)) fn)]
(call-with-input-file* [dest-file (build-path (or dest-dir (current-directory)) fn)]
src-file [next-file-name (lambda (dest)
(lambda (src) (let-values ([(base name dir?) (split-path dest)])
(call-with-input-file* (build-path
dest-file base
(lambda (dest) (let ([s (path-element->string (path-replace-suffix name #""))])
(or (equal? (port-file-identity src) (let ([n (regexp-match #rx"^(.*)_([0-9]+)$" s)])
(port-file-identity dest)) (format "~a_~a~a"
(let loop () (if n (cadr n) s)
(let ([s (read-bytes 4096 src)] (if n (add1 (string->number (caddr n))) 2)
[d (read-bytes 4096 dest)]) (let ([ext (filename-extension name)])
(and (equal? s d) (if ext
(or (eof-object? s) (loop))))))))))) (bytes-append #"." ext)
(when (file-exists? dest-file) (delete-file dest-file)) ""))))))))])
(copy-file src-file dest-file)) (let-values ([(dest-file normalized-dest-file)
(path->string fn))))) (let loop ([dest-file dest-file])
(let ([normalized-dest-file
(normal-case-path (simplify-path (path->complete-path dest-file)))])
(if (file-exists? dest-file)
(cond
[(call-with-input-file*
src-file
(lambda (src)
(call-with-input-file*
dest-file
(lambda (dest)
(or (equal? (port-file-identity src)
(port-file-identity dest))
(let loop ()
(let ([s (read-bytes 4096 src)]
[d (read-bytes 4096 dest)])
(and (equal? s d)
(or (eof-object? s) (loop))))))))))
;; same content at that destination
(values dest-file normalized-dest-file)]
[(hash-ref copied-dests normalized-dest-file #f)
;; need a different file
(loop (next-file-name dest-file))]
[else
;; replace the file
(delete-file dest-file)
(values dest-file normalized-dest-file)])
;; new file
(values dest-file normalized-dest-file))))])
(unless (file-exists? dest-file)
(copy-file src-file dest-file))
(hash-set! copied-dests normalized-dest-file #t)
(let ([result (path->string (file-name-from-path dest-file))])
(hash-set! copied-srcs normalized result)
result))))))))
;; ---------------------------------------- ;; ----------------------------------------