From 893a993c727cd08afcdb7f87b1344d8e85042841 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 12 Nov 2006 09:20:19 +0000 Subject: [PATCH] 0.9.18.44: Patch from Zach Beane for sb-posix support for time, utime and utimes. --- NEWS | 4 ++- contrib/sb-posix/TODO | 4 +-- contrib/sb-posix/constants.lisp | 13 +++++++++ contrib/sb-posix/defpackage.lisp | 2 +- contrib/sb-posix/interface.lisp | 53 +++++++++++++++++++++++++++++++++++++ contrib/sb-posix/posix-tests.lisp | 43 ++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 116 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index eaf7403..ec9d5f4 100644 --- a/NEWS +++ b/NEWS @@ -11,7 +11,9 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18: * improvement: writes to CLOS instance slots are type-checked in code compiled with (SAFETY 3) * improvement: floating-point exception handling should work on all - POSIX platforms (thanks to NIIMI Satoshi) + POSIX platforms (thanks to NIIMI Satoshi) + * improvement: SB-POSIX supports time(2), utime(2) and utimes(2) + (thanks to Zach Beane) * bug fix: compiler bug triggered by a (non-standard) VALUES declaration in a LET* was fixed. (reported by Kaersten Poeck) * bug fix: file compiler no longer confuses validated and already diff --git a/contrib/sb-posix/TODO b/contrib/sb-posix/TODO index f28b5d5..0261a5a 100644 --- a/contrib/sb-posix/TODO +++ b/contrib/sb-posix/TODO @@ -28,8 +28,8 @@ settimeofday sgetmask shmat shmctl shmdt shmget shmop shutdown sigaction sigaltstack sigblock siggetmask sigmask signal sigpause sigpending sigprocmask sigreturn sigsetmask sigsuspend sigvec socket socketcall socketpair ssetmask statfs stime stty swapoff swapon -syscalls sysctl sysfs sysinfo syslog time times -ulimit umount uname ustat utime utimes vfork vhangup wait3 +syscalls sysctl sysfs sysinfo syslog times +ulimit umount uname ustat vfork vhangup wait3 wait4 write writev 4) In the spec but not implemented: diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index a040eba..cf5c767 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -6,6 +6,7 @@ (#||# "sys/types.h" "sys/stat.h" + #-win32 "utime.h" #-win32 "sys/socket.h" #-win32 "sys/un.h" #-win32 "netinet/in.h" @@ -349,6 +350,18 @@ (tcflag-t lflag "tcflag_t" "c_lflag") ((array cc-t) cc "cc_t" "c_cc"))) + ;; utime(), utimes() + #-win32 + (:structure alien-utimbuf + ("struct utimbuf" + (time-t actime "time_t" "actime") + (time-t modtime "time_t" "modtime"))) + #-win32 + (:structure alien-timeval + ("struct timeval" + (long sec "long" "tv_sec") + (long usec "long" "tv_usec"))) + (:integer veof "VEOF" nil t) (:integer veol "VEOL" nil t) (:integer verase "VERASE" nil t) diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index 6fc71ca..bf507d5 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -1,5 +1,5 @@ (defpackage :sb-posix (:use #:sb-alien #:cl) - (:shadow close open ftruncate truncate) + (:shadow close open ftruncate truncate time) (:export #:syscall-error #:syscall-errno ;; grovel structure accessors diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index f5cb4fb..a5c7ace 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -445,6 +445,59 @@ (function speed-t (* alien-termios))) a-termios)))) + +#-win32 +(progn + (export 'time :sb-posix) + (defun time () + (let ((result (alien-funcall (extern-alien "time" + (function time-t (* time-t))) + nil))) + (if (minusp result) + (syscall-error) + result))) + (export 'utime :sb-posix) + (defun utime (filename &optional access-time modification-time) + (let ((fun (extern-alien "utime" (function int c-string + (* alien-utimbuf)))) + (name (filename filename))) + (if (not (and access-time modification-time)) + (alien-funcall fun name nil) + (with-alien ((utimbuf (struct alien-utimbuf))) + (setf (slot utimbuf 'actime) (or access-time 0) + (slot utimbuf 'modtime) (or modification-time 0)) + (let ((result (alien-funcall fun name (alien-sap utimbuf)))) + (if (minusp result) + (syscall-error) + result)))))) + (export 'utimes :sb-posix) + (defun utimes (filename &optional access-time modification-time) + (flet ((seconds-and-useconds (time) + (multiple-value-bind (integer fractional) + (cl:truncate time) + (values integer (cl:truncate (* fractional 1000000))))) + (maybe-syscall-error (value) + (if (minusp value) + (syscall-error) + value))) + (let ((fun (extern-alien "utimes" (function int c-string + (* (array alien-timeval 2))))) + (name (filename filename))) + (if (not (and access-time modification-time)) + (maybe-syscall-error (alien-funcall fun name nil)) + (with-alien ((buf (array alien-timeval 2))) + (let ((actime (deref buf 0)) + (modtime (deref buf 1))) + (setf (values (slot actime 'sec) + (slot actime 'usec)) + (seconds-and-useconds (or access-time 0)) + (values (slot modtime 'sec) + (slot modtime 'usec)) + (seconds-and-useconds (or modification-time 0))) + (maybe-syscall-error (alien-funcall fun name + (alien-sap buf)))))))))) + + ;;; environment (export 'getenv :sb-posix) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 4e6e6c9..c228642 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -461,3 +461,46 @@ (setf termios (sb-posix:tcgetattr 0)) (= new (sb-posix:cfgetospeed termios)))) t) + + +#-win32 +(deftest time.1 + (plusp (sb-posix:time)) + t) + +#-win32 +(deftest utime.1 + (let ((file (merge-pathnames #p"utime.1" *test-directory*)) + (atime (random (1- (expt 2 31)))) + (mtime (random (1- (expt 2 31))))) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (princ "Hello, utime" stream)) + (sb-posix:utime file atime mtime) + (let* ((stat (sb-posix:stat file))) + (delete-file file) + (list (= (sb-posix:stat-atime stat) atime) + (= (sb-posix:stat-mtime stat) mtime)))) + (t t)) + +#-win32 +(deftest utimes.1 + (let ((file (merge-pathnames #p"utimes.1" *test-directory*)) + (atime (random (1- (expt 2 31)))) + (mtime (random (1- (expt 2 31))))) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (princ "Hello, utimes" stream)) + (sb-posix:utime file atime mtime) + (let* ((stat (sb-posix:stat file))) + (delete-file file) + (list (= (sb-posix:stat-atime stat) atime) + (= (sb-posix:stat-mtime stat) mtime)))) + (t t)) + + + diff --git a/version.lisp-expr b/version.lisp-expr index 225ea6c..4305478 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.18.43" +"0.9.18.44" -- 1.7.10.4