;;; Ops that create objects in the file system:
  create-{directory , fifo , hard - link , symlink }
  Copyright ( c ) 1993 by   .

  This procedure nukes FNAME , whatever it may be : directory , file , fifo ,
;;; symlink.
;;;
;;; We can't probe FNAME to find out what it is and then do the right
;;; delete operation because there's a window in-between the probe and the
;;; delete where the file system can be altered -- the probe and delete
;;; aren't atomic. In order to deliver on our contract, we have to spin
;;; in a funny loop until we win. In practice, the loop will probably never
;;; execute more than once.

(define (delete-filesys-object fname)
  (let loop ()
    (or (with-errno-handler ; Assume it's a file and try.
	    ((err data)
	     ((perm) #f) ; Return #f if directory
	     ((isdir) #f)
	     ((noent) #t))
	    (delete-file fname)
	    #t)

	(with-errno-handler ; Assume it's a directory and try.
	    ((err data)
	     ((notdir) #f) ; Return #f if fname is not a directory.
	     ((noent) #t))
	    (delete-directory fname)
	    #t)

	(loop)))) ; Strange things are happening. Try again.


;;; For similar reasons, all of these ops must loop.

  Abstract out common code for create-{directory , fifo , hard - link , symlink } :

(define (create-file-thing fname makeit override? op-name syscall)
    (let ((query (lambda ()
		   (y-or-n? (string-append op-name ": " fname
					   " already exists. Delete")))))
      (let loop ((override? override?))
        (with-errno-handler
         ((err data)
          ((exist)
           (cond ((if (eq? override? 'query)
                      (query)
                      override?)
                  (delete-filesys-object fname)
                  (loop #t))
                 (else (errno-error err syscall (car data) fname)))))
         (with-resources-aligned
          (list cwd-resource umask-resource euid-resource egid-resource)
          (lambda ()
            (makeit fname)))))))

;;;;;;;

(define (create-directory dir . rest)
  (let-optionals rest ((mode (file-mode all))
                       (override? #f))
    (create-file-thing dir
                       (lambda (dir)
                         (make-directory dir mode))
                       override?
                       "create-directory"
                       create-directory)))


(define (create-fifo fifo . rest)
  (let-optionals rest ((mode (file-mode all))
                       (override? #f))
    (create-file-thing fifo
           (lambda (fifo)
             (make-fifo fifo mode))
           override?
           "create-fifo"
           create-fifo)))

(define (create-hard-link old-fname new-fname . maybe-override?)
  (create-file-thing new-fname
		     (lambda (new-fname)
		       (link old-fname new-fname)) ;from posix-files
		     (:optional maybe-override? #f)
		     "create-hard-link"
		     create-hard-link))

(define (create-symlink old-fname new-fname . maybe-override?)
  (create-file-thing new-fname
		     (lambda (symlink)
		       (%create-symlink old-fname symlink))
		     (:optional maybe-override? #f)
		     "create-symlink"
		     create-symlink))

  Unix rename ( ) works backwards from  ( ) ,  ( ) , link ( ) , and
;;; symlink() -- it overrides by default, (though insisting on a type
;;; match between the old and new object). So we can't use create-file-thing.
;;; Note that this loop has a tiny atomicity problem -- if someone
;;; creates a file *after* we do our existence check, but *before* we
;;; do the rename, we could end up overriding it, when the user asked
;;; us not to. That's life in the food chain.

(define (rename-file old-fname new-fname . maybe-override?)
  (let ((override? (:optional maybe-override? #f)))
    (if (or (and override? (not (eq? override? 'query)))
	    (file-not-exists? new-fname)
	    (and override?
		 (y-or-n? (string-append "rename-file:" new-fname
					 " already exists. Delete"))))
	(with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()
	   (rename old-fname new-fname)))))) ;from posix-files

(define (y-or-n? question . maybe-eof-value)
  (let loop ((count *y-or-n-eof-count*))
    (display question)
    (display " (y/n)? ")
    (let ((line (read-line)))
      (cond ((eof-object? line)
             (newline)
             (if (= count 0)
                 (:optional maybe-eof-value (error "EOF in y-or-n?"))
                 (begin (display "I'll only ask another ")
                        (write count)
                        (display " times.")
                        (newline)
                        (loop (- count 1)))))
            ((< (string-length line) 1) (loop count))
            ((char=? (string-ref line 0) #\y) #t)
            ((char=? (string-ref line 0) #\n) #f)
            (else (loop count))))))

(define *y-or-n-eof-count* 100)

(define (read-symlink path)
  (with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()
	   (os-string->string (read-symbolic-link path))))) ;from posix-files

(define (delete-directory path)
  (with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()
	   (remove-directory path)))) ; from posix-files

 Ops that create objects in the file system:
 symlink.

 We can't probe FNAME to find out what it is and then do the right
 delete operation because there's a window in-between the probe and the
 delete where the file system can be altered -- the probe and delete
 aren't atomic. In order to deliver on our contract, we have to spin
 in a funny loop until we win. In practice, the loop will probably never
 execute more than once.
 Assume it's a file and try.
 Return #f if directory
 Assume it's a directory and try.
 Return #f if fname is not a directory.
 Strange things are happening. Try again.
 For similar reasons, all of these ops must loop.

from posix-files
 symlink() -- it overrides by default, (though insisting on a type
 match between the old and new object). So we can't use create-file-thing.
 Note that this loop has a tiny atomicity problem -- if someone
 creates a file *after* we do our existence check, but *before* we
 do the rename, we could end up overriding it, when the user asked
 us not to. That's life in the food chain.
from posix-files
from posix-files
 from posix-files
  create-{directory , fifo , hard - link , symlink }
  Copyright ( c ) 1993 by   .

  This procedure nukes FNAME , whatever it may be : directory , file , fifo ,

(define (delete-filesys-object fname)
  (let loop ()
	    ((err data)
	     ((isdir) #f)
	     ((noent) #t))
	    (delete-file fname)
	    #t)

	    ((err data)
	     ((noent) #t))
	    (delete-directory fname)
	    #t)




  Abstract out common code for create-{directory , fifo , hard - link , symlink } :

(define (create-file-thing fname makeit override? op-name syscall)
    (let ((query (lambda ()
		   (y-or-n? (string-append op-name ": " fname
					   " already exists. Delete")))))
      (let loop ((override? override?))
        (with-errno-handler
         ((err data)
          ((exist)
           (cond ((if (eq? override? 'query)
                      (query)
                      override?)
                  (delete-filesys-object fname)
                  (loop #t))
                 (else (errno-error err syscall (car data) fname)))))
         (with-resources-aligned
          (list cwd-resource umask-resource euid-resource egid-resource)
          (lambda ()
            (makeit fname)))))))


(define (create-directory dir . rest)
  (let-optionals rest ((mode (file-mode all))
                       (override? #f))
    (create-file-thing dir
                       (lambda (dir)
                         (make-directory dir mode))
                       override?
                       "create-directory"
                       create-directory)))


(define (create-fifo fifo . rest)
  (let-optionals rest ((mode (file-mode all))
                       (override? #f))
    (create-file-thing fifo
           (lambda (fifo)
             (make-fifo fifo mode))
           override?
           "create-fifo"
           create-fifo)))

(define (create-hard-link old-fname new-fname . maybe-override?)
  (create-file-thing new-fname
		     (lambda (new-fname)
		     (:optional maybe-override? #f)
		     "create-hard-link"
		     create-hard-link))

(define (create-symlink old-fname new-fname . maybe-override?)
  (create-file-thing new-fname
		     (lambda (symlink)
		       (%create-symlink old-fname symlink))
		     (:optional maybe-override? #f)
		     "create-symlink"
		     create-symlink))

  Unix rename ( ) works backwards from  ( ) ,  ( ) , link ( ) , and

(define (rename-file old-fname new-fname . maybe-override?)
  (let ((override? (:optional maybe-override? #f)))
    (if (or (and override? (not (eq? override? 'query)))
	    (file-not-exists? new-fname)
	    (and override?
		 (y-or-n? (string-append "rename-file:" new-fname
					 " already exists. Delete"))))
	(with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()

(define (y-or-n? question . maybe-eof-value)
  (let loop ((count *y-or-n-eof-count*))
    (display question)
    (display " (y/n)? ")
    (let ((line (read-line)))
      (cond ((eof-object? line)
             (newline)
             (if (= count 0)
                 (:optional maybe-eof-value (error "EOF in y-or-n?"))
                 (begin (display "I'll only ask another ")
                        (write count)
                        (display " times.")
                        (newline)
                        (loop (- count 1)))))
            ((< (string-length line) 1) (loop count))
            ((char=? (string-ref line 0) #\y) #t)
            ((char=? (string-ref line 0) #\n) #f)
            (else (loop count))))))

(define *y-or-n-eof-count* 100)

(define (read-symlink path)
  (with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()

(define (delete-directory path)
  (with-resources-aligned
	 (list cwd-resource euid-resource egid-resource)
	 (lambda ()
