1: ;;
    2: ;; Tests for subtle effects of loading and autoloading
    3: ;;
    4: 
    5: (use gauche.test)
    6: 
    7: (test-start "load")
    8: 
    9: (add-load-path ".")
   10: 
   11: ;; Some abstraction for win32... The file.util module provides
   12: ;; higher abstraction, but we're not at the stage of using it yet.
   13: 
   14: (define *win32*
   15:   ;; we can't use string-suffix? yet.
   16:   (let* ((arch (gauche-architecture))
   17:          (len  (string-length arch)))
   18:     (and (> len 7)
   19:          (string=? (substring arch (- len 7) len) "mingw32"))))
   20: 
   21: (define (P path) (sys-normalize-pathname path))
   22: 
   23: ;;----------------------------------------------------------------
   24: (test-section "require and provide")
   25: 
   26: (sys-system "rm -rf test.o")
   27: (sys-mkdir "test.o" #o777)
   28: (with-output-to-file "test.o/a.scm"
   29:   (lambda ()
   30:     (write '(provide "test.o/a"))
   31:     (newline)))
   32: 
   33: (test* "double require"
   34:        #t
   35:        (begin
   36:          (eval '(require "test.o/a") (interaction-environment))
   37:          (sys-unlink "test.o/a.scm")
   38:          (eval '(require "test.o/a") (interaction-environment))
   39:          #t))
   40: 
   41: (sys-system "rm -rf test.o")
   42: (sys-mkdir "test.o" #o777)
   43: (with-output-to-file "test.o/b.scm"
   44:   (lambda ()
   45:     (write '(require "test.o/c"))
   46:     (write '(provide "test.o/b"))
   47:     (newline)))
   48: (with-output-to-file "test.o/c.scm"
   49:   (lambda ()
   50:     (write '(require "test.o/b"))
   51:     (write '(provide "test.o/c"))
   52:     (newline)))
   53: 
   54: (test* "detecting loop of require"
   55:        *test-error*
   56:        (eval '(require "test.o/b") (interaction-environment)))
   57: 
   58: (sys-system "rm -rf test.o")
   59: (sys-mkdir "test.o" #o777)
   60: (with-output-to-file "test.o/d.scm"
   61:   (lambda ()
   62:     (display "(define z 0)(")
   63:     (newline)))
   64: 
   65: (test "reload after error"
   66:       1
   67:       (lambda ()
   68:         (with-error-handler
   69:          (lambda (e) #t)
   70:          (lambda ()
   71:            (eval '(require "test.o/d") (interaction-environment))))
   72:         (with-output-to-file "test.o/d.scm"
   73:           (lambda ()
   74:             (write '(define z 1))
   75:             (write '(provide "tset.o/d"))))
   76:         (eval '(require "test.o/d") (interaction-environment))
   77:         (eval 'z (interaction-environment))))
   78: 
   79: ;; :environment arg -------------------------------------
   80: (test-section "load environment")
   81: 
   82: (with-output-to-file "test.o/d.scm"
   83:   (lambda ()
   84:     (display "(define foo 3)")))
   85: (define-module load.test )
   86: (define foo 8)
   87: 
   88: (test* ":environment argument"
   89:       3
   90:       (begin
   91:         (load "test.o/d" :environment (find-module 'load.test))
   92:         (with-module load.test foo)))
   93: 
   94: ;; a compicated case involving eval, load and restoration of environment.
   95: ;; this is actually testing code in Scm_VMEval, but I put it here
   96: ;; since the 'eval' test is done before i/o.
   97: (with-output-to-file "test.o/d.scm"
   98:   (lambda ()
   99:     (display "(define foo 6)")))
  100: 
  101: (test* "eval & load & environment" 6
  102:        (begin
  103:          (eval '(load "test.o/d") (find-module 'load.test))
  104:          (with-module load.test foo)))
  105: 
  106: 
  107: ;; autoloading -----------------------------------------
  108: (test-section "autoload")
  109: 
  110: (with-output-to-file "test.o/l0.scm"
  111:   (lambda ()
  112:     (write '(define foo 0))))
  113: (autoload "test.o/l0" foo)
  114: (test* "autoload (file)" 0 foo)
  115: 
  116: (with-output-to-file "test.o/l1.scm"
  117:   (lambda ()
  118:     (write '(define foo 0))))
  119: (autoload "test.o/l1" foo1)
  120: (test* "autoload (file/error)" *test-error* foo1)
  121: 
  122: (with-output-to-file "test.o/l0.scm"
  123:   (lambda ()
  124:     (write '(define-module foo (extend scheme)))
  125:     (write '(load "./test.o/l1.scm" :environment (find-module 'foo)))))
  126: (with-output-to-file "test.o/l1.scm"
  127:   (lambda ()
  128:     (write '(expt 2 3))))
  129: 
  130: (test* "autoload environment" #t
  131:        (load "./test.o/l0.scm"))
  132: 
  133: (sys-system "rm -rf test.o")
  134: 
  135: ;; library utilities -----------------------------------
  136: 
  137: (test-section "libutil")
  138: 
  139: (sys-system "mkdir test.o")
  140: (sys-system #`"mkdir ,(P \"test.o/_test\")")
  141: (sys-system #`"mkdir ,(P \"test.o/_tset\")")
  142: 
  143: (with-output-to-file "test.o/_test.scm"
  144:   (lambda ()
  145:     (write '(define-module _test ))
  146:     (write '(provide "_test"))))
  147: 
  148: (with-output-to-file "test.o/_test/_test.scm"
  149:   (lambda ()
  150:     (write '(define-module _test._test ))
  151:     (write '(provide "_test/_test"))))
  152: 
  153: (with-output-to-file "test.o/_test/_test1.scm"
  154:   (lambda ()
  155:     (write '(define-module _test._test1 ))
  156:     (write '(provide "_test/_test2"))))
  157: 
  158: (with-output-to-file "test.o/_tset/_test.scm"
  159:   (lambda ()
  160:     (write '(define-module _tset._test ))
  161:     (write '(provide "_tset/_test"))))
  162: 
  163: (with-output-to-file "test.o/_tset/_test1"
  164:   (lambda ()
  165:     (write '(define-module dummy ))))
  166: 
  167: (with-output-to-file "test.o/_tset/_test2.scm"
  168:   (lambda ()
  169:     (write '(provide "_tset/_test2"))))
  170: 
  171: (test* "library-fold _test" `((_test . ,(P "test.o/_test.scm")))
  172:        (library-fold '_test acons '() :paths '("./test.o")))
  173: 
  174: (test* "library-fold _test" `(("_test" . ,(P "test.o/_test.scm")))
  175:        (library-fold "_test" acons '() :paths '("./test.o")))
  176: 
  177: (define paths-a (map P '("./test.o" "./test.o/_test" "./test.o/_tset")))
  178: (define paths-b (map P '("./test.o/_test" "./test.o" "./test.o/_tset")))
  179: 
  180: (test* "library-fold _test (multi)" `((_test . ,(P "test.o/_test.scm")))
  181:        (library-fold '_test acons '() :paths paths-a))
  182: (test* "library-fold _test (multi)" `((_test . ,(P "test.o/_test.scm")))
  183:        (library-fold '_test acons '() :paths paths-b))
  184: (test* "library-fold _test (multi)"
  185:        `(("_test" . ,(P "test.o/_test/_test.scm")))
  186:        (library-fold "_test" acons '() :paths paths-b))
  187: (test* "library-fold _test (multi)"
  188:        `(("_test" . ,(P "test.o/_tset/_test.scm"))
  189:          ("_test" . ,(P "test.o/_test.scm"))
  190:          ("_test" . ,(P "test.o/_test/_test.scm")))
  191:        (library-fold "_test" acons '() :paths paths-b
  192:                      :allow-duplicates? #t))
  193: (test* "library-fold _test (non-strict)"
  194:        `((_test . ,(P "test.o/_tset/_test.scm"))
  195:          (_test . ,(P "test.o/_test.scm"))
  196:          (_test . ,(P "test.o/_test/_test.scm")))
  197:        (library-fold '_test acons '() :paths paths-b
  198:                      :strict? #f :allow-duplicates? #t))
  199: 
  200: (test* "library-fold _test._test"
  201:        `((_test._test . ,(P "test.o/_test/_test.scm")))
  202:        (library-fold '_test._test acons '() :paths paths-b))
  203: (test* "library-fold _test/_test"
  204:        `(("_test/_test" . ,(P "test.o/_test/_test.scm")))
  205:        (library-fold "_test/_test" acons '() :paths paths-b))
  206: 
  207: ;; needs sort the result, for the order library-fold returns depends on
  208: ;; readdir(), which may be system dependent.
  209: (test* "library-fold _test.*"
  210:        `((_test._test . ,(P "test.o/_test/_test.scm"))
  211:          (_test._test1 . ,(P "test.o/_test/_test1.scm")))
  212:        (sort (library-fold '_test.* acons '() :paths paths-b)
  213:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  214: (test* "library-fold _tset.*"
  215:        `((_tset._test . ,(P "test.o/_tset/_test.scm")))
  216:        (sort (library-fold '_tset.* acons '() :paths paths-b)
  217:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  218: (test* "library-fold _tset/*"
  219:        `(("_tset/_test" . ,(P "test.o/_tset/_test.scm"))
  220:          ("_tset/_test2" . ,(P "test.o/_tset/_test2.scm")))
  221:        (sort (library-fold "_tset/*" acons '() :paths paths-b)
  222:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  223: 
  224: (test* "library-fold _test.*1"
  225:        `((_test._test1 . ,(P "test.o/_test/_test1.scm")))
  226:        (sort (library-fold '_test.*1 acons '() :paths paths-b)
  227:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  228: (test* "library-fold _*t._te*"
  229:        `((_test._test .  ,(P "test.o/_test/_test.scm"))
  230:          (_test._test1 . ,(P "test.o/_test/_test1.scm"))
  231:          (_tset._test .  ,(P "test.o/_tset/_test.scm")))
  232:        (sort (library-fold '_*t._te* acons '() :paths paths-b)
  233:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  234: (test* "library-fold */*"
  235:        `(("_test/_test" .  ,(P "test.o/_test/_test.scm"))
  236:          ("_test/_test1" . ,(P "test.o/_test/_test1.scm"))
  237:          ("_tset/_test" .  ,(P "test.o/_tset/_test.scm"))
  238:          ("_tset/_test2" . ,(P "test.o/_tset/_test2.scm")))
  239:        (sort (library-fold "*/*" acons '() :paths paths-b)
  240:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  241: 
  242: (test* "library-fold _t??t._test?"
  243:        `((_test._test1 . ,(P "test.o/_test/_test1.scm")))
  244:        (sort (library-fold '_t??t._test? acons '() :paths paths-b)
  245:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  246: (test* "library-fold ?test.?test"
  247:        `((_test._test . ,(P "test.o/_test/_test.scm")))
  248:        (sort (library-fold '?test.?test acons '() :paths paths-b)
  249:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  250: (test* "library-fold _t??t._test?"
  251:        `((_test._test1 . ,(P "test.o/_test/_test1.scm"))
  252:          (_tset._test2 . ,(P "test.o/_tset/_test2.scm")))
  253:        (sort (library-fold '_t??t._test? acons '() :paths paths-b :strict? #f)
  254:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  255: (test* "library-fold _t??t/_test?"
  256:        `(("_test/_test1" . ,(P "test.o/_test/_test1.scm"))
  257:          ("_tset/_test2" . ,(P "test.o/_tset/_test2.scm")))
  258:        (sort (library-fold "_t??t/_test?" acons '() :paths paths-b)
  259:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  260: (test* "library-fold _t??t?/_test?"
  261:        '()
  262:        (sort (library-fold "_t??t?/_test?" acons '() :paths paths-b)
  263:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  264: 
  265: (test* "library-map" `((_test._test . ,(P "test.o/_test/_test.scm"))
  266:                        (_test._test1 . ,(P "test.o/_test/_test1.scm")))
  267:        (sort (library-map '_test.* cons :paths paths-b)
  268:              (lambda (a b) (string<? (cdr a) (cdr b)))))
  269: (test* "library-for-each" `((_test._test .  ,(P "test.o/_test/_test.scm"))
  270:                             (_test._test1 . ,(P "test.o/_test/_test1.scm")))
  271:        (let ((p '()))
  272:          (library-for-each '_test.*
  273:                            (lambda (x y) (push! p (cons x y)))
  274:                            :paths paths-b)
  275:          (sort p (lambda (a b) (string<? (cdr a) (cdr b))))))
  276: 
  277: (test* "library-exists? _test" #t
  278:        (not (not (library-exists? '_test :paths paths-b))))
  279: (test* "library-exists? _test1" #f
  280:        (not (not (library-exists? '_test1 :paths paths-b))))
  281: (test* "library-exists? _test1, non-strict" #t
  282:        (not (not (library-exists? '_test1 :paths paths-b :strict? #f))))
  283: (test* "library-exists? _tset._test" #t
  284:        (not (not (library-exists? '_tset._test :paths paths-b :strict? #f))))
  285: (test* "library-exists? \"_test1\"" #t
  286:        (not (not (library-exists? "_test1" :paths paths-b))))
  287: (test* "library-exists? \"_tset/_test2\"" #t
  288:        (not (not (library-exists? "_tset/_test2" :paths paths-b))))
  289: (test* "library-exists? \"_test9\"" #f
  290:        (not (not (library-exists? "_test9" :paths paths-b))))
  291: 
  292: (test* "library-exists? gauche" #t
  293:        (not (not (library-exists? 'gauche :paths paths-b))))
  294: (test* "library-exists? gauche, force-search" #f
  295:        (not (not (library-exists? 'gauche :paths paths-b :force-search? #t))))
  296: (test* "library-exists? gauche" #f
  297:        (not (not (library-exists? "gauche" :paths paths-b))))
  298: ;;NB: this no longer work since gauche.object is compiled in.
  299: ;(test* "library-exists? gauche/object" #t
  300: ;       (not (not (library-exists? "gauche/object" :paths paths-b))))
  301: 
  302: ;; we check module here, since gauche.libutil is autoloaded.
  303: (test-module 'gauche.libutil)
  304: 
  305: (sys-system "rm -rf test.o")
  306: 
  307: (test-end)