1;;;
2;;;  Preliminary implementation of srfi-170
3;;;
4
5(define-module srfi-170
6  (use gauche.fcntl)
7  (use gauche.generator)
8  (use data.random)
9  (use srfi-13)
10  (use srfi-19)
11  (use file.util)
12  (export posix-error? posix-error-name posix-error-message
13
14          binary-input textual-input
15          binary-output textual-output
16          binary-input/output
17          buffer-none buffer-block buffer-line
18          open/append open/create open/exclusive open/nofollow open/truncate
19          open-file fd->port
20
21          create-directory
22          create-fifo
23          create-hard-link
24          create-symlink
25          read-symlink
26          rename-file
27          delete-directory
28          set-file-mode
29          set-file-owner owner/unchanged group/unchanged
30          set-file-timespecs time/now time/unchanged
31          truncate-file
32
33          file-info
34          file-info?
35          file-info:device
36          file-info:inode
37          file-info:mode
38          file-info:nlinks
39          file-info:uid
40          file-info:gid
41          file-info:rdev
42          file-info:size
43          file-info:blksize
44          file-info:blocks
45          file-info:atime
46          file-info:mtime
47          file-info:ctime
48          file-info-directory?
49          file-info-fifo?
50          file-info-symlink?
51          file-info-regular?
52          file-info-socket?
53          file-info-device?
54
55          directory-files
56          make-directory-files-generator
57          open-directory
58          read-directory
59          close-directory
60
61          real-path
62          file-space
63
64          temp-file-prefix
65          create-temp-file
66          call-with-temporary-filename
67
68          umask set-umask!
69          current-directory set-current-directory!
70          pid
71          nice
72          user-uid user-gid
73          user-effective-uid user-effective-gid
74          user-supplementary-gids
75
76          user-info
77          user-info?
78          user-info:name
79          user-info:uid
80          user-info:gid
81          user-info:home-dir
82          user-info:shell
83          user-info:full-name
84          user-info:parsed-full-name
85
86          group-info
87          group-info?
88          group-info:name
89          group-info:gid
90
91          posix-time
92          monotonic-time
93
94          set-environment-variable!
95          delete-environment-variable!
96
97          terminal?
98          ))
99(select-module srfi-170)
100
101;; Errors
102
103(define (posix-error? obj) (<system-error> obj))
104
105(define (posix-error-name obj)
106  (assume (posix-error? obj))
107  (sys-errno->symbol (condition-ref obj 'errno)))
108
109(define (posix-error-message obj)
110  (assume (posix-error? obj))
111  (sys-strerror (condition-ref obj 'errno)))
112
113;; 3.2 I/O
114
115(define-constant binary-input 'binary-input)
116(define-constant binary-output 'binary-output)
117(define-constant textual-input 'textual-input)
118(define-constant textual-output 'textual-output)
119(define-constant binary-input/output 'binary-input/output)
120(define-constant buffer-none 'buffer-none)
121(define-constant buffer-block 'buffer-block)
122(define-constant buffer-line 'buffer-line)
123
124(define-constant open/append O_APPEND)
125(define-constant open/create O_CREAT)
126(define-constant open/exclusive O_EXCL)
127(define-constant open/nofollow   (global-variable-ref
128                                  (find-module 'gauche.fcntl)
129                                  'O_NOFOLLOW
130                                  0))
131(define-constant open/truncate   O_TRUNC)
132
133(define (open-file fname port-type flags
134                   :optional (permission-bits #o666)
135                             (buffer-mode buffer-block))
136  (define xflags
137    (case port-type
138      [(binary-input textual-input) (logior flags O_RDONLY)]
139      [(binary-output textual-output) (logior flags O_WRONLY)]
140      [(binary-input/output) (logior flags O_RDWR)]))
141  (fd->port (sys-open fname xflags permission-bits) port-type buffer-mode))
142
143(define (fd->port fd port-type :optional (buffer-mode buffer-block))
144  (define (%bufmode sym in?)
145    (ecase sym
146      [(buffer-none)  :none]
147      [(buffer-block) :full]
148      [(buffer-line)  (if in? :modest :line)]))
149  ;; We don't distinguish textual/binary port.
150  (ecase port-type
151    [(binary-input textual-nput)
152     (open-input-fd-port fd :buffering (%bufmode buffer-mode #t) :owner? #t)]
153    [(binary-output textual-output)
154     (open-output-fd-port fd :buffering (%bufmode buffer-mode #f) :owner? #t)]
155    [(binary-input/output)
156     (error "Bidirectional port is not supported yet.")]))
157
158;; 3.3 File system
159
160(define (create-directory name :optional (perm #o775))
161  (sys-mkdir name perm))
162(define (create-fifo name :optional (perm #o664))
163  (cond-expand
164   [gauche.os.windows (error "create-fifo is not supported on this platform.")]
165   [else (sys-mkfifo name perm)]))
166(define (create-hard-link old new)
167  (sys-link old new))
168(define (create-symlink old new)
169  (cond-expand
170   [gauche.os.windows (error "create-symlink is not supported on this platform")]
171   [else (sys-symlink old new)]))
172
173(define (read-symlink name)
174  (cond-expand
175   [gauche.os.windows (error "read-symlink is not supported on this platform")]
176   [else (sys-readlink name)]))
177
178(define (rename-file old new) (sys-rename old new))
179
180(define (delete-directory name) (sys-rmdir name))
181
182(define-constant owner/unchanged -1)
183(define-constant group/unchanged -1)
184(define (set-file-owner name uid gid) (sys-chown name uid gid))
185
186(define-constant time/now       'time/now)
187(define-constant time/unchanged 'time/unchanged)
188(define (set-file-timespecs fname :optional (atime 'time/now)
189                                            (mtime 'time/now))
190  (define-syntax argcheck
191    (syntax-rules ()
192      [(_ x)
193       (cond [(eq? x 'time/now) #f]
194             [(eq? x 'time/unchanged) #t]
195             [else (assume-type x <time>)])]))
196  (sys-utime fname (argcheck atime) (argcheck mtime)))
197
198(define (truncate-file fname/port len)
199  (assume (or (string? fname/port) (port? fname/port)))
200  (cond [(string? fname/port)
201         (sys-truncate fname/port len)]
202        [(port? fname/port)
203         (sys-ftruncate fname/port len)]))
204
205(define (file-info fname/port follow?)
206  (assume (or (string? fname/port) (port? fname/port)))
207  (if (string? fname/port)
208    (if follow?
209      (sys-stat fname/port)
210      (sys-lstat fname/port))
211    (sys-fstat fname/port)))
212
213(define (file-info? obj) (is-a? obj <sys-stat>))
214(define (file-info:device stat)
215  (assume-type stat <sys-stat>)
216  (~ stat'dev))
217(define (file-info:inode stat)
218  (assume-type stat <sys-stat>)
219  (~ stat'ino))
220(define (file-info:mode stat)
221  (assume-type stat <sys-stat>)
222  (~ stat'mode))
223(define (file-info:nlinks stat)
224  (assume-type stat <sys-stat>)
225  (~ stat'nlink))
226(define (file-info:uid stat)
227  (assume-type stat <sys-stat>)
228  (~ stat'uid))
229(define (file-info:gid stat)
230  (assume-type stat <sys-stat>)
231  (~ stat'gid))
232(define (file-info:rdev stat)
233  (assume-type stat <sys-stat>)
234  (~ stat'rdev))
235(define (file-info:size stat)
236  (assume-type stat <sys-stat>)
237  (~ stat'size))
238(define (file-info:blksize stat)
239  (assume-type stat <sys-stat>)
240  4096)
241(define (file-info:blocks stat)
242  (assume-type stat <sys-stat>)
243  (quotient (+ (~ stat'size) 511) 512))
244(define (file-info:atime stat)
245  (assume-type stat <sys-stat>)
246  (~ stat'atim))
247(define (file-info:mtime stat)
248  (assume-type stat <sys-stat>)
249  (~ stat'mtim))
250(define (file-info:ctime stat)
251  (assume-type stat <sys-stat>)
252  (~ stat'ctim))
253
254(define (file-info-directory? stat)
255  (assume-type stat <sys-stat>)
256  (eq? (~ stat'type) 'directory))
257(define (file-info-fifo? stat)
258  (assume-type stat <sys-stat>)
259  (eq? (~ stat'type) 'fifo))
260(define (file-info-symlink? stat)
261  (assume-type stat <sys-stat>)
262  (eq? (~ stat'type) 'symlink))
263(define (file-info-regular? stat)
264  (assume-type stat <sys-stat>)
265  (eq? (~ stat'type) 'regular))
266(define (file-info-socket? stat)
267  (assume-type stat <sys-stat>)
268  (eq? (~ stat'type) 'socket))
269(define (file-info-device? stat)
270  (assume-type stat <sys-stat>)
271  (memq (~ stat'type) '(block character)))
272
273(define (set-file-mode name bits) (sys-chmod name bits))
274
275(define (directory-files dir :optional (dot? #f))
276  (directory-list dir
277                  :children? #t
278                  :filter (if dot? #f #/^[^\.]/)))
279
280(define (make-directory-files-generator dir :optional (dot? #f))
281  ;; can be more efficient
282  (list->generator (directory-files dir dot?)))
283
284;; Gauche don't have a direct interface to opendir etc.
285;; This is just an emulation.
286(define-class <DIR> ()
287  ((gen :init-keyword :gen)))
288
289(define (open-directory dir :optional (dot? #f))
290  (make <DIR> :gen (make-directory-files-generator dir dot?)))
291(define (read-directory dirobj)
292  (assume-type dirobj <DIR>)
293  ((~ dirobj'gen)))
294(define (close-directory dirobj)
295  (assume-type dirobj <DIR>)
296  (undefined))
297
298(define (real-path path) (sys-realpath path))
299
300(define (file-space path-or-port)
301  (cond-expand
302   [gauche.sys.statvfs
303    (let1 statvfs (if (string? path-or-port)
304                    (sys-statvfs path-or-port)
305                    (sys-fstatvfs path-or-port))
306      (* (~ statvfs'frsize)
307         (~ statvfs'bfree)))]
308   [gauche.os.windows
309    (use os.windows)
310    (let1 path (cond [(string? path-or-port) path-or-port]
311                     [(and (port? path-or-port)
312                           (port-file-number path-or-port))
313                      (port-name path-or-port)]
314                     [else
315                      (error "file-space: Invalid or unsupported path-or-port:"
316                             path-or-port)])
317      (list-ref (sys-get-disk-free-space-ex path) 2))]
318   [else
319    (error "file-space isn't supported on this platform yet.")]))
320
321(define temp-file-prefix
322  (make-parameter (build-path (temporary-directory)
323                              (x->string (sys-getpid)))))
324
325(define suffix-generator (strings-of 8 (chars$)))
326
327(define-constant TEMP_RETRY_MAX 256)
328
329(define (call-with-temporary-filename maker
330                                      :optional (prefix (temp-file-prefix)))
331  (let loop ([i 0])
332    (let1 f #"~|prefix|~(suffix-generator)"
333      (receive (success . rest) (guard (e [else #f])
334                                  (maker f))
335        (if success
336          (apply values success rest)
337          (if (>= i TEMP_RETRY_MAX)
338            (errorf "Couldn't create temporary file with prefix ~s" prefix)
339            (loop (+ i 1))))))))
340
341(define (create-temp-file :optional (prefix (temp-file-prefix)))
342  (receive (port name) (sys-mkstemp prefix)
343    (close-port port)
344    name))
345
346;;
347;; 3.5 Process state
348;;
349
350(define (umask) (sys-umask))
351
352(define (set-umask! umask) (sys-umask umask) (undefined))
353
354;; srfi-170#current-directory is a subset of file.util#current-directory
355
356(define (set-current-directory! dir) (current-directory dir) (undefined))
357
358(define (pid) (sys-getpid))
359
360(define (nice :optional (delta 1))
361  (cond-expand
362   [gauche.os.windows (error "nice is not supported on this platform")]
363   [else (sys-nice delta)]))
364
365(define (user-uid) (sys-getuid))
366(define (user-gid) (sys-getgid))
367(define (user-effective-uid) (sys-geteuid))
368(define (user-effective-gid) (sys-getegid))
369(define (user-supplementary-gids)
370  (cond-expand
371   [gauche.os.windows (list (sys-getgid))]
372   [else (sys-getgroups)]))
373
374;;
375;; 3.6 User and group database access
376;;
377
378(define (user-info uid/name)
379  (assume (or (exact-integer? uid/name) (string? uid/name)))
380  (if (string? uid/name)
381    (sys-getpwnam uid/name)
382    (sys-getpwuid uid/name)))
383
384(define (user-info? obj) (is-a? obj <sys-passwd>))
385(define (user-info:name uinfo)
386  (assume-type uinfo <sys-passwd>)
387  (~ uinfo'name))
388(define (user-info:uid uinfo)
389  (assume-type uinfo <sys-passwd>)
390  (~ uinfo'uid))
391(define (user-info:gid uinfo)
392  (assume-type uinfo <sys-passwd>)
393  (~ uinfo'gid))
394(define (user-info:home-dir uinfo)
395  (assume-type uinfo <sys-passwd>)
396  (~ uinfo'dir))
397(define (user-info:shell uinfo)
398  (assume-type uinfo <sys-passwd>)
399  (~ uinfo'shell))
400(define (user-info:full-name uinfo)
401  (assume-type uinfo <sys-passwd>)
402  (~ uinfo'gecos))
403(define (user-info:parsed-full-name uinfo)
404  (assume-type uinfo <sys-passwd>)
405  ;; This cond-expand is based on the srfi-170 spec
406  (cond-expand
407   [gauche.os.windows (list (~ uinfo'gecos))]
408   [else (let1 fields (string-split (~ uinfo'gecos) ",")
409           (if (null? fields)
410             fields
411             (cons (regexp-replace-all #/&/ (car fields)
412                                       (^_ (string-titlecase (~ uinfo'name))))
413                   (cdr fields))))]))
414
415(define (group-info gid/name)
416  (assume (or (exact-integer? gid/name) (string? gid/name)))
417  (if (string? gid/name)
418    (sys-getgrnam gid/name)
419    (sys-getgrgid gid/name)))
420(define (group-info? obj) (is-a? obj <sys-group>))
421(define (group-info:name ginfo)
422  (assume-type ginfo <sys-group>)
423  (~ ginfo'name))
424(define (group-info:gid ginfo)
425  (assume-type ginfo <sys-group>)
426  (~ ginfo'gid))
427
428;;
429;; 3.10 Time
430;;
431
432(define (posix-time) (current-time))
433
434(define (monotonic-time)
435  (receive (s ns) (sys-clock-gettime-monotonic)
436    (make-time 'time-monotonic ns s)))
437
438;;
439;; 3.11 Environment variables
440;;
441
442(define (set-environment-variable! name value)
443  (sys-setenv name value #t))
444(define (delete-environment-variable! name)
445  (sys-unsetenv name))
446
447;;
448;; 3.12 Terminal device control
449;;
450
451(define (terminal? port) (sys-isatty port))
452