Skip to content
Snippets Groups Projects
filesys.lisp 35.3 KiB
Newer Older
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)))))