123 lines
4.5 KiB
Racket
123 lines
4.5 KiB
Racket
#lang racket/base
|
|
(require file/untar
|
|
file/untgz
|
|
racket/file
|
|
racket/system)
|
|
|
|
(define tmp (find-system-path 'temp-dir))
|
|
(define tar-exe (find-executable-path "tar"))
|
|
(define gzip-exe (find-executable-path "gzip"))
|
|
|
|
(define work-dir (build-path tmp (format "untar-testing~a" (random 1000))))
|
|
(printf "Working in ~a\n" work-dir)
|
|
(when (directory-exists? work-dir)
|
|
(delete-directory/files work-dir))
|
|
(define a.tar (build-path work-dir "a.tar"))
|
|
|
|
(define sub-dir (build-path work-dir "sub"))
|
|
|
|
(define (make-file path mod-time [permissions '(read write)])
|
|
(with-output-to-file path
|
|
(lambda ()
|
|
(write-bytes (make-bytes (random 100000)))))
|
|
(file-or-directory-modify-seconds path mod-time)
|
|
(file-or-directory-permissions* path permissions))
|
|
|
|
(define (file-or-directory-permissions* path permissions)
|
|
(file-or-directory-permissions path
|
|
(bitwise-ior
|
|
(if (memq 'read permissions)
|
|
#o444
|
|
0)
|
|
(if (memq 'write permissions)
|
|
#o222
|
|
0)
|
|
(if (memq 'execute permissions)
|
|
#o111
|
|
0))))
|
|
|
|
(define ex1-dir (build-path work-dir "ex1"))
|
|
|
|
(make-directory* ex1-dir)
|
|
(make-file (build-path ex1-dir "f1") (- (current-seconds) 12))
|
|
(make-file (build-path ex1-dir "f2") (+ (current-seconds) 12) '(read write execute))
|
|
(make-file (build-path ex1-dir "f3") (- (current-seconds) 7) '(read))
|
|
(make-file-or-directory-link "fnone" (build-path ex1-dir "f4"))
|
|
(define more-dir (build-path ex1-dir "more"))
|
|
(make-directory* more-dir)
|
|
(make-file (build-path more-dir "f4") (current-seconds))
|
|
(file-or-directory-permissions* more-dir '(read execute)) ; not 'write
|
|
|
|
(define (tar dir)
|
|
(define-values (base name dir?) (split-path dir))
|
|
(parameterize ([current-directory base])
|
|
(void (system* tar-exe "-c" "-f" a.tar name))))
|
|
|
|
(define (diff-error src dest)
|
|
(error 'diff "different: ~e ~e\n" src dest))
|
|
|
|
(define (diff src dest)
|
|
(cond
|
|
[(link-exists? src)
|
|
(unless (link-exists? dest) (diff-error src dest))
|
|
(diff (resolve-path src) (resolve-path dest))]
|
|
[(file-exists? src)
|
|
(unless (and (file-exists? dest)
|
|
(= (file-size src) (file-size dest))
|
|
(= (file-or-directory-modify-seconds src)
|
|
(file-or-directory-modify-seconds dest))
|
|
(equal? (file-or-directory-permissions src)
|
|
(file-or-directory-permissions dest))
|
|
(equal? (file->bytes src) (file->bytes dest)))
|
|
(diff-error src dest))]
|
|
[(directory-exists? src)
|
|
(unless (and (directory-exists? dest)
|
|
(= (file-or-directory-modify-seconds src)
|
|
(file-or-directory-modify-seconds dest))
|
|
(equal? (file-or-directory-permissions src)
|
|
(file-or-directory-permissions dest)))
|
|
(diff-error src dest))
|
|
(define (sort-paths l)
|
|
(sort l bytes<? #:key path->bytes))
|
|
(define srcs (sort-paths (directory-list src)))
|
|
(define dests (sort-paths (directory-list dest)))
|
|
(unless (equal? srcs dests) (diff-error src dest))
|
|
(for ([src-item (in-list srcs)]
|
|
[dest-item (in-list dests)])
|
|
(diff (build-path src src-item) (build-path dest dest-item)))
|
|
;; make dest writable to simplify clean-up:
|
|
(file-or-directory-permissions* dest '(read execute write))]
|
|
[else (void)]))
|
|
|
|
(tar ex1-dir)
|
|
|
|
(make-directory* sub-dir)
|
|
(parameterize ([current-directory sub-dir])
|
|
(untar a.tar))
|
|
(diff ex1-dir (build-path sub-dir "ex1"))
|
|
(delete-directory/files sub-dir)
|
|
|
|
(parameterize ([current-directory work-dir])
|
|
(untar a.tar #:dest "sub"))
|
|
(diff ex1-dir (build-path sub-dir "ex1"))
|
|
(delete-directory/files sub-dir)
|
|
|
|
(parameterize ([current-directory work-dir])
|
|
(untgz a.tar #:dest "sub"))
|
|
(diff ex1-dir (build-path sub-dir "ex1"))
|
|
(delete-directory/files sub-dir)
|
|
|
|
(parameterize ([current-directory work-dir])
|
|
(untar a.tar #:dest "sub" #:filter (lambda args #f)))
|
|
(when (directory-exists? sub-dir)
|
|
(error "should not have been unpacked"))
|
|
|
|
(void (system* gzip-exe a.tar))
|
|
(parameterize ([current-directory work-dir])
|
|
(untgz (path-replace-suffix a.tar #".tar.gz") #:dest "sub"))
|
|
(diff ex1-dir (build-path sub-dir "ex1"))
|
|
(delete-directory/files sub-dir)
|
|
|
|
(file-or-directory-permissions* more-dir '(read execute write))
|
|
(delete-directory/files work-dir)
|