1\ Copyright (c) 2006-2017 Michael Scholz <mi-scholz@users.sourceforge.net> 2\ All rights reserved. 3\ 4\ Redistribution and use in source and binary forms, with or without 5\ modification, are permitted provided that the following conditions 6\ are met: 7\ 1. Redistributions of source code must retain the above copyright 8\ notice, this list of conditions and the following disclaimer. 9\ 2. Redistributions in binary form must reproduce the above copyright 10\ notice, this list of conditions and the following disclaimer in the 11\ documentation and/or other materials provided with the distribution. 12\ 13\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 14\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 16\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 17\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23\ SUCH DAMAGE. 24\ 25\ @(#)io-test.fs 1.48 12/2/17 26 27require test-utils.fs 28 29undef set-version-control 30 31'socket provided? [if] 32 : unix-server { name -- io } 33 AF_UNIX SOCK_STREAM net-socket { fd } 34 fd name -1 AF_UNIX net-bind 35 fd net-listen 36 fd name AF_UNIX net-accept 37 ; 38 39 : unix-client { name -- io } 40 AF_UNIX SOCK_STREAM net-socket { fd } 41 fd name -1 AF_UNIX net-connect 42 ; 43 44 : inet-server { host port -- io } 45 AF_INET SOCK_STREAM net-socket { fd } 46 fd host port AF_INET net-bind 47 fd net-listen 48 fd host AF_INET net-accept 49 ; 50 51 : inet-client { host port -- io } 52 AF_INET SOCK_STREAM net-socket { fd } 53 fd host port AF_INET net-connect 54 ; 55[then] 56 57nil value *io* 58 59:port-name "fth-test" 60:write-line lambda: <{ line -- }> 61 *io* line io-write 62; make-soft-port value io-test-stdout-port 63 64:port-name "fth-test" 65:fam r/o 66:read-line lambda: <{ -- line }> 67 *io* io-read 68; make-soft-port value io-test-stdin-port 69 70: test-with-input-port <{ io -- val }> 71 io io-read 72; 73 74: test-with-output-port <{ io -- val }> 75 io "hello" io-write 76; 77 78: test-with-input-from-port <{ -- val }> 79 *stdin* io-read 80; 81 82: test-with-output-to-port <{ -- val }> 83 *stdout* "hello" io-write 84; 85 86: test-with-error-to-port <{ -- val }> 87 *stderr* "hello" io-write 88; 89 90\ io-test.fs ends here 91\ Check if pwd accepts option -P: 92"sh -c pwd -P 2>&1 /dev/null" file-shell drop 93exit-status [if] "pwd" [else] "pwd -P" [then] constant *io-test-pwd-cmd* 94 95: test-rewind { io -- } 96 'minix provided? if 97 io io-close 98 io io-filename io-open-read to io 99 else 100 io io-rewind 101 then 102; 103 104'socket provided? [if] 105 : socket-test ( -- ) 106 \ io-nopen, make-socket-port (alias) 107 nil { io } 108 "localhost" :port 21 :domain AF_INET <'> io-nopen #t nil 109 fth-catch if 110 stack-reset 111 else 112 to io 113 io io-input? not 114 "io-nopen not input? (r/w inet-socket)" test-expr 115 io io-output? not 116 "io-nopen not output? (r/w inet-socket)" test-expr 117 io io-close 118 then 119 "localhost" <'> io-nopen #t nil fth-catch if 120 stack-reset 121 else 122 to io 123 io io-input? not 124 "io-nopen not input? (r/w def socket)" test-expr 125 io io-output? not 126 "io-nopen not output? (r/w def socket)" test-expr 127 io io-close 128 then 129 ; 130[else] 131 : socket-test ( -- ) ; 132[then] 133 134: io-test ( -- ) 135 "file.test" { ftest } 136 nil nil nil { io io1 io2 } 137 nil nil nil { s1 s2 slen } 138 nil nil nil { line lines lines1 } 139 nil nil { version-name version-name2 } 140 nil nil { old-stdin old-stdout } 141 \ io-filename 142 *stdin* io-filename "*stdin*" string<> 143 "*stdin* io-filename" test-expr 144 *stdout* io-filename "*stdout*" string<> 145 "*stdout* io-filename" test-expr 146 *stderr* io-filename "*stderr*" string<> 147 "*stderr* io-filename" test-expr 148 \ io-mode 149 *stdin* io-mode "r" string<> "*stdin* io-mode" test-expr 150 *stdout* io-mode "w" string<> "*stdout* io-mode" test-expr 151 *stderr* io-mode "w" string<> "*stderr* io-mode" test-expr 152 \ io-fileno 153 *stdin* io-fileno 0 <> "*stdin* io-fileno" test-expr 154 *stdout* io-fileno 1 <> "*stdout* io-fileno" test-expr 155 *stderr* io-fileno 2 <> "*stderr* io-fileno" test-expr 156 \ io->string, io-rewind 157 fname file-delete 158 fname :fam r/w io-open to io 159 io "io->string-test" io-write 160 io io-rewind 161 io io-read to s1 162 io io->string to s2 163 s1 s2 string<> "io->string" test-expr 164 io io-close 165 \ io? 166 nil io? "nil io?" test-expr 167 #() io? "#() io?" test-expr 168 0 io? "0 io?" test-expr 169 fname io-open-write to io 170 io io? not "io?" test-expr 171 io io-close 172 \ *stdin*|out*|err* io?|io-input?|output?|closed? 173 *stdin* io? not "*stdin* not io?" test-expr 174 *stdout* io? not "*stdout* not io?" test-expr 175 *stderr* io? not "*stderr* not io?" test-expr 176 *stdin* io-input? not "*stdin* not input?" test-expr 177 *stdin* io-output? "*stdin* output?" test-expr 178 *stdin* io-closed? "*stdin* closed?" test-expr 179 *stdout* io-input? "*stdout* input?" test-expr 180 *stdout* io-output? not "*stdout* not output?" test-expr 181 *stdout* io-closed? "*stdout* closed?" test-expr 182 *stderr* io-input? "*stderr* input?" test-expr 183 *stderr* io-output? not "*stderr* not output?" test-expr 184 *stderr* io-closed? "*stderr* closed?" test-expr 185 \ verion-control, set-version-control, :if-exists :rename 186 fname file-delete 187 fname :fam w/o io-open io-close 188 #t set-version-control 189 fname :if-exists :rename :fam w/o io-open io-close 190 fname ".~1~" $+ to version-name 191 version-name file-exists? not "io-open rename #t" test-expr 192 nil set-version-control 193 fname :if-exists :rename :fam w/o io-open io-close 194 fname ".~2~" $+ to version-name2 195 version-name2 file-exists? not "io-open rename nil numb" test-expr 196 version-name2 file-delete 197 version-name file-delete 198 fname :if-exists :rename :fam w/o io-open io-close 199 fname "~" $+ to version-name 200 version-name file-exists? not "io-open rename nil" test-expr 201 version-name file-delete 202 #f set-version-control 203 fname :if-exists :rename :fam w/o io-open io-close 204 fname "~" $+ to version-name 205 version-name file-exists? not "io-open rename #f" test-expr 206 version-name file-delete 207 undef set-version-control 208 fname :if-exists :rename :fam w/o io-open io-close 209 fname to version-name 210 version-name file-exists? not "io-open rename undef" test-expr 211 version-name file-delete 212 \ io-open-file, io-open-input-file, io-open-output-file 213 fname io-open-write io-close 214 :filename fname io-open-file to io 215 io io-input? not "io-open-file not readable?" test-expr 216 io io-close 217 :string "io-open-input-file" io-open-input-file to io 218 io io-input? not "io-open-input-file not readable?" test-expr 219 io io-read to s1 220 io io->string to s2 221 s1 s2 string<> "io-open-input-file" test-expr 222 io io-close 223 :filename fname io-open-output-file to io 224 io io-output? not "io-open-output-file not writeable?" test-expr 225 io io-close 226 \ io-open :if-exists :error, make-file-port (alias), io-close 227 fname :fam r/w io-open to io 228 io io-input? not "not io-input? (r/w)" test-expr 229 io io-output? not "not io-output? (r/w)" test-expr 230 io "fth-test" io-write 231 io io-rewind 232 io io-read "fth-test" string<> "r/w io-open" test-expr 233 io io-closed? "io-closed? (open)" test-expr 234 io io-close 235 io io-closed? not "io-closed? (closed)" test-expr 236 fname :if-exists :error :fam w/o <'> io-open 'io-error nil fth-catch if 237 stack-reset 238 else 239 dup io? if 240 ( io ) io-close 241 #t "io-open :error still open?" test-expr 242 else 243 ( ex ) 1 >list "io-open :error %s?" swap 244 test-expr-format 245 then 246 then 247 fname :fam r/o io-open io-close 248 fname io-open-read io-close 249 fname :fam w/o io-open io-close 250 fname io-open-write io-close 251 fname :fam a/o io-open io-close 252 fname :fam r/a io-open io-close 253 \ io-open-read, make-file-input-port (alias) 254 fname io-open-read to io 255 io io-input? not "io-open-read not io-input? (r/o)" test-expr 256 io io-output? "io-open-read io-output? (r/o)" test-expr 257 io io-close 258 \ io-open-write, make-file-output-port (alias) 259 fname io-open-write to io 260 io io-input? "io-open-write io-input? (r/o)" test-expr 261 io io-output? not "io-open-write not io-output? (r/o)" test-expr 262 io io-close 263 \ io-reopen 264 fname io-open-write to io 265 io io-input? "io-input? (w/o)" test-expr 266 io io-output? not "io-output? (w/o) not" test-expr 267 "foo, bar, baz\n" to s1 268 "baz, bar, foo\n" to s2 269 io s1 io-write 270 nil to io1 271 io "new-name" io-reopen to io1 272 io1 s2 io-write 273 io1 io-close 274 fname readlines #( s1 ) array= not "freopen" test-expr 275 "new-name" readlines #( s2 ) array= not "freopen new-name" test-expr 276 "new-name" file-delete 277 \ io-fdopen 278 fname io-open-read to io 279 io io-fileno :fam r/o <'> io-fdopen #t nil fth-catch if 280 stack-reset 281 else 282 to io1 283 io1 io? if 284 io1 io-close 285 else 286 "fdopen %s?" #( io1 ) test-expr-format 287 then 288 io1 io-closed? not "fdopen not closed?" test-expr 289 then 290 io io-close 291 \ XXX: Minix pipe 292 \ Pipe-issues in scripts with Minix. 293 \ It works on command line. 294 'minix provided? unless 295 \ io-popen, make-pipe-port (alias) 296 *io-test-pwd-cmd* :fam r/o io-popen to io 297 io io-input? not "io-popen not input? (r/o pipe)" test-expr 298 io io-output? "io-popen output? (r/o pipe)" test-expr 299 io io-read string-chomp file-pwd string<> 300 "io-popen `pwd`" test-expr 301 io io-close 302 "cat > " fname $+ :fam w/o io-popen to io 303 io io-input? "io-popen input? (w/o pipe)" test-expr 304 io io-output? not "io-popen not output? (w/o pipe)" test-expr 305 io "fth-test pipe input (w/o)\n" io-write 306 io io-close 307 fname io-open-read to io 308 io io-read to line 309 io io-close 310 line "fth-test pipe input (w/o)\n" string<> 311 "io-popen (w/o) `cat > name`" test-expr 312 \ io-popen-read, make-pipe-input-port (alias) 313 *io-test-pwd-cmd* io-popen-read to io 314 io io-read string-chomp file-pwd string<> 315 "io-popen-read `pwd`" test-expr 316 io io-close 317 \ io-popen-write, make-pipe-output-port (alias) 318 "cat > " fname $+ io-popen-write to io 319 io "fth-test pipe input (io-popen-write)\n" io-write 320 io io-closed? "io-closed? (io-popen-write 1)" test-expr 321 io io-close 322 io io-closed? not "io-closed? (io-popen-write 2)" test-expr 323 fname io-open-read to io 324 io io-read to line 325 line "fth-test pipe input (io-popen-write)\n" string<> 326 "io-popen-write `cat > name`" test-expr 327 io io-close 328 then 329 \ io-sopen, make-string-port (alias) 330 "out string comes\nhere" to s1 331 s1 string-copy to s2 332 s1 string-length to slen 333 s1 :fam r/w io-sopen to io 334 io io? not "io-sopen not io?" test-expr 335 io io-input? not "io-sopen not input?" test-expr 336 io io-output? not "io-sopen output?" test-expr 337 io 3 :whence SEEK_SET io-seek 3 <> "io-sopen (io-seek 3)" test-expr 338 io io-rewind 339 io io-pos-ref 0 <> "io-sopen (io-seek 0)" test-expr 340 io 4 io-pos-set! 341 io "strang" io-write 342 s1 string-length slen <> "io-sopen(4 len slen)" test-expr 343 s1 s2 string= "io-sopen(4 s1 s2)" test-expr 344 io io->string s1 string<> "io-sopen(4 io->string s1)" test-expr 345 s1 "out strang comes\nhere" string<> "io-sopen(4 s1 value)" test-expr 346 io 17 io-pos-set! 347 io "there and here" io-write 348 s1 string-length slen = "io-sopen(17 len slen)" test-expr 349 s1 s2 string= "io-sopen(17 s1 s2)" test-expr 350 io io->string s1 string<> "io-sopen(17 io->string s1)" test-expr 351 s1 "out strang comes\nthere and here" string<> 352 "io-sopen(17 s1 value)" test-expr 353 io io-close 354 \ io-sopen-read, make-string-input-port (alias) 355 s1 io-sopen-read to io 356 io io-input? not "io-sopen-read not readable?" test-expr 357 io io-close 358 \ io-sopen-write, make-string-output-port (alias) 359 s1 io-sopen-write to io 360 io io-output? not "io-sopen-write not writeable?" test-expr 361 io io-close 362 \ sockets 363 socket-test 364 \ io-exit-status, exit-status (alias) 365 "ls" file-shell drop 366 exit-status 0<> "exit-status -> \"ls\" shell <> 0" test-expr 367 "ls aGZ 2>&1 > /dev/null" file-shell drop 368 exit-status 0= "exit-status -> \"ls aGZ\" shell == 0" test-expr 369 \ io= 370 fname io-open-read to io 371 fname io-open-write to io1 372 fname io-open-write to io2 373 io io io= not "io io io=" test-expr 374 io io1 io= "io io1 io=" test-expr 375 io1 io2 io= not "io1 io2 io=" test-expr 376 #( io io1 io2 ) each 377 io-close 378 end-each 379 \ io-putc|getc, io-flush 380 fname :fam r/w io-open to io 381 io <char> f io-putc 382 io <char> t io-putc 383 io <char> h io-putc 384 \ XXX: Minix "w+" 385 \ Issues with "w+" (more such cases below) 386 'minix provided? if 387 io io-close 388 fname io-open-read to io 389 else 390 io io-flush 391 io io-rewind 392 then 393 io io-getc <char> f <> "io-putc|getc f" test-expr 394 io io-getc <char> t <> "io-putc|getc t" test-expr 395 io io-getc <char> h <> "io-putc|getc h" test-expr 396 io io-close 397 \ io-read|write(-format) 398 fname :fam r/w io-open to io 399 io "fth-test io-write" io-write 400 io test-rewind 401 io io-read "fth-test io-write" string<> "io-read|write" test-expr 402 io test-rewind 403 io "fth-test %s" #( <'> io-write-format xt->name ) io-write-format 404 io test-rewind 405 io io-read "fth-test io-write-format" string<> 406 "io-read|write-format" test-expr 407 io io-close 408 \ io-readlines|writelines|eof? 409 #( "line 1\n" "line 2\n" "line 3\n" ) to lines 410 fname :fam r/w io-open to io 411 io lines io-writelines 412 'minix provided? if 413 io io-close 414 fname io-open-read to io 415 then 416 io io-readlines to lines1 417 lines1 lines array= not "io-readlines|writelines" test-expr 418 io io-eof? not "io-eof?" test-expr 419 io io-close 420 \ io-seek|pos 421 fname io-open-write to io 422 io io-pos-ref 0<> "io-open-write io-pos-ref (0)" test-expr 423 io "fth-test" io-write 424 io io-pos-ref 8 <> "io-write io-pos-ref (8)" test-expr 425 io 3 :whence SEEK_SET io-seek 3 <> "3 SEEK_SET io-seek" test-expr 426 io io-pos-ref 3 <> "3 io-pos-ref" test-expr 427 io -3 :whence SEEK_END io-seek 8 3 - <> 428 "8 3 - SEEK_END io-seek" test-expr 429 io io-pos-ref 8 3 - <> "8 3 - io-pos-ref" test-expr 430 io 2 :whence SEEK_CUR io-seek 8 3 - 2 + <> 431 "8 3 - 2 + SEEK_CUR io-seek" test-expr 432 io io-pos-ref 8 3 - 2 + <> "8 3 - 2 + io-pos-ref" test-expr 433 io 4 io-pos-set! 434 io io-pos-ref 4 <> "4 io-pos-set!" test-expr 435 io io-close 436 \ readlines|writelines 437 #( "line 1\n" "line 2\n" "line 3\n" ) to lines 438 fname lines writelines 439 fname readlines to lines1 440 lines1 lines array= not "readlines|writelines" test-expr 441 \ write soft port, *stdout*, set-*stdout* 442 fname :fam w/o io-open to *io* 443 io-test-stdout-port set-*stdout* to old-stdout 444 ." \ " 445 "Hello" .string 446 ." , World! (stdout)" 447 cr 448 *io* io-close 449 old-stdout set-*stdout* drop 450 \ read soft port, *stdin*, set-*stdin* 451 fname :fam r/o io-open to *io* 452 io-test-stdin-port set-*stdin* to old-stdin 453 *stdin* io-read to line 454 line "\\ Hello, World! (stdout)\n" string<> "soft port" test-expr 455 *io* io-close 456 old-stdin set-*stdin* drop 457 \ with-input|output-port 458 ftest file-delete 459 <'> test-with-output-port :filename ftest with-output-port 460 <'> test-with-input-port :filename ftest with-input-port 461 "hello" string<> 462 "with-input|output-port (:file and return)" test-expr 463 ftest readlines 0 array-ref "hello" string<> 464 "with-input|output-port (:file)" test-expr 465 ftest file-delete 466 "hello" :filename ftest with-output-port 467 nil :filename ftest with-input-port "hello" string<> 468 "with-input|output-port (:file and str-return)" test-expr 469 ftest readlines 0 array-ref "hello" string<> 470 "with-input|output-port (:file str)" test-expr 471 "" to s1 472 <'> test-with-output-port :string s1 with-output-port 473 <'> test-with-input-port :string s1 with-input-port "hello" string<> 474 "with-input|output-port (:string and return)" test-expr 475 s1 "hello" string<> "with-input|output-port (:string)" test-expr 476 "" to s1 477 "hello" :string s1 with-output-port 478 nil :string s1 with-input-port "hello" string<> 479 "with-input|output-port (:string and str-return)" test-expr 480 s1 "hello" string<> "with-input|output-port (:string str)" test-expr 481 \ with-input-from-port, with-output|error-to-port 482 ftest file-delete 483 <'> test-with-output-to-port :filename ftest with-output-to-port 484 <'> test-with-input-from-port :filename ftest with-input-from-port 485 "hello" string<> 486 "with-input|output-to-port (:file and return)" test-expr 487 ftest readlines 0 array-ref "hello" string<> 488 "with-input|output-to-port (:file)" test-expr 489 ftest file-delete 490 "hello" :filename ftest with-output-to-port 491 nil :filename ftest with-input-from-port "hello" string<> 492 "with-input|output-to-port (:file and str-return)" test-expr 493 ftest readlines 0 array-ref "hello" string<> 494 "with-input|output-to-port (:file str)" test-expr 495 ftest file-delete 496 <'> test-with-error-to-port :filename ftest with-error-to-port 497 <'> test-with-input-from-port :filename ftest with-input-from-port 498 "hello" string<> 499 "with-input|error-to-port (:file and return)" test-expr 500 ftest readlines 0 array-ref "hello" string<> 501 "with-input|error-to-port (:file)" test-expr 502 ftest file-delete 503 "hello" :filename ftest with-error-to-port 504 nil :filename ftest with-input-from-port "hello" string<> 505 "with-input|error-to-port (:file and str-return)" test-expr 506 ftest readlines 0 array-ref "hello" string<> 507 "with-input|error-to-port (:file str)" test-expr 508 "" to s1 509 <'> test-with-output-to-port :string s1 with-output-to-port 510 <'> test-with-input-from-port :string s1 with-input-from-port 511 "hello" string<> 512 "with-input|output-to-port (:string and return)" test-expr 513 s1 "hello" string<> "with-input|output-to-port (:string)" test-expr 514 "" to s1 515 "hello" :string s1 with-output-to-port 516 nil :string s1 with-input-from-port "hello" string<> 517 "with-input|output-to-port (:string and str-return)" test-expr 518 s1 "hello" string<> "with-input|output-to-port (:string str)" test-expr 519 "" to s1 520 <'> test-with-error-to-port :string s1 with-error-to-port 521 <'> test-with-input-from-port :string s1 with-input-from-port 522 "hello" string<> 523 "with-input|error-to-port (:string and return)" test-expr 524 s1 "hello" string<> "with-input|error-to-port (:string)" test-expr 525 "" to s1 526 "hello" :string s1 with-error-to-port 527 nil :string s1 with-input-from-port "hello" string<> 528 "with-input|error-to-port (:string and str-return)" test-expr 529 s1 "hello" string<> "with-input|error-to-port (:string str)" test-expr 530 ftest file-delete 531 fname file-delete 532; 533 534*fth-test-count* 0> [if] io-test [then] 535 536\ io-test.fs ends here 537