@(== "Abstract") @("The host environment is the set of resources, such as the filesystem, network and processes, that are managed by the operating system on top of which a Scheme program is executing. This SRFI specifies some of the ways the host environment can be accessed from within a Scheme program. It does so by leveraging widespread support for POSIX, the Portable Operating System Interface standardized by the IEEE. Not all of the functions of this SRFI are available on all operating systems.") @(== "Rationale") @("The I/O and other environmental procedures provided by the various Scheme standards were designed at a time when operating systems were far more diverse than they are today, and therefore portability was difficult or impossible to achieve. In addition, Scheme has historically focused on programming-language features rather than the practical needs of mainstream software development. Consequently, none of the standards provide more than a limited set of operations. Individual implementations often provide much more, but in incompatible ways.") @("This SRFI uses the IEEE 1003 POSIX.1-2017 standard to provide maximally portable access to the services of the operating system on which typical Scheme implementations run. Almost all operating systems today support all or part of POSIX, so the use of this SRFI is mostly portable, but implementations are definitely not portable. However, an implementation of this SRFI can be layered over many existing implementation-specific interfaces, or directly over a C FFI. It is even possible to implement it on top of the JVM and CLR virtual machines.") @("This SRFI describes a specific POSIX API for Scheme. Rather than attempting to compromise between existing implementations, the scsh system call specification was chosen as a base document. Consequently, this SRFI is a reduced and heavily edited version of Chapter 3, \"System Calls\" of version 0.6.7 of the Scsh Reference Manual. The numbered headers are aligned with those used in the Reference Manual.") @("Scsh 0.6.7 was chosen for two main reasons. It is fairly old, so most of its operations, even those which were non-POSIX at the time (2006) are now included in POSIX, and it has few or no operations that aren't POSIX at all. In addition, it is politically fairly neutral, being tied to an obsolete version of Scheme 48, an implementation which is not being actively developed. Scsh 0.7 exists and runs on the current version of Scheme 48 (see Implementation section), but was not used in designing this SRFI because it is incompletely documented.") @(== "Implementation Notes") @("Some of these functions exist in one form or another in other eggs. In particular, this egg is in some ways in competition with the (chicken file posix) module. It's an open question whether this spec has a better interface than (chicken file posix) or some of those other specs. I think in many respects the API is better here. For example, the option to use open-directory to control the open/close lifecycle, and file-info which has named getters. It being the case, that this reinvents some of these internal chicken modules, it's hard to decide whether to reimplement from scratch or to piggy back off them. In most (but not all) cases I've take the approach to reimplement from scratch, partly on the assumption that those other eggs might want to reliquish resonsibility for them for the standard, partly because the srfi spec has specific error reporting, which they may not implement.") @("One notable question was what to do about ports. I could have just relied on (chicken port) and bypassed (chicken file posix) altogether, and in many ways I would have preferred that. On the other hand, that would have made this module non interoperable with (chicken file posix) in one important respect: the ports returned by (chicken file posix) contain the file descriptor and implement (port->fileno), so the ports returned would not have interoperated with ports here had I done that. In many ways, that doesn't seem like a big deal, because (chicken file posix) does not contain many extra features, and I intend to add those features here anyway so that users can at least bypass it in favor of this. On the other hand, it's at least conceivable that you may want to include some other scheme library that uses (chicken file posix) so that would have potentially been a headache. So I've taken the pragmatic approach, and I allow (chicken file posix) to create the port, just so it can be the custodian of the file descriptor and allow interoperability") @("I have made a small amount of effort to make the code here work on Windows, but have not tested it as of yet, and I have no idea what might be required to make it actually work or what (chicken file posix) does about that. I've made a good faith effort to make it compatible with BSD and MacOS, but have not tested it there either. File a bug report if it doesn't work for you.") (module srfi-170 ( posix-error? posix-error-name posix-error-number posix-error-message posix-error-procedure posix-error-arguments binary-input textual-input binary-output textual-output binary-input/output buffer-none buffer-block buffer-line open/create open/exclusive open/truncate open/append open/no-follow open-file fd->port create-directory create-fifo create-hard-link create-symlink read-symlink rename-file delete-directory set-file-owner set-file-times truncate-file file-info file-info? file-info:device file-info:inode file-info:mode file-info:nlinks file-info:uid file-info:gid file-info:rdev file-info:size file-info:blksize file-info:blocks file-info:atime file-info:mtime file-info:ctime file-info-directory? file-info-fifo? file-info-symlink? file-info-regular? file-info-socket? file-info-device? set-file-mode directory-files make-directory-files-generator directory-object? open-directory read-directory-entry dirent:name direct:ino read-directory close-directory real-path file-system-info file-system-info? file-system-info:block-size file-system-info:fragment-size file-system-info:number-of-fragments file-system-info:blocks-free file-system-info:blocks-available file-system-info:inode-number file-system-info:inodes-free file-system-info:inodes-available file-system-info:id file-system-info:name-max file-space temp-file-prefix create-temp-file call-with-temporary-filename umask set-umask! current-directory set-current-directory! pid parent-pid process-group create-session set-process-group! terminal-foreground-process-group set-terminal-foreground-process-group! nice user-uid user-gid user-effective-uid user-effective-gid user-supplementary-gids user-info user-info? user-info:name user-info:password user-info:uid user-info:gid user-info:home-dir user-info:shell user-info:full-name user-info:parsed-full-name group-info group-info? group-info:name group-info:password group-info:gid group-info:members posix-time monotonic-time get-environment-variables get-environment-variable delete-environment-variable! terminal?) (import scheme) (import (only srfi-1 list-tabulate)) (import (only srfi-13 string-null? string-titlecase)) (import (only srfi-19 make-time time-utc time-second time-nanosecond)) (import (only srfi-121 generator->list)) (import (only (chicken file posix) port->fileno open-input-file* open-output-file*)) (import (chicken foreign)) (import (only (chicken gc) set-finalizer!)) (import (only (chicken process-context) get-environment-variable unset-environment-variable! get-environment-variables)) (import (only (chicken file) delete-file)) (import (only (chicken port) set-buffering-mode! terminal-port? make-bidirectional-port)) (import (chicken base)) (import (chicken condition)) (import (only (chicken blob) make-blob blob->string string->blob)) (import (only (chicken bitwise) bitwise-and bitwise-ior)) (import (only (chicken string) string-split)) (import (only (chicken irregex) irregex-replace)) @(== "Error Handling") @("The C binding of POSIX places an error number in the global variable errno to report an error, along with (in most cases) returning a sentinel value such as -1. However, the procedures of this SRFI work differently. Rather than reporting errors as return values, they report errors by signaling condition objects satisfying the predicate posix-error? defined below.") @("This SRFI provides three procedures which will typically be shims over whatever the implementation uses to report such errors:") (define c-error-name (foreign-lambda* c-string ((int err)) "switch(err) { /* Core POSIX Errors (Standard on virtually all systems) */ case EACCES: C_return(\"EACCES\"); case E2BIG: C_return(\"E2BIG\"); case EBADF: C_return(\"EBADF\"); case EBUSY: C_return(\"EBUSY\"); case ECHILD: C_return(\"ECHILD\"); case EDOM: C_return(\"EDOM\"); case EEXIST: C_return(\"EEXIST\"); case EFAULT: C_return(\"EFAULT\"); case EFBIG: C_return(\"EFBIG\"); case EINTR: C_return(\"EINTR\"); case EINVAL: C_return(\"EINVAL\"); case EIO: C_return(\"EIO\"); case EISDIR: C_return(\"EISDIR\"); case EMFILE: C_return(\"EMFILE\"); case EMLINK: C_return(\"EMLINK\"); case ENAMETOOLONG: C_return(\"ENAMETOOLONG\"); case ENFILE: C_return(\"ENFILE\"); case ENODEV: C_return(\"ENODEV\"); case ENOENT: C_return(\"ENOENT\"); case ENOEXEC: C_return(\"ENOEXEC\"); case ENOMEM: C_return(\"ENOMEM\"); case ENOSPC: C_return(\"ENOSPC\"); case ENOTDIR: C_return(\"ENOTDIR\"); case ENOTTY: C_return(\"ENOTTY\"); case ENXIO: C_return(\"ENXIO\"); case EPERM: C_return(\"EPERM\"); case EPIPE: C_return(\"EPIPE\"); case ERANGE: C_return(\"ERANGE\"); case EROFS: C_return(\"EROFS\"); case ESPIPE: C_return(\"ESPIPE\"); case ESRCH: C_return(\"ESRCH\"); case EXDEV: C_return(\"EXDEV\"); /* Primary Error with potential Aliases */ case EAGAIN: C_return(\"EAGAIN\"); case EDEADLK: C_return(\"EDEADLK\"); #ifdef ENOTSUP case ENOTSUP: C_return(\"ENOTSUP\"); #endif /* Aggressive Alias Protection: Only include if defined AND distinct */ #if defined(EWOULDBLOCK) && (EWOULDBLOCK != EAGAIN) case EWOULDBLOCK: C_return(\"EWOULDBLOCK\"); #endif #if defined(EDEADLOCK) && (EDEADLOCK != EDEADLK) case EDEADLOCK: C_return(\"EDEADLOCK\"); #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) case EOPNOTSUPP: C_return(\"EOPNOTSUPP\"); #endif /* Networking & Advanced POSIX (ifdefed for existence) */ #ifdef EADDRINUSE case EADDRINUSE: C_return(\"EADDRINUSE\"); #endif #ifdef EADDRNOTAVAIL case EADDRNOTAVAIL:C_return(\"EADDRNOTAVAIL\"); #endif #ifdef EAFNOSUPPORT case EAFNOSUPPORT: C_return(\"EAFNOSUPPORT\"); #endif #ifdef EALREADY case EALREADY: C_return(\"EALREADY\"); #endif #ifdef EBADMSG case EBADMSG: C_return(\"EBADMSG\"); #endif #ifdef ECANCELED case ECANCELED: C_return(\"ECANCELED\"); #endif #ifdef ECONNABORTED case ECONNABORTED: C_return(\"ECONNABORTED\"); #endif #ifdef ECONNREFUSED case ECONNREFUSED: C_return(\"ECONNREFUSED\"); #endif #ifdef ECONNRESET case ECONNRESET: C_return(\"ECONNRESET\"); #endif #ifdef EDESTADDRREQ case EDESTADDRREQ: C_return(\"EDESTADDRREQ\"); #endif #ifdef EDQUOT case EDQUOT: C_return(\"EDQUOT\"); #endif #ifdef EHOSTUNREACH case EHOSTUNREACH: C_return(\"EHOSTUNREACH\"); #endif #ifdef EIDRM case EIDRM: C_return(\"EIDRM\"); #endif #ifdef EILSEQ case EILSEQ: C_return(\"EILSEQ\"); #endif #ifdef EINPROGRESS case EINPROGRESS: C_return(\"EINPROGRESS\"); #endif #ifdef EISCONN case EISCONN: C_return(\"EISCONN\"); #endif #ifdef ELOOP case ELOOP: C_return(\"ELOOP\"); #endif #ifdef EMSGSIZE case EMSGSIZE: C_return(\"EMSGSIZE\"); #endif #ifdef EMULTIHOP case EMULTIHOP: C_return(\"EMULTIHOP\"); #endif #ifdef ENETDOWN case ENETDOWN: C_return(\"ENETDOWN\"); #endif #ifdef ENETRESET case ENETRESET: C_return(\"ENETRESET\"); #endif #ifdef ENETUNREACH case ENETUNREACH: C_return(\"ENETUNREACH\"); #endif #ifdef ENOBUFS case ENOBUFS: C_return(\"ENOBUFS\"); #endif #ifdef ENODATA case ENODATA: C_return(\"ENODATA\"); #endif #ifdef ENOLCK case ENOLCK: C_return(\"ENOLCK\"); #endif #ifdef ENOLINK case ENOLINK: C_return(\"ENOLINK\"); #endif #ifdef ENOMSG case ENOMSG: C_return(\"ENOMSG\"); #endif #ifdef ENOPROTOOPT case ENOPROTOOPT: C_return(\"ENOPROTOOPT\"); #endif #ifdef ENOSR case ENOSR: C_return(\"ENOSR\"); #endif #ifdef ENOSTR case ENOSTR: C_return(\"ENOSTR\"); #endif #ifdef ENOSYS case ENOSYS: C_return(\"ENOSYS\"); #endif #ifdef ENOTCONN case ENOTCONN: C_return(\"ENOTCONN\"); #endif #ifdef ENOTEMPTY case ENOTEMPTY: C_return(\"ENOTEMPTY\"); #endif #ifdef ENOTRECOVERABLE case ENOTRECOVERABLE: C_return(\"ENOTRECOVERABLE\"); #endif #ifdef ENOTSOCK case ENOTSOCK: C_return(\"ENOTSOCK\"); #endif #ifdef EOVERFLOW case EOVERFLOW: C_return(\"EOVERFLOW\"); #endif #ifdef EOWNERDEAD case EOWNERDEAD: C_return(\"EOWNERDEAD\"); #endif #ifdef EPROTO case EPROTO: C_return(\"EPROTO\"); #endif #ifdef EPROTONOSUPPORT case EPROTONOSUPPORT: C_return(\"EPROTONOSUPPORT\"); #endif #ifdef EPROTOTYPE case EPROTOTYPE: C_return(\"EPROTOTYPE\"); #endif #ifdef ESTALE case ESTALE: C_return(\"ESTALE\"); #endif #ifdef ETIME case ETIME: C_return(\"ETIME\"); #endif #ifdef ETIMEDOUT case ETIMEDOUT: C_return(\"ETIMEDOUT\"); #endif #ifdef ETXTBSY case ETXTBSY: C_return(\"ETXTBSY\"); #endif default: C_return(\"UNKNOWN\"); }")) (define errno (foreign-lambda* int () "C_return(errno);")) (define set-errno! (foreign-lambda* void ((int v)) " errno = v; ")) (define c-strerror (foreign-lambda c-string "strerror" int)) (define (raise-posix-error loc . args) (let* ((err-num (errno)) (err-name (string->symbol (c-error-name err-num))) (err-msg (c-strerror err-num))) (abort (make-composite-condition ;; We pass 'args' directly to the 'arguments slot as it is already a list (make-property-condition 'exn 'message err-msg 'location loc 'arguments args) (make-property-condition 'i/o-error) (make-property-condition 'file-error) (make-property-condition 'posix-error 'errno err-num 'name err-name 'message err-msg 'location loc 'arguments args))))) (define (posix-error? obj) @("This procedure returns #t if obj is a condition object that describes a POSIX error, and #f otherwise." (obj "A condition error object") (@to "boolean")) ((condition-predicate 'posix-error) obj)) (define (posix-error-name posix-error) @("This procedure returns a symbol that is the name associated with the value of errno when the POSIX function reported an error. This can be used to provide programmatic recovery when a POSIX function can return more than one value of errno. Because the errno codes are not standardized across different POSIX systems, but the associated names (bound by a #define in the file /usr/include/errno.h) are the same for the most part, this function returns the name rather than the code. For example, ENOENT (a reference was made to a file or a directory that does not exist) almost always corresponds to an errno value of 2. But although ETIMEDOUT (meaning that a TCP connection has been unresponsive for too long) is standardized by POSIX, it has a errno value of 110 on Linux, 60 on FreeBSD, and 116 on Cygwin." (posix-error "A condition error object") (@to "symbol")) (if (and (condition? posix-error) ((condition-predicate 'posix-error) posix-error)) (get-condition-property posix-error 'posix-error 'name) (error "Object is not a posix-error condition" posix-error))) (define (posix-error-number posix-error) @("Return the errno code. Recommended to use posix-error-name for portability." (posix-error "A condition error object") (@to "number")) (if (and (condition? posix-error) ((condition-predicate 'posix-error) posix-error)) (get-condition-property posix-error 'posix-error 'errno) (error "Object is not a posix-error condition" posix-error))) (define (posix-error-message posix-error) @("Returns a human-readable string describing the POSIX error described by the condition object obj." (posix-error "A condition error object") (@to "string")) (if (and (condition? posix-error) ((condition-predicate 'posix-error) posix-error)) (get-condition-property posix-error 'posix-error 'message) (error "Object is not a posix-error condition" posix-error))) (define (posix-error-procedure posix-error) @("The procedure which caused the error" (posix-error "A condition error object") (@to "symbol")) (if (and (condition? posix-error) ((condition-predicate 'posix-error) posix-error)) (get-condition-property posix-error 'posix-error 'location) (error "Object is not a posix-error condition" posix-error))) (define (posix-error-arguments posix-error) @("The arguments passed to the api which caused the error" (posix-error "A condition error object") (@to "list")) (if (and (condition? posix-error) ((condition-predicate 'posix-error) posix-error)) (get-condition-property posix-error 'posix-error 'arguments) (error "Object is not a posix-error condition" posix-error))) ;;;;;;;;;;;;;; TODO: Implement posix-error-c-function ;;;;;;;;;;;;;;;;;;;; @(== "I/O") @("Dealing with POSIX file descriptors in a Scheme environment is difficult. In POSIX, open files are part of the process environment, and are referenced by small exact integers called file descriptors. Open file descriptors are the fundamental way I/O redirections are passed to subprocesses and executed programs, since file descriptors are preserved across fork and exec operations.") @("Scheme, on the other hand, uses ports for specifying I/O sources and sinks. Ports are garbage-collected Scheme objects, not integers. When a port is garbage collected, it is effectively closed, but whether the underlying file descriptor is closed is left as an implementation detail. Because file descriptors are just integers, it's impossible to garbage collect them.") @("Ideally, a Scheme program could only use ports and not file descriptors. But code written in any language, including Scheme, needs to descend to the file descriptor level in at least two circumstances: when interfacing with foreign code, and when interfacing with a subprocess. ") @("This causes a problem. Suppose we have a Scheme port constructed on top of file descriptor 3. We intend to execute a successor program that will expect this file descriptor. If we drop references to the port, the garbage collector may prematurely close file 3 before the successor program starts.") @("Unfortunately, there is no even vaguely portable solution to the general problem. Scsh and Guile undertake heroic measures to open new file descriptors for ports when the old file descriptors are repurposed for something else, and to track when closing a port implies closing its file descriptor or not. But doing so involves more changes than an implementation should have to make in order to provide this SRFI.") @("Consequently, this SRFI assumes that file descriptors will only be used at the edges of the program, and that most I/O operations will be performed on ports. As an exception, open-file is provided, because it allows arguments that the Scheme standard does not. It returns a port of a specified type.") @("However, as an extension to the spec, many APIs that take ports will be extended to also take file descriptors") (define binary-input @("Binary input") 'binary-input) (define binary-output @("Binary output") 'binary-output) (define textual-input @("Text input") 'textual-input) (define textual-output @("Text output") 'textual-output) (define binary-input/output @("Binary input/output") 'binary-input/output) @("Constants whose values represent the type of port to be returned by open-file or fd->port. The textual ports use the same character encoding applied by default in the underlying implementation. The value of binary-input/output represents a binary port that allows both input and output operations, as discussed in SRFI 181.") (define buffer-none @("No buffering") 'none) (define buffer-line @("Buffering at the line level") 'line) (define buffer-block @("Buffering at the block level") 'block) @("Constants whose values represent, respectively: the absence of port buffering, where bytes are intended to appear from the source or at the destination as soon as possible; buffering with a block of implementation-dependent size; and buffering line by line, where a line is terminated by a newline byte #xA. The default is implementation-dependent. ") ;; Open-time Flags (define open/read (foreign-value "O_RDONLY" int)) (define open/write (foreign-value "O_WRONLY" int)) (define open/read-write (foreign-value "O_RDWR" int)) (define read-only (foreign-value "O_RDONLY" int)) (define open/create @("Create file if it doesn't exist") (foreign-value "O_CREAT" int)) (define open/exclusive @("Fails if the file exists") (foreign-value "O_EXCL" int)) (define open/truncate @("Truncates the file") (foreign-value "O_TRUNC" int)) (define open/append @("Always appends to the file") (foreign-value "O_APPEND" int)) ;; Optional/Platform-Dependent (define open/no-follow (cond-expand (windows 0) (else (foreign-value "O_NOFOLLOW" int)))) (cond-expand (windows (foreign-declare "#include ") (define-constant open/binary (foreign-value "_O_BINARY" int)) (define-constant open/text (foreign-value "_O_TEXT" int)) (define (fd-set-mode! fd port-type) (let ((mode (cond ((or (eq? port-type textual-input) (eq? port-type textual-output)) open/text) ((or (eq? port-type binary-input) (eq? port-type binary-output) (eq? port-type binary-input/output)) open/binary) (else (error 'fd-set-mode! "invalid port-type for mode setting" port-type))))) ((foreign-lambda int "_setmode" int int) fd mode)))) (else ;; Unix/Linux implementation (define-constant open/binary 0) (define-constant open/text 0) (define (fd-set-mode! fd port-type) ;; Still validate the type even if we don't need to flip bits (if (not (memq port-type (list binary-input binary-output textual-input textual-output binary-input/output))) (error 'fd-set-mode! "invalid port-type" port-type) #t)))) (define fcntl/get-flags (foreign-value "F_GETFL" int)) (define (fd-get-flags fd) (let ((res ((foreign-lambda int "fcntl" int int) fd fcntl/get-flags))) (if (= res -1) (error 'fd-get-flags "Could not get file descriptor flags" fd) res))) (define (open-file fname port-type flags #!optional (permission-bits #o644) (buffer-mode buffer-block)) @("Opens the file named by fname and returns a port of the type specified by port-type. Flags is an integer bitmask, composed by adding together any of the following constants: open/append, open/create, open/exclusive, open/nofollow, open/truncate. (The POSIX flags O_RDONLY, R_WRONLY, and O_RDWR are inferred from the port type.) Permission-bits defaults to #o666, but are masked by the current umask." (fname "The file name") (port-type "constant for binary/textual input/output") (flags "open/append, open/create, open/exclusive, open/nofollow, open/truncate") (permission-bits "file permissions, default #0666") (buffer-mode "buffer-none, buffer-block, buffer-line") (@to "port")) (let* ((access-mode (cond ((or (eq? port-type binary-input) (eq? port-type textual-input)) open/read) ((or (eq? port-type binary-output) (eq? port-type textual-output)) open/write) ((eq? port-type binary-input/output) open/read-write) (else (error 'open-file "invalid port-type" port-type)))) (mode-flag (cond ((or (eq? port-type textual-input) (eq? port-type textual-output)) open/text) (else open/binary))) (final-flags (bitwise-ior flags access-mode mode-flag)) (fd ((foreign-lambda int "open" c-string int int) fname final-flags permission-bits))) (if (= fd -1) (raise-posix-error 'open-file fname port-type flags permission-bits buffer-mode) (fd->port fd port-type buffer-mode)))) (define (fd->port fd port-type #!optional (buffer-mode buffer-block)) @("This procedure wraps a newly created port around the specified file descriptor, effectively importing it into the Scheme world. The most common use of this procedure is for a file descriptor other than 0, 1, 2 (standard input, standard output, standard error) that is already open when the Scheme program starts. It is an error if a port already exists that encapsulates fd, or if an attempt is made to use fd->port twice on the same fd." (fd "File descriptor") (port-type "constant for binary/textual input/output") (buffer-mode "buffer-none, buffer-block, buffer-line") (@to "port")) (fd-set-mode! fd port-type) (let* ((actual-flags (fd-get-flags fd)) (append? (not (zero? (bitwise-and actual-flags open/append)))) (chicken-buffering (cond ((eq? buffer-mode buffer-none) #:none) ((eq? buffer-mode buffer-line) #:line) ((eq? buffer-mode buffer-block) #:full) (else (error 'fd->port "invalid buffer-mode" buffer-mode))))) (let ((port (cond ((or (eq? port-type binary-input) (eq? port-type textual-input)) (open-input-file* fd)) ((or (eq? port-type binary-output) (eq? port-type textual-output)) (if append? (open-output-file* fd #:append) (open-output-file* fd))) ((eq? port-type binary-input/output) (make-bidirectional-port (open-input-file* fd) (if append? (open-output-file* fd #:append) (open-output-file* fd)))) (else (error 'fd->port "invalid port-type" port-type))))) (set-buffering-mode! port chicken-buffering) port))) (foreign-declare "#include ") (foreign-declare "#include ") (foreign-declare "#include ") (foreign-declare "#include ") ;; Define DIR* type for readability (define-foreign-type DIR* (c-pointer "DIR")) (define-foreign-type dirent* (c-pointer "struct dirent")) (define-foreign-type mode-t unsigned-int) (define-foreign-type uid-t unsigned-int) (define-foreign-type gid-t unsigned-int) (define-foreign-type off-t int) (define (create-directory fname #!optional (permission-bits #o775)) @("Creates a directory in the file system. If an object with the same name exists, an exception is signaled." (fname "File name") (permission-bits "file permission bits") (@to "undefined")) (let ((res ((foreign-lambda int "mkdir" c-string mode-t) fname permission-bits))) (if (< res 0) (raise-posix-error 'create-directory fname)))) (define (create-fifo fname #!optional (permission-bits #o664)) @("Creates a FIFO in the file system. If an object with the same name exists, an exception is signaled." (fname "File name") (permission-bits "file permission bits") (@to "undefined")) (let ((res ((foreign-lambda int "mkfifo" c-string mode-t) fname permission-bits))) (if (< res 0) (raise-posix-error 'create-fifo fname)))) (define (create-hard-link old-fname new-fname) @("Creates a hard link in the file system. If an object with the same name exists, an exception is signaled." (old-fname "Existing name") (new-fname "New name") (permission-bits "file permission bits") (@to "undefined")) (let ((res ((foreign-lambda int "link" c-string c-string) old-fname new-fname))) (if (< res 0) (raise-posix-error 'create-hard-link old-fname new-fname)))) (define (create-symlink old-fname new-fname) @("Creates a symolic link in the file system. If an object with the same name exists, an exception is signaled." (old-fname "Existing name") (new-fname "New name") (@to "undefined")) (let ((res ((foreign-lambda int "symlink" c-string c-string) old-fname new-fname))) (if (< res 0) (raise-posix-error 'create-symlink old-fname new-fname)))) (define (read-symlink path) @("Return the filename referenced by the symlink fname." (fname "path") (@to "string")) (let* ((c-readlink (foreign-lambda* c-string* ((c-string path)) " size_t sz = 1024; char * buf = malloc(sz+1); if (!buf) C_return(NULL); ssize_t len = readlink(path, buf, sz+1); while (len > (ssize_t)sz) { sz *= 2; char * tmp = realloc(buf, sz+1); if (!tmp) { free(buf); C_return(NULL); } buf = tmp; len = readlink(path, buf, sz+1); } if (0 <= len) { buf[len] = '\\0'; // readlink does not append a null byte C_return(buf); } free(buf); C_return(NULL); ")) (ptr (c-readlink path))) (if ptr ptr (raise-posix-error 'read-symlink path)))) (define (rename-file old-fname new-fname) @("If you override an existing object, then old-fname and new-fname must type-match — either both directories, or both non-directories. This is required by the semantics of POSIX rename(). Calling rename-file on a symbolic link will rename the symbolic link, not the file it refers to. Remark: There is an unfortunate atomicity problem with the rename-file procedure: if you create file new-fname sometime between rename-file's existence check and the actual rename operation, your file will be clobbered with old-fname. There is no way to prevent this problem; at least it is highly unlikely to occur in practice." (old-fname "Existing name") (new-fname "New name") (@to "undefined")) (let ((res ((foreign-lambda int "rename" c-string c-string) old-fname new-fname))) (if (< res 0) (raise-posix-error 'rename-file old-fname new-fname)))) (define (delete-directory fname) @("This procedure deletes directories from the file system. An error is signaled if fname is not a directory or is not empty." (fname "path") (@to "undefined")) (let ((res ((foreign-lambda int "rmdir" c-string) fname))) (if (< res 0) (raise-posix-error 'delete-directory fname)))) (define (set-file-owner fname uid gid) @("This procedure sets the owner and group of a file specified by supplying the filename. If the uid argument is the constant owner/unchanged, the owner is not changed; if the gid argument is the constant group/unchanged, the group is not changed. Setting file ownership usually requires root privileges. This procedure follows symlinks and changes the files to which they refer." (fname "path") (uid "user id") (gid "group id") (@to "undefined")) (let ((res ((foreign-lambda int "chown" c-string uid-t gid-t) fname uid gid))) (if (< res 0) (raise-posix-error 'set-file-owner fname)))) (foreign-declare "#include ") (foreign-declare "#include ") (foreign-declare "#include ") ;; int futimens(int fd, const struct timespec times[2]); (define %futimens (foreign-lambda int "futimens" int c-pointer)) ;; Keep %utimensat for path-based calls (define %utimensat (foreign-lambda int "utimensat" int c-string c-pointer int)) (define AT_FDCWD (foreign-value "AT_FDCWD" int)) (define AT_SYMLINK_NOFOLLOW (foreign-value "AT_SYMLINK_NOFOLLOW" int)) (define (set-file-times fname/port access-time-object modify-time-object #!optional (follow? #t)) @("This procedure sets the access and modified times for the file fname to the supplied time object values. It is an error if they are not of type time-utc. If neither time argument is supplied, they are both taken to be the current time. The constants time/now and time/unchanged are bound to values used to specify the current time and an unchanged time respectively. It is an error if exactly one time is provided. This procedure will follow symlinks and set the times of the file to which it refers. If the procedure completes successfully, the file's time of last status-change (ctime) is set to the current time." (fname/port "A path or a scheme port") (access-time-object "A time object per srfi-19") (modify-time-object "A time object per srfi-19") (follow? "Follow the symbolic link? Default #t") (@to "undefined")) (let* ((ts-size (foreign-value "sizeof(struct timespec)" int)) (buf (make-blob (* 2 ts-size))) (flags (if follow? 0 AT_SYMLINK_NOFOLLOW))) (define (pack-srfi19-time! t offset) (let ((sec (time-second t)) (nsec (time-nanosecond t))) ((foreign-lambda* void ((scheme-object b) (int off) (long s) (long ns)) "struct timespec *ts = (struct timespec *)(C_data_pointer(b) + off); ts->tv_sec = (time_t)s; ts->tv_nsec = (long)ns;") buf offset sec nsec))) (pack-srfi19-time! access-time-object 0) (pack-srfi19-time! modify-time-object ts-size) (let ((status (if (port? fname/port) (%futimens (port->fileno fname/port) (location buf)) (%utimensat AT_FDCWD fname/port (location buf) flags)))) (if (not (zero? status)) (raise-posix-error 'set-file-times fname/port))))) (define (truncate-file fname/port #!optional (len 0)) @("The specified file is truncated to len bytes in length." (fname/port "path or Scheme port") (len "length in bytes") (@to "undefined")) (let ((res (cond ((string? fname/port) ((foreign-lambda int "truncate" c-string off-t) fname/port len)) ((port? fname/port) ((foreign-lambda int "ftruncate" int off-t) (port->fileno fname/port) len))))) (if (< res 0) (raise-posix-error 'truncate-file fname/port)))) (foreign-declare "#include ") (foreign-declare " #include #include /* Use token pasting (##) to handle the 'a', 'm', and 'c' prefixes for both BSD/Apple and Linux/POSIX naming conventions. */ #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) #define ST_NSEC(s, prefix) ((s)->st_ ## prefix ## timespec.tv_nsec) #else #define ST_NSEC(s, prefix) ((s)->st_ ## prefix ## tim.tv_nsec) #endif ") (define get-dev (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_dev);")) (define get-ino (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_ino);")) (define get-mode (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_mode);")) (define get-nlink (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_nlink);")) (define get-uid (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_uid);")) (define get-gid (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_gid);")) (define get-rdev (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_rdev);")) (define get-size (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_size);")) (define get-blksize (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_blksize);")) (define get-blocks (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_blocks);")) ;; Basic seconds getters (define get-atime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_atime);")) (define get-mtime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_mtime);")) (define get-ctime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_ctime);")) ;; Nanoseconds getters using the ST_NSEC macro (define get-atime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), a));")) (define get-mtime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), m));")) (define get-ctime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), c));")) (define S_IFMT (foreign-value "S_IFMT" unsigned-int)) (define S_IFDIR (foreign-value "S_IFDIR" unsigned-int)) (define S_IFCHR (foreign-value "S_IFCHR" unsigned-int)) (define S_IFBLK (foreign-value "S_IFBLK" unsigned-int)) (define S_IFREG (foreign-value "S_IFREG" unsigned-int)) (define S_IFLNK (foreign-value "S_IFLNK" unsigned-int)) (define S_IFIFO (foreign-value "S_IFIFO" unsigned-int)) (define S_IFSOCK (foreign-value "S_IFSOCK" unsigned-int)) (define (file-info-type-is? info mask) (= (bitwise-and (file-info:mode info) S_IFMT) mask)) (define (file-info-directory? info) (file-info-type-is? info S_IFDIR)) (define (file-info-character-special? info) (file-info-type-is? info S_IFCHR)) (define (file-info-block-special? info) (file-info-type-is? info S_IFBLK)) (define (file-info-regular? info) (file-info-type-is? info S_IFREG)) (define (file-info-symlink? info) (file-info-type-is? info S_IFLNK)) (define (file-info-fifo? info) (file-info-type-is? info S_IFIFO)) (define (file-info-socket? info) (file-info-type-is? info S_IFSOCK)) (define (file-info-device? info) (or (file-info-type-is? info S_IFCHR) (file-info-type-is? info S_IFBLK))) (foreign-declare " #include #include /* Use token pasting (##) to handle 'a', 'm', and 'c' prefixes. */ #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) /* BSD/Apple Style: st_atimespec.tv_nsec */ #define ST_NSEC(s, prefix) ((s)->st_ ## prefix ## timespec.tv_nsec) #elif defined(__linux__) || defined(__CYGWIN__) || defined(__MSYS__) || defined(_POSIX_C_SOURCE) /* Linux/Cygwin/MSYS Style: st_atim.tv_nsec */ #define ST_NSEC(s, prefix) ((s)->st_ ## prefix ## tim.tv_nsec) #else /* Fallback for older or non-standard POSIX environments */ #define ST_NSEC(s, prefix) (0) #endif ") (define-record-type @("Record containing file information" (@full)) (make-file-info device inode mode nlinks uid gid rdev size atime mtime ctime blksize blocks) file-info? (device file-info:device) (inode file-info:inode) (mode file-info:mode) (nlinks file-info:nlinks) (uid file-info:uid) (gid file-info:gid) (rdev file-info:rdev) (size file-info:size) (atime file-info:atime) (mtime file-info:mtime) (ctime file-info:ctime) (blksize file-info:blksize) (blocks file-info:blocks)) ;; --- FFI Bindings --- (define %stat (foreign-lambda int "stat" c-string c-pointer)) (define %lstat (foreign-lambda int "lstat" c-string c-pointer)) (define %fstat (foreign-lambda int "fstat" int c-pointer)) (define get-dev (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_dev);")) (define get-ino (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_ino);")) (define get-mode (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_mode);")) (define get-nlink (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_nlink);")) (define get-uid (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_uid);")) (define get-gid (foreign-lambda* unsigned-int ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_gid);")) (define get-rdev (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_rdev);")) (define get-size (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_size);")) (define get-blksize (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_blksize);")) (define get-blocks (foreign-lambda* unsigned-integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_blocks);")) ;; Basic seconds getters (define get-atime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_atime);")) (define get-mtime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_mtime);")) (define get-ctime-sec (foreign-lambda* integer64 ((scheme-object p)) "C_return(((struct stat *)C_data_pointer(p))->st_ctime);")) ;; Nanoseconds getters using the ST_NSEC macro (define get-atime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), a));")) (define get-mtime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), m));")) (define get-ctime-nsec (foreign-lambda* integer64 ((scheme-object p)) "C_return(ST_NSEC((struct stat *)C_data_pointer(p), c));")) ;; --- Type Predicates --- (define S_IFMT (foreign-value "S_IFMT" unsigned-int)) (define S_IFDIR (foreign-value "S_IFDIR" unsigned-int)) (define S_IFCHR (foreign-value "S_IFCHR" unsigned-int)) (define S_IFBLK (foreign-value "S_IFBLK" unsigned-int)) (define S_IFREG (foreign-value "S_IFREG" unsigned-int)) (define S_IFLNK (foreign-value "S_IFLNK" unsigned-int)) (define S_IFIFO (foreign-value "S_IFIFO" unsigned-int)) (define S_IFSOCK (foreign-value "S_IFSOCK" unsigned-int)) (define (file-info-type-is? info mask) (= (bitwise-and (file-info:mode info) S_IFMT) mask)) (define (file-info-directory? info) (file-info-type-is? info S_IFDIR)) (define (file-info-character-special? info) (file-info-type-is? info S_IFCHR)) (define (file-info-block-special? info) (file-info-type-is? info S_IFBLK)) (define (file-info-regular? info) (file-info-type-is? info S_IFREG)) (define (file-info-symlink? info) (file-info-type-is? info S_IFLNK)) (define (file-info-fifo? info) (file-info-type-is? info S_IFIFO)) (define (file-info-socket? info) (file-info-type-is? info S_IFSOCK)) ;; --- Main Procedure --- (define (file-info fname/port #!optional (follow? #t)) @("The file-info procedure returns a file-info record containing useful information about a file. If the follow? flag is true the procedure will follow symlinks and report on the file to which they refer. If follow? is false the procedure checks the actual file itself, even if it's a symlink. The follow? flag is ignored if the file argument is a port." (fname/port "path or Scheme port") (follow? "Follow symlinks, default #t")) (let ((buf (make-blob (foreign-value "sizeof(struct stat)" int)))) (if (zero? (cond ((port? fname/port) (%fstat (port->fileno fname/port) (location buf))) (follow? (%stat fname/port (location buf))) (else (%lstat fname/port (location buf))))) (make-file-info (get-dev buf) (get-ino buf) (get-mode buf) (get-nlink buf) (get-uid buf) (get-gid buf) (get-rdev buf) (get-size buf) ;; Seconds + Nanoseconds -> SRFI-19