Skip to content
Snippets Groups Projects
filesys.lisp 49 KiB
Newer Older
ram's avatar
ram committed

;;; User-Homedir-Pathname  --  Public
;;;
;;;    Return Home:, which is set up for us at initialization time.
ram's avatar
ram committed
;;;
(defun user-homedir-pathname (&optional host)
  "Returns the home directory of the logged in user as a pathname.
  This is obtained from the logical name \"home:\"."
ram's avatar
ram committed
  (declare (ignore host))
ram's avatar
ram committed

;;; File-Write-Date  --  Public
;;;
(defun file-write-date (file)
  "Return file's creation date, or NIL if it doesn't exist.
toy's avatar
toy committed
 An error of type file-error is signalled if file is a wild pathname"
  (if (wild-pathname-p file)
	     :pathname file
	     :format-control "Bad place for a wild pathname.")
      (let ((name (unix-namestring file t)))
	(when name
	  (multiple-value-bind
	      (res dev ino mode nlink uid gid rdev size atime mtime)
	      (unix:unix-stat name)
	    (declare (ignore dev ino mode nlink uid gid rdev size atime))
	    (when res
	      (+ unix-to-universal-time mtime)))))))
ram's avatar
ram committed

;;; File-Author  --  Public
;;;
(defun file-author (file)
  "Returns the file author as a string, or nil if the author cannot be
 determined.  Signals an error of type file-error if file doesn't exist,
 or file is a wild pathname."
  (if (wild-pathname-p file)
	     :format-control "Bad place for a wild pathname.")
      (let ((name (unix-namestring (pathname file) t)))
	(unless name
		 :pathname file
		 :format-control "~S doesn't exist."
		 :format-arguments (list file)))
	(multiple-value-bind (winp dev ino mode nlink uid)
			     (unix:unix-stat name)
	  (declare (ignore dev ino mode nlink))
toy's avatar
toy committed
	  (when winp
            (let ((user-info (unix:unix-getpwuid uid)))
              (when user-info
                (unix:user-info-name user-info))))))))
ram's avatar
ram committed


;;;; DIRECTORY.

toy's avatar
toy committed
;;;
(defun directory (pathname &key (all t) (check-for-subdirs t)
			   (truenamep t) (follow-links t))
ram's avatar
ram committed
  "Returns a list of pathnames, one for each file that matches the given
   pathname.  Supplying :ALL as nil causes this to ignore Unix dot files.  This
   never includes Unix dot and dot-dot in the result.  If :TRUENAMEP is NIL,
toy's avatar
toy committed
   then symbolic links in the result are not expanded, which is not the
   default because TRUENAME does follow links and the result pathnames are
   defined to be the TRUENAME of the pathname (the truename of a link may well
toy's avatar
toy committed
   be in another directory).  If FOLLOW-LINKS is NIL then symbolic links are
  (let ((results nil))
    (enumerate-search-list
	(pathname (merge-pathnames pathname
				   (make-pathname :name :wild
						  :type :wild
						  :version :wild
						  :defaults *default-pathname-defaults*)
      (enumerate-matches (name pathname nil :follow-links follow-links)
	(when (or all
		  (let ((slash (position #\/ name :from-end t)))
		    (or (null slash)
			(= (1+ slash) (length name))
			(char/= (schar name (1+ slash)) #\.))))
	  (push name results))))
    (let ((*ignore-wildcards* t))
      (mapcar #'(lambda (name)
		  (let ((name (if (and check-for-subdirs
				       (eq (unix:unix-file-kind name)
					   :directory))
				  (concatenate 'string name "/")
				  name)))
		    (if truenamep (truename name) (pathname name))))
	      (sort (delete-duplicates results :test #'string=) #'string<)))))
ram's avatar
ram committed


ram's avatar
ram committed
;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
;;; 
(defun print-directory (pathname &optional stream &key all verbose return-list)
toy's avatar
toy committed
  "Like Directory, but prints a terse, multi-column directory listing
ram's avatar
ram committed
   instead of returning a list of pathnames.  When :all is supplied and
toy's avatar
toy committed
   non-nil, then Unix dot files are included too (as ls -a).  When :verbose
ram's avatar
ram committed
   is supplied and non-nil, then a long listing of miscellaneous
   information is output one file per line."
  (let ((*standard-output* (out-synonym-of stream))
ram's avatar
ram committed
    (if verbose
	(print-directory-verbose pathname all return-list)
	(print-directory-formatted pathname all return-list))))

(defun print-directory-verbose (pathname all return-list)
  (let ((contents (directory pathname :all all :check-for-subdirs nil
toy's avatar
toy committed
    (format t "Directory of ~A:~%" (namestring pathname))
    (dolist (file contents)
      (let* ((namestring (unix-namestring file))
	     (tail (subseq namestring
			   (1+ (or (position #\/ namestring
					     :from-end t
					     :test #'char=)
				   -1)))))
	(multiple-value-bind 
	    (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
	    (unix:unix-stat namestring)
	  (declare (ignore ino gid rdev atime)
		   (fixnum uid mode))
	  (cond (reslt
		 ;;
		 ;; Print characters for file modes.
		 (macrolet ((frob (bit name &optional sbit sname negate)
			      `(if ,(if negate
					`(not (logbitp ,bit mode))
					`(logbitp ,bit mode))
				   ,(if sbit
					`(if (logbitp ,sbit mode)
					     (write-char ,sname)
					     (write-char ,name))
					`(write-char ,name))
				   (write-char #\-))))
		   (frob 15 #\d nil nil t)
		   (frob 8 #\r)
		   (frob 7 #\w)
		   (frob 6 #\x 11 #\s)
		   (frob 5 #\r)
		   (frob 4 #\w)
		   (frob 3 #\x 10 #\s)
		   (frob 2 #\r)
		   (frob 1 #\w)
		   (frob 0 #\x))
		 ;;
		 ;; Print the rest.
		 (multiple-value-bind (sec min hour date month year)
				      (get-decoded-time)
		   (declare (ignore sec min hour date month))
		   (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
			   nlink
toy's avatar
toy committed
                           (let ((user-info (unix:unix-getpwuid uid)))
                             (if user-info (unix:user-info-name user-info) uid))
			   size
			   (decode-universal-time-for-files mtime year)
			   tail
			   (= (logand mode unix:s-ifmt) unix:s-ifdir))))
		(t (format t "Couldn't stat ~A -- ~A.~%"
			   tail
			   (unix:get-unix-error-msg dev-or-err))))
ram's avatar
ram committed
	  (when return-list
	    (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
		      (pathname (concatenate 'string namestring "/"))
		      file)
		  result)))))
    (nreverse result)))
ram's avatar
ram committed

(defun decode-universal-time-for-files (time current-year)
  (multiple-value-bind (sec min hour day month year)
		       (decode-universal-time (+ time unix-to-universal-time))
    (declare (ignore sec))
    (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
	    (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
		      "Sep" "Oct" "Nov" "Dec")
		   (1- month))
	    day (= current-year year) year hour min)))

(defun print-directory-formatted (pathname all return-list)
  (let ((width (or (line-length *standard-output*) 80))
	(names ())
	(cnt 0)
	(max-len 0)
	(result (directory pathname :all all :truenamep nil)))
ram's avatar
ram committed
    (declare (list names) (fixnum max-len cnt))
    ;;
    ;; Get the data.
    (dolist (file result)
      (let* ((name (unix-namestring file))
	     (length (length name))
	     (end (if (and (plusp length)
			   (char= (schar name (1- length)) #\/))
		      (1- length)
		      length))
	     (slash-name (subseq name
				 (1+ (or (position #\/ name
						   :from-end t
						   :end end
						   :test #'char=)
					 -1))))
	     (len (length slash-name)))
	(declare (simple-string slash-name)
		 (fixnum len))
	(if (> len max-len) (setq max-len len))
	(incf cnt)
	(push slash-name names)))
    (setq names (nreverse names))
    ;;
    ;; Do the output.
    (let* ((col-width (1+ max-len))
	   (cols (max (truncate width col-width) 1))
	   (lines (ceiling cnt cols)))
      (declare (fixnum cols lines))
toy's avatar
toy committed
      (format t "Directory of ~A:~%" (namestring pathname))
      (dotimes (i lines)
	(declare (fixnum i))
	(dotimes (j cols)
	  (declare (fixnum j))
	  (let ((name (nth (+ i (the fixnum (* j lines))) names)))
	    (when name
	      (write-string name)
	      (unless (eql j (1- cols))
		(dotimes (i (- col-width (length (the simple-string name))))
		  (write-char #\space))))))
	(terpri)))
    (when return-list
      result)))

ram's avatar
ram committed

chiles's avatar
 
chiles committed
;;; COMPLETE-FILE -- Public
;;;
(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
			       ignore-types)
  (let ((files (directory (complete-file-directory-arg pathname defaults)
    (cond ((null files)
	   (values nil nil))
	  ((null (cdr files))
	   (values (merge-pathnames (file-namestring (car files))
				    pathname)
		   t))
	  (t
	   (let ((good-files
		  (delete-if #'(lambda (pathname)
				 (and (simple-string-p
				       (pathname-type pathname))
				      (member (pathname-type pathname)
					      ignore-types
					      :test #'string=)))
			     files)))
	     (cond ((null good-files))
		   ((null (cdr good-files))
		    (return-from complete-file
				 (values (merge-pathnames (file-namestring
							   (car good-files))
							  pathname)
					 t)))
		   (t
		    (setf files good-files)))
	     (let ((common (file-namestring (car files))))
	       (dolist (file (cdr files))
		 (let ((name (file-namestring file)))
		   (dotimes (i (min (length common) (length name))
			       (when (< (length name) (length common))
				 (setf common name)))
		     (unless (char= (schar common i) (schar name i))
		       (setf common (subseq common 0 i))
		       (return)))))
	       (values (merge-pathnames common pathname)
		       nil)))))))

chiles's avatar
 
chiles committed
;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
;;;
(defun complete-file-directory-arg (pathname defaults)
  (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
	 (type (pathname-type pathname)))
    (flet ((append-multi-char-wild (thing)
	     (etypecase thing
	       (null :wild)
	       (pattern
		(make-pattern (append (pattern-pieces thing)
				      (list :multi-char-wild))))
	       (simple-string
		(make-pattern (list thing :multi-char-wild))))))
      (if (or (null type) (eq type :unspecific))
	  ;; There is no type.
	  (make-pathname :defaults pathname
	    :name (append-multi-char-wild (pathname-name pathname))
	    :type :wild)
	  ;; There already is a type, so just extend it.
	  (make-pathname :defaults pathname
	    :name (pathname-name pathname)
	    :type (append-multi-char-wild (pathname-type pathname)))))))
chiles's avatar
 
chiles committed

;;; Ambiguous-Files  --  Public
ram's avatar
ram committed
;;;
(defun ambiguous-files (pathname
			&optional (defaults *default-pathname-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 (complete-file-directory-arg pathname defaults)
ram's avatar
ram committed

;;; File-writable -- exported from extensions.
;;;
;;;   Determines whether the single argument (which should be a pathname)
dtc's avatar
dtc committed
;;;   can be written by the current task.
ram's avatar
ram committed
(defun file-writable (name)
  "File-writable accepts a pathname and returns T if the current
  process can write it, and NIL otherwise."
  (let ((name (unix-namestring name nil)))
	  ((unix:unix-file-kind name)
	   (values (unix:unix-access name unix:w_ok)))
	    (unix:unix-access (subseq name
				      0
				      (or (position #\/ name :from-end t)
					  0))
			      (logior unix:w_ok unix: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
;;;
(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)
                       (unix:unix-current-directory)
    (if gr
        (let ((*ignore-wildcards* t))
          (values
           (parse-namestring (concatenate 'simple-string dir-or-error "/")
                             *unix-host*)))
        (error dir-or-error))))
;;;
;;; XXXX This code was modified by me (fmg) to avoid calling
;;; concatenate.  The reason for this is that there have been
;;; intermittent instabilities (segv on startup) when the function
;;; environment-init (in save.lisp) is called.  Apparently the type
;;; system is not completely sorted out at the time this function is
;;; first called.  As a result, strange, not completely reproducable
;;; things happen, related to something in the state of the
;;; environment (e.g. the paths or the user environment variables or
;;; something).  These errors occur in the course of calling
;;; default-directory and the backtrace indicates they occur in the
;;; context of the type system.  Since I haven't been able to figure
;;; out why they happen, I decided to punt.
;;;
;;; Hopefully someone will really fix the problem someday.
;;;
;;; Seems like maybe it's fixed by changes made by Ray Toy to avoid heap corruption.
#- (and)
ram's avatar
ram committed
(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)
		       (unix:unix-current-directory)
ram's avatar
ram committed
    (if gr
	(let ((*ignore-wildcards* t)
	      (string (make-string (1+ (length dir-or-error)) :initial-element #\/)))
	   (parse-namestring (replace string dir-or-error) *unix-host*)))
	(error dir-or-error))))
ram's avatar
ram committed

ram's avatar
ram committed
;;; %Set-Default-Directory  --  Internal
;;; 
(defun %set-default-directory (new-val)
  (let ((namestring (unix-namestring new-val t)))
    (unless namestring
toy's avatar
toy committed
      (error 'simple-file-error
             :format-control "~S doesn't exist."
             :format-arguments (list new-val)))
    (multiple-value-bind (gr error)
			 (unix:unix-chdir namestring)
      (if gr
	  (setf (search-list "default:") (default-directory))
	  (error (unix:get-unix-error-msg error))))
;;;
(defsetf default-directory %set-default-directory)

(defun filesys-init ()
  ;; Use :unspecific so we don't create file versions whenever merging
  ;; happens.  If the user wants that, let him change
  ;; *default-pathname-defaults* appropriately.
  (setf *default-pathname-defaults*
	(%make-pathname *unix-host* nil nil nil nil :unspecific))
  (setf (search-list "default:") (default-directory))
  nil)

;;; Ensure-Directories-Exist  --  Public
;;;
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
  "Tests whether the directories containing the specified file
  actually exist, and attempts to create them if they do not.
  Portable programs should avoid using the :MODE keyword argument."
  (let* ((pathname (pathname pathspec))
	 (pathname (if (logical-pathname-p pathname)
		       (translate-logical-pathname pathname)
		       pathname))
	 (created-p nil))
    (when (wild-pathname-p pathname)
	     :format-control "Bad place for a wild pathname."
	     :pathname pathspec))
    (enumerate-search-list (pathname pathname)
       (let ((dir (pathname-directory pathname)))
	 (loop for i from 1 upto (length dir)
	       do (let ((newpath (make-pathname
				  :host (pathname-host pathname)
				  :device (pathname-device pathname)
				  :directory (subseq dir 0 i))))
		    (tagbody
		     retry
		       (restart-case
			   (unless (probe-file newpath)
			     (let ((namestring (namestring newpath)))
			       (when verbose
				 (format *standard-output* "~&Creating directory: ~A~%"
					 namestring))
			       (unix:unix-mkdir namestring mode)
			       (unless (probe-file namestring)
				 (error 'simple-file-error
					:pathname pathspec
					:format-control "Can't create directory ~A."
					:format-arguments (list namestring)))
			       (setf created-p t)))
			 (retry () :report "Try to create the directory again"
				(go retry))))))
	 ;; Only the first path in a search-list is considered.
	 (return (values pathname created-p))))))