;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Sep 2003
;;;;
-;;;; $Id: io.lisp 7795 2003-09-10 05:44:47Z kevin $
+;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
path))))
-(defun probe-directory (filename)
- (let ((path (canonicalize-directory-name filename)))
- #+allegro (excl:probe-directory path)
- #+clisp (values
- (ignore-errors
- (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
- path)))
- #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
- #+lispworks (lw:file-directory-p path)
- #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
- #-(or allegro clisp cmu lispworks sbcl scl)
- (probe-file path)))
-
+(defun probe-directory (filename &key (error-if-does-not-exist nil))
+ (let* ((path (canonicalize-directory-name filename))
+ (probe
+ #+allegro (excl:probe-directory path)
+ #+clisp (values
+ (ignore-errors
+ (#+lisp=cl ext:probe-directory
+ #-lisp=cl lisp:probe-directory
+ path)))
+ #+(or cmu scl) (when (eq :directory
+ (unix:unix-file-kind (namestring path)))
+ path)
+ #+lispworks (when (lw:file-directory-p path)
+ path)
+ #+sbcl (when (eq :directory
+ (sb-unix:unix-file-kind (namestring path)))
+ path)
+ #-(or allegro clisp cmu lispworks sbcl scl)
+ (probe-file path)))
+ (if probe
+ probe
+ (when error-if-does-not-exist
+ (error "Directory ~A does not exist." filename)))))
(defun cwd (&optional dir)
"Change directory and set default pathname"
#+sbcl sb-ext:*posix-argv*
)
-(defun shell-command-output (cmd &key directory whole)
- #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
- #+sbcl
- (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
- :adjustable t))
- (err (make-array '(0) :element-type 'base-char :fill-pointer 0
- :adjustable t))
- (status
- (sb-impl::process-exit-code
- (with-output-to-string (out-stream out)
- (with-output-to-string (err-stream err)
- (sb-ext:run-program
- "/bin/sh"
- (list "-c" cmd)
- :input nil :output out-stream :error err-stream))))))
- (values out err status))
- )
+(defun copy-file (from to &key link overwrite preserve-symbolic-links
+ (preserve-time t) remove-destination force verbose)
+ #+allegro (sys:copy-file from to :link link :overwrite overwrite
+ :preserve-symbolic-links preserve-symbolic-links
+ :preserve-time preserve-time
+ :remove-destination remove-destination
+ :force force :verbose verbose)
+ #-allegro
+ (cond
+ ((and (typep from 'stream) (typep to 'stream))
+ (copy-binary-stream from to))
+ ((not (probe-file from))
+ (error "File ~A does not exist." from))
+ ((eq link :hard)
+ (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
+ (link
+ (multiple-value-bind (stdout stderr status)
+ (command-output "ln -f ~A ~A" (namestring from) (namestring to))
+ (declare (ignore stdout stderr))
+ ;; try symbolic if command failed
+ (unless (zerop status)
+ (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
+ (t
+ (when (and (or force remove-destination) (probe-file to))
+ (delete-file to))
+ (let* ((options (if preserve-time
+ "-p"
+ ""))
+ (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
+ (run-shell-command cmd)))))