dev/copy-file.lisp

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