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

make make-temporary-file use the source location for its template argument

Browse Source 
(This involves making make-temporary-file be a macro instead of a procedure.)
This commit is contained in:
Robby Findler 2011-08-29 19:33:40 -05:00
parent d2d02cc7a2
commit d4f4f754f1
3 changed files with 99 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/racket/file.rkt
View File

@ -1,5 +1,7 @@
#lang racket/base
(require "path.rkt")
(require "path.rkt"
(for-syntax racket/base
setup/path-to-relative))
(provide delete-directory/files
copy-directory/files
@ -37,7 +39,6 @@
other-write-bit
other-execute-bit)
(require "private/portlines.rkt")
;; utility: sorted dirlist so functions are deterministic
@ -83,6 +84,50 @@
(unless (directory-exists? dir)
(make-directory dir))))
(define-syntax (make-temporary-file stx)
(with-syntax ([app (datum->syntax stx #'#%app stx)])
(syntax-case stx ()
[x (identifier? #'x) #'make-temporary-file/proc]
[(_)
(let ()
(define line (syntax-line stx))
(define col (syntax-column stx))
(define source (syntax-source stx))
(define pos (syntax-position stx))
(define str-src (cond
[(path? source)
(path->relative-string/library source)]
[(string? source)
source]
[else #f]))
(define str-loc (cond
[(and line col) (format "-~a-~a" line col)]
[pos (format "--~a" pos)]
[else ""]))
(define combined-str
(cond
[str-src (string-append str-src str-loc)]
[else (string-append "mztmp" str-loc)]))
(define sanitized-str
(regexp-replace*
#rx"[<>]"
(regexp-replace* #rx"[\\/:]" combined-str "-")
""))
(define max-len 40) ;; must be even
(define not-too-long-str
(cond
[(< max-len (string-length sanitized-str))
(string-append (substring sanitized-str 0 (- (/ max-len 2) 2))
"..."
(substring sanitized-str 0 (- (/ max-len 2) 1)))]
[else
sanitized-str]))
#`(app make-temporary-file/proc #,(string-append not-too-long-str "_~a")))]
[(_ . whatever)
#'(app make-temporary-file/proc . whatever)])))
(define make-temporary-file/proc
(let ()
(define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
(with-handlers ([exn:fail:contract?
(lambda (x)
@ -118,6 +163,7 @@
(copy-file copy-from name))
(close-output-port (open-output-file name)))
name)))))
make-temporary-file))
(define (with-pref-params thunk)
(parameterize ([read-case-sensitive #f]

6
collects/scribblings/reference/filesystem.scrbl
View File

@ -887,6 +887,12 @@ provided and non-@racket[#f], in which case the
file name generated from @racket[template] is combined with
@racket[directory] to obtain a full path.
The @racket[template] argument's default is only the string @racket["mztmp~a"]
when there is no source location information for the callsite of
@racket[make-temporary-file] (or if @racket[make-temporary-file] is
used in a higher-order position). If there is such information, then the template
string is built based on the source location.
If @racket[copy-from-filename] is provided as path, the temporary file
is created as a copy of the named file (using @racket[copy-file]). If
@racket[copy-from-filename] is @racket[#f], the temporary file is

10
collects/tests/racket/file.rktl
View File

@ -295,6 +295,16 @@
(err/rt-test (open-output-file (build-path (current-directory) "baddir" "x"))
exn:fail:filesystem?)
(let ([tf (make-temporary-file)])
(let-values ([(base name dir?) (split-path tf)])
(test #t 'make-temporary-file-uses-srcloc (and (regexp-match #rx"file.rktl" (path->bytes name)) #t)))
(delete-file tf))
(let ([tf ((λ (t) (t)) make-temporary-file)])
(test #t 'make-temporary-file-in-ho-position (file-exists? tf))
(delete-file tf))
(define tempfilename (make-temporary-file))
(when (file-exists? tempfilename)
(delete-file tempfilename))