; 	Verify scanning directory and getting of file status
; IMPORT
; appropriate prelude: myenv.scm, myenv-bigloo.scm, myenv-scm.scm
;	depending on your system
; catch-error.scm -- for procedure, for-syntax
; readdir.scm -- must be compiled in

(declare				; Compilation optimization options
 (block)
 (standard-bindings)
; (fixnum)	; mtime, etc. can be BIGNUM!
)

;;(require "readdir.scm")


	; Check out that the 'form' has failed indeed
	; (as it was supposed to)
(define-macro (must-have-failed form)
  `(assert (failed?
      (##catch-all
        (lambda (sig args) (error "catching " sig args))
        (lambda () ,form)))))

; The following validation code isn't completely fool-proof
; It makes certain assumptions about your system and its capabilities,
; say, that /tmp or /var/tmp directory exist and writable, that
; one can create files and folders in this directory, etc.
; that the system supports named FIFO pipes (which can be created
; as "/etc/mknod file-name p" etc). All of these assumptions appear
; to be valid on many UNIX/POSIX systems (HP/UX 10.0, SunSolaris 2.x
; etc). But your mileage may vary...

(cerr nl nl "--> Testing of getting the file status..." nl)
(let ((dir-name (OS:tmpnam))
        (file-name "0.tmp")
        (file-size 25)
        (my-effective-user-id (OS:geteuid))
        (my-effective-group-id (OS:getegid)))
        
    (let
      ((non-existing-file-name (OS:tmpnam)))
      (cerr "testing taking of a file status of a non-existing file "
        non-existing-file-name nl)
      (must-have-failed (OS:make-file-info non-existing-file-name)))
    
    (cerr "creating directory " dir-name " and descending into it" nl)
    (OS:ch-mk-dir dir-name)
    (cerr "writing a file " file-name " of size " file-size nl)
    (with-output-to-file file-name
      (lambda ()
        (do ((i 0 (++ i))) ((>= i file-size))
          (display (integer->char (+ i (char->integer #\space)))))))
    
    (cerr "checking the file size" nl)
    (assert (= (OS:file-length file-name) file-size))
    
    (cerr "getting stat of the file and testing it..." nl)
    (let ((file-stat (OS:make-file-info file-name)))
      (assert (string=? (file-stat 'name) file-name))
      (assert (= (file-stat 'link-count) 1))
      (assert (not (file-stat 'directory?)))
      (assert (not (file-stat 'block-special?)))
      (assert (not (file-stat 'char-special?)))
      (assert (not (file-stat 'pipe?)))
      (assert (file-stat 'regular-file?))
      (assert (= (file-stat 'size) file-size))
      (assert (= (file-stat 'uid) my-effective-user-id))
;      (assert (= (file-stat 'gid) my-effective-group-id))
      (let ((perm-predicate (file-stat 'perm)))
        (assert (perm-predicate 'owner 'read))
        (assert (perm-predicate 'owner 'write))
;        (assert (not (perm-predicate 'owner 'exec)))
        (assert (failed? (perm-predicate 'xxx 'read)))
        (assert (failed? (perm-predicate 'group 'xxx))))
      (assert (failed? (file-stat 'xxx)))
      (assert (= (file-stat 'ctime) (file-stat 'mtime)))
      (assert (= (file-stat 'atime) (file-stat 'mtime)))
      (assert (>= (OS:time) (file-stat 'atime))))
   
    (cerr "getting stat of the directory and testing it..." nl)
    (let ((dir-stat (OS:make-file-info dir-name)))
      (assert (substring? dir-name (dir-stat 'name)))
      (assert (= (dir-stat 'link-count) 2))
      (assert (dir-stat 'directory?))
      (assert (not (dir-stat 'block-special?)))
      (assert (not (dir-stat 'char-special?)))
      (assert (not (dir-stat 'pipe?)))
      (assert (not (dir-stat 'regular-file?)))
      (assert (>= (dir-stat 'size) 512))
      (assert (= ((OS:make-file-info ".") 'atime)
          (dir-stat 'atime)))
      (assert (= (dir-stat 'uid) my-effective-user-id))
;      (assert (= (dir-stat 'gid) my-effective-group-id))
      (let ((perm-predicate (dir-stat 'perm)))
        (assert (perm-predicate 'owner 'read))
        (assert (perm-predicate 'owner 'write))
        (assert (perm-predicate 'owner 'exec)))
      (assert (<= (dir-stat 'ctime) (dir-stat 'mtime)))
      (assert (<= (dir-stat 'atime) (dir-stat 'mtime)))
      (assert (>= (OS:time) (dir-stat 'atime))))

    (cerr "reading the file and making sure it causes atime > mtime" nl)
    (OS:system (string-append "sleep 1; cat " file-name " > /dev/null"))
    (let ((file-stat (OS:make-file-info file-name)))
      (assert (> (file-stat 'atime) (file-stat 'mtime)))
      		; make sure we read the file just _now_ (within 2 secs at least)
      (assert (< (- (OS:time) (file-stat 'atime)) 2)))

    (cerr "over-writing the file and making sure it causes atime < mtime" nl)
    (OS:system (string-append "sleep 1; echo 11 > " file-name))
    (let ((file-stat (OS:make-file-info file-name)))
      (assert (< (file-stat 'atime) (file-stat 'mtime)))
      (assert (< (- (OS:time) (file-stat 'mtime)) 2)))
      
    (cerr "removing the file and making it a pipe" nl)
;    (OS:system (string-append "rm -f " file-name
;        "; /etc/mknod " file-name " p"))
    (OS:system (string-append "rm -f " file-name
        "; mkfifo " file-name))
    (let ((file-stat (OS:make-file-info file-name)))
      (assert (string=? (file-stat 'name) file-name))
      (assert (= (file-stat 'link-count) 1))
      (assert (not (file-stat 'directory?)))
      (assert (not (file-stat 'block-special?)))
      (assert (not (file-stat 'char-special?)))
      (assert (file-stat 'pipe?))
      (assert (not (file-stat 'regular-file?)))
      (assert (= (file-stat 'size) 0))
      (assert (= (file-stat 'uid) my-effective-user-id))
;      (assert (= (file-stat 'gid) my-effective-group-id))
      (assert (= (file-stat 'ctime) (file-stat 'mtime)))
      (assert (= (file-stat 'atime) (file-stat 'mtime)))
      (assert (>= (OS:time) (file-stat 'atime))))
      
    (cerr "cleaning up")
    (OS:remove file-name)
    (OS:ch-parent-dir)
    (OS:system (string-append "rmdir " dir-name))
)
(cerr nl "Done" nl)

(cerr nl "--> Testing scanning of a directory" nl)
(let ((dir-name (OS:tmpnam))
      (file-name "0.tmp")
      (another-file-name "1.tmp")
      (file-base-size 25)
      (my-effective-user-id (OS:geteuid))
      (my-effective-group-id (OS:getegid)))
      
    (define (make-file-given-size file-name size)
      (cerr "writing a file " file-name " of size " size nl)
      (with-output-to-file file-name
        (lambda ()
          (do ((i 0 (++ i))) ((>= i size))
            (display #\space)))))
      
    (cerr "creating directory " dir-name " and descending into it" nl)
    (OS:ch-mk-dir dir-name)
    (make-file-given-size file-name file-base-size)
    (make-file-given-size another-file-name (++ file-base-size))
    
    (cerr "Trying to scan " file-name " which is *not* a directory")
    (must-have-failed (OS:for-each-file-in-directory file-name error))
    
    (cerr "getting back to the parent and starting scanning of " dir-name nl)
    (OS:ch-parent-dir)
    (let*
      ((seen-dot #f) (seen-dot-dot #f)		; If we saw "." and ".."
        ; for each regular file, make a list of pairs (name . size)
        (scan-list
          (OS:for-each-file-in-directory dir-name
            (lambda (file-info)
              (cond
                ((and (file-info 'directory?)
                    (string=? (file-info 'name) "."))
                  (set! seen-dot #t) '())
                ((and (file-info 'directory?)
                    (string=? (file-info 'name) ".."))
                  (set! seen-dot-dot #t) '())
                ((file-info 'regular-file?)
                  (cons (file-info 'name) (file-info 'size))))))))
      (assert seen-dot)
      (assert seen-dot-dot)
      (cerr "scan list: " scan-list nl)
      (assert (and (assoc file-name scan-list)
          (= file-base-size (cdr (assoc file-name scan-list)))))
      (assert (and (assoc another-file-name scan-list)
          (= (++ file-base-size) (cdr (assoc another-file-name scan-list)))))
      )
    
    (cerr "scanning the directory again (but terminating early...) " nl)
    (let
      ((scan-list
        (OS:for-each-file-in-directory dir-name
          (lambda (file-info)
              (cond
                ((file-info 'regular-file?)
                  (not (string=? file-name (file-info 'name))))
                (else (file-info 'name)))))))
      (cerr "scan list: " scan-list nl)
      (assert (not (member file-name scan-list)))
      )

    (cerr "cleaning up")
    (OS:chdir dir-name)
    (OS:remove file-name)
    (OS:remove another-file-name)
    (OS:ch-parent-dir)
    (OS:system (string-append "rmdir " dir-name))
  )
(cerr nl "Done" nl)
          
(cerr nl "--> emulate 'ls -l .' a little bit" nl)
(OS:for-each-file-in-directory "."
  (lambda (file-info)
    (cerr nl
      (cond
        ((file-info 'directory?) "d")
        ((file-info 'block-special?) "b")
        ((file-info 'char-special?) "c")
        ((file-info 'pipe?) "p")
        ((file-info 'regular-file?) "-")
        (else "?"))
        
        (lambda (port)
          (let ((perm-predicate (file-info 'perm)))
            (for-each
              (lambda (elem)
                (cerr (if (apply perm-predicate (cdr elem)) (car elem) #\-)))
              '((#\r owner read) (#\w owner write) (#\x owner exec)
                (#\r group read) (#\w group write) (#\x group exec)
                (#\r others read) (#\w others write) (#\x others exec)))))

        " "
        (file-info 'link-count)
        " "
        (file-info 'uid)
        "   "
        (file-info 'gid)
        " "
        (file-info 'size)
        " "
        (OS:cftime "%a, %d %b %Y %X" (file-info 'mtime))
        #\tab
        (file-info 'name))
      '()
      )
)
(cerr nl "Done" nl)

(cerr nl nl "All tests passed" nl)