← Back to branch summary

~ubuntu-branches/ubuntu/utopic/gridengine/utopic

« back to all changes in this revision

Viewing changes to source/3rdparty/qmake/tests/test_driver.pl

  • Committer: Bazaar Package Importer
  • Author(s): Mark Hymers
  • Date: 2008-06-25 22:36:13 UTC
  • Revision ID: james.westby@ubuntu.com-20080625223613-tvd9xlhuoct9kyhm
Tags: upstream-6.2~beta2
Import upstream version 6.2~beta2

Show diffs side-by-side

added added

removed removed

Lines of Context:
source/3rdparty/qmake/tests/test_driver.pl
 
1
#!/usr/local/bin/perl
 
2
# -*-perl-*-
 
3
 
 
4
# Modification history:
 
5
# Written 91-12-02 through 92-01-01 by Stephen McGee.
 
6
# Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize.
 
7
# End of modification history
 
8
 
 
9
# Test driver routines used by a number of test suites, including
 
10
# those for SCS, make, roll_dir, and scan_deps (?).
 
11
 
 
12
# this routine controls the whole mess; each test suite sets up a few
 
13
# variables and then calls &toplevel, which does all the real work.
 
14
 
 
15
sub toplevel
 
16
{
 
17
  # Get a clean environment
 
18
 
 
19
  %makeENV = ();
 
20
 
 
21
  # Pull in benign variables from the user's environment
 
22
  #
 
23
  foreach (# UNIX-specific things
 
24
           'TZ', 'LANG', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
 
25
           # Purify things
 
26
           'PURIFYOPTIONS',
 
27
           # Windows NT-specific stuff
 
28
           'Path', 'SystemRoot',
 
29
           # DJGPP-specific stuff
 
30
           'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN',
 
31
           'FNCASE', '387', 'EMU387', 'GROUP'
 
32
          ) {
 
33
    $makeENV{$_} = $ENV{$_} if $ENV{$_};
 
34
  }
 
35
 
 
36
  # Replace the environment with the new one
 
37
  #
 
38
  %origENV = %ENV;
 
39
 
 
40
  # We used to say "%ENV = ();" but this doesn't work in Perl 5.000
 
41
  # through Perl 5.004.  It was fixed in Perl 5.004_01, but we don't
 
42
  # want to require that here, so just delete each one individually.
 
43
 
 
44
  foreach $v (keys %ENV) {
 
45
    delete $ENV{$v};
 
46
  }
 
47
 
 
48
  %ENV = %makeENV;
 
49
 
 
50
  $| = 1;                     # unbuffered output
 
51
 
 
52
  $debug = 0;                 # debug flag
 
53
  $profile = 0;               # profiling flag
 
54
  $verbose = 0;               # verbose mode flag
 
55
  $detail = 0;                # detailed verbosity
 
56
  $keep = 0;                  # keep temp files around
 
57
  $workdir = "work";          # The directory where the test will start running
 
58
  $scriptdir = "scripts";     # The directory where we find the test scripts
 
59
  $tmpfilesuffix = "t";       # the suffix used on tmpfiles
 
60
  $default_output_stack_level = 0;  # used by attach_default_output, etc.
 
61
  $default_input_stack_level = 0;   # used by attach_default_input, etc.
 
62
  $cwd = ".";                 # don't we wish we knew
 
63
  $cwdslash = "";             # $cwd . $pathsep, but "" rather than "./"
 
64
 
 
65
  &get_osname;  # sets $osname, $vos, $pathsep, and $fancy_file_names
 
66
 
 
67
  &set_defaults;  # suite-defined
 
68
 
 
69
  &parse_command_line (@ARGV);
 
70
 
 
71
  print "OS name = `$osname'\n" if $debug;
 
72
 
 
73
  $workpath = "$cwdslash$workdir";
 
74
  $scriptpath = "$cwdslash$scriptdir";
 
75
 
 
76
  &set_more_defaults;  # suite-defined
 
77
 
 
78
  &print_banner;
 
79
 
 
80
  if (-d $workpath)
 
81
  {
 
82
    print "Clearing $workpath...\n";
 
83
    &remove_directory_tree("$workpath/")
 
84
          || &error ("Couldn't wipe out $workpath\n");
 
85
  }
 
86
  else
 
87
  {
 
88
    mkdir ($workpath, 0777) || &error ("Couldn't mkdir $workpath: $!\n");
 
89
  }
 
90
 
 
91
  if (!-d $scriptpath)
 
92
  {
 
93
    &error ("Failed to find $scriptpath containing perl test scripts.\n");
 
94
  }
 
95
 
 
96
  if (@TESTS)
 
97
  {
 
98
    print "Making work dirs...\n";
 
99
    foreach $test (@TESTS)
 
100
    {
 
101
      if ($test =~ /^([^\/]+)\//)
 
102
      {
 
103
        $dir = $1;
 
104
        push (@rmdirs, $dir);
 
105
        -d "$workpath/$dir"
 
106
           || mkdir ("$workpath/$dir", 0777)
 
107
           || &error ("Couldn't mkdir $workpath/$dir: $!\n");
 
108
      }
 
109
    }
 
110
  }
 
111
  else
 
112
  {
 
113
    print "Finding tests...\n";
 
114
    opendir (SCRIPTDIR, $scriptpath)
 
115
        || &error ("Couldn't opendir $scriptpath: $!\n");
 
116
    @dirs = readdir (SCRIPTDIR);
 
117
    closedir (SCRIPTDIR);
 
118
    foreach $dir (@dirs)
 
119
    {
 
120
      next if ! -d "$scriptpath/$dir" || $dir =~ /^\.\.?$/ || $dir eq 'CVS';
 
121
      push (@rmdirs, $dir);
 
122
      mkdir ("$workpath/$dir", 0777)
 
123
           || &error ("Couldn't mkdir $workpath/$dir: $!\n");
 
124
      opendir (SCRIPTDIR, "$scriptpath/$dir")
 
125
          || &error ("Couldn't opendir $scriptpath/$dir: $!\n");
 
126
      @files = readdir (SCRIPTDIR);
 
127
      closedir (SCRIPTDIR);
 
128
      foreach $test (@files)
 
129
      {
 
130
        next if $test =~ /^\.\.?$/ || $test =~ /~$/ || $test eq 'CVS';
 
131
        push (@TESTS, "$dir/$test");
 
132
      }
 
133
    }
 
134
  }
 
135
 
 
136
  if (@TESTS == 0)
 
137
  {
 
138
    &error ("\nNo tests in $scriptpath, and none were specified.\n");
 
139
  }
 
140
 
 
141
  print "\n";
 
142
 
 
143
  &run_each_test;
 
144
 
 
145
  foreach $dir (@rmdirs)
 
146
  {
 
147
    rmdir ("$workpath/$dir");
 
148
  }
 
149
 
 
150
  $| = 1;
 
151
 
 
152
  if ($num_failed)
 
153
  {
 
154
    print "\n$num_failed Test";
 
155
    print "s" unless $num_failed == 1;
 
156
    print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n";
 
157
    return 0;
 
158
  }
 
159
  else
 
160
  {
 
161
    print "\n$counter Test";
 
162
    print "s" unless $counter == 1;
 
163
    print " Complete ... No Failures :-)\n\n";
 
164
    return 1;
 
165
  }
 
166
}
 
167
 
 
168
sub get_osname
 
169
{
 
170
  # Set up an initial value.  In perl5 we can do it the easy way.
 
171
  #
 
172
  $osname = defined($^O) ? $^O : '';
 
173
 
 
174
  # See if the filesystem supports long file names with multiple
 
175
  # dots.  DOS doesn't.
 
176
  $fancy_file_names = 1;
 
177
  (open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD))
 
178
      || ($fancy_file_names = 0);
 
179
  unlink ("fancy.file.name") || ($fancy_file_names = 0);
 
180
 
 
181
  if ($fancy_file_names) {
 
182
    # Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
 
183
    # better way of doing this.  (We used to test for existence of a /mnt
 
184
    # dir, but that apparently fails on an SGI Indigo (whatever that is).)
 
185
    # Because perl on VOS translates /'s to >'s, we need to test for
 
186
    # VOSness rather than testing for Unixness (ie, try > instead of /).
 
187
 
 
188
    mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1);
 
189
    open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD);
 
190
    chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1);
 
191
  }
 
192
 
 
193
  if ($fancy_file_names && -f "ick")
 
194
  {
 
195
    $osname = "vos";
 
196
    $vos = 1;
 
197
    $pathsep = ">";
 
198
  }
 
199
  else
 
200
  {
 
201
    # the following is regrettably knarly, but it seems to be the only way
 
202
    # to not get ugly error messages if uname can't be found.
 
203
    # Hmmm, BSD/OS 2.0's uname -a is excessively verbose.  Let's try it
 
204
    # with switches first.
 
205
    eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
 
206
    if ($osname =~ /not found/i)
 
207
    {
 
208
        $osname = "(something unixy with no uname)";
 
209
    }
 
210
    elsif ($@ ne "" || $?)
 
211
    {
 
212
        eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
 
213
        if ($@ ne "" || $?)
 
214
        {
 
215
            $osname = "(something unixy)";
 
216
        }
 
217
    }
 
218
    $vos = 0;
 
219
    $pathsep = "/";
 
220
  }
 
221
 
 
222
  if ($fancy_file_names) {
 
223
    chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1);
 
224
    unlink (".ostest>ick");
 
225
    rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
 
226
  }
 
227
}
 
228
 
 
229
sub parse_command_line
 
230
{
 
231
  @argv = @_;
 
232
 
 
233
  # use @ARGV if no args were passed in
 
234
 
 
235
  if (@argv == 0)
 
236
  {
 
237
    @argv = @ARGV;
 
238
  }
 
239
 
 
240
  # look at each option; if we don't recognize it, maybe the suite-specific
 
241
  # command line parsing code will...
 
242
 
 
243
  while (@argv)
 
244
  {
 
245
    $option = shift @argv;
 
246
    if ($option =~ /^-debug$/i)
 
247
    {
 
248
      print "\nDEBUG ON\n";
 
249
      $debug = 1;
 
250
    }
 
251
    elsif ($option =~ /^-usage$/i)
 
252
    {
 
253
      &print_usage;
 
254
      exit 0;
 
255
    }
 
256
    elsif ($option =~ /^-(h|help)$/i)
 
257
    {
 
258
      &print_help;
 
259
      exit 0;
 
260
    }
 
261
    elsif ($option =~ /^-profile$/i)
 
262
    {
 
263
      $profile = 1;
 
264
    }
 
265
    elsif ($option =~ /^-verbose$/i)
 
266
    {
 
267
      $verbose = 1;
 
268
    }
 
269
    elsif ($option =~ /^-detail$/i)
 
270
    {
 
271
      $detail = 1;
 
272
      $verbose = 1;
 
273
    }
 
274
    elsif ($option =~ /^-keep$/i)
 
275
    {
 
276
      $keep = 1;
 
277
    }
 
278
    elsif (&valid_option($option))
 
279
    {
 
280
      # The suite-defined subroutine takes care of the option
 
281
    }
 
282
    elsif ($option =~ /^-/)
 
283
    {
 
284
      print "Invalid option: $option\n";
 
285
      &print_usage;
 
286
      exit 0;
 
287
    }
 
288
    else # must be the name of a test
 
289
    {
 
290
      $option =~ s/\.pl$//;
 
291
      push(@TESTS,$option);
 
292
    }
 
293
  }
 
294
}
 
295
 
 
296
sub max
 
297
{
 
298
  local($num) = shift @_;
 
299
  local($newnum);
 
300
 
 
301
  while (@_)
 
302
  {
 
303
    $newnum = shift @_;
 
304
    if ($newnum > $num)
 
305
    {
 
306
      $num = $newnum;
 
307
    }
 
308
  }
 
309
 
 
310
  return $num;
 
311
}
 
312
 
 
313
sub print_centered
 
314
{
 
315
  local($width, $string) = @_;
 
316
  local($pad);
 
317
 
 
318
  if (length ($string))
 
319
  {
 
320
    $pad = " " x ( ($width - length ($string) + 1) / 2);
 
321
    print "$pad$string";
 
322
  }
 
323
}
 
324
 
 
325
sub print_banner
 
326
{
 
327
  local($info);
 
328
  local($line);
 
329
  local($len);
 
330
 
 
331
  $info = "Running tests for $testee on $osname\n";  # $testee is suite-defined
 
332
  $len = &max (length ($line), length ($testee_version),
 
333
               length ($banner_info), 73) + 5;
 
334
  $line = ("-" x $len) . "\n";
 
335
  if ($len < 78)
 
336
  {
 
337
    $len = 78;
 
338
  }
 
339
 
 
340
  &print_centered ($len, $line);
 
341
  &print_centered ($len, $info);
 
342
  &print_centered ($len, $testee_version);  # suite-defined
 
343
  &print_centered ($len, $banner_info);     # suite-defined
 
344
  &print_centered ($len, $line);
 
345
  print "\n";
 
346
}
 
347
 
 
348
sub run_each_test
 
349
{
 
350
  $counter = 0;
 
351
 
 
352
  foreach $testname (sort @TESTS)
 
353
  {
 
354
    $counter++;
 
355
    $test_passed = 1;       # reset by test on failure
 
356
    $num_of_logfiles = 0;
 
357
    $num_of_tmpfiles = 0;
 
358
    $description = "";
 
359
    $details = "";
 
360
    $testname =~ s/^$scriptpath$pathsep//;
 
361
    $perl_testname = "$scriptpath$pathsep$testname";
 
362
    $testname =~ s/(\.pl|\.perl)$//;
 
363
    $testpath = "$workpath$pathsep$testname";
 
364
    # Leave enough space in the extensions to append a number, even
 
365
    # though it needs to fit into 8+3 limits.
 
366
    if ($port_host eq 'DOS') {
 
367
      $logext = 'l';
 
368
      $diffext = 'd';
 
369
      $baseext = 'b';
 
370
      $extext = '';
 
371
   }
 
372
    else {
 
373
      $logext = 'log';
 
374
      $diffext = 'diff';
 
375
      $baseext = 'base';
 
376
      $extext = '.';
 
377
    }
 
378
    $log_filename = "$testpath.$logext";
 
379
    $diff_filename = "$testpath.$diffext";
 
380
    $base_filename = "$testpath.$baseext";
 
381
    $tmp_filename = "$testpath.$tmpfilesuffix";
 
382
 
 
383
    &setup_for_test;          # suite-defined
 
384
 
 
385
    $output = "........................................................ ";
 
386
 
 
387
    substr($output,0,length($testname)) = "$testname ";
 
388
 
 
389
    print $output;
 
390
 
 
391
    # Run the actual test!
 
392
    #
 
393
    $code = do $perl_testname;
 
394
    if (!defined($code))
 
395
    {
 
396
      $test_passed = 0;
 
397
      if (length ($@))
 
398
      {
 
399
        warn "\n*** Test died ($testname): $@\n";
 
400
      }
 
401
      else
 
402
      {
 
403
        warn "\n*** Couldn't run $perl_testname\n";
 
404
      }
 
405
    }
 
406
    elsif ($code == -1) {
 
407
      $test_passed = 0;
 
408
    }
 
409
    elsif ($code != 1 && $code != -1) {
 
410
      $test_passed = 0;
 
411
      warn "\n*** Test returned $code\n";
 
412
    }
 
413
 
 
414
    if ($test_passed) {
 
415
      $status = "ok";
 
416
      for ($i = $num_of_tmpfiles; $i; $i--)
 
417
      {
 
418
        &delete ($tmp_filename . &num_suffix ($i) );
 
419
      }
 
420
 
 
421
      for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--)
 
422
      {
 
423
        &delete ($log_filename . &num_suffix ($i) );
 
424
        &delete ($base_filename . &num_suffix ($i) );
 
425
      }
 
426
    }
 
427
    elsif ($code > 0) {
 
428
      $status = "FAILED";
 
429
      $num_failed++;
 
430
    }
 
431
    elsif ($code < 0) {
 
432
      $status = "N/A";
 
433
      --$counter;
 
434
    }
 
435
 
 
436
    # If the verbose option has been specified, then a short description
 
437
    # of each test is printed before displaying the results of each test
 
438
    # describing WHAT is being tested.
 
439
 
 
440
    if ($verbose)
 
441
    {
 
442
      if ($detail)
 
443
      {
 
444
        print "\nWHAT IS BEING TESTED\n";
 
445
        print "--------------------";
 
446
      }
 
447
      print "\n\n$description\n\n";
 
448
    }
 
449
 
 
450
    # If the detail option has been specified, then the details of HOW
 
451
    # the test is testing what it says it is testing in the verbose output
 
452
    # will be displayed here before the results of the test are displayed.
 
453
 
 
454
    if ($detail)
 
455
    {
 
456
      print "\nHOW IT IS TESTED\n";
 
457
      print "----------------";
 
458
      print "\n\n$details\n\n";
 
459
    }
 
460
 
 
461
    print "$status\n";
 
462
  }
 
463
}
 
464
 
 
465
# If the keep flag is not set, this subroutine deletes all filenames that
 
466
# are sent to it.
 
467
 
 
468
sub delete
 
469
{
 
470
  local(@files) = @_;
 
471
 
 
472
  if (!$keep)
 
473
  {
 
474
    return (unlink @files);
 
475
  }
 
476
 
 
477
  return 1;
 
478
}
 
479
 
 
480
sub print_standard_usage
 
481
{
 
482
  local($plname,@moreusage) = @_;
 
483
  local($line);
 
484
 
 
485
  print "Usage:  perl $plname [testname] [-verbose] [-detail] [-keep]\n";
 
486
  print "                               [-profile] [-usage] [-help] "
 
487
      . "[-debug]\n";
 
488
  foreach $line (@moreusage)
 
489
  {
 
490
    print "                               $line\n";
 
491
  }
 
492
}
 
493
 
 
494
sub print_standard_help
 
495
{
 
496
  local(@morehelp) = @_;
 
497
  local($line);
 
498
  local($tline);
 
499
  local($t) = "      ";
 
500
 
 
501
  $line = "Test Driver For $testee";
 
502
  print "$line\n";
 
503
  $line = "=" x length ($line);
 
504
  print "$line\n";
 
505
 
 
506
  &print_usage;
 
507
 
 
508
  print "\ntestname\n"
 
509
      . "${t}You may, if you wish, run only ONE test if you know the name\n"
 
510
      . "${t}of that test and specify this name anywhere on the command\n"
 
511
      . "${t}line.  Otherwise ALL existing tests in the scripts directory\n"
 
512
      . "${t}will be run.\n"
 
513
      . "-verbose\n"
 
514
      . "${t}If this option is given, a description of every test is\n"
 
515
      . "${t}displayed before the test is run. (Not all tests may have\n"
 
516
      . "${t}descriptions at this time)\n"
 
517
      . "-detail\n"
 
518
      . "${t}If this option is given, a detailed description of every\n"
 
519
      . "${t}test is displayed before the test is run. (Not all tests\n"
 
520
      . "${t}have descriptions at this time)\n"
 
521
      . "-profile\n"
 
522
      . "${t}If this option is given, then the profile file\n"
 
523
      . "${t}is added to other profiles every time $testee is run.\n"
 
524
      . "${t}This option only works on VOS at this time.\n"
 
525
      . "-keep\n"
 
526
      . "${t}You may give this option if you DO NOT want ANY\n"
 
527
      . "${t}of the files generated by the tests to be deleted. \n"
 
528
      . "${t}Without this option, all files generated by the test will\n"
 
529
      . "${t}be deleted IF THE TEST PASSES.\n"
 
530
      . "-debug\n"
 
531
      . "${t}Use this option if you would like to see all of the system\n"
 
532
      . "${t}calls issued and their return status while running the tests\n"
 
533
      . "${t}This can be helpful if you're having a problem adding a test\n"
 
534
      . "${t}to the suite, or if the test fails!\n";
 
535
 
 
536
  foreach $line (@morehelp)
 
537
  {
 
538
    $tline = $line;
 
539
    if (substr ($tline, 0, 1) eq "\t")
 
540
    {
 
541
      substr ($tline, 0, 1) = $t;
 
542
    }
 
543
    print "$tline\n";
 
544
  }
 
545
}
 
546
 
 
547
#######################################################################
 
548
###########         Generic Test Driver Subroutines         ###########
 
549
#######################################################################
 
550
 
 
551
sub get_caller
 
552
{
 
553
  local($depth);
 
554
  local($package);
 
555
  local($filename);
 
556
  local($linenum);
 
557
 
 
558
  $depth = defined ($_[0]) ? $_[0] : 1;
 
559
  ($package, $filename, $linenum) = caller ($depth + 1);
 
560
  return "$filename: $linenum";
 
561
}
 
562
 
 
563
sub error
 
564
{
 
565
  local($message) = $_[0];
 
566
  local($caller) = &get_caller (1);
 
567
 
 
568
  if (defined ($_[1]))
 
569
  {
 
570
    $caller = &get_caller ($_[1] + 1) . " -> $caller";
 
571
  }
 
572
 
 
573
  die "$caller: $message";
 
574
}
 
575
 
 
576
sub compare_output
 
577
{
 
578
  local($answer,$logfile) = @_;
 
579
  local($slurp);
 
580
 
 
581
  if ($debug)
 
582
  {
 
583
    print "Comparing Output ........ ";
 
584
  }
 
585
 
 
586
  $slurp = &read_file_into_string ($logfile);
 
587
 
 
588
  # For make, get rid of any time skew error before comparing--too bad this
 
589
  # has to go into the "generic" driver code :-/
 
590
  $slurp =~ s/^.*modification time in the future.*\n//g;
 
591
  $slurp =~ s/\n.*modification time in the future.*//g;
 
592
  $slurp =~ s/^.*Clock skew detected.*\n//g;
 
593
  $slurp =~ s/\n.*Clock skew detected.*//g;
 
594
 
 
595
  if ($slurp eq $answer)
 
596
  {
 
597
    if ($debug)
 
598
    {
 
599
      print "ok\n";
 
600
    }
 
601
    return 1;
 
602
  }
 
603
  else
 
604
  {
 
605
    if ($debug)
 
606
    {
 
607
      print "DIFFERENT OUTPUT\n";
 
608
    }
 
609
    $test_passed = 0;
 
610
    &create_file (&get_basefile, $answer);
 
611
 
 
612
    if ($debug)
 
613
    {
 
614
      print "\nCreating Difference File ...\n";
 
615
    }
 
616
    # Create the difference file
 
617
    local($command) = "diff -c " . &get_basefile . " " . $logfile;
 
618
    &run_command_with_output(&get_difffile,$command);
 
619
 
 
620
    return 0;
 
621
  }
 
622
}
 
623
 
 
624
sub read_file_into_string
 
625
{
 
626
  local($filename) = @_;
 
627
  local($oldslash) = $/;
 
628
 
 
629
  undef $/;
 
630
 
 
631
  open (RFISFILE, $filename) || return "";
 
632
  local ($slurp) = <RFISFILE>;
 
633
  close (RFISFILE);
 
634
 
 
635
  $/ = $oldslash;
 
636
 
 
637
  return $slurp;
 
638
}
 
639
 
 
640
sub attach_default_output
 
641
{
 
642
  local ($filename) = @_;
 
643
  local ($code);
 
644
 
 
645
  if ($vos)
 
646
  {
 
647
    $code = system "++attach_default_output_hack $filename";
 
648
    $code == -2 || &error ("adoh death\n", 1);
 
649
    return 1;
 
650
  }
 
651
 
 
652
  open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT")
 
653
        || &error ("ado: $! duping STDOUT\n", 1);
 
654
  open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR")
 
655
        || &error ("ado: $! duping STDERR\n", 1);
 
656
 
 
657
  open (STDOUT, "> " . $filename)
 
658
        || &error ("ado: $filename: $!\n", 1);
 
659
  open (STDERR, ">&STDOUT")
 
660
        || &error ("ado: $filename: $!\n", 1);
 
661
 
 
662
  $default_output_stack_level++;
 
663
}
 
664
 
 
665
# close the current stdout/stderr, and restore the previous ones from
 
666
# the "stack."
 
667
 
 
668
sub detach_default_output
 
669
{
 
670
  local ($code);
 
671
 
 
672
  if ($vos)
 
673
  {
 
674
    $code = system "++detach_default_output_hack";
 
675
    $code == -2 || &error ("ddoh death\n", 1);
 
676
    return 1;
 
677
  }
 
678
 
 
679
  if (--$default_output_stack_level < 0)
 
680
  {
 
681
    &error ("default output stack has flown under!\n", 1);
 
682
  }
 
683
 
 
684
  close (STDOUT);
 
685
  close (STDERR);
 
686
 
 
687
  open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out")
 
688
        || &error ("ddo: $! duping STDOUT\n", 1);
 
689
  open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err")
 
690
        || &error ("ddo: $! duping STDERR\n", 1);
 
691
 
 
692
  close ("SAVEDOS" . $default_output_stack_level . "out")
 
693
        || &error ("ddo: $! closing SCSDOSout\n", 1);
 
694
  close ("SAVEDOS" . $default_output_stack_level . "err")
 
695
         || &error ("ddo: $! closing SAVEDOSerr\n", 1);
 
696
}
 
697
 
 
698
# run one command (passed as a list of arg 0 - n), returning 0 on success
 
699
# and nonzero on failure.
 
700
 
 
701
sub run_command
 
702
{
 
703
  local ($code);
 
704
 
 
705
  if ($debug)
 
706
  {
 
707
    print "\nrun_command: @_\n";
 
708
    $code = system @_;
 
709
    print "run_command: \"@_\" returned $code.\n";
 
710
    return $code;
 
711
  }
 
712
 
 
713
  return system @_;
 
714
}
 
715
 
 
716
# run one command (passed as a list of arg 0 - n, with arg 0 being the
 
717
# second arg to this routine), returning 0 on success and non-zero on failure.
 
718
# The first arg to this routine is a filename to connect to the stdout
 
719
# & stderr of the child process.
 
720
 
 
721
sub run_command_with_output
 
722
{
 
723
  local ($filename) = shift;
 
724
  local ($code);
 
725
 
 
726
  &attach_default_output ($filename);
 
727
  $code = system @_;
 
728
  &detach_default_output;
 
729
  if ($debug)
 
730
  {
 
731
    print "run_command_with_output: \"@_\" returned $code.\n";
 
732
  }
 
733
 
 
734
  return $code;
 
735
}
 
736
 
 
737
# performs the equivalent of an "rm -rf" on the first argument.  Like
 
738
# rm, if the path ends in /, leaves the (now empty) directory; otherwise
 
739
# deletes it, too.
 
740
 
 
741
sub remove_directory_tree
 
742
{
 
743
  local ($targetdir) = @_;
 
744
  local ($nuketop) = 1;
 
745
  local ($ch);
 
746
 
 
747
  $ch = substr ($targetdir, length ($targetdir) - 1);
 
748
  if ($ch eq "/" || $ch eq $pathsep)
 
749
  {
 
750
    $targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
 
751
    $nuketop = 0;
 
752
  }
 
753
 
 
754
  if (! -e $targetdir)
 
755
  {
 
756
    return 1;
 
757
  }
 
758
 
 
759
  &remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
 
760
  if ($nuketop)
 
761
  {
 
762
    rmdir $targetdir || return 0;
 
763
  }
 
764
 
 
765
  return 1;
 
766
}
 
767
 
 
768
sub remove_directory_tree_inner
 
769
{
 
770
  local ($dirhandle, $targetdir) = @_;
 
771
  local ($object);
 
772
  local ($subdirhandle);
 
773
 
 
774
  opendir ($dirhandle, $targetdir) || return 0;
 
775
  $subdirhandle = $dirhandle;
 
776
  $subdirhandle++;
 
777
  while ($object = readdir ($dirhandle))
 
778
  {
 
779
    if ($object eq "." || $object eq "..")
 
780
    {
 
781
      next;
 
782
    }
 
783
 
 
784
    $object = "$targetdir$pathsep$object";
 
785
    lstat ($object);
 
786
 
 
787
    if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
 
788
    {
 
789
      rmdir $object || return 0;
 
790
    }
 
791
    else
 
792
    {
 
793
      unlink $object || return 0;
 
794
    }
 
795
  }
 
796
  closedir ($dirhandle);
 
797
  return 1;
 
798
}
 
799
 
 
800
# We used to use this behavior for this function:
 
801
#
 
802
#sub touch
 
803
#{
 
804
#  local (@filenames) = @_;
 
805
#  local ($now) = time;
 
806
#  local ($file);
 
807
#
 
808
#  foreach $file (@filenames)
 
809
#  {
 
810
#    utime ($now, $now, $file)
 
811
#          || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
 
812
#               || &error ("Couldn't touch $file: $!\n", 1);
 
813
#  }
 
814
#  return 1;
 
815
#}
 
816
#
 
817
# But this behaves badly on networked filesystems where the time is
 
818
# skewed, because it sets the time of the file based on the _local_
 
819
# host.  Normally when you modify a file, it's the _remote_ host that
 
820
# determines the modtime, based on _its_ clock.  So, instead, now we open
 
821
# the file and write something into it to force the remote host to set
 
822
# the modtime correctly according to its clock.
 
823
#
 
824
 
 
825
sub touch
 
826
{
 
827
  local (@filenames) = @_;
 
828
  local ($file);
 
829
 
 
830
  foreach $file (@filenames) {
 
831
    (open(T, ">> $file") && print(T "\n") && close(T))
 
832
        || &error("Couldn't touch $file: $!\n", 1);
 
833
  }
 
834
}
 
835
 
 
836
# open a file, write some stuff to it, and close it.
 
837
 
 
838
sub create_file
 
839
{
 
840
  local ($filename, @lines) = @_;
 
841
 
 
842
  open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
 
843
  foreach $line (@lines)
 
844
  {
 
845
    print CF $line;
 
846
  }
 
847
  close (CF);
 
848
}
 
849
 
 
850
# create a directory tree described by an associative array, wherein each
 
851
# key is a relative pathname (using slashes) and its associated value is
 
852
# one of:
 
853
#    DIR            indicates a directory
 
854
#    FILE:contents  indicates a file, which should contain contents +\n
 
855
#    LINK:target    indicates a symlink, pointing to $basedir/target
 
856
# The first argument is the dir under which the structure will be created
 
857
# (the dir will be made and/or cleaned if necessary); the second argument
 
858
# is the associative array.
 
859
 
 
860
sub create_dir_tree
 
861
{
 
862
  local ($basedir, %dirtree) = @_;
 
863
  local ($path);
 
864
 
 
865
  &remove_directory_tree ("$basedir");
 
866
  mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
 
867
 
 
868
  foreach $path (sort keys (%dirtree))
 
869
  {
 
870
    if ($dirtree {$path} =~ /^DIR$/)
 
871
    {
 
872
      mkdir ("$basedir/$path", 0777)
 
873
               || &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
 
874
    }
 
875
    elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
 
876
    {
 
877
      &create_file ("$basedir/$path", $1 . "\n");
 
878
    }
 
879
    elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
 
880
    {
 
881
      symlink ("$basedir/$1", "$basedir/$path")
 
882
        || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
 
883
    }
 
884
    else
 
885
    {
 
886
      &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
 
887
    }
 
888
  }
 
889
  if ($just_setup_tree)
 
890
  {
 
891
    die "Tree is setup...\n";
 
892
  }
 
893
}
 
894
 
 
895
# compare a directory tree with an associative array in the format used
 
896
# by create_dir_tree, above.
 
897
# The first argument is the dir under which the structure should be found;
 
898
# the second argument is the associative array.
 
899
 
 
900
sub compare_dir_tree
 
901
{
 
902
  local ($basedir, %dirtree) = @_;
 
903
  local ($path);
 
904
  local ($i);
 
905
  local ($bogus) = 0;
 
906
  local ($contents);
 
907
  local ($target);
 
908
  local ($fulltarget);
 
909
  local ($found);
 
910
  local (@files);
 
911
  local (@allfiles);
 
912
 
 
913
  opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
 
914
  @allfiles = grep (!/^\.\.?$/, readdir (DIR) );
 
915
  closedir (DIR);
 
916
  if ($debug)
 
917
  {
 
918
    print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
 
919
  }
 
920
 
 
921
  foreach $path (sort keys (%dirtree))
 
922
  {
 
923
    if ($debug)
 
924
    {
 
925
      print "Checking $path ($dirtree{$path}).\n";
 
926
    }
 
927
 
 
928
    $found = 0;
 
929
    foreach $i (0 .. $#allfiles)
 
930
    {
 
931
      if ($allfiles[$i] eq $path)
 
932
      {
 
933
        splice (@allfiles, $i, 1);  # delete it
 
934
        if ($debug)
 
935
        {
 
936
          print "     Zapped $path; files now (@allfiles).\n";
 
937
        }
 
938
        lstat ("$basedir/$path");
 
939
        $found = 1;
 
940
        last;
 
941
      }
 
942
    }
 
943
 
 
944
    if (!$found)
 
945
    {
 
946
      print "compare_dir_tree: $path does not exist.\n";
 
947
      $bogus = 1;
 
948
      next;
 
949
    }
 
950
 
 
951
    if ($dirtree {$path} =~ /^DIR$/)
 
952
    {
 
953
      if (-d _ && opendir (DIR, "$basedir/$path") )
 
954
      {
 
955
        @files = readdir (DIR);
 
956
        closedir (DIR);
 
957
        @files = grep (!/^\.\.?$/ && ($_ = "$path/$_"), @files);
 
958
        push (@allfiles, @files);
 
959
        if ($debug)
 
960
        {
 
961
          print "     Read in $path; new files (@files).\n";
 
962
        }
 
963
      }
 
964
      else
 
965
      {
 
966
        print "compare_dir_tree: $path is not a dir.\n";
 
967
        $bogus = 1;
 
968
      }
 
969
    }
 
970
    elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
 
971
    {
 
972
      if (-l _ || !-f _)
 
973
      {
 
974
        print "compare_dir_tree: $path is not a file.\n";
 
975
        $bogus = 1;
 
976
        next;
 
977
      }
 
978
 
 
979
      if ($1 ne "*")
 
980
      {
 
981
        $contents = &read_file_into_string ("$basedir/$path");
 
982
        if ($contents ne "$1\n")
 
983
        {
 
984
          print "compare_dir_tree: $path contains wrong stuff."
 
985
              . "  Is:\n$contentsShould be:\n$1\n";
 
986
          $bogus = 1;
 
987
        }
 
988
      }
 
989
    }
 
990
    elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
 
991
    {
 
992
      $target = $1;
 
993
      if (!-l _)
 
994
      {
 
995
        print "compare_dir_tree: $path is not a link.\n";
 
996
        $bogus = 1;
 
997
        next;
 
998
      }
 
999
 
 
1000
      $contents = readlink ("$basedir/$path");
 
1001
      $contents =~ tr/>/\//;
 
1002
      $fulltarget = "$basedir/$target";
 
1003
      $fulltarget =~ tr/>/\//;
 
1004
      if (!($contents =~ /$fulltarget$/))
 
1005
      {
 
1006
        if ($debug)
 
1007
        {
 
1008
          $target = $fulltarget;
 
1009
        }
 
1010
        print "compare_dir_tree: $path should be link to $target, "
 
1011
            . "not $contents.\n";
 
1012
        $bogus = 1;
 
1013
      }
 
1014
    }
 
1015
    else
 
1016
    {
 
1017
      &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
 
1018
    }
 
1019
  }
 
1020
 
 
1021
  if ($debug)
 
1022
  {
 
1023
    print "leftovers: (@allfiles).\n";
 
1024
  }
 
1025
 
 
1026
  foreach $file (@allfiles)
 
1027
  {
 
1028
    print "compare_dir_tree: $file should not exist.\n";
 
1029
    $bogus = 1;
 
1030
  }
 
1031
 
 
1032
  return !$bogus;
 
1033
}
 
1034
 
 
1035
# this subroutine generates the numeric suffix used to keep tmp filenames,
 
1036
# log filenames, etc., unique.  If the number passed in is 1, then a null
 
1037
# string is returned; otherwise, we return ".n", where n + 1 is the number
 
1038
# we were given.
 
1039
 
 
1040
sub num_suffix
 
1041
{
 
1042
  local($num) = @_;
 
1043
 
 
1044
  if (--$num > 0) {
 
1045
    return "$extext$num";
 
1046
  }
 
1047
 
 
1048
  return "";
 
1049
}
 
1050
 
 
1051
# This subroutine returns a log filename with a number appended to
 
1052
# the end corresponding to how many logfiles have been created in the
 
1053
# current running test.  An optional parameter may be passed (0 or 1).
 
1054
# If a 1 is passed, then it does NOT increment the logfile counter
 
1055
# and returns the name of the latest logfile.  If either no parameter
 
1056
# is passed at all or a 0 is passed, then the logfile counter is
 
1057
# incremented and the new name is returned.
 
1058
 
 
1059
sub get_logfile
 
1060
{
 
1061
  local($no_increment) = @_;
 
1062
 
 
1063
  $num_of_logfiles += !$no_increment;
 
1064
 
 
1065
  return ($log_filename . &num_suffix ($num_of_logfiles));
 
1066
}
 
1067
 
 
1068
# This subroutine returns a base (answer) filename with a number
 
1069
# appended to the end corresponding to how many logfiles (and thus
 
1070
# base files) have been created in the current running test.
 
1071
# NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
 
1072
 
 
1073
sub get_basefile
 
1074
{
 
1075
  return ($base_filename . &num_suffix ($num_of_logfiles));
 
1076
}
 
1077
 
 
1078
# This subroutine returns a difference filename with a number appended
 
1079
# to the end corresponding to how many logfiles (and thus diff files)
 
1080
# have been created in the current running test.
 
1081
 
 
1082
sub get_difffile
 
1083
{
 
1084
  return ($diff_filename . &num_suffix ($num_of_logfiles));
 
1085
}
 
1086
 
 
1087
# just like logfile, only a generic tmp filename for use by the test.
 
1088
# they are automatically cleaned up unless -keep was used, or the test fails.
 
1089
# Pass an argument of 1 to return the same filename as the previous call.
 
1090
 
 
1091
sub get_tmpfile
 
1092
{
 
1093
  local($no_increment) = @_;
 
1094
 
 
1095
  $num_of_tmpfiles += !$no_increment;
 
1096
 
 
1097
  return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
 
1098
}
 
1099
 
 
1100
1;