test-suite/tests/load.test

   1 ;;;; load.test --- test LOAD and path searching functions  -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
   3 ;;;;
   4 ;;;;    Copyright (C) 1999 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  19 ;;;; Boston, MA 02111-1307 USA
  20
  21 (use-modules (test-suite lib))
  22
  23 (define temp-dir (tmpnam))
  24
  25 (define (create-tree parent tree)
  26   (let loop ((parent parent)
  27              (tree tree))
  28     (if (pair? tree)
  29         (let ((elt (car tree)))
  30           (cond
  31
  32            ;; A string means to create an empty file with that name.
  33            ((string? elt)
  34             (close-port (open-file (string-append parent "/" elt) "w")))
  35
  36            ;; A list means to create a directory, and then create files
  37            ;; within it.
  38            ((pair? elt)
  39             (let ((dirname (string-append parent "/" (car elt))))
  40               (mkdir dirname)
  41               (loop dirname (cdr elt))))
  42
  43            (else
  44             (error "create-tree: bad tree structure")))
  45
  46           (loop parent (cdr tree))))))
  47
  48 (define (delete-tree tree)
  49   (cond
  50    ((file-is-directory? tree)
  51     (let ((dir (opendir tree)))
  52       (let loop ()
  53         (let ((entry (readdir dir)))
  54           (cond
  55            ((member entry '("." ".."))
  56             (loop))
  57            ((not (eof-object? entry))
  58             (let ((name (string-append tree "/" entry)))
  59               (delete-tree name)
  60               (loop))))))
  61       (closedir dir)
  62       (rmdir tree)))
  63    ((file-exists? tree)
  64     (delete-file tree))
  65    (else
  66     (error "delete-tree: can't delete " tree))))
  67
  68 (define (try-search-with-extensions path input extensions expected)
  69   (let ((test-name (call-with-output-string
  70                     (lambda (port)
  71                       (display "search-path for " port)
  72                       (write input port)
  73                       (if (pair? extensions)
  74                           (begin
  75                             (display " with extensions " port)
  76                             (write extensions port)))
  77                       (display " yields " port)
  78                       (write expected port)))))
  79     (let ((result (search-path path input extensions)))
  80       (pass-if test-name
  81                (equal? (if (string? expected)
  82                            (string-append temp-dir "/" expected)
  83                            expected)
  84                        result)))))
  85
  86 (define (try-search path input expected)
  87   (try-search-with-extensions path input '() expected))
  88
  89 ;; Create a bunch of files for use in testing.
  90 (mkdir temp-dir)
  91 (create-tree temp-dir
  92              '(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm"
  93                 ("subdir1"))
  94                ("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss")
  95                ("dir3" "ugly.scm" "ugly.ss.scm")))
  96
  97 ;; Try some searches without extensions.
  98 (define path (list
  99               (string-append temp-dir "/dir1")
 100               (string-append temp-dir "/dir2")
 101               (string-append temp-dir "/dir3")))
 102
 103 (try-search path "foo.scm"  "dir1/foo.scm")
 104 (try-search path "bar.scm"  "dir1/bar.scm")
 105 (try-search path "baz.scm"  "dir2/baz.scm")
 106 (try-search path "baz.ss"   "dir2/baz.ss")
 107 (try-search path "ugly.scm" "dir3/ugly.scm")
 108 (try-search path "subdir1"  #f)
 109
 110 (define extensions '(".ss" ".scm" ""))
 111 (try-search-with-extensions path "foo"      extensions "dir1/foo.scm")
 112 (try-search-with-extensions path "bar"      extensions "dir1/bar.scm")
 113 (try-search-with-extensions path "baz"      extensions "dir2/baz.ss")
 114 (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
 115 (try-search-with-extensions path "ugly.ss"  extensions #f)
 116
 117 (delete-tree temp-dir)