Skip to content
Snippets Groups Projects
filesys.lisp 36.3 KiB
Newer Older
chiles's avatar
 
chiles committed
		     :directory (concatenate 'simple-vector
					     (pathname-directory defaults)
					     (pathname-directory pathname))
		     :name (or (pathname-name pathname) (pathname-name defaults))
		     :type (or (pathname-type pathname)
			       (pathname-type defaults))))
		   (t
		    ;; This branch should never fire, but just in case ...
		    (merge-pathnames pathname defaults))))
		 "*")))

;;; Ambiguous-Files  --  Public
ram's avatar
ram committed
;;;
(defun ambiguous-files (pathname &optional defaults)
  "Return a list of all files which are possible completions of Pathname.
chiles's avatar
 
chiles committed
   We look in the directory specified by Defaults as well as looking down
   the search list."
  (directory (concatenate 'string
			  (namestring
			   (merge-pathnames pathname
					    (make-pathname :defaults defaults
							   :name nil
							   :type nil)))
			  "*")))
ram's avatar
ram committed

;;; File-writable -- exported from extensions.
;;;
;;;   Determines whether the single argument (which should be a pathname)
;;;   can be written by the the current task.

(defun file-writable (name)
  "File-writable accepts a pathname and returns T if the current
  process can write it, and NIL otherwise."
  (let ((truename (probe-file name)))
    (values
     (mach:unix-access
      (unix-namestring (or truename (directory-namestring name)) t)
      (if truename mach:w_ok (logior mach:w_ok mach:x_ok))))))
ram's avatar
ram committed


;;; Pathname-Order  --  Internal
;;;
;;;    Predicate to order pathnames by.  Goes by name.
;;;
(defun pathname-order (x y)
  (let ((xn (%pathname-name x))
	(yn (%pathname-name y)))
    (if (and xn yn)
	(let ((res (string-lessp xn yn)))
	  (cond ((not res) nil)
		((= res (length (the simple-string xn))) t)
		((= res (length (the simple-string yn))) nil)
		(t t)))
	xn)))


;;; Default-Directory  --  Public
;;;
;;;    This fills in a hole in Common Lisp.  We return the first thing we
;;; find by doing a ResolveSearchList on Default.
;;; 
(defun default-directory ()
  "Returns the pathname for the default directory.  This is the place where
  a file will be written if no directory is specified.  This may be changed
  with setf."
  (multiple-value-bind (gr dir-or-error)
		       (mach:unix-current-directory)
    (if gr
	(pathname (concatenate 'simple-string dir-or-error "/"))
	(error dir-or-error))))
ram's avatar
ram committed

;;;
;;; Maybe this shouldn't go here...
(defsetf default-directory %set-default-directory)

;;; %Set-Default-Directory  --  Internal
;;;
;;;    The setf method for Default-Directory.  We actually set the environment
;;; variable Current which is by convention the head of the search list.
;;; 
(defun %set-default-directory (new-val)
  (multiple-value-bind (gr error)
		       (mach:unix-chdir (unix-namestring new-val t))
ram's avatar
ram committed
    (if gr
	(car (setf (search-list "default:")
		   (list (default-directory))))
ram's avatar
ram committed
	(error (mach:get-unix-error-msg error)))))