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