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