1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
(in-package :cl-fad)
(defparameter *default-template* "TEMPORARY-FILES:TEMP-%")
(defparameter *max-tries* 10000)
(defvar *name-random-state* (make-random-state t))
;; from XCVB
(eval-when (:load-toplevel :execute)
(defun getenv (x)
"Query the libc runtime environment. See getenv(3)."
(declare (ignorable x))
#+(or abcl clisp xcl) (ext:getenv x)
#+allegro (sys:getenv x)
#+clozure (ccl:getenv x)
#+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
#+cormanlisp
(let* ((buffer (ct:malloc 1))
(cname (ct:lisp-string-to-c-string x))
(needed-size (win:getenvironmentvariable cname buffer 0))
(buffer1 (ct:malloc (1+ needed-size))))
(prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
nil
(ct:c-string-to-lisp-string buffer1))
(ct:free buffer)
(ct:free buffer1)))
#+ecl (si:getenv x)
#+gcl (system:getenv x)
#+lispworks (lispworks:environment-variable x)
#+mcl (ccl:with-cstrs ((name x))
(let ((value (_getenv name)))
(unless (ccl:%null-ptr-p value)
(ccl:%get-cstring value))))
#+sbcl (sb-ext:posix-getenv x)
#+clasp (ext:getenv x)
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl clasp)
(error "~S is not supported on your implementation" 'getenv))
(defun directory-from-environment (environment-variable-name)
(let ((string (getenv environment-variable-name)))
(when (plusp (length string))
(pathname-as-directory string))))
#+win32
(define-condition missing-temp-environment-variable (error)
()
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "the TEMP environment variable has not been found, cannot continue"))))
#+win32
(defun get-default-temporary-directory ()
(or (directory-from-environment "TEMP")
(error 'missing-temp-environment-variable)))
#-win32
(defun get-default-temporary-directory ()
(or (directory-from-environment "TMPDIR")
(and #-clisp (probe-file #P"/tmp/")
#+clisp (ext:probe-directory #P"/tmp/")
#P"/tmp/")))
(handler-case
(logical-pathname-translations "TEMPORARY-FILES")
(error ()
(alexandria:if-let (default-temporary-directory (get-default-temporary-directory))
(setf (logical-pathname-translations "TEMPORARY-FILES") `(("*.*.*" ,default-temporary-directory)))
(warn "could not automatically determine a default mapping for TEMPORARY-FILES")))))
;; locking for multi-threaded operation with unsafe random function
(defvar *create-file-name-lock* (bordeaux-threads:make-lock "Temporary File Name Creation Lock"))
(defmacro with-file-name-lock-held (() &body body)
`(bordeaux-threads:with-lock-held (*create-file-name-lock*)
,@body))
(defun generate-random-string ()
(with-file-name-lock-held ()
(format nil "~:@(~36,8,'0R~)" (random (expt 36 8) *name-random-state*))))
(define-condition invalid-temporary-pathname-template (error)
((string :initarg :string))
(:report (lambda (condition stream)
(with-slots (string) condition
(format stream "invalid temporary file name template ~S, must contain a percent sign that is to be replaced by a random string" string)))))
(defun generate-random-pathname (template random-string-generator)
(let ((percent-position (or (position #\% template)
(error 'invalid-temporary-pathname-template :string template))))
(merge-pathnames (concatenate 'string
(subseq template 0 percent-position)
(funcall random-string-generator)
(subseq template (1+ percent-position))))))
(define-condition cannot-create-temporary-file (error)
((template :initarg :template)
(max-tries :initarg :max-tries))
(:report (lambda (condition stream)
(with-slots (template max-tries) condition
(format stream "cannot create temporary file with template ~A, giving up after ~D attempt~:P"
template max-tries)))))
(defun open-temporary (&rest open-arguments
&key
(template *default-template*)
(generate-random-string 'generate-random-string)
(max-tries *max-tries*)
(direction :output)
&allow-other-keys)
"Create a file with a randomly generated name and return the opened
stream. The resulting pathname is generated from TEMPLATE, which
is a string representing a pathname template. A percent sign (%)
in that string is replaced by a randomly generated string to make
the filename unique. The default for TEMPLATE places temporary
files in the TEMPORARY-FILES logical pathname host, which is
automatically set up in a system specific manner. The file name
generated from TEMPLATE is merged with *DEFAULT-PATHNAME-DEFAULTS*,
so random pathnames relative to that directory can be generated by
not specifying a directory in TEMPLATE.
GENERATE-RANDOM-STRING can be passed to override the default
function that generates the random name component. It should
return a random string consisting of characters that are permitted
in a pathname (logical or physical, depending on TEMPLATE).
The name of the temporary file can be accessed calling the PATHNAME
function on STREAM. For convenience, the temporary file is opened
on the physical pathname, i.e. if the TEMPLATE designate a logical
pathname the translation to a physical pathname is performed before
opening the stream.
In order to create a unique file name, OPEN-TEMPORARY may loop
internally up to MAX-TRIES times before giving up and signalling a
CANNOT-CREATE-TEMPORARY-FILE condition."
(loop thereis (apply #'open
(translate-logical-pathname (generate-random-pathname template generate-random-string))
:direction direction
:if-exists nil
(alexandria:remove-from-plist open-arguments :template :generate-random-string :max-tries))
repeat max-tries
finally (error 'cannot-create-temporary-file
:template template
:max-tries max-tries)))
(defmacro with-output-to-temporary-file ((stream &rest args) &body body)
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
with STREAM bound to the temporary file stream. Returns the
pathname of the file that has been created. See OPEN-TEMPORARY for
permitted options."
`(with-open-stream (,stream (open-temporary ,@args))
,@body
(pathname ,stream)))
(defmacro with-open-temporary-file ((stream &rest args &key keep &allow-other-keys) &body body)
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
with STREAM bound to the temporary file stream. Returns the values
returned by BODY. By default, the file is deleted when BODY is
exited. If a true value is passed in KEEP, the file is not deleted
when the body is exited. See OPEN-TEMPORARY for more permitted
options."
`(with-open-stream (,stream (open-temporary ,@(alexandria:remove-from-plist args :keep)))
#+sbcl
(declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
,(if (and (constantp keep)
keep)
`(progn ,@body)
`(unwind-protect
(progn ,@body)
(unless ,keep
(close ,stream)
(delete-file (pathname ,stream)))))))
|
