scsh-conservatory
/
scsh-install-lib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- first attempt at a regression test for the installation library

This commit is contained in:
michel-schinz 2004-09-20 17:42:31 +00:00
parent c1c3d8211e
commit 2308badf7a
2 changed files with 249 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
test/fetch-test-packages.scm Executable file
View File

@ -0,0 +1,38 @@
#!/bin/sh
exec scsh -o thread-fluids -s "$0" "$@"
!#
;; Fetch (via HTTP) the various packages needed to test the
;; installation library. Requires either curl or wget.
(define pkg-dir "pkgs")
(define pkgs
'(("http://savannah.nongnu.org/download/sunterlib/" .
"sunterlib-0.7.tar.gz")
("ftp://ftp.scsh.net/pub/scsh/packages/scx/" .
"scx-0.2.tar.gz")))
(define fetch-url
(let ((path (thread-fluid exec-path-list)))
(cond ((exec-path-search "curl" path)
(lambda (url) (run (curl --silent --remote-name ,url))))
((exec-path-search "wget" path)
(lambda (url) (run (wget --passive-ftp --quiet ,url))))
(else
(error "this script needs either curl or wget to work...")))))
(if (file-not-exists? pkg-dir)
(create-directory pkg-dir))
(for-each
(lambda (pkg)
(let ((pkg-url (car pkg))
(pkg-file (cdr pkg)))
(if (file-not-exists? (absolute-file-name pkg-file pkg-dir))
(begin
(format #t "Fetching ~a..." pkg-file)
(with-cwd pkg-dir
(fetch-url (string-append pkg-url pkg-file)))
(format #t "done\n")))))
pkgs)

211
test/test-install-lib.scm Executable file
View File

@ -0,0 +1,211 @@
#!/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)))))