Skip to content
Snippets Groups Projects
filesys.lisp 42.2 KiB
Newer Older
ram's avatar
ram committed
    ;; 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))
      (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


;;;; Translating uid's and gid's.

(defvar *uid-hash-table* (make-hash-table)
  "Hash table for keeping track of uid's and login names.")

;;; LOOKUP-LOGIN-NAME translates a user id into a login name.  Previous
;;; lookups are cached in a hash table since groveling the passwd(s) files
;;; is somewhat expensive.  The table may hold nil for id's that cannot
;;; be looked up since this means the files are searched in their entirety
;;; each time this id is translated.
;;; 
(defun lookup-login-name (uid)
  (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
    (if foundp
	login-name
	(setf (gethash uid *uid-hash-table*)
	      (get-group-or-user-name :user uid)))))

(defvar *gid-hash-table* (make-hash-table)
  "Hash table for keeping track of gid's and group names.")

;;; LOOKUP-GROUP-NAME translates a group id into a group name.  Previous
;;; lookups are cached in a hash table since groveling the group(s) files
;;; is somewhat expensive.  The table may hold nil for id's that cannot
;;; be looked up since this means the files are searched in their entirety
;;; each time this id is translated.
;;; 
(defun lookup-group-name (gid)
  (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*)
    (if foundp
	group-name
	(setf (gethash gid *gid-hash-table*)
	      (get-group-or-user-name :group gid)))))


;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is
;;; a much smaller file, contains all the local id's, and most uses probably
;;; involve id's on machines one would login into.  Then if necessary, we look
;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be
;;; fetched over the net.
;;;
(defun get-group-or-user-name (group-or-user id)
  "Returns the simple-string user or group name of the user whose uid or gid
   is id, or NIL if no such user or group exists.  Group-or-user is either
   :group or :user."
  (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
    (declare (simple-string id-string))
    (multiple-value-bind (file1 file2)
			 (ecase group-or-user
			   (:group (values "/etc/group" "/etc/groups"))
			   (:user (values "/etc/passwd" "/etc/passwd")))
      (or (get-group-or-user-name-aux id-string file1)
	  (get-group-or-user-name-aux id-string file2)))))

(defun get-group-or-user-name-aux (id-string passwd-file)
  (with-open-file (stream passwd-file)
    (loop
      (let ((entry (read-line stream nil)))
	(unless entry (return nil))
	(let ((name-end (position #\: (the simple-string entry)
				  :test #'char=)))
	  (when name-end
	    (let ((id-start (position #\: (the simple-string entry)
				      :start (1+ name-end) :test #'char=)))
	      (when id-start
		(incf id-start)
		(let ((id-end (position #\: (the simple-string entry)
					:start id-start :test #'char=)))
		  (when (and id-end
			     (string= id-string entry
				      :start2 id-start :end2 id-end))
		    (return (subseq entry 0 name-end))))))))))))


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)
ram's avatar
ram committed
    (if gr
	(let ((*ignore-wildcards* t))
	  (pathname (concatenate 'simple-string dir-or-error "/")))
	(error dir-or-error))))
ram's avatar
ram committed

;;; %Set-Default-Directory  --  Internal
;;; 
(defun %set-default-directory (new-val)
  (let ((namestring (unix-namestring new-val t)))
    (unless namestring
      (error "~S doesn't exist." 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 ()
  (setf *default-pathname-defaults*
	(%make-pathname *unix-host* nil nil nil nil :newest))
  (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))))
		    (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)
				 :pathname pathspec
				 :format-control "Can't create directory ~A."
				 :format-arguments (list namestring)))
			(setf created-p t)))))
	 ;; Only the first path in a search-list is considered.
	 (return (values pathname created-p))))))