1 2(********************************************************************) 3(* *) 4(* chkcmd.sd7 Check functions that manipulate files. *) 5(* Copyright (C) 2014 Thomas Mertes *) 6(* *) 7(* This program is free software; you can redistribute it and/or *) 8(* modify it under the terms of the GNU General Public License as *) 9(* published by the Free Software Foundation; either version 2 of *) 10(* the License, or (at your option) any later version. *) 11(* *) 12(* This program is distributed in the hope that it will be useful, *) 13(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 15(* GNU General Public License for more details. *) 16(* *) 17(* You should have received a copy of the GNU General Public *) 18(* License along with this program; if not, write to the *) 19(* Free Software Foundation, Inc., 51 Franklin Street, *) 20(* Fifth Floor, Boston, MA 02110-1301, USA. *) 21(* *) 22(********************************************************************) 23 24 25$ include "seed7_05.s7i"; 26 include "osfiles.s7i"; 27 include "getf.s7i"; 28 include "utf8.s7i"; 29 30 31const proc: check_removeFile is func 32 local 33 const string: fileName is "remove_file_test"; 34 var boolean: okay is TRUE; 35 var boolean: fileErrorRaised is FALSE; 36 begin 37 mkdir(fileName); 38 putf(fileName & "/" & fileName, "File content check_removeFile 1"); 39 fileErrorRaised := FALSE; 40 block 41 removeFile(fileName); 42 exception 43 catch FILE_ERROR: 44 fileErrorRaised := TRUE; 45 end block; 46 if not fileErrorRaised then 47 writeln(" ***** removeFile with nonempty directory does not raise FILE_ERROR."); 48 okay := FALSE; 49 end if; 50 51 block 52 removeFile(fileName & "/" & fileName); 53 exception 54 catch FILE_ERROR: 55 writeln(" ***** removeFile with a regular file raises FILE_ERROR"); 56 okay := FALSE; 57 end block; 58 59 block 60 removeFile(fileName); 61 exception 62 catch FILE_ERROR: 63 writeln(" ***** removeFile with an empty directory raises FILE_ERROR"); 64 okay := FALSE; 65 end block; 66 67 if okay then 68 writeln("Removing regular files and empty directories with removeFile works correct."); 69 else 70 writeln(" ***** Removing regular files and empty directories with removeFile does not work correct."); 71 writeln; 72 end if; 73 end func; 74 75 76const proc: check_removeTree is func 77 local 78 const string: fileName is "remove_tree_test"; 79 var boolean: okay is TRUE; 80 begin 81 putf(fileName, "File content check_removeTree 1"); 82 block 83 removeTree(fileName); 84 exception 85 catch FILE_ERROR: 86 writeln(" ***** removeTree with a regular file raises FILE_ERROR"); 87 okay := FALSE; 88 end block; 89 90 mkdir(fileName); 91 block 92 removeTree(fileName); 93 exception 94 catch FILE_ERROR: 95 writeln(" ***** removeTree with an empty directory raises FILE_ERROR"); 96 okay := FALSE; 97 end block; 98 99 mkdir(fileName); 100 putf(fileName & "/" & fileName, "File content check_removeTree 2"); 101 block 102 removeTree(fileName); 103 exception 104 catch FILE_ERROR: 105 writeln(" ***** removeTree a directory tree raises FILE_ERROR"); 106 okay := FALSE; 107 end block; 108 109 if okay then 110 writeln("Removing regular files and directories with removeTree works correct."); 111 else 112 writeln(" ***** Removing regular files and empty directories with removeTree does not work correct."); 113 writeln; 114 end if; 115 end func; 116 117 118const proc: check_copyFile is func 119 local 120 const string: fileName1 is "asdf_file_test"; 121 const string: fileName2 is "jkl_file_test"; 122 var boolean: okay is TRUE; 123 var boolean: fileErrorRaised is FALSE; 124 begin 125 putf(fileName1, "File content check_copyFile 1"); 126 putf(fileName2, "File content check_copyFile 2"); 127 fileErrorRaised := FALSE; 128 block 129 copyFile(fileName1, fileName2); 130 exception 131 catch FILE_ERROR: 132 fileErrorRaised := TRUE; 133 end block; 134 if not fileErrorRaised then 135 writeln(" ***** copyFile to existing file does not raise FILE_ERROR."); 136 okay := FALSE; 137 end if; 138 removeFile(fileName1); 139 removeFile(fileName2); 140 141 putf(fileName1, "File content check_copyFile 3"); 142 mkdir(fileName2); 143 fileErrorRaised := FALSE; 144 block 145 copyFile(fileName1, fileName2); 146 exception 147 catch FILE_ERROR: 148 fileErrorRaised := TRUE; 149 end block; 150 if not fileErrorRaised then 151 writeln(" ***** copyFile to existing file does not raise FILE_ERROR."); 152 okay := FALSE; 153 end if; 154 removeFile(fileName1); 155 removeFile(fileName2); 156 157 mkdir(fileName1); 158 putf(fileName2, "File content check_copyFile 4"); 159 fileErrorRaised := FALSE; 160 block 161 copyFile(fileName1, fileName2); 162 exception 163 catch FILE_ERROR: 164 fileErrorRaised := TRUE; 165 end block; 166 if not fileErrorRaised then 167 writeln(" ***** copyFile to existing file does not raise FILE_ERROR."); 168 okay := FALSE; 169 end if; 170 removeFile(fileName1); 171 removeFile(fileName2); 172 173 mkdir(fileName1); 174 mkdir(fileName2); 175 fileErrorRaised := FALSE; 176 block 177 copyFile(fileName1, fileName2); 178 exception 179 catch FILE_ERROR: 180 fileErrorRaised := TRUE; 181 end block; 182 if not fileErrorRaised then 183 writeln(" ***** copyFile to existing file does not raise FILE_ERROR."); 184 okay := FALSE; 185 end if; 186 removeFile(fileName1); 187 removeFile(fileName2); 188 189 putf(fileName1, "File content check_copyFile 5"); 190 block 191 copyFile(fileName1, fileName2); 192 exception 193 catch FILE_ERROR: 194 writeln(" ***** copyFile with a regular file raises FILE_ERROR."); 195 okay := FALSE; 196 end block; 197 if fileType(fileName1) = FILE_ABSENT then 198 writeln(" ***** copyFile does remove the old file."); 199 okay := FALSE; 200 else 201 removeFile(fileName1); 202 end if; 203 if fileType(fileName2) = FILE_ABSENT then 204 writeln(" ***** copyFile does not create the destination."); 205 okay := FALSE; 206 elsif fileType(fileName2) <> FILE_REGULAR then 207 writeln(" ***** copyFile creates destination with wrong file type."); 208 okay := FALSE; 209 removeFile(fileName2); 210 else 211 if getf(fileName2) <> "File content check_copyFile 5" then 212 writeln(" ***** copyFile creates destination with wrong content."); 213 okay := FALSE; 214 end if; 215 removeFile(fileName2); 216 end if; 217 218 mkdir(fileName1); 219 block 220 copyFile(fileName1, fileName2); 221 exception 222 catch FILE_ERROR: 223 writeln(" ***** copyFile with an empty directory raises FILE_ERROR."); 224 okay := FALSE; 225 end block; 226 if fileType(fileName1) = FILE_ABSENT then 227 writeln(" ***** copyFile does remove the old file."); 228 okay := FALSE; 229 else 230 removeFile(fileName1); 231 end if; 232 if fileType(fileName2) = FILE_ABSENT then 233 writeln(" ***** copyFile does not create the destination."); 234 okay := FALSE; 235 elsif fileType(fileName2) <> FILE_DIR then 236 writeln(" ***** copyFile creates destination with wrong file type."); 237 okay := FALSE; 238 removeFile(fileName2); 239 else 240 if readDir(fileName2) <> 0 times "" then 241 writeln(" ***** copyFile creates destination directory with wrong content."); 242 okay := FALSE; 243 end if; 244 removeFile(fileName2); 245 end if; 246 247 mkdir(fileName1); 248 putf(fileName1 & "/" & fileName1, "File content check_copyFile 6"); 249 block 250 copyFile(fileName1, fileName2); 251 exception 252 catch FILE_ERROR: 253 writeln(" ***** copyFile with a directory raises FILE_ERROR."); 254 okay := FALSE; 255 end block; 256 if fileType(fileName1) = FILE_ABSENT then 257 writeln(" ***** copyFile does remove the old file."); 258 okay := FALSE; 259 else 260 removeTree(fileName1); 261 end if; 262 if fileType(fileName2) = FILE_ABSENT then 263 writeln(" ***** copyFile does not create the destination."); 264 okay := FALSE; 265 elsif fileType(fileName2) <> FILE_DIR then 266 writeln(" ***** copyFile creates destination with wrong file type."); 267 okay := FALSE; 268 removeFile(fileName2); 269 else 270 if length(readDir(fileName2)) <> 1 or 271 readDir(fileName2)[1] <> fileName1 then 272 writeln(" ***** copyFile creates destination directory with wrong content."); 273 okay := FALSE; 274 elsif getf(fileName2 & "/" & fileName1) <> "File content check_copyFile 6" then 275 writeln(" ***** copyFile creates destination file with wrong content."); 276 okay := FALSE; 277 end if; 278 removeTree(fileName2); 279 end if; 280 281 mkdir(fileName1); 282 mkdir(fileName2); 283 putf(fileName1 & "/" & fileName1, "File content check_copyFile 7"); 284 block 285 copyFile(fileName1 & "/" & fileName1, fileName2 & "/" & fileName2); 286 exception 287 catch FILE_ERROR: 288 writeln(" ***** copyFile with an empty directory raises FILE_ERROR."); 289 okay := FALSE; 290 end block; 291 if fileType(fileName1 & "/" & fileName1) = FILE_ABSENT then 292 writeln(" ***** copyFile does remove the old file."); 293 okay := FALSE; 294 else 295 removeFile(fileName1 & "/" & fileName1); 296 end if; 297 if fileType(fileName2 & "/" & fileName2) = FILE_ABSENT then 298 writeln(" ***** copyFile does not create the destination."); 299 okay := FALSE; 300 elsif fileType(fileName2 & "/" & fileName2) <> FILE_REGULAR then 301 writeln(" ***** copyFile creates destination with wrong file type."); 302 okay := FALSE; 303 removeFile(fileName2 & "/" & fileName2); 304 else 305 if getf(fileName2 & "/" & fileName2) <> "File content check_copyFile 7" then 306 writeln(" ***** copyFile creates destination file with wrong content."); 307 okay := FALSE; 308 end if; 309 removeFile(fileName2 & "/" & fileName2); 310 end if; 311 removeTree(fileName1); 312 removeTree(fileName2); 313 314 mkdir(fileName1); 315 mkdir(fileName2); 316 mkdir(fileName1 & "/" & fileName1); 317 block 318 copyFile(fileName1 & "/" & fileName1, fileName2 & "/" & fileName2); 319 exception 320 catch FILE_ERROR: 321 writeln(" ***** copyFile with an empty directory raises FILE_ERROR."); 322 okay := FALSE; 323 end block; 324 if fileType(fileName1 & "/" & fileName1) = FILE_ABSENT then 325 writeln(" ***** copyFile does remove the old file."); 326 okay := FALSE; 327 else 328 removeFile(fileName1 & "/" & fileName1); 329 end if; 330 if fileType(fileName2 & "/" & fileName2) = FILE_ABSENT then 331 writeln(" ***** copyFile does not create the destination."); 332 okay := FALSE; 333 elsif fileType(fileName2 & "/" & fileName2) <> FILE_DIR then 334 writeln(" ***** copyFile creates destination with wrong file type."); 335 okay := FALSE; 336 removeFile(fileName2 & "/" & fileName2); 337 else 338 if readDir(fileName2 & "/" & fileName2) <> 0 times "" then 339 writeln(" ***** copyFile creates destination directory with wrong content."); 340 okay := FALSE; 341 end if; 342 removeFile(fileName2 & "/" & fileName2); 343 end if; 344 removeTree(fileName1); 345 removeTree(fileName2); 346 347 if okay then 348 writeln("Copying files with copyFile works correct."); 349 else 350 writeln(" ***** Copying files with copyFile does not work correct."); 351 writeln; 352 end if; 353 end func; 354 355 356const proc: check_moveFile is func 357 local 358 const string: fileName1 is "asdf_file_test"; 359 const string: fileName2 is "jkl_file_test"; 360 var boolean: okay is TRUE; 361 var boolean: fileErrorRaised is FALSE; 362 begin 363 putf(fileName1, "File content check_moveFile 1"); 364 putf(fileName2, "File content check_moveFile 2"); 365 fileErrorRaised := FALSE; 366 block 367 moveFile(fileName1, fileName2); 368 exception 369 catch FILE_ERROR: 370 fileErrorRaised := TRUE; 371 end block; 372 if not fileErrorRaised then 373 writeln(" ***** moveFile to existing file does not raise FILE_ERROR."); 374 okay := FALSE; 375 end if; 376 removeFile(fileName1); 377 removeFile(fileName2); 378 379 putf(fileName1, "File content check_moveFile 3"); 380 mkdir(fileName2); 381 fileErrorRaised := FALSE; 382 block 383 moveFile(fileName1, fileName2); 384 exception 385 catch FILE_ERROR: 386 fileErrorRaised := TRUE; 387 end block; 388 if not fileErrorRaised then 389 writeln(" ***** moveFile to existing file does not raise FILE_ERROR."); 390 okay := FALSE; 391 end if; 392 removeFile(fileName1); 393 removeFile(fileName2); 394 395 mkdir(fileName1); 396 putf(fileName2, "File content check_moveFile 4"); 397 fileErrorRaised := FALSE; 398 block 399 moveFile(fileName1, fileName2); 400 exception 401 catch FILE_ERROR: 402 fileErrorRaised := TRUE; 403 end block; 404 if not fileErrorRaised then 405 writeln(" ***** moveFile to existing file does not raise FILE_ERROR."); 406 okay := FALSE; 407 end if; 408 removeFile(fileName1); 409 removeFile(fileName2); 410 411 mkdir(fileName1); 412 mkdir(fileName2); 413 fileErrorRaised := FALSE; 414 block 415 moveFile(fileName1, fileName2); 416 exception 417 catch FILE_ERROR: 418 fileErrorRaised := TRUE; 419 end block; 420 if not fileErrorRaised then 421 writeln(" ***** moveFile to existing file does not raise FILE_ERROR."); 422 okay := FALSE; 423 end if; 424 removeFile(fileName1); 425 removeFile(fileName2); 426 427 putf(fileName1, "File content check_moveFile 5"); 428 block 429 moveFile(fileName1, fileName2); 430 exception 431 catch FILE_ERROR: 432 writeln(" ***** moveFile with a regular file raises FILE_ERROR."); 433 okay := FALSE; 434 end block; 435 if fileType(fileName1) <> FILE_ABSENT then 436 writeln(" ***** moveFile does not remove the old file."); 437 okay := FALSE; 438 removeFile(fileName1); 439 end if; 440 if fileType(fileName2) = FILE_ABSENT then 441 writeln(" ***** moveFile does not create the destination."); 442 okay := FALSE; 443 elsif fileType(fileName2) <> FILE_REGULAR then 444 writeln(" ***** moveFile creates destination with wrong file type."); 445 okay := FALSE; 446 removeFile(fileName2); 447 else 448 if getf(fileName2) <> "File content check_moveFile 5" then 449 writeln(" ***** moveFile creates destination with wrong content."); 450 okay := FALSE; 451 end if; 452 removeFile(fileName2); 453 end if; 454 455 mkdir(fileName1); 456 block 457 moveFile(fileName1, fileName2); 458 exception 459 catch FILE_ERROR: 460 writeln(" ***** moveFile with an empty directory raises FILE_ERROR."); 461 okay := FALSE; 462 end block; 463 if fileType(fileName1) <> FILE_ABSENT then 464 writeln(" ***** moveFile does not remove the old file."); 465 okay := FALSE; 466 removeFile(fileName1); 467 end if; 468 if fileType(fileName2) = FILE_ABSENT then 469 writeln(" ***** moveFile does not create the destination."); 470 okay := FALSE; 471 elsif fileType(fileName2) <> FILE_DIR then 472 writeln(" ***** moveFile creates destination with wrong file type."); 473 okay := FALSE; 474 removeFile(fileName2); 475 else 476 if readDir(fileName2) <> 0 times "" then 477 writeln(" ***** moveFile creates destination directory with wrong content."); 478 okay := FALSE; 479 end if; 480 removeFile(fileName2); 481 end if; 482 483 mkdir(fileName1); 484 putf(fileName1 & "/" & fileName1, "File content check_moveFile 6"); 485 block 486 moveFile(fileName1, fileName2); 487 exception 488 catch FILE_ERROR: 489 writeln(" ***** moveFile with a directory raises FILE_ERROR."); 490 okay := FALSE; 491 end block; 492 if fileType(fileName1) <> FILE_ABSENT then 493 writeln(" ***** moveFile does not remove the old file."); 494 okay := FALSE; 495 removeFile(fileName1); 496 end if; 497 if fileType(fileName2) = FILE_ABSENT then 498 writeln(" ***** moveFile does not create the destination."); 499 okay := FALSE; 500 elsif fileType(fileName2) <> FILE_DIR then 501 writeln(" ***** moveFile creates destination with wrong file type."); 502 okay := FALSE; 503 removeFile(fileName2); 504 else 505 if length(readDir(fileName2)) <> 1 or 506 readDir(fileName2)[1] <> fileName1 then 507 writeln(" ***** moveFile creates destination directory with wrong content."); 508 okay := FALSE; 509 elsif getf(fileName2 & "/" & fileName1) <> "File content check_moveFile 6" then 510 writeln(" ***** moveFile creates destination file with wrong content."); 511 okay := FALSE; 512 end if; 513 removeTree(fileName2); 514 end if; 515 516 mkdir(fileName1); 517 mkdir(fileName2); 518 putf(fileName1 & "/" & fileName1, "File content check_moveFile 7"); 519 block 520 moveFile(fileName1 & "/" & fileName1, fileName2 & "/" & fileName2); 521 exception 522 catch FILE_ERROR: 523 writeln(" ***** moveFile with an empty directory raises FILE_ERROR."); 524 okay := FALSE; 525 end block; 526 if fileType(fileName1 & "/" & fileName1) <> FILE_ABSENT then 527 writeln(" ***** moveFile does not remove the old file."); 528 okay := FALSE; 529 removeFile(fileName1 & "/" & fileName1); 530 end if; 531 if fileType(fileName2 & "/" & fileName2) = FILE_ABSENT then 532 writeln(" ***** moveFile does not create the destination."); 533 okay := FALSE; 534 elsif fileType(fileName2 & "/" & fileName2) <> FILE_REGULAR then 535 writeln(" ***** moveFile creates destination with wrong file type."); 536 okay := FALSE; 537 removeFile(fileName2 & "/" & fileName2); 538 else 539 if getf(fileName2 & "/" & fileName2) <> "File content check_moveFile 7" then 540 writeln(" ***** moveFile creates destination file with wrong content."); 541 okay := FALSE; 542 end if; 543 removeFile(fileName2 & "/" & fileName2); 544 end if; 545 removeTree(fileName1); 546 removeTree(fileName2); 547 548 mkdir(fileName1); 549 mkdir(fileName2); 550 mkdir(fileName1 & "/" & fileName1); 551 block 552 moveFile(fileName1 & "/" & fileName1, fileName2 & "/" & fileName2); 553 exception 554 catch FILE_ERROR: 555 writeln(" ***** moveFile with an empty directory raises FILE_ERROR."); 556 okay := FALSE; 557 end block; 558 if fileType(fileName1 & "/" & fileName1) <> FILE_ABSENT then 559 writeln(" ***** moveFile does not remove the old file."); 560 okay := FALSE; 561 removeFile(fileName1 & "/" & fileName1); 562 end if; 563 if fileType(fileName2 & "/" & fileName2) = FILE_ABSENT then 564 writeln(" ***** moveFile does not create the destination."); 565 okay := FALSE; 566 elsif fileType(fileName2 & "/" & fileName2) <> FILE_DIR then 567 writeln(" ***** moveFile creates destination with wrong file type."); 568 okay := FALSE; 569 removeFile(fileName2 & "/" & fileName2); 570 else 571 if readDir(fileName2 & "/" & fileName2) <> 0 times "" then 572 writeln(" ***** moveFile creates destination directory with wrong content."); 573 okay := FALSE; 574 end if; 575 removeFile(fileName2 & "/" & fileName2); 576 end if; 577 removeTree(fileName1); 578 removeTree(fileName2); 579 580 if okay then 581 writeln("Moving files with moveFile works correct."); 582 else 583 writeln(" ***** Moving files with moveFile does not work correct."); 584 writeln; 585 end if; 586 end func; 587 588 589const func string: randomString (in integer: length) is func 590 result 591 var string: randomString is ""; 592 local 593 var integer: pos is 0; 594 begin 595 for pos range 1 to length do 596 randomString &:= rand('A', 'Z'); 597 end for; 598 end func; 599 600 601const func string: randomNameNotInEnvironment is func 602 result 603 var string: randomName is ""; 604 local 605 var string: name is ""; 606 var boolean: found is FALSE; 607 begin 608 repeat 609 randomName := randomString(10); 610 found := FALSE; 611 for name range environment until found do 612 if randomName = name then 613 found := TRUE; 614 end if; 615 end for; 616 until not found; 617 end func; 618 619 620const proc: check_environment is func 621 local 622 var string: name is ""; 623 var string: value is ""; 624 var string: randomName is ""; 625 var string: randomValue is ""; 626 var boolean: found is FALSE; 627 var boolean: okay is TRUE; 628 begin 629 # Get the values of all environment variables. 630 for name range environment do 631 if getenv(name) <> "" then 632 found := TRUE; 633 end if; 634 end for; 635 if length(environment) <> 0 and not found then 636 writeln(" ***** All environment variables have \"\" as value."); 637 okay := FALSE; 638 end if; 639 640 randomName := randomNameNotInEnvironment; 641 if getenv(randomName) <> "" then 642 writeln(" ***** getenv succeeds for non-existing environment variable."); 643 okay := FALSE; 644 end if; 645 for name range environment do 646 if randomName = name then 647 writeln(" ***** New environment variable exists already in the environment."); 648 okay := FALSE; 649 end if; 650 end for; 651 652 randomValue := randomString(10); 653 setenv(randomName, randomValue); 654 if getenv(randomName) <> randomValue then 655 writeln(" ***** Setting an environment variable does not work correct."); 656 okay := FALSE; 657 end if; 658 found := FALSE; 659 for name range environment do 660 if randomName = name then 661 found := TRUE; 662 end if; 663 end for; 664 if not found then 665 writeln(" ***** New environment variable does not exist in the environment after being set."); 666 okay := FALSE; 667 end if; 668 669 randomValue := randomString(10); 670 setenv(randomName, randomValue); 671 if getenv(randomName) <> randomValue then 672 writeln(" ***** Changing an environment variable does not work correct."); 673 okay := FALSE; 674 end if; 675 676 if okay then 677 writeln("Getting and setting environment variables works correct."); 678 else 679 writeln(" ***** Getting and setting environment variables does not work correct."); 680 writeln; 681 end if; 682 end func; 683 684 685const proc: main is func 686 begin 687 writeln; 688 writeln("Note that windows has race conditions if files"); 689 writeln("are copied, moved and removed quickly in succession."); 690 writeln("This bug of windows cannot be fixed in a runtime library."); 691 check_removeFile; 692 check_removeTree; 693 check_copyFile; 694 check_moveFile; 695 check_environment; 696 end func; 697