From f88819accc06f5a98e2e906d981a2c7f3559e53c Mon Sep 17 00:00:00 2001
From: michel-schinz <michel-schinz>
Date: Sun, 14 Nov 2004 14:14:52 +0000
Subject: [PATCH] *** empty log message ***

---
 scheme/pkg-checker/scsh-test-pkg | 375 +++++++++++++++++++++++++++++++
 1 file changed, 375 insertions(+)
 create mode 100755 scheme/pkg-checker/scsh-test-pkg

diff --git a/scheme/pkg-checker/scsh-test-pkg b/scheme/pkg-checker/scsh-test-pkg
new file mode 100755
index 0000000..484f47d
--- /dev/null
+++ b/scheme/pkg-checker/scsh-test-pkg
@@ -0,0 +1,375 @@
+#!/bin/sh
+exec scsh -o let-opt -o sort -o srfi-26 -o thread-fluids -e main -s "$0" "$@"
+!#
+
+;; Test a scsh package (either stand-alone or composed of two
+;; archives) by checking that is conforms to the rules given in the
+;; proposal.
+
+;; $Id: scsh-test-pkg,v 1.1 2004/11/14 14:14:52 michel-schinz Exp $
+
+; TODO have a way to give a log file
+
+(define valid-extensions '(".tar" ".tar.gz" ".tar.bz2"))
+
+;;; Utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string->version str)
+  (map string->number ((infix-splitter ".") str)))
+
+(define (version->string v)
+  (string-join (map number->string v) "."))
+
+(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 (paths->file-name . paths)
+  (path-list->file-name paths))
+
+(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-temp-directory proc)
+  (let ((temp-dir (create-temp-directory)))
+    (proc temp-dir)
+    (delete-directory-and-contents temp-dir)))
+
+(define (with-temp-directory* thunk)
+  (call-with-temp-directory (lambda (dir) (with-cwd dir (thunk)))))
+
+(define-syntax with-temp-directory
+  (syntax-rules ()
+    ((with-temp-directory body ...)
+     (with-temp-directory* (lambda () body ...)))))
+
+(define-syntax let-temp-directories
+  (syntax-rules ()
+    ((let-temp-directories () body ...)
+     (begin body ...))
+    ((let-temp-directories (i1 i2 ...) body ...)
+     (call-with-temp-directory
+      (lambda (i1) (let-temp-directories (i2 ...) body ...))))))
+
+(define-syntax when
+  (syntax-rules ()
+    ((when cond body1 ...)
+     (if cond (begin body1 ...)))))
+
+(define-syntax unless
+  (syntax-rules ()
+    ((unless cond body1 ...)
+     (if (not cond) (begin body1 ...)))))
+
+(define (dir-for-each f dir)
+  (for-each (lambda (thing)
+              (f thing)
+              (if (file-directory? thing #f)
+                  (dir-for-each f (absolute-file-name thing dir))))
+            (directory-files dir)))
+
+(define (directory-contents dir)
+  (with-cwd dir
+    (append-map (lambda (path)
+                  (if (file-directory? path #f)
+                      (cons path
+                            (map (cut absolute-file-name <> path)
+                                 (directory-contents path)))
+                      (list path)))
+                (directory-files))))
+
+(define (take-max lst len ellipsis)
+  (if (zero? len)
+      (if (null? lst) lst (list ellipsis))
+      (cons (car lst) (take-max (cdr lst) (- len 1) ellipsis))))
+
+;; Package name parsing
+
+(define pkg-name-rx
+  (rx (w/nocase alphabetic (* (| "-" alphanumeric)))))
+
+(define pkg-version-rx
+  (rx (+ digit) (* "." (+ digit))))
+
+(define pkg-full-name-rx
+  (rx (submatch ,pkg-name-rx) "-" (submatch ,pkg-version-rx)))
+
+(define (parse-pkg-full-name full-name)
+  (let-match (regexp-search pkg-full-name-rx full-name) (#f pkg-name pkg-vers)
+             (list pkg-name pkg-vers)))
+
+;; Interface with TAR
+
+(define (tar-decompress-option archive)
+  (let ((archive-ext (string-downcase (file-name-extension archive))))
+    (cond ((string=? archive-ext ".gz")  '(--gzip))
+          ((string=? archive-ext ".bz2") '(--bzip2))
+          (else '()))))
+
+(define (tar-unpack! archive)
+  (run (tar --extract ,@(tar-decompress-option archive) --file ,archive)))
+
+(define (tar-file-list archive)
+  (run/strings (tar --list ,@(tar-decompress-option archive) --file ,archive)))
+
+;; Directory comparison
+
+(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 (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")))
+
+;;; Logging
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (display* . args)
+  (for-each (cut display <> (current-output-port)) args))
+
+(define (log . args)
+  (apply display* args)
+  (newline))
+
+(define log-info log)
+
+(define error-count 0)
+
+(define (log-error . args)
+  (apply log "Error: " args)
+  (set! error-count (+ 1 error-count)))
+
+(define (log-check . args)
+  (apply log "Checking " args))
+
+;;; Tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (pkg-full-name name version)
+  (string-append name "-" (version->string version)))
+
+(define test-layout
+  '(lambda (pkg)
+     (let ((pkg-full-name (package-full-name pkg)))
+       `((base        . ,pkg-full-name)
+         (misc-shared . ,pkg-full-name)
+         (scheme      . ,(paths->file-name pkg-full-name "scheme"))
+         (lib         . ,(paths->file-name pkg-full-name "lib"))
+         (doc         . ,(paths->file-name pkg-full-name "doc"))
+         (active      . ".")))))
+
+(define (base-location pkg-dir) pkg-dir)
+(define (doc-location pkg-dir) (absolute-file-name "doc" pkg-dir))
+
+(define (layout->string layout)
+  (call-with-string-output-port (lambda (port) (write layout port))))
+
+(define (valid-archive-names base-name)
+  (map (cut string-append base-name <>) valid-extensions))
+
+(define (check-archive-name base-name archive-name)
+  (let ((valid-names (valid-archive-names base-name)))
+    (unless (member archive-name valid-names)
+            (log-error "invalid archive name "archive-name"\n"
+                       "  should be one of: "(string-join valid-names ", ")))))
+
+(define (check-archive-contents name version archive)
+  (let ((top-dir-name (pkg-full-name name version))
+        (archive-files (map simplify-file-name (tar-file-list archive))))
+    (for-each (lambda (req-file)
+                (unless (member req-file archive-files)
+                        (log-error "required file "req-file" not found "
+                                   "in archive")))
+              (map (cut absolute-file-name <> top-dir-name)
+                   '("pkg-def.scm" "README" "COPYING")))
+    (for-each
+     (lambda (name)
+       (let ((dir-name (first (split-file-name name))))
+         (unless (string=? dir-name top-dir-name)
+                 (log-error "archive file "name" not in correct directory"
+                            "\n(should be: "top-dir-name")"))))
+     archive-files)))
+
+(define (check-dir-file dir sub-dir file)
+  (let ((abs-sub-dir (absolute-file-name sub-dir dir)))
+    (when (and (file-exists? abs-sub-dir)
+               (file-not-exists? (absolute-file-name file abs-sub-dir)))
+          (log-error "directory "abs-sub-dir" exists, but it doesn't contain\n"
+                     "required file "file))))
+
+;; Check that the installed files have the appropriate names.
+(define (check-installation-names pkg-name pkg-root)
+  (check-dir-file (base-location pkg-root) "." "load.scm")
+  (let ((doc (doc-location pkg-root)))
+    (check-dir-file doc "html" "index.html")
+    (check-dir-file doc "pdf" (string-append pkg-name ".pdf"))
+    (check-dir-file doc "ps" (string-append pkg-name ".ps"))))
+
+(define (for-all-contents f dir)
+  (for-each (lambda (thing)
+              (f thing)
+              (if (file-directory? thing)
+                  (for-all-contents f thing)))
+            (map (cut absolute-file-name <> dir) (directory-files dir))))
+
+(define (check-installation-protections pkg-root)
+  (for-all-contents
+   (lambda (file)
+     (let* ((info (file-info file))
+            (fnd-perms (file-info:mode info))
+            (req-perms (cond ((file-info-regular? info) #o444)
+                             ((file-info-directory? info) #o555)
+                             (else 0))))
+     (unless (= req-perms (bitwise-and req-perms fnd-perms))
+             (log-error "insufficient permissions for file "file"\n"
+                        "  required: "(permissions->string req-perms)"\n"
+                        "     found: "(permissions->string fnd-perms)))))
+   pkg-root))
+
+(define (check-installation main-pkg-full-name prefix-dir)
+  (with-cwd prefix-dir
+    (let ((all-dirs (filter (cut file-directory? <> #f) (directory-files))))
+      (unless (member main-pkg-full-name all-dirs)
+              (log-error "expected at least one directory called "
+                         main-pkg-full-name" to be installed\n"
+                         "  only found: "(string-join all-dirs ", ")))
+      (for-each (lambda (pkg-dir)
+                  (let ((abs-pkg-dir (absolute-file-name pkg-dir))
+                        (pkg-name (first (parse-pkg-full-name pkg-dir))))
+                    (check-installation-names pkg-name abs-pkg-dir)
+                    (check-installation-protections abs-pkg-dir)))
+                all-dirs))))
+
+(define (install-pkg installer pkg-full-name archives prefix options)
+  (with-temp-directory
+   (for-each tar-unpack! archives)
+   (with-cwd pkg-full-name
+     (unless (zero? (run (,installer --no-user-defaults
+                                     --layout ,(layout->string test-layout)
+                                     --prefix ,prefix
+                                     ,@options)
+                         (> /dev/null)))
+       (log-error "unsuccessful installation")))))
+
+(define (log-dest-dir-mismatch file-normal file-dest-dir characteristic)
+  (log-error "difference between file installed with and without --dest-dir\n"
+             "  file: ~a\n"
+             "  without --dest-dir: ~a\n"
+             "     with --dest-dir: ~a\n"
+             file-normal
+             (get-characteristic file-normal characteristic)
+             (get-characteristic file-dest-dir characteristic)))
+
+(define (test-pkg name version main-archive pkg-archive)
+  (let ((full-name (pkg-full-name name version))
+        (all-archives (delete #f (list main-archive pkg-archive)))
+        (sip (exec-path-search "scsh-install-pkg"
+                               (thread-fluid exec-path-list))))
+    (unless (zero? (run (,sip --version) (> /dev/null)))
+            (error "need at least install-lib 1.2.0"))
+    (log-info "Using scsh-install-pkg executable: "sip"\n"
+              "  ("(string-trim-right (run/string (,sip --version)))")")
+    (log-check "archive name")
+    (check-archive-name full-name (file-name-nondirectory main-archive))
+    (if pkg-archive
+        (check-archive-name (string-append "pkg_" full-name)
+                            (file-name-nondirectory pkg-archive)))
+    (log-check "archive contents")
+    (for-each (cut check-archive-contents name version <>) all-archives)
+    (let-temp-directories (ref-dir tst-dir)
+      (log-check "basic installation")
+      (install-pkg sip full-name all-archives ref-dir '())
+      (check-installation full-name ref-dir)
+      (log-check "installation with --dest-dir")
+      (install-pkg sip full-name all-archives ref-dir `(--dest-dir ,tst-dir))
+      (compare-directories ref-dir tst-dir log-dest-dir-mismatch))
+    (log-check "installation with --dry-run")
+    (let-temp-directories (empty-dir)
+      (install-pkg sip full-name all-archives empty-dir `(--dry-run))
+      (let ((contents (directory-contents empty-dir)))
+        (unless (null? contents)
+                (log-error "no files should have been installed, but the "
+                           "following were:\n  "
+                           (string-join (take-max contents 3 "...") ", ")))))))
+
+;   (log-check "installation with --non-shared-only")
+;   (do-test check-non-shared-installation main-archive pkg-archive))
+
+
+(define (display-usage-then-exit prog)
+  (format #t
+          "Usage: ~a <pkg-name> <pkg-version> <main-archive> [<pkg-archive>]\n"
+          prog)
+  (exit 1))
+
+(define (main cmd-line)
+  (let ((prog (car cmd-line))
+        (args (cdr cmd-line)))
+    (if (<= 3 (length args) 4)
+        (test-pkg (first args)
+                  (string->version (second args))
+                  (absolute-file-name (third args))
+                  (and (> (length args) 3)
+                       (absolute-file-name (fourth args))))
+        (display-usage-then-exit (file-name-nondirectory prog)))
+    (if (zero? error-count)
+        (display "Test passed.\n")
+        (begin
+          (display* "Test failed "
+                    "("error-count" error"(if (= 1 error-count) "" "s")")\n")
+          (exit 1)))))
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End: