Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl
Commits:
4a7207b6 by Raymond Toy at 2022-10-17T18:58:45+00:00
Fix #130: Implement file_author in C
- - - - -
ba5c5d2a by Raymond Toy at 2022-10-17T18:58:45+00:00
Merge branch 'issue-130-file-author-in-c' into 'master'
Fix #130: Implement file_author in C
Closes #130
See merge request cmucl/cmucl!88
- - - - -
5944241c by Raymond Toy at 2022-10-18T17:13:26-07:00
Merge branch 'master' into issue-140-stream-element-type-two-way-stream
- - - - -
4 changed files:
- src/code/filesys.lisp
- src/lisp/os-common.c
- tests/issues.lisp
- + tests/안녕하십니까.txt
Changes:
=====================================
src/code/filesys.lisp
=====================================
@@ -1079,13 +1079,21 @@ optionally keeping some of the most recent old versions."
:pathname file
:format-control (intl:gettext "~S doesn't exist.")
:format-arguments (list file)))
- (multiple-value-bind (winp dev ino mode nlink uid)
- (unix:unix-stat name)
- (declare (ignore dev ino mode nlink))
- (when winp
- (let ((user-info (unix:unix-getpwuid uid)))
- (when user-info
- (unix:user-info-name user-info))))))))
+ ;; unix-namestring converts "." to "". Convert it back to
+ ;; "." so we can stat the current directory. (Perhaps
+ ;; that's a bug in unix-namestring?)
+ (when (zerop (length name))
+ (setf name "."))
+ (let (author)
+ (unwind-protect
+ (progn
+ (setf author (alien:alien-funcall
+ (alien:extern-alien "os_file_author"
+ (function (alien:* c-call:c-string) c-call:c-string))
+ (unix::%name->file name)))
+ (unless (alien:null-alien author)
+ (alien:cast author c-call:c-string)))
+ (alien:free-alien author))))))
;;;; DIRECTORY.
=====================================
src/lisp/os-common.c
=====================================
@@ -5,12 +5,16 @@
*/
+#include <assert.h>
#include <errno.h>
#include <math.h>
#include <netdb.h>
+#include <pwd.h>
#include <stdio.h>
+#include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
+#include <unistd.h>
#include <time.h>
#include "os.h"
@@ -715,3 +719,57 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u
return rc;
}
+
+/*
+ * Interface for file-author. Given a pathname, returns a new string
+ * holding the author of the file or NULL if some error occurred. The
+ * caller is responsible for freeing the memory used by the string.
+ */
+char *
+os_file_author(const char *path)
+{
+ struct stat sb;
+ char initial[1024];
+ char *buffer, *obuffer;
+ size_t size;
+ struct passwd pwd;
+ struct passwd *ppwd;
+ char *result;
+
+ if (stat(path, &sb) != 0) {
+ return NULL;
+ }
+
+ result = NULL;
+ buffer = initial;
+ obuffer = NULL;
+ size = sizeof(initial) / sizeof(initial[0]);
+
+ /*
+ * Keep trying with larger buffers until a maximum is reached. We
+ * assume (1 << 20) is large enough for any OS.
+ */
+ while (size <= (1 << 20)) {
+ switch (getpwuid_r(sb.st_uid, &pwd, buffer, size, &ppwd)) {
+ case 0:
+ /* Success, though we might not have a matching entry */
+ result = (ppwd == NULL) ? NULL : strdup(pwd.pw_name);
+ goto exit;
+ case ERANGE:
+ /* Buffer is too small, double its size and try again */
+ size *= 2;
+ obuffer = (buffer == initial) ? NULL : buffer;
+ if ((buffer = realloc(obuffer, size)) == NULL) {
+ goto exit;
+ }
+ continue;
+ default:
+ /* All other errors */
+ goto exit;
+ }
+ }
+exit:
+ free(obuffer);
+
+ return result;
+}
=====================================
tests/issues.lisp
=====================================
@@ -670,6 +670,14 @@
(err (relerr value answer)))
(assert-true (<= err eps) base err eps)))))))
+(define-test issue.130
+ (:tag :issues)
+ ;; Just verify that file-author works. In particular "." should
+ ;; work and not return NIL.
+ (assert-true (file-author "."))
+ (assert-true (file-author "bin/build.sh"))
+ (assert-true (file-author "tests/안녕하십니까.txt")))
+
;;; Test stream-external-format for various types of streams.
;; Test two-way-stream where both streams have the same external
=====================================
tests/안녕하십니까.txt
=====================================
@@ -0,0 +1,3 @@
+The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.)
+
+
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/145aa085a805aa7f20ea45…
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/145aa085a805aa7f20ea45…
You're receiving this email because of your account on gitlab.common-lisp.net.
Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl
Commits:
145aa085 by Raymond Toy at 2022-10-18T17:06:58-07:00
Allow broadcast-stream and two-way-stream for stream-external-format
`stream-external-format` for a `broadcast-stream` is `:default`,
according to the CLHS.
For a `two-way-stream`, the CLHS doesn't say, so we'll return the
common external format if there is one, or `:default` if they're
different.
For a `synonym-stream`, the CLHS also doesn't say, so we'll just
return the format of the value of the synonym stream symbol.
Add tests for test different types of streams, except for
`broadcast-stream`. The ansi-tests have tests for this.
- - - - -
2 changed files:
- src/code/stream.lisp
- tests/issues.lisp
Changes:
=====================================
src/code/stream.lisp
=====================================
@@ -295,8 +295,22 @@
(etypecase stream
#+unicode
(fd-stream (fd-stream-external-format stream))
- (synonym-stream (stream-external-format
- (symbol-value (synonym-stream-symbol stream)))))
+ (broadcast-stream
+ ;; See http://www.lispworks.com/documentation/HyperSpec/Body/t_broadc.htm
+ :default)
+ (synonym-stream
+ ;; What should happen if (synonym-stream-symbol stream) is unbound?
+ (stream-external-format
+ (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ ;; Not defined by CLHS, but useful to return the common format
+ ;; of the input and output streams when they're the same;
+ ;; otherwise return :default.
+ (let ((in-format (stream-external-format (two-way-stream-input-stream stream)))
+ (out-format (stream-external-format (two-way-stream-output-stream stream))))
+ (if (eql in-format out-format)
+ in-format
+ :default))))
;; fundamental-stream
:default))
=====================================
tests/issues.lisp
=====================================
@@ -670,9 +670,42 @@
(err (relerr value answer)))
(assert-true (<= err eps) base err eps)))))))
-(define-test issue.140
+;;; Test stream-external-format for various types of streams.
+
+;; Test two-way-stream where both streams have the same external
+;; format.
+(define-test issue.140.1
+ (:tag :issues)
+ (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+ :direction :input
+ :external-format :utf-8)
+ (with-open-file (out "/tmp/output.tst"
+ :direction :output
+ :external-format :utf-8
+ :if-exists :supersede)
+ (let ((two-way-stream (make-two-way-stream in out)))
+ (assert-equal :utf-8 (stream-external-format two-way-stream))))))
+
+;; Test two-way-stream where the two streams have the different
+;; external formats.
+(define-test issue.140.2
(:tag :issues)
- (with-output-to-string (out)
- (with-input-from-string (in "abc")
+ (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+ :direction :input
+ :external-format :iso8859-1)
+ (with-open-file (out "/tmp/output.tst"
+ :direction :output
+ :external-format :utf-8
+ :if-exists :supersede)
(let ((two-way-stream (make-two-way-stream in out)))
- (assert-error 'type-error (stream-external-format two-way-stream))))))
+ (assert-equal :default (stream-external-format two-way-stream))))))
+
+;; Test synonym-stream returns the format of the underlying stream.
+(define-test issue.140.3
+ (:tag :issues)
+ (with-open-file (s (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+ :direction :input
+ :external-format :iso8859-1)
+ (let ((syn (make-synonym-stream '*syn-stream*)))
+ (setf syn s)
+ (assert-equal :iso8859-1 (stream-external-format syn)))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/145aa085a805aa7f20ea455…
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/145aa085a805aa7f20ea455…
You're receiving this email because of your account on gitlab.common-lisp.net.
Raymond Toy pushed to branch issue-130-file-author-in-c at cmucl / cmucl
Commits:
cde14045 by Raymond Toy at 2022-10-16T14:26:39+00:00
Fix #142: (random 0) signals incorrect error
- - - - -
4c9cbf43 by Raymond Toy at 2022-10-16T14:26:41+00:00
Merge branch 'issue-142-random-0-wrong-error' into 'master'
Fix #142: (random 0) signals incorrect error
Closes #142
See merge request cmucl/cmucl!99
- - - - -
b59185fc by Raymond Toy at 2022-10-16T14:27:39+00:00
Fix #136: ensure-directories-exist should return the given pathspec
- - - - -
49ecc858 by Raymond Toy at 2022-10-16T14:27:39+00:00
Merge branch 'issue-136-ansi-test-ensure-directories-exist.8' into 'master'
Fix #136: ensure-directories-exist should return the given pathspec
Closes #136
See merge request cmucl/cmucl!92
- - - - -
08e5370a by Raymond Toy at 2022-10-16T07:33:23-07:00
Update release notes based on recent merges
Forgot to update the release notes with recent merges that fixed a few
issues. Hence update the notes now.
Also testing see if we need to add a strikeout for closed issues, so
didn't add strikeout for these.
- - - - -
556b1a5b by Raymond Toy at 2022-10-16T07:35:57-07:00
Add strikeout for closed issues
Nope, gitlab doesn't mark closed issues in anyway, unlike Trac that
would automatically strikeout references to closed issues. We have to
do it ourselves.
- - - - -
95b4fc5c by Raymond Toy at 2022-10-16T13:05:09-07:00
Fix #146: CI passes incorrectly
We forgot to update the script for macos to use separate `grep`
commands like we did for linux.
- - - - -
66cb86f6 by Raymond Toy at 2022-10-17T10:53:42-07:00
Merge branch 'master' into issue-130-file-author-in-c
- - - - -
e3f73659 by Raymond Toy at 2022-10-17T11:07:05-07:00
Address review comments
Remove the assert and change the loop limit from 16384 to 1<<20.
- - - - -
9e208e62 by Raymond Toy at 2022-10-17T11:26:32-07:00
Change so we only free in one place.
- - - - -
6 changed files:
- .gitlab-ci.yml
- src/code/filesys.lisp
- src/code/rand-xoroshiro.lisp
- src/general-info/release-21e.md
- src/lisp/os-common.c
- tests/filesys.lisp
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -167,7 +167,8 @@ osx:ansi-test:
script:
- cd ansi-test
- make LISP="../dist/bin/lisp -batch -noinit -nositeinit"
- - grep 'No unexpected \(successes\|failures\)' test.out
+ # There should be no unexpected successes or failures; check these separately.
+ - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out
osx:benchmark:
stage: benchmark
=====================================
src/code/filesys.lisp
=====================================
@@ -1486,4 +1486,4 @@ optionally keeping some of the most recent old versions."
(retry () :report "Try to create the directory again"
(go retry))))))
;; Only the first path in a search-list is considered.
- (return (values pathname created-p))))))
+ (return (values pathspec created-p))))))
=====================================
src/code/rand-xoroshiro.lisp
=====================================
@@ -491,8 +491,8 @@
(t
(error 'simple-type-error
:expected-type '(or (integer 1) (float (0.0))) :datum arg
- :format-control _"Argument is not a positive integer or a positive float: ~S")
- :format-arguments (list arg))))
+ :format-control _"Argument is not a positive integer or a positive float: ~S"
+ :format-arguments (list arg)))))
;; Jump function for the generator. See the jump function in
;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c
=====================================
src/general-info/release-21e.md
=====================================
@@ -50,8 +50,13 @@ public domain.
* ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF.
* ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM
* ~~#122~~ gcc 11 can't build cmucl
+ * ~~#125~~ Linux `unix-stat` returning incorrect values
* ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid.
* ~~#128~~ `QUIT` accepts an exit code
+ * ~~#132~~ Ansi test `RENAME-FILE.1` no fails
+ * ~~#134~~ Handle the case of `(expt complex complex-rational)`
+ * ~~#136~~ `ensure-directories-exist` should return the given pathspec
+ * ~~#142~~ `(random 0)` signals incorrect error
* Other changes:
* Improvements to the PCL implementation of CLOS:
* Changes to building procedure:
=====================================
src/lisp/os-common.c
=====================================
@@ -730,7 +730,7 @@ os_file_author(const char *path)
{
struct stat sb;
char initial[1024];
- char *buffer, *obuffer;
+ char *buffer, *newbuffer;
size_t size;
struct passwd pwd;
struct passwd *ppwd;
@@ -745,15 +745,10 @@ os_file_author(const char *path)
size = sizeof(initial) / sizeof(initial[0]);
/*
- * Assume a buffer of size 16384 is enough to for getpwuid_r to do
- * it's thing.
+ * Keep trying with larger buffers until a maximum is reached. We
+ * assume (1 << 20) is large enough for any OS.
*/
- assert(sysconf(_SC_GETPW_R_SIZE_MAX) <= 16384);
-
- /*
- * Keep trying with larger buffers until a maximum is reached.
- */
- while (size <= 16384) {
+ while (size <= (1 << 20)) {
switch (getpwuid_r(sb.st_uid, &pwd, buffer, size, &ppwd)) {
case 0:
/* Success, though we might not have a matching entry */
@@ -762,11 +757,11 @@ os_file_author(const char *path)
case ERANGE:
/* Buffer is too small, double its size and try again */
size *= 2;
- obuffer = (buffer == initial) ? NULL : buffer;
- if ((buffer = realloc(obuffer, size)) == NULL) {
- free(obuffer);
+ if ((newbuffer = realloc((buffer == initial) ? NULL : buffer,
+ size)) == NULL) {
goto exit;
}
+ buffer = newbuffer;
continue;
default:
/* All other errors */
=====================================
tests/filesys.lisp
=====================================
@@ -10,7 +10,7 @@
(define-test unix-namestring.1.exists
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
(dolist (path '("/tmp/hello.txt"
"/tmp/foo/"
@@ -27,7 +27,7 @@
(define-test unix-namestring.1.non-existent
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
;; These paths contain directories that don't exist.
(dolist (path '("/tmp/oops/"
@@ -42,7 +42,7 @@
(define-test unix-namestring.2
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
(unwind-protect
(progn
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3d81bc22fae31018c2fd97…
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3d81bc22fae31018c2fd97…
You're receiving this email because of your account on gitlab.common-lisp.net.
Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl
Commits:
7d17444a by Raymond Toy at 2022-10-17T09:49:42-07:00
Forgot to update release notes for this fix.
- - - - -
1 changed file:
- src/general-info/release-21e.md
Changes:
=====================================
src/general-info/release-21e.md
=====================================
@@ -56,7 +56,7 @@ public domain.
* ~~#132~~ Ansi test `RENAME-FILE.1` no fails
* ~~#134~~ Handle the case of `(expt complex complex-rational)`
* ~~#136~~ `ensure-directories-exist` should return the given pathspec
- * ~~#140~~ External format of `two-way-stream` returns the common format of the input and output streams if possible; otherwise, return `:default`.
+ * ~~#140~~ External format of `two-way-stream`
* ~~#142~~ `(random 0)` signals incorrect error
* Other changes:
* Improvements to the PCL implementation of CLOS:
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7d17444a4249f6430737792…
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7d17444a4249f6430737792…
You're receiving this email because of your account on gitlab.common-lisp.net.