Index: /trunk/source/level-1/linux-files.lisp =================================================================== --- /trunk/source/level-1/linux-files.lisp (revision 8342) +++ /trunk/source/level-1/linux-files.lisp (revision 8343) @@ -201,6 +201,9 @@ (cwd path)) +(defmacro with-filename-cstrs (&rest rest) + `(#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ,@rest)) + (defun %chdir (dirname) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname)) + (with-filename-cstrs ((dirname dirname)) (syscall syscalls::chdir dirname))) @@ -210,10 +213,10 @@ (when (and (> len 0) (eql (char name (1- len)) #\/)) (setq name (subseq name 0 (1- len)))) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) + (with-filename-cstrs ((name name)) (syscall syscalls::mkdir name mode)))) (defun %rmdir (name) (let* ((last (1- (length name)))) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) + (with-filename-cstrs ((name name)) (when (and (>= last 0) (eql (%get-byte name last) (char-code #\/))) @@ -269,10 +272,15 @@ (pref stat :stat.st_ino) (pref stat :stat.st_uid) - (pref stat :stat.st_blksize)) + (pref stat :stat.st_blksize) + #+linux-target + (pref stat :stat.st_mtim.tv_usec) + #-linux-target + (round (pref stat :stat.st_mtimespec.tv_nsec) 1000) + (pref stat :stat.st_gid)) (values nil nil nil nil nil nil nil))) (defun %%stat (name stat) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) + (with-filename-cstrs ((cname name)) (%stat-values #+linux-target @@ -291,5 +299,5 @@ (defun %%lstat (name stat) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) + (with-filename-cstrs ((cname name)) (%stat-values #+linux-target @@ -341,4 +349,45 @@ "unknown")) +(defun try-hard-to-get-errno (err) + (when (eq err -1) + (let ((nerr (%get-errno))) + (unless (eq nerr 0) (setq err nerr)))) + #+darwin-target + (when (eq err -1) + ;; Not thread safe, but what else can I do?? + (let ((nerr (pref (foreign-symbol-address "_errno") :signed))) + (unless (eq nerr 0) (setq err nerr)))) + err) + +(defun copy-file-attributes (source-path dest-path) + "Copy the mode, owner, group and modification time of source-path to dest-path. + Returns T if succeeded, NIL if some of the attributes couldn't be copied due to + permission problems. Any other failures cause an error to be signalled" + (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid) + (%stat (native-translated-namestring source-path) t) + (declare (ignore ignore)) + (unless win + (error "Cannot get attributes of ~s" source-path)) + (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path))) + (macrolet ((errchk (form) + `(let ((err ,form)) + (unless (eql err 0) + (setq win nil) + ;; We need the real errno so we can tell if it's a permission + ;; error or something else... + (when (eql err -1) + (setq err (try-hard-to-get-errno err))) + (unless (eql err #$EPERM) (%errno-disp err dest-path)))))) + (errchk (#_chmod cnamestr mode)) + (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2)))) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (record-length :timeval)) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (- (record-length :timeval))) + (#_utimes cnamestr times))) + (errchk (#_chown cnamestr uid gid)))) + win)) #+linux-target @@ -406,5 +455,5 @@ (setq namestring (current-directory-name))) (%stack-block ((resultbuf #$PATH_MAX)) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#)) + (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#)) (let* ((result (#_realpath name resultbuf))) (declare (dynamic-extent result)) @@ -477,5 +526,5 @@ (defun %utimes (namestring) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring)) + (with-filename-cstrs ((cnamestring namestring)) (let* ((err (#_utimes cnamestring (%null-ptr)))) (declare (fixnum err)) @@ -495,5 +544,5 @@ (defun %open-dir (namestring) - (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring)) + (with-filename-cstrs ((name namestring)) (let* ((DIR (#_opendir name))) (unless (%null-ptr-p DIR) Index: /trunk/source/lib/pathnames.lisp =================================================================== --- /trunk/source/lib/pathnames.lisp (revision 8342) +++ /trunk/source/lib/pathnames.lisp (revision 8343) @@ -110,24 +110,20 @@ (values new-name original (truename new-name)))))) - (defun copy-file (source-path dest-path &key (if-exists :error) (preserve-attributes nil)) (let* ((original (truename source-path)) - (original-namestring (native-translated-namestring original)) (new-name (merge-pathnames dest-path original)) - (new-namestring (native-translated-namestring new-name)) - (flags (if preserve-attributes "-pf" "-f"))) - (unless new-namestring - (error "~S can't be created." new-name)) - (unless (and (probe-file new-name) - (not (if-exists if-exists new-name))) - (let* ((proc (run-program "/bin/cp" - `(,flags ,original-namestring ,new-namestring) - :wait t)) - (exit-code (external-process-%exit-code proc))) - (unless (zerop exit-code) - (error "Error copying ~s to ~s: ~a" - source-path dest-path (%strerror exit-code))) - (values new-name original (truename new-name)))))) + (buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (in original :direction :input + :element-type '(unsigned-byte 8)) + (with-open-file (out new-name :direction :output + :if-exists if-exists + :element-type '(unsigned-byte 8)) + (loop + as n = (stream-read-vector in buffer 0 4096) until (eql n 0) + do (stream-write-vector out buffer 0 n)))) + (when preserve-attributes + (copy-file-attributes original new-name)) + (values new-name original (truename new-name)))) (defun recursive-copy-directory (source-path dest-path &key test (if-exists :error))