[Git][cmucl/cmucl][issue-139-add-alias-local-external-format] 7 commits: Fix #130: Implement file_author in C
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Mon Oct 31 17:15:10 UTC 2022
Raymond Toy pushed to branch issue-139-add-alias-local-external-format 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
- - - - -
e8a0cc6c by Raymond Toy at 2022-10-30T15:03:27+00:00
Fix #147: Add method for stream-line-column
- - - - -
0dad5a1a by Raymond Toy at 2022-10-30T15:03:28+00:00
Merge branch 'issue-147-stream-line-column-impl' into 'master'
Fix #147: Add method for stream-line-column
Closes #147
See merge request cmucl/cmucl!104
- - - - -
1300830b by Raymond Toy at 2022-10-31T17:12:48+00:00
Address #139: *default-external-format* is :utf-8
- - - - -
649a4f1e by Raymond Toy at 2022-10-31T17:12:49+00:00
Merge branch 'issue-139-default-external-format-utf8' into 'master'
Address #139: *default-external-format* is :utf-8
See merge request cmucl/cmucl!103
- - - - -
69f2a990 by Raymond Toy at 2022-10-31T10:14:48-07:00
Merge branch 'master' into issue-139-add-alias-local-external-format
- - - - -
9 changed files:
- src/code/extfmts.lisp
- src/code/filesys.lisp
- src/general-info/release-21e.md
- src/lisp/os-common.c
- src/pcl/gray-streams.lisp
- + tests/.gitignore
- tests/issues.lisp
- + tests/utf8.txt
- + tests/안녕하십니까.txt
Changes:
=====================================
src/code/extfmts.lisp
=====================================
@@ -22,7 +22,7 @@
describe-external-format))
(defvar *default-external-format*
- :iso8859-1
+ :utf-8
"The default external format to use if no other external format is
specified")
=====================================
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/general-info/release-21e.md
=====================================
@@ -22,6 +22,7 @@ public domain.
* Feature enhancements
* Changes
* Update to ASDF 3.3.6
+ * The default external format is `:utf-8` instead of `:iso8859-1`
* ANSI compliance fixes:
* Bug fixes:
* ~~#97~~ Fixes stepping through the source forms in the debugger. This has been broken for quite some time, but it works now.
@@ -56,6 +57,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
+ * #139 `*default-external-format*` defaults to `:utf-8`
* ~~#142~~ `(random 0)` signals incorrect error
* Other changes:
* Improvements to the PCL implementation of CLOS:
=====================================
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;
+}
=====================================
src/pcl/gray-streams.lisp
=====================================
@@ -235,6 +235,9 @@
defined for this function, although it is permissible for it to
always return NIL."))
+(defmethod stream-line-column ((stream fundamental-character-output-stream))
+ nil)
+
;;; Stream-line-length is a CMUCL extension to Gray streams.
(defgeneric stream-line-length (stream)
(:documentation _N"Return the stream line length or Nil."))
=====================================
tests/.gitignore
=====================================
@@ -0,0 +1 @@
+/out-utf8.txt
=====================================
tests/issues.lisp
=====================================
@@ -5,6 +5,12 @@
(in-package "ISSUES-TESTS")
+(defparameter *test-path*
+ (merge-pathnames (make-pathname :name :unspecific :type :unspecific
+ :version :unspecific)
+ *load-truename*)
+ "Path to where this file is.")
+
(defun square (x)
(expt x 2))
@@ -670,3 +676,72 @@
(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"))
+ (let ((unix::*filename-encoding* :utf-8))
+ ;; Set filename encoding to utf-8 so that we can encode the
+ ;; filename properly.
+ (assert-true
+ (file-author
+ (merge-pathnames
+ (concatenate 'string
+ ;; Write the test file name this way so
+ ;; that it's independent of the encoding
+ ;; used to load this file. The name is
+ ;; "안녕하십니까".
+ '(#\Hangul_Syllable_An #\Hangul_Syllable_Nyeong #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Sib #\Hangul_Syllable_Ni #\Hangul_Syllable_Gga)
+ ".txt")
+ *test-path*)))))
+
+(define-test issue.139-default-external-format
+ (:tag :issues)
+ (assert-eq :utf-8 stream:*default-external-format*))
+
+(define-test issue.139-default-external-format-read-file
+ (:tag :issues)
+ (let ((string (concatenate 'string
+ ;; This is "hello" in Korean
+ '(#\Hangul_syllable_an
+ #\Hangul_Syllable_Nyeong
+ #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Se
+ #\Hangul_Syllable_Yo))))
+ ;; Test that opening a file for reading uses the the default :utf8
+ ;; encoding.
+ (with-open-file (s (merge-pathnames "utf8.txt"
+ *test-path*)
+ :direction :input)
+ ;; The first line should be "hello" in Hangul.
+ (assert-equal (map 'list #'char-name string)
+ (map 'list #'char-name (read-line s))))))
+
+(define-test issue.139-default-external-format-write-file
+ (:tag :issues)
+ ;; Test that opening a file for writing uses the default :utf8.
+ ;; First write something out to the file. Then read it back in
+ ;; using an explicit format of utf8 and verifying that we got the
+ ;; right contents.
+ (let ((string (concatenate 'string
+ ;; This is "hello" in Korean
+ '(#\Hangul_syllable_an
+ #\Hangul_Syllable_Nyeong
+ #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Se
+ #\Hangul_Syllable_Yo))))
+ (with-open-file (s (merge-pathnames "out-utf8.txt"
+ *test-path*)
+ :direction :output
+ :if-exists :supersede)
+ (write-line string s))
+ (with-open-file (s (merge-pathnames "out-utf8.txt"
+ *test-path*)
+ :direction :input
+ :external-format :utf-8)
+ (assert-equal (map 'list #'char-name string)
+ (map 'list #'char-name (read-line s))))))
+
=====================================
tests/utf8.txt
=====================================
@@ -0,0 +1,2 @@
+안녕하세요
+UTF8 test. The above line is "Hello" in Hangul.
=====================================
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/b627c1e36a02140adc626495cb39a98adc8bc192...69f2a9909142a2e6d5b91db6853c956f6d16cb5b
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b627c1e36a02140adc626495cb39a98adc8bc192...69f2a9909142a2e6d5b91db6853c956f6d16cb5b
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20221031/2665bf42/attachment-0001.html>
More information about the cmucl-cvs
mailing list