212 lines
7.6 KiB
Scheme
Executable File
212 lines
7.6 KiB
Scheme
Executable File
#!/bin/sh
|
|
exec scsh -e main -o srfi-26 -o sort -s "$0" "$@"
|
|
!#
|
|
|
|
;; Regression testing for the installation library. Works by
|
|
;; installing a set of packages with two different versions of the
|
|
;; library and checking that both install the same files, with the
|
|
;; same attributes. Every package is installed successively with a
|
|
;; different set of options, specified below.
|
|
|
|
;; $Id: test-install-lib.scm,v 1.1 2004/09/20 17:42:31 michel-schinz Exp $
|
|
|
|
(define options-set
|
|
'(()
|
|
("--layout" "fhs")))
|
|
|
|
;; Utilities
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax unless
|
|
(syntax-rules ()
|
|
((unless cond body1 ...)
|
|
(if (not cond) (begin body1 ...)))))
|
|
|
|
;; Temporary directories management
|
|
|
|
(define (delete-directory-and-contents dir)
|
|
(run (rm -rf ,(directory-as-file-name dir))))
|
|
|
|
(define (create-temp-directory)
|
|
(temp-file-iterate (lambda (dir) (create-directory dir) dir)
|
|
"/var/tmp/tmp.~a"))
|
|
|
|
(define (call-with-temporary-directory proc)
|
|
(let ((temp-dir (create-temp-directory)))
|
|
(proc temp-dir)
|
|
(delete-directory-and-contents temp-dir)))
|
|
|
|
(define (with-temporary-directory* thunk)
|
|
(call-with-temporary-directory (lambda (dir) (with-cwd dir (thunk)))))
|
|
|
|
(define-syntax with-temporary-directory
|
|
(syntax-rules ()
|
|
((with-temporary-directory body ...)
|
|
(with-temporary-directory* (lambda () body ...)))))
|
|
|
|
(define-syntax let-temporary-directories
|
|
(syntax-rules ()
|
|
((let-temporary-directories () body ...)
|
|
(begin body ...))
|
|
((let-temporary-directories (i1 i2 ...) body ...)
|
|
(call-with-temporary-directory
|
|
(lambda (i1) (let-temporary-directories (i2 ...) body ...))))))
|
|
|
|
(define (create-temp-symlink old-name)
|
|
(temp-file-iterate (lambda (l) (create-symlink old-name l) l)))
|
|
|
|
;; Logging
|
|
|
|
(define (log msg . args)
|
|
(apply format #t msg args))
|
|
|
|
(define error-count 0)
|
|
|
|
(define (log-error msg . args)
|
|
(set! error-count (+ 1 error-count))
|
|
(apply log msg args))
|
|
|
|
(define (log-notice msg . args)
|
|
(apply log msg args))
|
|
|
|
|
|
;; Main program
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (single-subdirectory)
|
|
(let ((all-files (directory-files)))
|
|
(if (and (= (length all-files) 1) (file-directory? (first all-files)))
|
|
(first all-files)
|
|
(begin
|
|
(log-error "more than one file in directory ~a: ~a\n"
|
|
(cwd)
|
|
all-files)
|
|
#f))))
|
|
|
|
(define (install-install-lib archive bin-dir prefix)
|
|
(with-temporary-directory
|
|
(run (tar --extract --gzip --file ,archive))
|
|
(with-cwd (single-subdirectory)
|
|
(run (./install.scm --bindir ,bin-dir --prefix ,prefix)))))
|
|
|
|
(define (install-package archive bin-dir prefix options)
|
|
(with-temporary-directory
|
|
(run (tar --extract --gzip --file ,archive))
|
|
(with-cwd (single-subdirectory)
|
|
(run (,(absolute-file-name "scsh-install-pkg" bin-dir)
|
|
--no-user-defaults
|
|
--prefix ,prefix
|
|
,@options)
|
|
(> /dev/null)))))
|
|
|
|
(define (sorted-directory-files dir)
|
|
(sort-list (map (cut absolute-file-name <> dir) (directory-files dir))
|
|
string<?))
|
|
|
|
(define (compare-file-kind f1 i1 f2 i2 mismatch-handler)
|
|
(unless (eq? (file-info:type i1) (file-info:type i2))
|
|
(mismatch-handler f1 f2 'type)))
|
|
|
|
(define (compare-file-mode f1 i1 f2 i2 mismatch-handler)
|
|
(unless (= (file-info:mode i1) (file-info:mode i2))
|
|
(mismatch-handler f1 f2 'mode)))
|
|
|
|
(define (compare-file-contents f1 i1 f2 i2 mismatch-handler)
|
|
(unless (and (= (file-info:size i1) (file-info:size i2))
|
|
(zero? (run (diff -q ,f1 ,f2) (> /dev/null))))
|
|
(mismatch-handler f1 f2 'contents)))
|
|
|
|
(define (compare-directories dir1 dir2 mismatch-handler)
|
|
(for-each (lambda (f1 f2)
|
|
(unless (string=? (file-name-nondirectory f1)
|
|
(file-name-nondirectory f2))
|
|
(mismatch-handler f1 f2 'name))
|
|
(let ((i1 (file-info f1 #f)) (i2 (file-info f2 #f)))
|
|
(compare-file-kind f1 i1 f2 i2 mismatch-handler)
|
|
(cond ((file-info-regular? i1)
|
|
(compare-file-mode f1 i1 f2 i2 mismatch-handler)
|
|
(compare-file-contents f1 i1 f2 i2 mismatch-handler))
|
|
((file-info-directory? i1)
|
|
(compare-file-mode f1 i1 f2 i2 mismatch-handler)
|
|
(compare-directories f1 f2 mismatch-handler))
|
|
((file-info-symlink? i1)
|
|
)
|
|
(else
|
|
(mismatch-handler f1 f2 'unknown)))))
|
|
(sorted-directory-files dir1)
|
|
(sorted-directory-files dir2)))
|
|
|
|
(define (permissions->string perms)
|
|
(let ((decode (lambda (mask str)
|
|
(if (zero? (bitwise-and perms mask)) "-" str))))
|
|
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
|
|
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
|
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
|
|
|
(define (get-characteristic file characteristic)
|
|
(case characteristic
|
|
((name)
|
|
(string-append "name = " file))
|
|
((mode)
|
|
(string-append "mode = " (permissions->string (file-mode file))))
|
|
((type)
|
|
(string-append "type = " (file-type file)))
|
|
((contents)
|
|
"contents")
|
|
(else
|
|
"unknown characteristic")))
|
|
|
|
(define (log-mismatch ref-file tst-file reason)
|
|
(log-error "difference found for file ~a:\n reference: ~a\n to-test: ~a\n"
|
|
(string-take-right ref-file
|
|
(string-suffix-length ref-file tst-file))
|
|
(get-characteristic ref-file reason)
|
|
(get-characteristic tst-file reason)))
|
|
|
|
(define (test-install-lib ref-archive tst-archive . pkg-archives)
|
|
(let-temporary-directories (ref-bin-dir
|
|
ref-iprefix-dir
|
|
tst-bin-dir
|
|
tst-iprefix-dir)
|
|
(log-notice "Installing reference library...\n")
|
|
(install-install-lib ref-archive ref-bin-dir ref-iprefix-dir)
|
|
(log-notice "Installing test library...\n")
|
|
(install-install-lib tst-archive tst-bin-dir tst-iprefix-dir)
|
|
(for-each
|
|
(lambda (options)
|
|
(log-notice "\nTesting with options: ~a\n" options)
|
|
(for-each
|
|
(lambda (pkg-archive)
|
|
(log-notice " ~a: " (file-name-nondirectory pkg-archive))
|
|
(let-temporary-directories (ref-prefix-dir tst-prefix-dir)
|
|
(let ((link (create-temp-symlink ref-prefix-dir)))
|
|
(log-notice "[ref]")
|
|
(install-package pkg-archive ref-bin-dir link options)
|
|
(create-symlink tst-prefix-dir link #t)
|
|
(log-notice "[test]")
|
|
(install-package pkg-archive tst-bin-dir link options)
|
|
(delete-file link))
|
|
(log-notice "[compare]\n")
|
|
(compare-directories ref-prefix-dir tst-prefix-dir log-mismatch)))
|
|
pkg-archives))
|
|
options-set)))
|
|
|
|
(define (main cmd-line)
|
|
(let ((prog (car cmd-line))
|
|
(args (cdr cmd-line)))
|
|
(if (>= (length args) 3)
|
|
(begin
|
|
(apply test-install-lib (map absolute-file-name args))
|
|
(if (zero? error-count)
|
|
(begin
|
|
(log-notice "\nTest succeeded.\n")
|
|
(exit 0))
|
|
(begin
|
|
(log-notice "\nTest failed with ~a error~a.\n"
|
|
error-count
|
|
(if (> error-count 1) "s" ""))
|
|
(exit 1))))
|
|
(begin
|
|
(format #t "Usage: ~a <reference> <to-test> <pkg_1> ...\n" prog)
|
|
(exit 1)))))
|