From e6eca190e3f3a565a39602ee534d4bc1e6616463 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 24 Jul 2026 09:08:55 +0300 Subject: [PATCH] srfi-170: Memory freeing fixes --- srfi/170.scm | 234 +-------------------------------------------- srfi/170/README.md | 6 +- srfi/170/VERSION | 2 +- 3 files changed, 11 insertions(+), 231 deletions(-) diff --git a/srfi/170.scm b/srfi/170.scm index 433f6bf..a1c559e 100644 --- a/srfi/170.scm +++ b/srfi/170.scm @@ -173,11 +173,6 @@ (st_mtim.tv_nsec long) (st_ctim.tv_sec long) (st_ctim.tv_nsec long))) -;;> 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. (define (file-info fname/port follow?) (when (port? fname/port) (error "file-info implementation does not support ports as arguments")) @@ -219,8 +214,6 @@ (c-bytevector-free fname-pointer) (c-bytevector-free stat-pointer) fi))) -;;> The permission-bits for create-directory default to #o775 but are masked -;;> by the current umask. (define create-directory (lambda (fname . permission-bits) (let* ((fname-pointer (string->c-bytevector fname)) @@ -240,8 +233,6 @@ (error error-message)) (c-bytevector-free error-pointer)))) -;;> The permission-bits for create-directory default to #o664, but are masked -;;> by the current umask. (define (create-fifo fname . permission-bits) (let* ((fname-pointer (string->c-bytevector fname)) (mode (if (null? permission-bits) @@ -289,27 +280,12 @@ (c-bytevector-free buffer) name))))) -;;> Return the filename referenced by the symlink fname. (define (read-symlink fname) (internal-read-symlink fname 128)) -;;> 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. (define (rename-file old-fname new-fname) (c-rename (string->c-bytevector old-fname) (string->c-bytevector new-fname))) -;;> This procedure deletes directories from the file system. An error is -;;> signaled if fname is not a directory or is not empty. (define (delete-directory fname) (let* ((fname-pointer (string->c-bytevector fname)) (result (c-rmdir fname-pointer))) @@ -321,28 +297,12 @@ (c-bytevector-free error-pointer) (error error-message))))) -;;> 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. (define (set-file-owner fname uid gid) (let ((fname-pointer (string->c-bytevector fname))) (c-chown fname-pointer uid gid) (c-bytevector-free fname-pointer))) (define-c-array-type timespec-array 'long) -;;> \procedure{(set-file-times fname [access-time-object modify-time-object])} -;;> 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. (define (set-file-times fname . args) (when (and (not (= (length args) 0)) (not (= (length args) 2))) @@ -371,10 +331,7 @@ (c-bytevector-set! timespecs-cbv timespec-array 3 (time-nanosecond modify-time-object)) (let ((result (c-utimensat current-dir-fd fname-cbv timespecs-cbv 0))) - (c-bytevector-free fname-cbv) - (c-bytevector-free timespecs-cbv) - (c-bytevector-free current-dir-cbv) - (c-bytevector-free current-dir-stream) + (c-bytevector-free fname-cbv timespecs-cbv current-dir-cbv current-dir-stream) (when (< result 0) (let* ((error-message "set-file-times error") (error-pointer (string->c-bytevector error-message))) @@ -382,7 +339,6 @@ (c-bytevector-free error-pointer) (error error-message)))))) -;;> The specified file is truncated to len bytes in length. (define (truncate-file fname/port len) (when (not (exact-integer? len)) (error "truncate-file error: len must be exact-integer")) @@ -412,26 +368,6 @@ ; struct dirent d_name offset on linux (define d-name-offset 19) -;;> Return a list of filenames in directory dir. The dotfiles? flag -;;> (default #f) causes files beginning with . to be included in the list. -;;> Regardless of the value of dotfiles?, the two files . and .. are never -;;> returned. -;;> The directory dir is not prepended to each filename in the result list. -;;> That is, -;;> -;;> (directory-files "/etc") -;;> -;;>returns -;;> -;;> ("chown" "exports" "fstab" ...) -;;> -;;>not -;;> -;;> ("/etc/chown" "/etc/exports" "/etc/fstab" ...) -;;> -;;> To use the filenames in the returned list, the programmer can either -;;> manually prepend the directory, or change to the directory before using -;;> the filenames. (define directory-files (lambda (dir . dotfiles?) (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?))) @@ -467,9 +403,6 @@ (c-closedir directory-pointer) files)))) -;;> This procedure sets the mode bits of a file specified by supplying the -;;> filename. This procedure follows symlinks and changes the files to which -;;> they refer. (define (set-file-mode path mode) (c-chmod (string->c-bytevector path) (string->number (string-append "#o" (number->string mode))))) @@ -480,24 +413,12 @@ (handle directory:handle) (dot-files? directory:dot-files?)) -;;> Opens the directory with the specified pathname for reading, returning an -;;> opaque directory object. - -;;> The dot-files? argument controls whether filenames beginning with "." are -;;> returned. If it is #f, which is the default, they are not. The filenames -;;> . and .. are never returned. (define (open-directory path . dot-files?) (make-directory (c-opendir (string->c-bytevector path)) (if (null? dot-files?) #f (car dot-files?)))) -;;> Returns the name of the next available file, or the end-of-file object if -;;> there are no more files. - -;;> The dot-files? argument controls whether filenames beginning with "." are -;;> returned. If it is #f, which is the default, they are not. The filenames -;;> . and .. are never returned. (define (read-directory directory-object) (let ((directory-entity (c-readdir (directory:handle directory-object)))) (if (c-bytevector-null? directory-entity) @@ -513,13 +434,9 @@ (read-directory directory-object)) (else name)))))) -;;> Closes a directory object. (define (close-directory directory-object) (c-closedir (directory:handle directory-object))) -;;> Returns an absolute pathname derived from pathname that names the same -;;> file and whose resolution does not involve dot (.), dot-dot (..), or -;;> symlinks. (define real-path (lambda (path) (let* ((path-pointer (string->c-bytevector path)) @@ -529,10 +446,6 @@ (c-bytevector-free real-path-pointer) real-path))) -;;> SRFI 39 or R7RS parameter that returns a string when invoked. Its initial -;;> value is the value of the environment variable TMPDIR concatenated with -;;> "/pid" if TMPDIR is set and to "/tmp/pid" otherwise, where pid is the id -;;> of the current process. (define temp-file-prefix (make-parameter (if (get-environment-variable "TMPDIR") @@ -544,25 +457,6 @@ slash (number->string (c-getpid)))))) -;;> Creates a new temporary file and returns its name. The optional argument -;;> specifies the filename prefix to use, and defaults to the result of -;;> invoking temp-file-prefix. The procedure generates a sequence of filenames -;;> that have prefix as a common prefix, looking for a filename that doesn't -;;> already exist in the file system. When it finds one, it creates it with -;;> permission #o600 and returns the filename. (The file permission can be -;;> changed to a more permissive permission with set-file-mode after being -;;> created.) - -;;> This file is guaranteed to be brand new. No other process will have it -;;> open. This procedure does not simply return a filename that is very likely -;;> to be unused. It returns a filename that definitely did not exist at the -;;> moment create-temp-file created it. - -;;> It is not necessary for the process's pid to be a part of the filename -;;> for the uniqueness guarantees to hold. The pid component of the default -;;> prefix simply serves to scatter the name searches into sparse regions, so -;;> that collisions are less likely to occur. This speeds things up, but does -;;> not affect correctness. (define create-temp-file (lambda prefix (let* ((tmpdir (cond-expand @@ -580,52 +474,6 @@ (set-file-mode path 600) path))))) -;;> This procedure can be used to perform certain atomic transactions on the -;;> file system involving filenames. Some examples: -;;> -;;> Linking a file to a fresh backup temp name. -;;> Creating and opening an unused, secure temp file. -;;> Creating an unused temporary directory. -;;> -;;> This procedure uses prefix to generate a series of trial filenames. Prefix -;;> is a string, and defaults to the value of invoking temp-file-prefix. File -;;> names are generated by concatenating prefix with a varying string. -;;> -;;> The maker procedure is called serially on each filename generated. It must -;;> return at least one value; it may return multiple values. If the first -;;> return value is #f or if maker signals an exception indicating that the -;;> file exists, call-with-temporary-filename will loop, generating a new -;;> filename and calling maker again. If the first return value is true, the -;;> loop is terminated, returning whatever value(s) maker returned. -;;> -;;> After a number of unsuccessful trials, call-with-temporary-filename may -;;> give up, in which case an exception is signaled or propagated. -;;> -;;> To rename a file to a temporary name: -;;> -;;> (call-with-temporary-filename -;;> (lambda (backup) -;;> (create-hard-link old-file backup) -;;> backup) -;;> ".temp.") ; Keep link in current working directory -;;> (delete-file old-file) -;;> -;;> Recall that this SRFI reports procedure failure by signaling an error. -;;> This is critical for this example — the programmer can assume that if the -;;> call-with-temporary-filename call returns, it returns successfully. So the -;;> following delete-file call can be reliably invoked, safe in the knowledge -;;> that the backup link has definitely been established. -;;> -;;> To create a unique temporary directory: -;;> -;;> (call-with-temporary-filename -;;> (lambda (dir) -;;> (create-directory dir) -;;> dir) -;;> "/tmp/tempdir.") -;;> -;;> Similar operations can be used to generate unique fifos, or to return -;;> values other than the new filename (for example, an open port). (define (call-with-temporary-filename maker . prefix) (let* ((tmpdir (cond-expand (windows (get-environment-variable "TMP")) (else "/tmp"))) @@ -637,22 +485,14 @@ (path (string-append real-prefix "-" (random-string 6)))) (apply maker (list path)))) -;;> Returns the current file protection mask, or umask, as an exact integer. -;;> Whenever a file is created, the specified or default permissions are -;;> bitwise-anded with the complement of the umask before they are used. (define (umask) (let ((mask (c-umask 0))) (c-umask mask) mask)) -;;> Sets the file protection mask to the exact integer umask and returns an -;;> unspecified value. (define (set-umask! umask) (c-umask umask)) -;;> Returns the current directory as a string containing an absolute pathname. -;;> Whenever a file is referenced with a relative path, it is interpreted as -;;> relative to this directory. (define (current-directory) (let* ((path-pointer (make-c-bytevector 1024)) (path (begin @@ -661,19 +501,11 @@ (c-bytevector-free path-pointer) path)) -;;> Sets the current directory to new-directory and returns an unspecified -;;> value. (define (set-current-directory! path) (c-chdir (string->c-bytevector path))) -;;> Retrieves the process id for the current process. (define (pid) (c-getpid)) -;;> Increments the niceness of the current process by delta. The lower the -;;> niceness value is, the more the process is favored during scheduling. -;;> If delta is not specified, the increment is 1. - -;;> Real-time processes are not affected by nice. (define nice (lambda args (let ((result (if (null? args) (c-nice 1) (c-nice (car args))))) @@ -718,48 +550,15 @@ (shell internal-user-info:shell) (full-name internal-user-info:full-name)) -;;> Returns the user name stored in user-info respectively. -;;> An implementation returns #f for any unavailable items. (define (user-info:name user-info) (internal-user-info:name user-info)) -;;> Returns the user uid stored in user-info respectively. -;;> An implementation returns #f for any unavailable items. (define (user-info:uid user-info) (internal-user-info:uid user-info)) -;;> Returns the user gid stored in user-info respectively. -;;> An implementation returns #f for any unavailable items. (define (user-info:gid user-info) (internal-user-info:gid user-info)) -;;> Returns the user home directory stored in user-info respectively. -;;> An implementation returns #f for any unavailable items. (define (user-info:home-dir user-info) (internal-user-info:home-dir user-info)) -;;> Returns the shell path stored in user-info respectively. -;;> An implementation returns #f for any unavailable items. (define (user-info:shell user-info) (internal-user-info:shell user-info)) -;;> Returns the contents of the pw_gecos field stored in user-info. Although -;;> this field is not part of POSIX, it has been part of all Unix variants -;;> since at least the Sixth Edition of Research Unix. It normally contains -;;> the user's full name, but may contain additional system-specific -;;> information; on Windows, it contains exactly the full name. (define (user-info:full-name user-info) (internal-user-info:full-name user-info)) -;;> Returns a parsed and expanded version of the raw string returned by -;;> user-info:full-name. The raw value is split on commas, creating a list of -;;> strings to be returned. All ampersands in the first element of the list -;;> are replaced by user-info:name, which is capitalized if it starts with an -;;> ASCII lowercase letter. - -;;> However, on Windows the implementation is completely different: -;;> user-info:parsed-full-name returns a list with a single element, the -;;> result of user-info:full-name. No comma splitting or ampersand -;;> substitution is performed. - -;;> The meaning of the first element of the returned list is the user's full -;;> name on all known systems. The remaining elements have varying meaning. -;;> For example, on BSD systems, the second through fourth elements are the -;;> user's work location, the user's work phone number, and the user's home -;;> phone number, respectively. On Cygwin, the second element is the Windows -;;> SID corresponding to this user; further elements depend on Cygwin-specific -;;> entries in the /etc/nsswitch.conf file. (define (user-info:parsed-full-name user-info) (let* ((parsed-list (string-split (internal-user-info:full-name user-info) #\,)) @@ -770,11 +569,6 @@ (cons (string-char-replace first #\& (user-info:name user-info)) (cdr parsed-list)))) -;;> Return a user-info record giving the recorded information for a particular -;;> user. The uid/name argument is either an exact integer user id or a string -;;> user name. If uid/name does not identify an existing user, #f is returned; -;;> this does not constitute an error situation, and callers must be prepared -;;> to handle it. (define (user-info uid/name) (let ((password-struct (if (number? uid/name) (c-getpwuid uid/name) @@ -819,23 +613,16 @@ 'int (* (c-type-size 'pointer) 2))))) -;;> Change the value of the environment variable name to be value. Both name -;;> and value are strings. If name is not defined at the time of call, a new -;;> variable is added; if name is defined, its old value is discarded and -;;> replaced by value. If name or value are invalid according to the operating -;;> system, an exception is signaled. Mutating name or value after the call -;;> must not change the name or value of the environment variable. (define (set-environment-variable! name value) (when (not (string? name)) (error "set-environment-variable! error: name must be string")) (when (not (string? value)) (error "set-environment-variable! error: value must be string")) - (c-setenv (string->c-bytevector name) (string->c-bytevector value) 1)) + (let ((name-cbv (string->c-bytevector name)) + (value-cbv (string->c-bytevector value))) + (c-setenv name-cbv value-cbv 1) + (c-bytevector-free name-cbv value-cbv))) -;;> Remove the environment variable name such that a subsequent -;;> (get-environment-variable name) would return #f. If the variable cannot -;;> be removed, an exception is signaled. If name does not currently have a -;;> value, the call silently succeeds. (define (delete-environment-variable! name) (when (not (string? name)) (error "delete-environment-variable! error: Name must be string")) @@ -847,10 +634,6 @@ (define tv_nsec-type 'long) (define timespec (make-c-bytevector (c-type-size+ tv_sec-type tv_nsec-type))) -;;> Returns the current time as a time object of type time-utc, which -;;> represents the time since the POSIX epoch (midnight January 1, 1970 -;;> Universal Time), excluding leap seconds. It uses the POSIX CLOCK_REALTIME -;;> clock. (define (posix-time) (let* ((result (c-clock-gettime CLOCK_REALTIME timespec))) (cond @@ -868,13 +651,6 @@ (c-type-size tv_sec-type)) (c-bytevector-ref timespec tv_sec-type 0)))))) -;;> Returns the current time as a time object of type time-monotonic, which -;;> represents the time since an arbitrary epoch. This epoch is arbitrary, -;;> but cannot change after the current program begins to run. It is -;;> guaranteed that a call to monotonic-time cannot return a time earlier -;;> than a previous call to monotonic-time. This is not guaranteed for -;;> posix-time because the system's POSIX clock is sometimes turned backward -;;> to correct local clock drift. It uses the POSIX CLOCK_MONOTONIC clock. (define (monotonic-time) (let* ((result (c-clock-gettime CLOCK_MONOTONIC timespec))) (cond diff --git a/srfi/170/README.md b/srfi/170/README.md index 61412ee..e062fd9 100644 --- a/srfi/170/README.md +++ b/srfi/170/README.md @@ -1,5 +1,9 @@ Implementation of SRFI 170 - POSIX API using (foreign c) +Not everything is implemented yet, see 170.sld for commented out parts + Currently only supports Linux. -Not everything is implemented yet, see 170.sld for commented out parts +## Documentation + +See [https://srfi.schemers.org/srfi-170/srfi-170.html](https://srfi.schemers.org/srfi-170/srfi-170.html) diff --git a/srfi/170/VERSION b/srfi/170/VERSION index 0ea3a94..0c62199 100644 --- a/srfi/170/VERSION +++ b/srfi/170/VERSION @@ -1 +1 @@ -0.2.0 +0.2.1