1: ;;
    2: ;; test for port I/O functions
    3: ;;
    4: 
    5: (use gauche.test)
    6: 
    7: (test-start "io")
    8: 
    9: ;;-------------------------------------------------------------------
   10: (test-section "file i/o")
   11: 
   12: (sys-system "rm -rf tmp2.o")
   13: 
   14: (test* "open-input-file" *test-error*
   15:        (open-input-file "tmp2.o"))
   16: 
   17: (test* "open-input-file :if-does-not-exist #f" #f
   18:        (open-input-file "tmp2.o" :if-does-not-exist #f))
   19: 
   20: (test* "open-output-file :if-does-not-exist :error" *test-error*
   21:        (open-output-file "tmp2.o" :if-does-not-exist :error))
   22: 
   23: (test* "open-output-file :if-does-not-exit #f" #f
   24:        (open-output-file "tmp2.o" :if-does-not-exist #f))
   25: 
   26: (test* "open-output-file" #t
   27:        (let* ((p (open-output-file "tmp2.o"))
   28:               (r (output-port? p)))
   29:          (display "abcde" p)
   30:          (close-output-port p)
   31:          r))
   32: 
   33: (test* "open-input-file" 'abcde
   34:        (let* ((p (open-input-file "tmp2.o"))
   35:               (s (read p)))
   36:          (close-input-port p)
   37:          s))
   38: 
   39: (test* "open-output-file :if-exists :error" *test-error*
   40:        (open-output-file "tmp2.o" :if-exists :error))
   41: 
   42: (test* "open-output-file :if-exists :supersede" 'cdefg
   43:        (let ((o (open-output-file "tmp2.o")))
   44:          (display "cdefg" o)
   45:          (close-output-port o)
   46:          (let* ((i (open-input-file "tmp2.o"))
   47:                 (s (read i)))
   48:            (close-input-port i)
   49:            s)))
   50: 
   51: (test* "open-output-file :if-exists :append" 'cdefghij
   52:        (let ((o (open-output-file "tmp2.o" :if-exists :append)))
   53:          (display "hij" o)
   54:          (close-output-port o)
   55:          (let* ((i (open-input-file "tmp2.o"))
   56:                 (s (read i)))
   57:            (close-input-port i)
   58:            s)))
   59: 
   60: (test* "open-output-file :if-exists :append" 'cdefghijklm
   61:        (let1 o (open-output-file "tmp2.o"
   62:                                  :if-exists :append
   63:                                  :if-does-not-exist :error)
   64:          (display "klm" o)
   65:          (close-output-port o)
   66:          (let* ((i (open-input-file "tmp2.o"))
   67:                 (s (read i)))
   68:            (close-input-port i)
   69:            s)))
   70: 
   71: (test* "open-output-file :if-exists :supersede" 'nopqr
   72:        (let1 o (open-output-file "tmp2.o"
   73:                                  :if-exists :supersede
   74:                                  :if-does-not-exist #f)
   75:          (display "nopqr" o)
   76:          (close-output-port o)
   77:          (let* ((i (open-input-file "tmp2.o"))
   78:                 (s (read i)))
   79:            (close-input-port i)
   80:            s)))
   81: 
   82: (sys-system "rm -f tmp2.o")
   83: 
   84: (test* "call-with-input-file :if-does-not-exist #f" '(#f #f)
   85:        (call-with-input-file "tmp2.o" (lambda (p) (list p p))
   86:                              :if-does-not-exist #f))
   87: 
   88: (test* "with-input-from-file :if-does-not-exist #f" #f
   89:        (with-input-from-file "tmp2.o" (lambda () 5)
   90:                              :if-does-not-exist #f))
   91: 
   92: (call-with-output-file "tmp2.o" (lambda (p) (display "stu" p)))
   93: 
   94: (test* "call-with-output-file :if-exists #f" 'stu
   95:        (begin
   96:          (call-with-output-file "tmp2.o" (lambda (p)
   97:                                            (and p (display "vwx" p)))
   98:                                 :if-exists #f)
   99:          (call-with-input-file "tmp2.o" read)))
  100: 
  101: (test* "with-output-to-file :if-exists #f" 'stu
  102:        (or (with-output-to-file "tmp2.o"
  103:              (lambda () (display "yz" p) 4)
  104:              :if-exists #f)
  105:            (call-with-input-file "tmp2.o" read)))
  106: 
  107: ;;-------------------------------------------------------------------
  108: (test-section "port-fd-dup!")
  109: 
  110: (cond-expand
  111:  (gauche.os.windows #f)
  112:  (else
  113:   (test* "port-fd-dup!" '("foo" "bar")
  114:          (let* ((p1 (open-output-file "tmp1.o"))
  115:                 (p2 (open-output-file "tmp2.o")))
  116:            (display "foo\n" p1)
  117:            (port-fd-dup! p1 p2)
  118:            (display "bar\n" p1)
  119:            (close-output-port p1)
  120:            (close-output-port p2)
  121:            (list (call-with-input-file "tmp1.o" read-line)
  122:                  (call-with-input-file "tmp2.o" read-line))))
  123: 
  124:   (test* "port-fd-dup!" '("foo" "bar")
  125:          (let* ((p1 (open-input-file "tmp1.o"))
  126:                 (p2 (open-input-file "tmp2.o"))
  127:                 (s1 (read-line p1)))
  128:            (port-fd-dup! p1 p2)
  129:            (list s1 (read-line p1))))
  130: 
  131:   (test* "port-fd-dup!" *test-error*
  132:          (let* ((p1 (open-output-file "tmp1.o"))
  133:                 (p2 (open-input-file "tmp2.o")))
  134:            (guard (e (else
  135:                       (close-output-port p1)
  136:                       (close-input-port p2)
  137:                       (raise e)))
  138:              (port-fd-dup! p1 p2))))
  139: 
  140:   (test* "port-fd-dup!" *test-error*
  141:          (let* ((p1 (open-input-file "tmp2.o")))
  142:            (guard (e (else
  143:                       (close-input-port p1)
  144:                       (raise e)))
  145:              (port-fd-dup! (open-input-string "") p1))))
  146:   )) ; !gauche.os.windows
  147: 
  148: ;;-------------------------------------------------------------------
  149: (test-section "input ports")
  150: 
  151: (sys-unlink "tmp1.o")
  152: (with-output-to-file "tmp1.o" (lambda () (display "")))
  153: (test* "read-char (EOF)" #t
  154:        (eof-object? (call-with-input-file "tmp1.o" read-char)))
  155: (test* "read-byte (EOF)" #t
  156:        (eof-object? (call-with-input-file "tmp1.o" read-byte)))
  157: (test* "read-line (EOF)" #t
  158:        (eof-object? (call-with-input-file "tmp1.o" read-line)))
  159: (test* "read-block (EOF)" #t
  160:        (eof-object? (call-with-input-file "tmp1.o"
  161:                       (cut read-block 10 <>))))
  162: 
  163: (with-output-to-file "tmp1.o" (lambda () (display "ab")))
  164: (test* "read-char (a)" #\a
  165:        (call-with-input-file "tmp1.o" read-char))
  166: (test* "read-byte (a)" 97
  167:        (call-with-input-file "tmp1.o" read-byte))
  168: (test* "read-byte (ungotten)" 97
  169:        (call-with-input-file "tmp1.o"
  170:          (lambda (p) (peek-char p) (read-byte p))))
  171: (test* "read-line (a)" "ab"
  172:        (call-with-input-file "tmp1.o" read-line))
  173: (test* "read-byte (ungotten)" 97
  174:        (call-with-input-file "tmp1.o"
  175:          (lambda (p) (peek-char p) (read-byte p))))
  176: (test* "peek-byte (a)" '(97 97)
  177:        (call-with-input-file "tmp1.o"
  178:          (lambda (p) (let1 a (peek-byte p) (list a (read-byte p))))))
  179: (test* "peek-byte (ungotten)" '(97 97)
  180:        (call-with-input-file "tmp1.o"
  181:          (lambda (p)
  182:            (peek-char p) (let1 a (peek-byte p) (list a (read-byte p))))))
  183: (test* "peek-byte and read-char" #\a
  184:        (call-with-input-file "tmp1.o"
  185:          (lambda (p) (peek-byte p) (read-char p))))
  186: (test* "peek-byte and peek-char" #\a
  187:        (call-with-input-file "tmp1.o"
  188:          (lambda (p) (peek-byte p) (peek-char p))))
  189: (test* "read-block (a)" #*"ab"
  190:        (call-with-input-file "tmp1.o" (cut read-block 10 <>)))
  191: (test* "read-block (ungotten)" #*"ab"
  192:        (call-with-input-file "tmp1.o"
  193:          (lambda (p) (peek-char p) (read-block 10 p))))
  194: 
  195: (with-output-to-file "tmp1.o" (lambda () (display "\n")))
  196: (test* "read-line (LF)" ""
  197:        (call-with-input-file "tmp1.o" read-line))
  198: (test* "read-line (LF, ungotten)" ""
  199:        (call-with-input-file "tmp1.o"
  200:          (lambda (p) (peek-char p) (read-line p))))
  201: (with-output-to-file "tmp1.o" (lambda () (display "\r")))
  202: (test* "read-line (CR)" ""
  203:        (call-with-input-file "tmp1.o" read-line))
  204: (test* "read-line (CR, ungotten)" ""
  205:        (call-with-input-file "tmp1.o"
  206:          (lambda (p) (peek-char p) (read-line p))))
  207: (with-output-to-file "tmp1.o" (lambda () (display "\n\n")))
  208: (test* "read-line (LF)" '("" "" #t)
  209:        (call-with-input-file "tmp1.o"
  210:          (lambda (_)
  211:            (let* ((c1 (peek-char _))
  212:                   (l1 (read-line _))
  213:                   (c2 (peek-char _))
  214:                   (l2 (read-line _))
  215:                   (c2 (peek-char _))
  216:                   (l3 (read-line _)))
  217:              (list l1 l2 (eof-object? l3))))))
  218: (with-output-to-file "tmp1.o" (lambda () (display "\r\r\n")))
  219: (test* "read-line (CR, CRLF)" '("" "" #t)
  220:        (call-with-input-file "tmp1.o"
  221:          (lambda (_)
  222:            (let* ((c1 (peek-char _))
  223:                   (l1 (read-line _))
  224:                   (c2 (peek-char _))
  225:                   (l2 (read-line _))
  226:                   (c2 (peek-char _))
  227:                   (l3 (read-line _)))
  228:              (list l1 l2 (eof-object? l3))))))
  229: (with-output-to-file "tmp1.o" (lambda () (display "a\r\nb\nc")))
  230: (test* "read-line (mix)" '("a" "b" "c" #t)
  231:        (call-with-input-file "tmp1.o"
  232:          (lambda (_)
  233:            (let* ((c1 (peek-char _))
  234:                   (l1 (read-line _))
  235:                   (c2 (peek-char _))
  236:                   (l2 (read-line _))
  237:                   (c2 (peek-char _))
  238:                   (l3 (read-line _))
  239:                   (c3 (peek-char _)))
  240:              (list l1 l2 l3 (eof-object? c3))))))
  241: 
  242: (with-output-to-file "tmp1.o"
  243:   (lambda ()
  244:     (for-each write-byte '(#x80 #xff #x80 #xff #x80 #x0d #x0a #x0d #x0a))))
  245: (test* "read-line (bad sequence)" '(5 0)
  246:        (call-with-input-file "tmp1.o"
  247:          (lambda (_)
  248:            (let* ((s1 (read-line _ #t))
  249:                   (s2 (read-line _ #t))
  250:                   (s3 (read-line _ #t)))
  251:              (and (eof-object? s3)
  252:                   (list (string-size s1) (string-size s2)))))))
  253: 
  254: (with-output-to-file "tmp1.o"
  255:   (lambda ()
  256:     (display "a b c \"d e\" f g\n(0 1 2\n3 4 5)\n")))
  257: 
  258: (test* "port->string" "a b c \"d e\" f g\n(0 1 2\n3 4 5)\n"
  259:        (call-with-input-file "tmp1.o" port->string))
  260: (test* "port->list" '(a b c "d e" f g (0 1 2 3 4 5))
  261:        (call-with-input-file "tmp1.o" (lambda (p) (port->list read p))))
  262: (test* "port->list" '("a b c \"d e\" f g" "(0 1 2" "3 4 5)")
  263:        (call-with-input-file "tmp1.o" (lambda (p) (port->list read-line p))))
  264: (test* "port->string-list" '("a b c \"d e\" f g" "(0 1 2" "3 4 5)")
  265:        (call-with-input-file "tmp1.o" port->string-list))
  266: (test* "port->sexp-list" '(a b c "d e" f g (0 1 2 3 4 5))
  267:        (call-with-input-file "tmp1.o" port->sexp-list))
  268: 
  269: (test* "port-fold" '((0 1 2 3 4 5) g f "d e" c b a)
  270:        (with-input-from-file "tmp1.o"
  271:          (lambda () (port-fold cons '() read))))
  272: (test* "port-fold" '("3 4 5)" "(0 1 2" "a b c \"d e\" f g")
  273:        (with-input-from-file "tmp1.o"
  274:          (lambda () (port-fold cons '() read-line))))
  275: (test* "port-fold-right" '(a b c "d e" f g (0 1 2 3 4 5))
  276:        (with-input-from-file "tmp1.o"
  277:          (lambda () (port-fold-right cons '() read))))
  278: 
  279: (test* "port-map" '(a b c "d e" f g (0 1 2 3 4 5))
  280:        (with-input-from-file "tmp1.o"
  281:          (lambda () (port-map (lambda (x) x) read))))
  282: 
  283: ;;-------------------------------------------------------------------
  284: (test-section "with-ports")
  285: 
  286: (test* "with-input-from-port" '(#\b #\d #\c #\a)
  287:        (let ((x (open-input-string "ab"))
  288:              (y (open-input-string "cd"))
  289:              (r '())
  290:              (restart #f))
  291:          (if (call/cc 
  292:               (lambda (escape)
  293:                 (with-input-from-port x
  294:                   (lambda ()
  295:                     (push! r (read-char))
  296:                     (with-input-from-port y
  297:                       (lambda ()
  298:                         (push! r (read-char))
  299:                         (call/cc (lambda (k) (set! restart k) (escape #t)))
  300:                         (push! r (read-char))))
  301:                     (push! r (read-char))))
  302:                 #f))
  303:            (restart #f)
  304:            r)))
  305: 
  306: (for-each
  307:  (lambda (with cur name)
  308:    (test* "with-,|name|-to-port" '("ad" "bc")
  309:           (let ((x (open-output-string))
  310:                 (y (open-output-string))
  311:                 (restart #f))
  312:             (if (call/cc 
  313:                  (lambda (escape)
  314:                    (with x
  315:                      (lambda ()
  316:                        (write-char #\a (cur))
  317:                        (with y
  318:                          (lambda ()
  319:                            (write-char #\b (cur))
  320:                            (call/cc (lambda (k) (set! restart k) (escape #t)))
  321:                            (write-char #\c (cur))))
  322:                        (write-char #\d (cur))))
  323:                    #f))
  324:               (restart #f)
  325:               (list (get-output-string x) (get-output-string y))))))
  326:  `(,with-output-to-port ,with-error-to-port)
  327:  `(,current-output-port ,current-error-port)
  328:  '("output" "error"))
  329: 
  330: (test* "with-ports 1" '("a" "b")
  331:        (let ((o0 (open-output-string))
  332:              (o1 (open-output-string)))
  333:          (with-ports (open-input-string "abcd") o0 o1
  334:            (lambda ()
  335:              (write-char (read-char))
  336:              (write-char (read-char) (current-error-port))))
  337:          (list (get-output-string o0) (get-output-string o1))))
  338: (test* "with-ports 2" '("B" "A")
  339:        (let ((o0 (open-output-string))
  340:              (o1 (open-output-string)))
  341:          (with-ports (open-input-string "abcd") o0 o0
  342:            (lambda ()
  343:              (with-ports (open-input-string "ABCD") o1 #f
  344:                (lambda ()
  345:                  (write-char (read-char))
  346:                  (write-char (read-char) (current-error-port))))))
  347:          (list (get-output-string o0) (get-output-string o1))))
  348: (test* "with-ports 3" '("A" "B")
  349:        (let ((o0 (open-output-string))
  350:              (o1 (open-output-string)))
  351:          (with-ports (open-input-string "abcd") o0 o0
  352:            (lambda ()
  353:              (with-ports (open-input-string "ABCD") #f o1
  354:                (lambda ()
  355:                  (write-char (read-char))
  356:                  (write-char (read-char) (current-error-port))))))
  357:          (list (get-output-string o0) (get-output-string o1))))
  358: (test* "with-ports 4" '("" "ab")
  359:        (let ((o0 (open-output-string))
  360:              (o1 (open-output-string)))
  361:          (with-ports (open-input-string "abcd") o0 o0
  362:            (lambda ()
  363:              (with-ports #f o1 o1
  364:                (lambda ()
  365:                  (write-char (read-char))
  366:                  (write-char (read-char) (current-error-port))))))
  367:          (list (get-output-string o0) (get-output-string o1))))
  368: 
  369: ;;-------------------------------------------------------------------
  370: (test-section "seeking")
  371: 
  372: (define (seek-tester1 p)
  373:   (display (read-block 5 p))
  374:   (let ((p0 (port-tell p)))
  375:     (port-seek p -3 SEEK_CUR)
  376:     (display (read-block 5 p))
  377:     (port-seek p p0)
  378:     (display (read p))
  379:     (port-seek p 0 SEEK_SET)
  380:     (display (read-block 3 p))
  381:     (port-seek p -3 SEEK_END)
  382:     (display (read p))))
  383: 
  384: (test* "seek (istr)" "abcdecdefgfghijabchij"
  385:        (with-output-to-string
  386:          (lambda ()
  387:            (call-with-input-string "abcdefghij" seek-tester1))))
  388: (test* "seek (istr, boundary)" #\a
  389:        (call-with-input-string "abcdefghij"
  390:          (lambda (p)
  391:            (read-char p)
  392:            (port-seek p -1 SEEK_CUR)
  393:            (read-char p))))
  394: (test* "seek (istr, boundary)" #t
  395:        (call-with-input-string "abcdefghij"
  396:          (lambda (p)
  397:            (read-char p)
  398:            (port-seek p 10)
  399:            (eof-object? (read-char p)))))
  400: (test* "seek (istr, out of range)" #f
  401:        (call-with-input-string "abcdefghij"
  402:          (lambda (p)
  403:            (read-char p)
  404:            (port-seek p 10 SEEK_CUR))))
  405: (test* "seek (istr, out of range)" #f
  406:        (call-with-input-string "abcdefghij"
  407:          (lambda (p)
  408:            (read-char p)
  409:            (port-seek p -2))))
  410: ;; ungetc and seek interaction; pointed out by Alex Shinn
  411: (test* "seek (istr, with peek-char)" '("hello" "hello")
  412:        (letrec ((read-zstring
  413:                  (lambda (p)
  414:                    (let loop ((ls '()))
  415:                      (let ((c (peek-char p)))
  416:                        (if (or (eof-object? c) (eqv? c #\null))
  417:                          (list->string (reverse ls))
  418:                          (begin (read-char p) (loop (cons c ls)))))))))
  419:          (call-with-input-string "hello\0world"
  420:            (lambda (p)
  421:              (let* ((first (read-zstring p))
  422:                     (dummy (port-seek p 0))
  423:                     (second (read-zstring p)))
  424:                (list first second))))))
  425: (test* "seek (istr, with peek-char)" '(#\b #\b)
  426:        (with-input-from-string "abc"
  427:          (lambda ()
  428:            (read-char)
  429:            (let ((c1 (peek-char)))
  430:              (port-seek (current-input-port) 0 SEEK_CUR)
  431:              (list c1 (peek-char))))))
  432: 
  433: ;; NB: in the following four test, each ifile-ofile test is a pair
  434: ;;     (the ofile test depends on the previous state by ifile).  do not
  435: ;;     separate them.
  436: (test* "seek (ifile)" "abcdecdefgfghijabchij"
  437:        (begin
  438:          (sys-unlink "test.o")
  439:          (with-output-to-file "test.o" (lambda () (display "abcdefghij")))
  440:          (with-output-to-string
  441:            (lambda ()
  442:              (call-with-input-file "test.o" seek-tester1)))))
  443: 
  444: (test* "seek (ofile)" "--//efg**j++"
  445:        (begin
  446:          (call-with-output-file "test.o"
  447:            (lambda (p)
  448:              (port-seek p 0)
  449:              (display "--" p)
  450:              (let ((p0 (port-tell p)))
  451:                (port-seek p 0 SEEK_END)
  452:                (display "++" p)
  453:                (port-seek p -5 SEEK_CUR)
  454:                (display "**" p)
  455:                (port-seek p p0)
  456:                (display "//" p)))
  457:            :if-exists :overwrite)
  458:          (call-with-input-file "test.o" port->string)))
  459: 
  460: (test* "seek (ifile, large)"
  461:        "0000050055019999050100027500"
  462:        (begin
  463:          (sys-unlink "test.o")
  464:          (with-output-to-file "test.o"
  465:            (lambda () (dotimes (n 10000) (format #t "~4,'0d" n))))
  466:          (with-output-to-string
  467:            (lambda ()
  468:              (call-with-input-file "test.o"
  469:                (lambda (p)
  470:                  (display (read-block 4 p))
  471:                  (port-seek p 2000)
  472:                  (display (read-block 4 p))
  473:                  (let ((p0 (port-tell p)))
  474:                    (port-seek p 20000 SEEK_CUR)
  475:                    (display (read-block 4 p))
  476:                    (port-seek p -4 SEEK_END)
  477:                    (display (read-block 4 p))
  478:                    (port-seek p p0)
  479:                    (display (read-block 4 p))
  480:                    (port-seek p -2000 SEEK_CUR)
  481:                    (display (read-block 4 p))
  482:                    (port-seek p -10000 SEEK_END)
  483:                    (display (read-block 4 p))
  484:                    )))))))
  485: 
  486: (test* "seek (ofile, large)"
  487:        "*0-0*/-0999+"
  488:        (begin
  489:          (call-with-output-file "test.o"
  490:            (lambda (p)
  491:              (display "*" p)
  492:              (port-seek p 20000)
  493:              (display "*" p)
  494:              (let ((p0 (port-tell p)))
  495:                (port-seek p -19999 SEEK_CUR)
  496:                (display "-" p)
  497:                (port-seek p -19998 SEEK_END)
  498:                (display "-" p)
  499:                (port-seek p 19996 SEEK_CUR)
  500:                (display "+" p)
  501:                (port-seek p p0)
  502:                (display "/" p)))
  503:            :if-exists :overwrite)
  504:          (with-output-to-string
  505:            (lambda ()
  506:              (call-with-input-file "test.o"
  507:                (lambda (p)
  508:                  (display (read-block 4 p))
  509:                  (port-seek p 20000)
  510:                  (display (read-block 4 p))
  511:                  (port-seek p 39996)
  512:                  (display (read-block 4 p))))))
  513:          ))
  514: 
  515: (test* "seek (ifile, with peek-char)" '("hello" "hello")
  516:        (letrec ((read-zstring
  517:                  (lambda (p)
  518:                    (let loop ((ls '()))
  519:                      (let ((c (peek-char p)))
  520:                        (if (or (eof-object? c) (eqv? c #\null))
  521:                          (list->string (reverse ls))
  522:                          (begin (read-char p) (loop (cons c ls)))))))))
  523:          (begin
  524:            (