Changeset 8343

Timestamp:

Jan 28, 2008, 4:49:47 PM (17 years ago)

Author:

gz

Message:

implement copy-file directly (rather than by run-program), add copy-file-attributes

Location:

trunk/source

Files:

• level-1/linux-files.lisp (modified) (8 diffs)
• lib/pathnames.lisp (modified) (1 diff)

trunk/source/level-1/linux-files.lisp

@@ -201 +201 @@
   (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 +213 @@
     (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 +272 @@
        (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 +299 @@
 
 (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 +349 @@
     "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 +455 @@
     (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 +526 @@
 
 (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 +544 @@
 
 (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)

trunk/source/lib/pathnames.lisp

@@ -110 +110 @@
         (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))