From 2308badf7a031c0b4b7bb83ddf3a525965afa1d5 Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Mon, 20 Sep 2004 17:42:31 +0000 Subject: [PATCH] - first attempt at a regression test for the installation library --- test/fetch-test-packages.scm | 38 +++++++ test/test-install-lib.scm | 211 +++++++++++++++++++++++++++++++++++ 2 files changed, 249 insertions(+) create mode 100755 test/fetch-test-packages.scm create mode 100755 test/test-install-lib.scm diff --git a/test/fetch-test-packages.scm b/test/fetch-test-packages.scm new file mode 100755 index 0000000..fd4ff1f --- /dev/null +++ b/test/fetch-test-packages.scm @@ -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) diff --git a/test/test-install-lib.scm b/test/test-install-lib.scm new file mode 100755 index 0000000..6039f52 --- /dev/null +++ b/test/test-install-lib.scm @@ -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 /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 ...\n" prog) + (exit 1)))))