X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=impl.lisp;h=7135eb0e4ea1005b97aa420de3bf743bfe4574c6;hp=c2d7cabb84a3a36750374cf33aefa5d24ae36ae8;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=1738d41053dae41266d5740385be9aac03a864ad diff --git a/impl.lisp b/impl.lisp index c2d7cab..7135eb0 100644 --- a/impl.lisp +++ b/impl.lisp @@ -7,8 +7,6 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2003 ;;;; -;;;; $Id$ -;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; KMRCL users are granted the rights to distribute and use this software @@ -20,43 +18,56 @@ (defun canonicalize-directory-name (filename) (flet ((un-unspecific (value) - (if (eq value :unspecific) nil value))) + (if (eq value :unspecific) nil value))) (let* ((path (pathname filename)) - (name (un-unspecific (pathname-name path))) - (type (un-unspecific (pathname-type path))) - (new-dir - (cond ((and name type) (list (concatenate 'string name "." type))) - (name (list name)) - (type (list type)) - (t nil)))) + (name (un-unspecific (pathname-name path))) + (type (un-unspecific (pathname-type path))) + (new-dir + (cond ((and name type) (list (concatenate 'string name "." type))) + (name (list name)) + (type (list type)) + (t nil)))) (if new-dir - (make-pathname - :directory (append (un-unspecific (pathname-directory path)) - new-dir) - :name nil :type nil :version nil :defaults path) - path)))) - + (make-pathname + :directory (append (un-unspecific (pathname-directory path)) + new-dir) + :name nil :type nil :version nil :defaults path) + 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 + (let ((file-kind-fun + (or (find-symbol "NATIVE-FILE-KIND" :sb-impl) + (find-symbol "UNIX-FILE-KIND" :sb-unix)))) + (when (eq :directory (funcall file-kind-fun (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" (cond ((not (null dir)) (when (and (typep dir 'logical-pathname) - (translate-logical-pathname dir)) + (translate-logical-pathname dir)) (setq dir (translate-logical-pathname dir))) (when (stringp dir) (setq dir (parse-namestring dir))) @@ -71,16 +82,16 @@ (setq cl:*default-pathname-defaults* dir)) (t (let ((dir - #+allegro (excl:current-directory) - #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) - #+(or cmu scl) (ext:default-directory) - #+sbcl (sb-unix:posix-getcwd/) - #+cormanlisp (ccl:get-current-directory) - #+lispworks (hcl:get-working-directory) - #+mcl (ccl:mac-default-directory) - #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) + #+allegro (excl:current-directory) + #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) + #+(or cmu scl) (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd/) + #+cormanlisp (ccl:get-current-directory) + #+lispworks (hcl:get-working-directory) + #+mcl (ccl:mac-default-directory) + #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) (when (stringp dir) - (setq dir (parse-namestring dir))) + (setq dir (parse-namestring dir))) dir)))) @@ -105,20 +116,34 @@ #+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 + (declare (ignore verbose preserve-symbolic-links overwrite)) + (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)))))