Commit | Line | Data |
---|---|---|
f91cb909 JB |
1 | ;;;; load.test --- test LOAD and path searching functions -*- scheme -*- |
2 | ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 | |
3 | ;;;; | |
017eb4a6 | 4 | ;;;; Copyright (C) 1999, 2001, 2006, 2010, 2012 Free Software Foundation, Inc. |
f91cb909 | 5 | ;;;; |
53befeb7 NJ |
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. | |
f91cb909 | 10 | ;;;; |
53befeb7 | 11 | ;;;; This library is distributed in the hope that it will be useful, |
f91cb909 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
f91cb909 | 15 | ;;;; |
53befeb7 NJ |
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 | |
f91cb909 | 19 | |
8aa28a91 | 20 | (define-module (test-suite test-load) |
017eb4a6 AW |
21 | #:use-module (test-suite lib) |
22 | #:use-module (test-suite guile-test) | |
23 | #:use-module (system base compile)) | |
f91cb909 | 24 | |
c685b42f | 25 | (define temp-dir (data-file-name "load-test.dir")) |
f91cb909 JB |
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) | |
f91cb909 JB |
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))) | |
f91cb909 JB |
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 | ||
92a61010 AW |
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) | |
123 | #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)) | |
bbd26b5a | 127 | |
017eb4a6 AW |
128 | (with-test-prefix "return value of `load'" |
129 | (let ((temp-file (in-vicinity temp-dir "foo.scm"))) | |
130 | (call-with-output-file temp-file | |
131 | (lambda (port) | |
132 | (write '(+ 2 3) port) | |
133 | (newline port))) | |
134 | (pass-if "primitive-load" | |
135 | (equal? 5 (primitive-load temp-file))) | |
136 | (let ((temp-compiled-file (in-vicinity temp-dir "foo.go"))) | |
137 | (compile-file temp-file #:output-file temp-compiled-file) | |
138 | (pass-if "load-compiled" | |
139 | (equal? 5 (load-compiled temp-compiled-file)))))) | |
140 | ||
f91cb909 | 141 | (delete-tree temp-dir) |