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, 2001, 2006 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., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-load)
  22   :use-module (test-suite lib)
  23   :use-module (test-suite guile-test))
  24
  25 (define temp-dir (data-file-name "load-test.dir"))
  26
  27 (define (create-tree parent tree)
  28   (let loop ((parent parent)
  29              (tree tree))
  30     (if (pair? tree)
  31         (let ((elt (car tree)))
  32           (cond
  33
  34            ;; A string means to create an empty file with that name.
  35            ((string? elt)
  36             (close-port (open-file (string-append parent "/" elt) "w")))
  37
  38            ;; A list means to create a directory, and then create files
  39            ;; within it.
  40            ((pair? elt)
  41             (let ((dirname (string-append parent "/" (car elt))))
  42               (mkdir dirname)
  43               (loop dirname (cdr elt))))
  44
  45            (else
  46             (error "create-tree: bad tree structure")))
  47
  48           (loop parent (cdr tree))))))
  49
  50 (define (delete-tree tree)
  51   (cond
  52    ((file-is-directory? tree)
  53     (let ((dir (opendir tree)))
  54       (let loop ()
  55         (let ((entry (readdir dir)))
  56           (cond
  57            ((member entry '("." ".."))
  58             (loop))
  59            ((not (eof-object? entry))
  60             (let ((name (string-append tree "/" entry)))
  61               (delete-tree name)
  62               (loop))))))
  63       (closedir dir)
  64       (rmdir tree)))
  65    ((file-exists? tree)
  66     (delete-file tree))
  67    (else
  68     (error "delete-tree: can't delete " tree))))
  69
  70 (define (try-search-with-extensions path input extensions expected)
  71   (let ((test-name (call-with-output-string
  72                     (lambda (port)
  73                       (display "search-path for " port)
  74                       (write input port)
  75                       (if (pair? extensions)
  76                           (begin
  77                             (display " with extensions " port)
  78                             (write extensions port)))
  79                       (display " yields " port)
  80                       (write expected port)))))
  81     (let ((result (search-path path input extensions)))
  82       (pass-if test-name
  83                (equal? (if (string? expected)
  84                            (string-append temp-dir "/" expected)
  85                            expected)
  86                        result)))))
  87
  88 (define (try-search path input expected)
  89   (try-search-with-extensions path input '() expected))
  90
  91 ;; Create a bunch of files for use in testing.
  92 (mkdir temp-dir)
  93 (create-tree temp-dir
  94              '(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm"
  95                 ("subdir1"))
  96                ("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss")
  97                ("dir3" "ugly.scm" "ugly.ss.scm")))
  98
  99 ;; Try some searches without extensions.
 100 (define path (list
 101               (string-append temp-dir "/dir1")
 102               (string-append temp-dir "/dir2")
 103               (string-append temp-dir "/dir3")))
 104
 105 (try-search path "foo.scm"  "dir1/foo.scm")
 106 (try-search path "bar.scm"  "dir1/bar.scm")
 107 (try-search path "baz.scm"  "dir2/baz.scm")
 108 (try-search path "baz.ss"   "dir2/baz.ss")
 109 (try-search path "ugly.scm" "dir3/ugly.scm")
 110 (try-search path "subdir1"  #f)
 111
 112 (define extensions '(".ss" ".scm" ""))
 113 (try-search-with-extensions path "foo"      extensions "dir1/foo.scm")
 114 (try-search-with-extensions path "bar"      extensions "dir1/bar.scm")
 115 (try-search-with-extensions path "baz"      extensions "dir2/baz.ss")
 116 (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
 117 (try-search-with-extensions path "ugly.ss"  extensions #f)
 118
 119 (if (defined? '%nil)
 120     ;; Check that search-path accepts Elisp nil-terminated lists for
 121     ;; PATH and EXTENSIONS.
 122     (with-test-prefix "elisp-nil"
 123       (set-cdr! (last-pair path) %nil)
 124       (set-cdr! (last-pair extensions) %nil)
 125       (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
 126       (try-search-with-extensions path "ugly.ss"  extensions #f)))
 127
 128 (delete-tree temp-dir)