1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
;;;; load.test --- test LOAD and path searching functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2006, 2010, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-load)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile))
(define temp-dir (data-file-name "load-test.dir"))
(define (create-tree parent tree)
(let loop ((parent parent)
(tree tree))
(if (pair? tree)
(let ((elt (car tree)))
(cond
;; A string means to create an empty file with that name.
((string? elt)
(close-port (open-file (string-append parent "/" elt) "w")))
;; A list means to create a directory, and then create files
;; within it.
((pair? elt)
(let ((dirname (string-append parent "/" (car elt))))
(mkdir dirname)
(loop dirname (cdr elt))))
(else
(error "create-tree: bad tree structure")))
(loop parent (cdr tree))))))
(define (delete-tree tree)
(cond
((file-is-directory? tree)
(let ((dir (opendir tree)))
(let loop ()
(let ((entry (readdir dir)))
(cond
((member entry '("." ".."))
(loop))
((not (eof-object? entry))
(let ((name (string-append tree "/" entry)))
(delete-tree name)
(loop))))))
(closedir dir)
(rmdir tree)))
((file-exists? tree)
(delete-file tree))
(else
(error "delete-tree: can't delete " tree))))
(define (try-search-with-extensions path input extensions expected)
(let ((test-name (call-with-output-string
(lambda (port)
(display "search-path for " port)
(write input port)
(if (pair? extensions)
(begin
(display " with extensions " port)
(write extensions port)))
(display " yields " port)
(write expected port)))))
(let ((result (search-path path input extensions)))
(pass-if test-name
(equal? (if (string? expected)
(string-append temp-dir "/" expected)
expected)
result)))))
(define (try-search path input expected)
(try-search-with-extensions path input '() expected))
;; Create a bunch of files for use in testing.
(mkdir temp-dir)
(create-tree temp-dir
'(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm"
("subdir1"))
("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss")
("dir3" "ugly.scm" "ugly.ss.scm")))
;; Try some searches without extensions.
(define path (list
(string-append temp-dir "/dir1")
(string-append temp-dir "/dir2")
(string-append temp-dir "/dir3")))
(try-search path "foo.scm" "dir1/foo.scm")
(try-search path "bar.scm" "dir1/bar.scm")
(try-search path "baz.scm" "dir2/baz.scm")
(try-search path "baz.ss" "dir2/baz.ss")
(try-search path "ugly.scm" "dir3/ugly.scm")
(try-search path "subdir1" #f)
(define extensions '(".ss" ".scm" ""))
(try-search-with-extensions path "foo" extensions "dir1/foo.scm")
(try-search-with-extensions path "bar" extensions "dir1/bar.scm")
(try-search-with-extensions path "baz" extensions "dir2/baz.ss")
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
(try-search-with-extensions path "ugly.ss" extensions #f)
;; Check that search-path accepts Elisp nil-terminated lists for
;; PATH and EXTENSIONS.
(with-test-prefix "elisp-nil"
(set-cdr! (last-pair path)
#nil)
(set-cdr! (last-pair extensions) #nil)
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
(try-search-with-extensions path "ugly.ss" extensions #f))
(with-test-prefix "return value of `load'"
(let ((temp-file (in-vicinity temp-dir "foo.scm")))
(call-with-output-file temp-file
(lambda (port)
(write '(+ 2 3) port)
(newline port)))
(pass-if "primitive-load"
(equal? 5 (primitive-load temp-file)))
(let ((temp-compiled-file (in-vicinity temp-dir "foo.go")))
(compile-file temp-file #:output-file temp-compiled-file)
(pass-if "load-compiled"
(equal? 5 (load-compiled temp-compiled-file))))))
(delete-tree temp-dir)
|
