Skip to content
Snippets Groups Projects
filesys.lisp 35.5 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Log: code.log; Package: Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.22 1991/12/18 23:15:38 wlott Exp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; File system interface functions.  This file is pretty UNIX specific.
ram's avatar
ram committed
;;;
;;; Written by William Lott
ram's avatar
ram committed
;;;
;;; **********************************************************************
(export '(truename probe-file user-homedir-pathname directory
          rename-file delete-file file-write-date file-author))
ram's avatar
ram committed

(use-package "EXTENSIONS")

(in-package "EXTENSIONS")
(export '(print-directory complete-file ambiguous-files default-directory
			  file-writable unix-namestring))
ram's avatar
ram committed

;;;; Unix pathname host support.
ram's avatar
ram committed

;;; Unix namestrings have the following format:
ram's avatar
ram committed
;;;
;;; namestring := [ directory ] [ file [ type [ version ]]]
;;; directory := [ "/" | search-list ] { file "/" }*
;;; search-list := [^:/]*:
;;; file := [^/]*
;;; type := "." [^/.]*
;;; version := "." ([0-9]+ | "*")
ram's avatar
ram committed
;;;
;;; Note: this grammer is ambiguous.  The string foo.bar.5 can be parsed
;;; as either just the file specified or as specifying the file, type, and
;;; version.  Therefore, we use the following rules when confronted with
;;; an ambiguous file.type.version string:
ram's avatar
ram committed
;;;
;;; - If the first character is a dot, it's part of the file.  It is not
;;; considered a dot in the following rules.
ram's avatar
ram committed
;;;
;;; - If there is only one dot, it seperates the file and the type.
;;;
;;; - If there are multiple dots and the stuff following the last dot
;;; is a valid version, then that is the version and the stuff between
;;; the second to last dot and the last dot is the type.
;;;
;;; Wildcard characters:
;;;
;;; If the directory, file, type components contain any of the following
;;; characters, it is considered part of a wildcard pattern and has the
;;; following meaning.
;;;
;;; ? - matches any character
;;; * - matches any zero or more characters.
;;; [abc] - matches any of a, b, or c.
;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
;;;
;;; Any of these special characters can be preceeded by a backslash to
;;; cause it to be treated as a regular character.
ram's avatar
ram committed
;;;

72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
(defun remove-backslashes (namestr start end)
  "Remove and occurences of \\ from the string because we've already
   checked for whatever they may have been backslashed."
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let* ((result (make-string (- end start)))
	 (dst 0)
	 (quoted nil))
    (do ((src start (1+ src)))
	((= src end))
      (cond (quoted
	     (setf (schar result dst) (schar namestr src))
	     (setf quoted nil)
	     (incf dst))
	    (t
	     (let ((char (schar namestr src)))
	       (cond ((char= char #\\)
		      (setq quoted t))
		     (t
		      (setf (schar result dst) char)
		      (incf dst)))))))
    (when quoted
      (error 'namestring-parse-error
	     :complaint "Backslash in bad place."
	     :namestring namestr
	     :offset (1- end)))
    (shrink-vector result dst)))

(defvar *ignore-wildcards* nil)

(defun maybe-make-pattern (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (if *ignore-wildcards*
      (subseq namestr start end)
      (collect ((pattern))
	(let ((quoted nil)
	      (any-quotes nil)
	      (last-regular-char nil)
	      (index start))
	  (flet ((flush-pending-regulars ()
		   (when last-regular-char
		     (pattern (if any-quotes
				  (remove-backslashes namestr
						      last-regular-char
						      index)
				  (subseq namestr last-regular-char index)))
		     (setf any-quotes nil)
		     (setf last-regular-char nil))))
	    (loop
	      (when (>= index end)
		(return))
	      (let ((char (schar namestr index)))
		(cond (quoted
		       (incf index)
		       (setf quoted nil))
		      ((char= char #\\)
		       (setf quoted t)
		       (setf any-quotes t)
		       (unless last-regular-char
			 (setf last-regular-char index))
		       (incf index))
		      ((char= char #\?)
		       (flush-pending-regulars)
		       (pattern :single-char-wild)
		       (incf index))
		      ((char= char #\*)
		       (flush-pending-regulars)
		       (pattern :multi-char-wild)
		       (incf index))
		      ((char= char #\[)
		       (flush-pending-regulars)
		       (let ((close-bracket
			      (position #\] namestr :start index :end end)))
			 (unless close-bracket
			   (error 'namestring-parse-error
				  :complaint "``['' with no corresponding ``]''"
				  :namestring namestr
				  :offset index))
			 (pattern (list :character-set
					(subseq namestr
						(1+ index)
						close-bracket)))
			 (setf index (1+ close-bracket))))
		      (t
		       (unless last-regular-char
			 (setf last-regular-char index))
		       (incf index)))))
	    (flush-pending-regulars)))
	(cond ((null (pattern))
	       "")
	      ((and (null (cdr (pattern)))
		    (simple-string-p (car (pattern))))
	       (car (pattern)))
	      (t
	       (make-pattern (pattern)))))))

(defun extract-name-type-and-version (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
			     :from-end t))
	 (second-to-last-dot (and last-dot
				  (position #\. namestr :start (1+ start)
					    :end last-dot :from-end t)))
	 (version :newest))
    ;; If there is a second-to-last dot, check to see if there is a valid
    ;; version after the last dot.
    (when second-to-last-dot
      (cond ((and (= (+ last-dot 2) end)
		  (char= (schar namestr (1+ last-dot)) #\*))
	     (setf version :wild))
	    ((and (< (1+ last-dot) end)
		  (do ((index (1+ last-dot) (1+ index)))
		      ((= index end) t)
		    (unless (char<= #\0 (schar namestr index) #\9)
		      (return nil))))
	     (setf version
		   (parse-integer namestr :start (1+ last-dot) :end end)))
	    (t
	     (setf second-to-last-dot nil))))
    (cond (second-to-last-dot
	   (values (maybe-make-pattern namestr start second-to-last-dot)
		   (maybe-make-pattern namestr
				       (1+ second-to-last-dot)
				       last-dot)
		   version))
	  (last-dot
	   (values (maybe-make-pattern namestr start last-dot)
		   (maybe-make-pattern namestr (1+ last-dot) end)
		   version))
	  (t
	   (values (maybe-make-pattern namestr start end)
		   nil
		   version)))))

(defun split-at-slashes (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let ((absolute (and (/= start end)
		       (char= (schar namestr start) #\/))))
    (when absolute
      (incf start))
    ;; Next, split the remainder into slash seperated chunks.
    (collect ((pieces))
      (loop
	(let ((slash (position #\/ namestr :start start :end end)))
	  (pieces (cons start (or slash end)))
	  (unless slash
	    (return))
	  (setf start (1+ slash))))
      (values absolute (pieces)))))

(defun maybe-extract-search-list (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let ((quoted nil))
    (do ((index start (1+ index)))
	((= index end)
	 (values nil start))
      (if quoted
	  (setf quoted nil)
	  (case (schar namestr index)
	    (#\\
	     (setf quoted t))
	    (#\:
	     (return (values (remove-backslashes namestr start index)
			     (1+ index)))))))))

(defun parse-unix-namestring (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (multiple-value-bind
      (absolute pieces)
      (split-at-slashes namestr start end)
    (let ((search-list
	   (if absolute
	       nil
	       (let ((first (car pieces)))
		 (multiple-value-bind
		     (search-list new-start)
		     (maybe-extract-search-list namestr
						(car first) (cdr first))
		   (when search-list
		     (setf absolute t)
		     (setf (car first) new-start))
		   search-list)))))
      (multiple-value-bind
	  (name type version)
	  (let* ((tail (car (last pieces)))
		 (tail-start (car tail))
		 (tail-end (cdr tail)))
	    (unless (= tail-start tail-end)
	      (setf pieces (butlast pieces))
	      (extract-name-type-and-version namestr tail-start tail-end)))
	;; Now we have everything we want.  So return it.
	(values nil ; no host for unix namestrings.
		nil ; no devices for unix namestrings.
		(collect ((dirs))
		  (when search-list
		    (dirs (intern-search-list search-list)))
		  (dolist (piece pieces)
		    (let ((piece-start (car piece))
			  (piece-end (cdr piece)))
		      (unless (= piece-start piece-end)
			(let ((dir (maybe-make-pattern namestr
						       piece-start
						       piece-end)))
			  (if (and (simple-string-p dir)
				   (string= dir ".."))
			      (dirs :up)
			      (dirs dir))))))
		  (if (dirs)
		      (cons (if absolute :absolute :relative) (dirs))
		      nil))
		name
		type
		version)))))

(defun unparse-unix-host (pathname)
  (declare (type pathname pathname)
	   (ignore pathname))
  "Unix")

(defun unparse-unix-piece (thing)
  (etypecase thing
    (simple-string
     (let* ((srclen (length thing))
	    (dstlen srclen))
       (dotimes (i srclen)
	 (case (schar thing i)
	   ((#\* #\? #\[)
	    (incf dstlen))))
       (let ((result (make-string dstlen))
	     (dst 0))
	 (dotimes (src srclen)
	   (let ((char (schar thing src)))
	     (case char
	       ((#\* #\? #\[)
		(setf (schar result dst) #\\)
		(incf dst)))
	     (setf (schar result dst) char)
	     (incf dst)))
	 result)))
    (pattern
     (collect ((strings))
       (dolist (piece (pattern-pieces thing))
	 (etypecase piece
	   (simple-string
	    (strings piece))
	   (symbol
	    (case piece
	      (:multi-char-wild
	       (strings "*"))
	      (:single-char-wild
	       (strings "?"))
	      (t
	       (error "Invalid pattern piece: ~S" piece))))
	   (cons
	    (case (car piece)
	      (:character-set
	       (strings "[")
	       (strings (cdr piece))
	       (strings "]"))
	      (t
	       (error "Invalid pattern piece: ~S" piece))))))
       (apply #'concatenate
	      'simple-string
	      (strings))))))

(defun unparse-unix-directory-list (directory)
  (declare (type list directory))
  (collect ((pieces))
    (when directory
      (ecase (pop directory)
	(:absolute
	 (cond ((search-list-p (car directory))
		(pieces (search-list-name (pop directory)))
		(pieces ":"))
	       (t
		(pieces "/"))))
	(:relative
	 ;; Nothing special.
	 ))
      (dolist (dir directory)
	(typecase dir
	  ((member :up)
	   (pieces "../"))
	  ((member :back)
	   (error ":BACK cannot be represented in namestrings."))
	  ((or simple-string pattern)
	   (pieces (unparse-unix-piece dir))
	   (pieces "/"))
	  (t
	   (error "Invalid directory component: ~S" dir)))))
    (apply #'concatenate 'simple-string (pieces))))

(defun unparse-unix-directory (pathname)
  (declare (type pathname pathname))
  (unparse-unix-directory-list (%pathname-directory pathname)))
  
(defun unparse-unix-file (pathname)
  (declare (type pathname pathname))
  (collect ((strings))
    (let* ((name (%pathname-name pathname))
	   (type (%pathname-type pathname))
	   (type-supplied (not (or (null type) (eq type :unspecific))))
	   (version (%pathname-version pathname))
	   (version-supplied (not (or (null version) (eq version :newest)))))
      (when name
	(strings (unparse-unix-piece name)))
      (when type-supplied
	(unless name
	  (error "Cannot specify the type without a file: ~S" pathname))
	(strings ".")
	(strings (unparse-unix-piece type)))
      (when version-supplied
	(unless type-supplied
	  (error "Cannot specify the version without a type: ~S" pathname))
	(strings (if (eq version :wild)
		     ".*"
		     (format nil ".~D" version)))))
    (apply #'concatenate 'simple-string (strings))))

(defun unparse-unix-namestring (pathname)
  (declare (type pathname pathname))
  (concatenate 'simple-string
	       (unparse-unix-directory pathname)
	       (unparse-unix-file pathname)))

(defun unparse-unix-enough (pathname defaults)
  (declare (type pathname pathname defaults))
  (flet ((lose ()
	   (error "~S cannot be represented relative to ~S"
		  pathname defaults)))
    (collect ((strings))
      (let* ((pathname-directory (%pathname-directory pathname))
	     (defaults-directory (%pathname-directory defaults))
	     (prefix-len (length defaults-directory))
	     (result-dir
	      (cond ((and (> prefix-len 1)
			  (>= (length pathname-directory) prefix-len)
			  (compare-component (subseq pathname-directory
						     0 prefix-len)
					     defaults-directory))
		     ;; Pathname starts with a prefix of default.  So just
		     ;; use a relative directory from then on out.
		     (cons :relative (nthcdr prefix-len pathname-directory)))
		    ((eq (car pathname-directory) :absolute)
		     ;; We are an absolute pathname, so we can just use it.
		     pathname-directory)
		    (t
		     ;; We are a relative directory.  So we lose.
		     (lose)))))
	(strings (unparse-unix-directory-list result-dir)))
      (let* ((pathname-version (%pathname-version pathname))
	     (version-needed (and pathname-version
				  (not (eq pathname-version :newest))))
	     (pathname-type (%pathname-type pathname))
	     (type-needed (or version-needed
			      (and pathname-type
				   (not (eq pathname-type :unspecific)))))
	     (pathname-name (%pathname-name pathname))
	     (name-needed (or type-needed
			      (and pathname-name
				   (not (compare-component pathname-name
							   (%pathname-name
							    defaults)))))))
	(when name-needed
	  (unless pathname-name (lose))
	  (strings (unparse-unix-piece pathname-name)))
	(when type-needed
	  (when (or (null pathname-type) (eq pathname-type :unspecific))
	    (lose))
	  (strings ".")
	  (strings (unparse-unix-piece pathname-type)))
	(when version-needed
	  (typecase pathname-version
	    ((member :wild)
	     (strings ".*"))
	    (integer
	     (strings (format nil ".~D" pathname-version)))
	    (t
	     (lose)))))
      (apply #'concatenate 'simple-string (strings)))))


(defstruct (unix-host
	    (:include host
		      (:parse #'parse-unix-namestring)
		      (:unparse #'unparse-unix-namestring)
		      (:unparse-host #'unparse-unix-host)
		      (:unparse-directory #'unparse-unix-directory)
		      (:unparse-file #'unparse-unix-file)
		      (:unparse-enough #'unparse-unix-enough)
		      (:customary-case :lower))
	    (:make-load-form-fun make-unix-host-load-form))
  )

(defvar *unix-host* (make-unix-host))

(defun make-unix-host-load-form (host)
  (declare (ignore host))
  '*unix-host*)
ram's avatar
ram committed


;;;; Wildcard matching stuff.

(defmacro enumerate-matches ((var pathname &optional result
				  &key (verify-existance t))
			     &body body)
  (let ((body-name (gensym)))
    `(block nil
       (flet ((,body-name (,var)
		,@body))
	 (%enumerate-matches (pathname ,pathname)
			     ,verify-existance
			     #',body-name)
	 ,result))))

(defun %enumerate-matches (pathname verify-existance function)
  (when (pathname-type pathname)
    (unless (pathname-name pathname)
      (error "Cannot supply a type without a name:~%  ~S" pathname)))
  (when (and (integerp (pathname-version pathname))
	     (member (pathname-type pathname) '(nil :unspecific)))
    (error "Cannot supply a version without a type:~%  ~S" pathname))
  (let ((directory (pathname-directory pathname)))
    (if directory
	(ecase (car directory)
	  (:absolute
	   (%enumerate-directories "/" (cdr directory) pathname
				   verify-existance function))
	  (:relative
	   (%enumerate-directories "" (cdr directory) pathname
				   verify-existance function)))
	(%enumerate-files "" pathname verify-existance function))))

(defun %enumerate-directories (head tail pathname verify-existance function)
  (if tail
      (let ((piece (car tail)))
	(etypecase piece
	  (simple-string
	   (%enumerate-directories (concatenate 'string head piece "/")
				   (cdr tail) pathname verify-existance
				   function))
	  (pattern
	   (let ((dir (mach:open-dir head)))
	     (when dir
	       (unwind-protect
		   (loop
		     (let ((name (mach:read-dir dir)))
		       (cond ((null name)
			      (return))
			     ((string= name "."))
			     ((string= name ".."))
			     ((pattern-matches piece name)
			      (let ((subdir (concatenate 'string
							 head name "/")))
				(when (eq (mach:unix-file-kind subdir)
					  :directory)
				  (%enumerate-directories
				   subdir (cdr tail) pathname verify-existance
				   function)))))))
		 (mach:close-dir dir)))))
	  ((member :up)
	   (%enumerate-directories (concatenate 'string head "../")
				   (cdr tail) pathname verify-existance
				   function))))
      (%enumerate-files head pathname verify-existance function)))

(defun %enumerate-files (directory pathname verify-existance function)
  (let ((name (pathname-name pathname))
	(type (pathname-type pathname))
	(version (pathname-version pathname)))
    (cond ((null name)
	   (when (or (not verify-existance)
		     (mach:unix-file-kind directory))
	     (funcall function directory)))
	  ((or (pattern-p name)
	       (pattern-p type)
	       (eq version :wild))
	   (let ((dir (mach:open-dir directory)))
	     (when dir
	       (unwind-protect
		   (loop
		     (let ((file (mach:read-dir dir)))
		       (if file
			   (unless (or (string= file ".")
				       (string= file ".."))
			     (multiple-value-bind
				 (file-name file-type file-version)
				 (let ((*ignore-wildcards* t))
				   (extract-name-type-and-version
				    file 0 (length file)))
			       (when (and (components-match file-name name)
					  (components-match file-type type)
					  (components-match file-version
							    version))
				 (funcall function
					  (concatenate 'string
						       directory
						       file)))))
			   (return))))
		 (mach:close-dir dir)))))
	  (t
	   (let ((file (concatenate 'string directory name)))
	     (unless (or (null type) (eq type :unspecific))
	       (setf file (concatenate 'string file "." type)))
	     (unless (or (null version) (eq version :newest))
	       (setf file (concatenate 'string file "."
wlott's avatar
wlott committed
				       (quick-integer-to-string version))))
	     (when (or (not verify-existance)
		       (mach:unix-file-kind file))
	       (funcall function file)))))))
ram's avatar
ram committed

(defun quick-integer-to-string (n)
ram's avatar
ram committed
  (cond ((zerop n) "0")
	((eql n 1) "1")
	((minusp n)
	 (concatenate 'simple-string "-"
		      (the simple-string (quick-integer-to-string (- n)))))
	(t
	 (do* ((len (1+ (truncate (integer-length n) 3)))
	       (res (make-string len))
	       (i (1- len) (1- i))
	       (q n)
	       (r 0))
	      ((zerop q)
	       (incf i)
	       (replace res res :start2 i :end2 len)
	       (shrink-vector res (- len i)))
ram's avatar
ram committed
	   (declare (simple-string res)
		    (fixnum len i r))
	   (multiple-value-setq (q r) (truncate q 10))
	   (setf (schar res i) (schar "0123456789" r))))))

;;; 
(defun unix-namestring (pathname &optional (for-input t))
  "Convert PATHNAME into a string that can be used with UNIX system calls.
   Search-lists and wild-cards are expanded."
  (enumerate-search-list
      (pathname pathname)
    (collect ((names))
      (enumerate-matches (name pathname nil :verify-existance for-input)
	(names name))
      (let ((names (names)))
	(when names
	  (when (cdr names)
	    (error "~S is ambiguous:~{~%  ~A~}" pathname names))
	  (return (car names)))))))
ram's avatar
ram committed


;;;; TRUENAME and PROBE-FILE.
ram's avatar
ram committed

;;; Truename  --  Public
;;;
;;; Another silly file function trivially different from another function.
ram's avatar
ram committed
;;;
(defun truename (pathname)
  "Return the pathname for the actual file described by the pathname
  An error is signalled if no such file exists."
  (let ((result (probe-file pathname)))
    (unless result
      (error "The file ~S does not exist." (namestring pathname)))
    result))

;;; Probe-File  --  Public
;;;
;;; If PATHNAME exists, return it's truename, otherwise NIL.
ram's avatar
ram committed
;;;
(defun probe-file (pathname)
  "Return a pathname which is the truename of the file if it exists, NIL
  (let ((namestring (unix-namestring pathname t)))
    (when (and namestring (mach:unix-file-kind namestring))
      (let ((truename (mach:unix-resolve-links
		       (mach:unix-maybe-prepend-current-directory
			namestring))))
	(when truename
	  (let ((*ignore-wildcards* t))
	    (pathname (mach:unix-simplify-pathname truename))))))))
ram's avatar
ram committed


;;;; Other random operations.
ram's avatar
ram committed

;;; Rename-File  --  Public
;;;
(defun rename-file (file new-name)
  "Rename File to have the specified New-Name.  If file is a stream open to a
  file, then the associated file is renamed.  If the file does not yet exist
  then the file is created with the New-Name when the stream is closed."
  (let* ((original (truename file))
	 (original-namestring (unix-namestring original t))
	 (new-name (merge-pathnames new-name original))
	 (new-namestring (unix-namestring new-name nil)))
    (unless original-namestring
      (error "~S doesn't exist." file))
    (unless new-namestring
      (error "~S can't be created." new-name))
    (multiple-value-bind (res error)
			 (mach:unix-rename original-namestring
					   new-namestring)
      (unless res
	(error "Failed to rename ~A to ~A: ~A"
	       original new-name (mach:get-unix-error-msg error)))
      (when (streamp file)
	(file-name file new-namestring))
      (values new-name original (truename new-name)))))
ram's avatar
ram committed

;;; Delete-File  --  Public
;;;
;;;    Delete the file, Man.
;;;
(defun delete-file (file)
  "Delete the specified file."
  (let ((namestring (unix-namestring file t)))
ram's avatar
ram committed
    (when (streamp file)
      (close file :abort t))
    (when namestring
      (multiple-value-bind (res err) (mach:unix-unlink namestring)
	(unless res
	  (error "Could not delete ~A: ~A."
		 namestring
		 (mach:get-unix-error-msg err))))))
ram's avatar
ram committed
  t)
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))
  #p"home:")
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."
  (let ((name (unix-namestring file t)))
    (when name
      (multiple-value-bind
	  (res dev ino mode nlink uid gid rdev size atime mtime)
	  (mach: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 if file doesn't exist."
  (let ((name (unix-namestring (pathname file) t)))
    (unless name
      (error "~S doesn't exist." file))
    (multiple-value-bind (winp dev ino mode nlink uid)
			 (mach:unix-stat file)
      (declare (ignore dev ino mode nlink))
      (if winp (lookup-login-name uid)))))
ram's avatar
ram committed



;;;; DIRECTORY.

;;; DIRECTORY  --  public.
;;; 
(defun directory (pathname &key (all t) (check-for-subdirs 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."
  (let ((results nil))
    (enumerate-search-list
	(pathname (merge-pathnames pathname
				   (make-pathname :name :wild
						  :type :wild
						  :version :wild)))
      (enumerate-matches (name pathname)
	(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)
		  (if (and check-for-subdirs
			   (eq (mach:unix-file-kind name) :directory))
		      (truename (concatenate 'string name "/"))
		      (truename 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)
  "Like Directory, but prints a terse, multi-coloumn directory listing
   instead of returning a list of pathnames.  When :all is supplied and
   non-nil, then Unix dot files are included too (as ls -a).  When :vervose
   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))
	(pathname pathname))
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))
	(result nil))
    (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)
	    (mach: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
			   (or (lookup-login-name uid) uid)
			   size
			   (decode-universal-time-for-files mtime year)
			   tail
			   (= (logand mode mach::s_ifmt) mach::s_ifdir))))
		(t (format t "Couldn't stat ~A -- ~A.~%"
			   tail
			   (mach:get-unix-error-msg dev-or-err))))
ram's avatar
ram committed
	  (when return-list
	    (push (if (= (logand mode mach::s_ifmt) mach::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)))
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))
      (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)
			  :check-for-subdirs nil)))
    (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)