external/lift.darcs/dev/copy-file.lisp

   1 ;;;;
   2 ;;; directly pullled from metatilities, sigh
   3
   4 (in-package #:lift)
   5 ;(in-package #:metatilities)
   6
   7 (define-condition source/target-file-error (file-error)
   8                   ((pathname :reader source-pathname
   9                              :initarg :source-pathname)
  10                    (target-pathname :reader target-pathname
  11                                     :initarg :target-pathname :initform nil))
  12   (:report (lambda (c s)
  13              (format s "Copy of ~S to ~S failed"
  14                      (source-pathname c) (target-pathname c))))
  15   (:documentation "General condition for file errors that have a source and target."))
  16
  17 (define-condition source/target-target-already-exists-error (source/target-file-error)
  18                   ()
  19   (:report (lambda (c s)
  20              (format s "File action failed because target ~S already exists"
  21                      (target-pathname c))))
  22   (:documentation "This error is signaled when the target pathname already exists."))
  23
  24 (define-condition source/target-source-does-not-exist-error
  25     (source/target-file-error)
  26                   ()
  27   (:report (lambda (c s)
  28              (format s "File action failed because source ~S does not exist"
  29                      (source-pathname c))))
  30   (:documentation "This error is signaled when the source file does not exist."))
  31
  32 (defun copy-file (from to &key (if-does-not-exist :error)
  33                        (if-exists :error))
  34   "Copies the file designated by the non-wild pathname designator FROM
  35 to the file designated by the non-wild pathname designator TO. The following
  36 keyword parameters are supported:
  37
  38 * :if-exists
  39     this can be either :supersede or :error (the default). If it is :error then
  40 a source/target-target-already-exists-error will be signaled if the file designated
  41 by the TO pathname already exists.
  42
  43 * :if-does-not-exist
  44     this can be either :ignore or :error (the default). If it is :error then
  45 a source/target-source-does-not-exist-error will be signaled if the FROM pathname
  46 designator does not exist.
  47 "
  48   (assert (member if-exists '(:error :supersede))
  49           nil
  50           "The if-exists keyword parameter must be one of :error or :supersede. It is currently set to ~S"
  51           if-exists)
  52   (assert (member if-does-not-exist '(:error :ignore))
  53           nil
  54           "The if-does-not-exist keyword parameter must be one of :error or :ignore. It is currently set to ~S"
  55           if-does-not-exist)
  56   (ensure-directories-exist to)
  57   (cond ((probe-file from)
  58          #+:allegro
  59          (excl.osi:copy-file
  60           from to
  61           :overwrite (if (eq if-exists :supersede) :ignore nil))
  62          #-:allegro
  63          (let ((element-type #-:cormanlisp '(unsigned-byte 8)
  64                              #+:cormanlisp 'unsigned-byte))
  65            (with-open-file (in from :element-type element-type)
  66              (with-open-file (out to :element-type element-type
  67                                   :direction :output
  68                                   :if-exists if-exists)
  69                (unless out
  70                  (error (make-condition 'source/target-target-already-exists
  71                                         :pathname from
  72                                         :target-pathname to)))
  73                (copy-stream in out))))
  74          (values t))
  75         (t
  76          ;; no source file!
  77          (ecase if-does-not-exist
  78            ((:error) (error 'source/target-source-does-not-exist-error
  79                             :pathname from :target-pathname to))
  80            ((:ignore) nil)))))
  81
  82 (defun move-file (from to &rest args &key (if-does-not-exist :error)
  83                   (if-exists :error))
  84   (declare (dynamic-extent args)
  85            (ignore if-exists if-does-not-exist))
  86   (when (apply #'copy-file from to args)
  87     (delete-file from)))
  88
  89 ;;; borrowed from asdf-install -- how did this ever work ?!
  90 ;; for non-SBCL we just steal this from SB-EXECUTABLE
  91 #-(or :digitool)
  92 (defvar *stream-buffer-size* 8192)
  93 #-(or :digitool)
  94 (defun copy-stream (from to)
  95   "Copy into TO from FROM until end of the input stream, in blocks of
  96 *stream-buffer-size*.  The streams should have the same element type."
  97   (unless (subtypep (stream-element-type to) (stream-element-type from))
  98     (error "Incompatible streams ~A and ~A." from to))
  99   (let ((buf (make-array *stream-buffer-size*
 100                          :element-type (stream-element-type from))))
 101     (loop
 102       (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
 103                  #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
 104                  #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
 105         (when (zerop pos) (return))
 106         (write-sequence buf to :end pos)))))
 107
 108 #+:digitool
 109 (defun copy-stream (from to)
 110   "Perform copy and map EOL mode."
 111   (multiple-value-bind (reader reader-arg) (ccl::stream-reader from)
 112     (multiple-value-bind (writer writer-arg) (ccl::stream-writer to)
 113       (let ((datum nil))
 114         (loop (unless (setf datum (funcall reader reader-arg))
 115                 (return))
 116               (funcall writer writer-arg datum))))))
 117