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