utils/perlivp.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename;
   5 use Cwd;
   6
   7 # List explicitly here the variables you want Configure to
   8 # generate.  Metaconfig only looks for shell variables, so you
   9 # have to mention them as if they were shell variables, not
  10 # %Config entries:
  11 #  $startperl
  12 #  $perlpath
  13 #  $eunicefix
  14
  15 # This forces PL files to create target in same directory as PL file.
  16 # This is so that make depend always knows where to find PL derivatives.
  17 my $origdir = cwd;
  18 chdir dirname($0);
  19 my $file = basename($0, '.PL');
  20 $file .= '.com' if $^O eq 'VMS';
  21
  22 # Create output file.
  23 open OUT,">$file" or die "Can't create $file: $!";
  24
  25 print "Extracting $file (with variable substitutions)\n";
  26
  27 # In this section, perl variables will be expanded during extraction.
  28 # You can use $Config{...} to use Configure variables.
  29
  30 print OUT <<"!GROK!THIS!";
  31 $Config{'startperl'}
  32     eval 'exec $Config{'perlpath'} -S \$0 \${1+"\$@"}'
  33         if \$running_under_some_shell;
  34 !GROK!THIS!
  35
  36 print OUT "\n# perlivp $^V\n";
  37
  38 # In the following, perl variables are not expanded during extraction.
  39
  40 print OUT <<'!NO!SUBS!';
  41
  42 sub usage {
  43     warn "@_\n" if @_;
  44     print << "    EOUSAGE";
  45 Usage:
  46
  47     $0 [-a] [-p] [-v] | [-h]
  48
  49     -a Run all tests (default is to skip .ph tests)
  50     -p Print a preface before each test telling what it will test.
  51     -v Verbose mode in which extra information about test results
  52        is printed.  Test failures always print out some extra information
  53        regardless of whether or not this switch is set.
  54     -h Prints this help message.
  55     EOUSAGE
  56     exit;
  57 }
  58
  59 use vars qw(%opt); # allow testing with older versions (do not use our)
  60
  61 @opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
  62
  63 while ($ARGV[0] =~ /^-/) {
  64     $ARGV[0] =~ s/^-//;
  65     for my $flag (split(//,$ARGV[0])) {
  66         usage() if '?' =~ /\Q$flag/;
  67         usage() if 'h' =~ /\Q$flag/;
  68         usage() if 'H' =~ /\Q$flag/;
  69         usage("unknown flag: `$flag'") unless 'HhPpVva' =~ /\Q$flag/;
  70         warn "$0: `$flag' flag already set\n" if $opt{$flag}++;
  71     }
  72     shift;
  73 }
  74
  75 $opt{p}++ if $opt{P};
  76 $opt{v}++ if $opt{V};
  77
  78 my $pass__total = 0;
  79 my $error_total = 0;
  80 my $tests_total = 0;
  81
  82 !NO!SUBS!
  83
  84 # We cannot merely check the variable `$^X' in general since on many
  85 # Unixes it is the basename rather than the full path to the perl binary.
  86 my $perlpath = '';
  87 if (defined($Config{'perlpath'})) { $perlpath = $Config{'perlpath'}; }
  88
  89 # The useithreads Config variable plays a role in whether or not
  90 # threads and threads/shared work when C<use>d.  They apparently always
  91 # get installed on systems that can run Configure.
  92 my $useithreads = '';
  93 if (defined($Config{'useithreads'})) { $useithreads = $Config{'useithreads'}; }
  94
  95 print OUT <<"!GROK!THIS!";
  96 my \$perlpath = '$perlpath';
  97 my \$useithreads = '$useithreads';
  98 !GROK!THIS!
  99
 100 print OUT <<'!NO!SUBS!';
 101
 102 print "## Checking Perl binary via variable `\$perlpath' = $perlpath.\n" if $opt{'p'};
 103
 104 if (-x $perlpath) {
 105     print "## Perl binary `$perlpath' appears executable.\n" if $opt{'v'};
 106     print "ok 1\n";
 107     $pass__total++;
 108 }
 109 else {
 110     print "# Perl binary `$perlpath' does not appear executable.\n";
 111     print "not ok 1\n";
 112     $error_total++;
 113 }
 114 $tests_total++;
 115
 116
 117 print "## Checking Perl version via variable `\$]'.\n" if $opt{'p'};
 118
 119 !NO!SUBS!
 120
 121 print OUT <<"!GROK!THIS!";
 122 my \$ivp_VERSION = "$]";
 123
 124 !GROK!THIS!
 125 print OUT <<'!NO!SUBS!';
 126 if ($ivp_VERSION eq $]) {
 127     print "## Perl version `$]' appears installed as expected.\n" if $opt{'v'};
 128     print "ok 2\n";
 129     $pass__total++;
 130 }
 131 else {
 132     print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
 133     print "not ok 2\n";
 134     $error_total++;
 135 }
 136 $tests_total++;
 137
 138
 139 print "## Checking roots of the Perl library directory tree via variable `\@INC'.\n" if $opt{'p'};
 140
 141 my $INC_total = 0;
 142 my $INC_there = 0;
 143 foreach (@INC) {
 144     next if $_ eq '.'; # skip -d test here
 145     if ($^O eq 'MacOS') {
 146         next if $_ eq ':'; # skip -d test here
 147         next if $_ eq 'Dev:Pseudo:'; # why is this in @INC?
 148     }
 149     if (-d $_) {
 150         print "## Perl \@INC directory `$_' exists.\n" if $opt{'v'};
 151         $INC_there++;
 152     }
 153     else {
 154         print "# Perl \@INC directory `$_' does not appear to exist.\n";
 155     }
 156     $INC_total++;
 157 }
 158 if ($INC_total == $INC_there) {
 159     print "ok 3\n";
 160     $pass__total++;
 161 }
 162 else {
 163     print "not ok 3\n";
 164     $error_total++;
 165 }
 166 $tests_total++;
 167
 168
 169 print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
 170
 171 my $needed_total = 0;
 172 my $needed_there = 0;
 173 foreach (qw(Config.pm ExtUtils/Installed.pm)) {
 174     $@ = undef;
 175     $needed_total++;
 176     eval "require \"$_\";";
 177     if (!$@) {
 178         print "## Module `$_' appears to be installed.\n" if $opt{'v'};
 179         $needed_there++;
 180     }
 181     else {
 182         print "# Needed module `$_' does not appear to be properly installed.\n";
 183     }
 184     $@ = undef;
 185 }
 186 if ($needed_total == $needed_there) {
 187     print "ok 4\n";
 188     $pass__total++;
 189 }
 190 else {
 191     print "not ok 4\n";
 192     $error_total++;
 193 }
 194 $tests_total++;
 195
 196
 197 print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
 198
 199 use Config;
 200
 201 my $extensions_total = 0;
 202 my $extensions_there = 0;
 203 if (defined($Config{'extensions'})) {
 204     my @extensions = split(/\s+/,$Config{'extensions'});
 205     foreach (@extensions) {
 206         next if ($_ eq '');
 207         if ( $useithreads !~ /define/i ) {
 208             next if ($_ eq 'threads');
 209             next if ($_ eq 'threads/shared');
 210         }
 211         # that's a distribution name, not a module name
 212         next if $_ eq 'IO/Compress';
 213         next if $_ eq 'Devel/DProf';
 214         next if $_ eq 'libnet';
 215         next if $_ eq 'Locale/Codes';
 216         next if $_ eq 'podlators';
 217         # test modules
 218         next if $_ eq 'XS/APItest';
 219         next if $_ eq 'XS/Typemap';
 220            # VMS$ perl  -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
 221            # \NT> perl  -e "eval \"require 'Devel/DProf.pm'\"; print $@"
 222            # DProf: run perl with -d to use DProf.
 223            # Compilation failed in require at (eval 1) line 1.
 224         eval " require \"$_.pm\"; ";
 225         if (!$@) {
 226             print "## Module `$_' appears to be installed.\n" if $opt{'v'};
 227             $extensions_there++;
 228         }
 229         else {
 230             print "# Required module `$_' does not appear to be properly installed.\n";
 231             $@ = undef;
 232         }
 233         $extensions_total++;
 234     }
 235
 236     # A silly name for a module (that hopefully won't ever exist).
 237     # Note that this test serves more as a check of the validity of the
 238     # actuall required module tests above.
 239     my $unnecessary = 'bLuRfle';
 240
 241     if (!grep(/$unnecessary/, @extensions)) {
 242         $@ = undef;
 243         eval " require \"$unnecessary.pm\"; ";
 244         if ($@) {
 245             print "## Unnecessary module `$unnecessary' does not appear to be installed.\n" if $opt{'v'};
 246         }
 247         else {
 248             print "# Unnecessary module `$unnecessary' appears to be installed.\n";
 249             $extensions_there++;
 250         }
 251     }
 252     $@ = undef;
 253 }
 254 if ($extensions_total == $extensions_there) {
 255     print "ok 5\n";
 256     $pass__total++;
 257 }
 258 else {
 259     print "not ok 5\n";
 260     $error_total++;
 261 }
 262 $tests_total++;
 263
 264
 265 print "## Checking installations of later additional extensions.\n" if $opt{'p'};
 266
 267 use ExtUtils::Installed;
 268
 269 my $installed_total = 0;
 270 my $installed_there = 0;
 271 my $version_check = 0;
 272 my $installed = ExtUtils::Installed -> new();
 273 my @modules = $installed -> modules();
 274 my @missing = ();
 275 my $version = undef;
 276 for (@modules) {
 277     $installed_total++;
 278     # Consider it there if it contains one or more files,
 279     # and has zero missing files,
 280     # and has a defined version
 281     $version = undef;
 282     $version = $installed -> version($_);
 283     if ($version) {
 284         print "## $_; $version\n" if $opt{'v'};
 285         $version_check++;
 286     }
 287     else {
 288         print "# $_; NO VERSION\n" if $opt{'v'};
 289     }
 290     $version = undef;
 291     @missing = ();
 292     @missing = $installed -> validate($_);
 293
 294     # .bs files are optional
 295     @missing = grep { ! /\.bs$/ } @missing;
 296     # man files are often compressed
 297     @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
 298
 299     if ($#missing >= 0) {
 300         print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
 301         print '# ',join(' ',@missing),"\n";
 302     }
 303     elsif ($#missing == -1) {
 304         $installed_there++;
 305     }
 306     @missing = ();
 307 }
 308 if (($installed_total == $installed_there) &&
 309     ($installed_total == $version_check)) {
 310     print "ok 6\n";
 311     $pass__total++;
 312 }
 313 else {
 314     print "not ok 6\n";
 315     $error_total++;
 316 }
 317 $tests_total++;
 318
 319
 320 if ($opt{'a'}) {
 321 print "## Checking installations of *.h -> *.ph header files.\n" if $opt{'p'};
 322 my $ph_there = 0;
 323 my $var = undef;
 324 my $val = undef;
 325 my $h_file = undef;
 326 # Just about "any" C implementation ought to have a stdio.h (even if
 327 # Config.pm may not list a i_stdio var).
 328 my @ph_files = qw(stdio.ph);
 329 # Add the ones that we know that perl thinks are there:
 330 while (($var, $val) = each %Config) {
 331     if ($var =~ m/i_(.+)/ && $val eq 'define') {
 332         $h_file = $1;
 333         # Some header and symbol names don't match for hysterical raisins.
 334         $h_file = 'arpa/inet'    if $h_file eq 'arpainet';
 335         $h_file = 'netinet/in'   if $h_file eq 'niin';
 336         $h_file = 'netinet/tcp'  if $h_file eq 'netinettcp';
 337         $h_file = 'sys/resource' if $h_file eq 'sysresrc';
 338         $h_file = 'sys/select'   if $h_file eq 'sysselct';
 339         $h_file = 'sys/security' if $h_file eq 'syssecrt';
 340         $h_file = 'rpcsvc/dbm'   if $h_file eq 'rpcsvcdbm';
 341         # This ought to distinguish syslog from sys/syslog.
 342         # (NB syslog.ph is heavily used for the DBI pre-requisites).
 343         $h_file =~ s{^sys(\w.+)}{sys/$1} unless $h_file eq 'syslog';
 344         push(@ph_files, "$h_file.ph");
 345     }
 346 }
 347 #foreach (qw(stdio.ph syslog.ph)) {
 348 foreach (@ph_files) {
 349     $@ = undef;
 350     eval "require \"$_\";";
 351     if (!$@) {
 352         print "## Perl header `$_' appears to be installed.\n" if $opt{'v'};
 353         $ph_there++;
 354     }
 355     else {
 356         print "# Perl header `$_' does not appear to be properly installed.\n";
 357     }
 358     $@ = undef;
 359 }
 360
 361 if (scalar(@ph_files) == $ph_there) {
 362     print "ok 7\n";
 363     $pass__total++;
 364 }
 365 else {
 366     print "not ok 7\n";
 367     $error_total++;
 368 }
 369 $tests_total++;
 370 }
 371 else {
 372     print "##  Skip checking of *.ph header files.\n" if $opt{'p'};
 373 }
 374
 375 # Final report (rather than feed ousrselves to Test::Harness::runtests()
 376 # we simply format some output on our own to keep things simple and
 377 # easier to "fix" - at least for now.
 378
 379 if ($error_total == 0 && $tests_total) {
 380     print "All tests successful.\n";
 381 } elsif ($tests_total==0){
 382         die "FAILED--no tests were run for some reason.\n";
 383 } else {
 384     my $rate = 0.0;
 385     if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
 386     printf " %d/%d subtests failed, %.2f%% okay.\n",
 387                               $error_total, $tests_total, $rate;
 388 }
 389
 390 =head1 NAME
 391
 392 perlivp - Perl Installation Verification Procedure
 393
 394 =head1 SYNOPSIS
 395
 396 B<perlivp> [B<-a>] [B<-p>] [B<-v>] [B<-h>]
 397
 398 =head1 DESCRIPTION
 399
 400 The B<perlivp> program is set up at Perl source code build time to test the
 401 Perl version it was built under.  It can be used after running:
 402
 403     make install
 404
 405 (or your platform's equivalent procedure) to verify that B<perl> and its
 406 libraries have been installed correctly.  A correct installation is verified
 407 by output that looks like:
 408
 409     ok 1
 410     ok 2
 411
 412 etc.
 413
 414 =head1 OPTIONS
 415
 416 =over 5
 417
 418 =item B<-h> help
 419
 420 Prints out a brief help message.
 421
 422 =item B<-a> run all tests
 423
 424 Normally tests for optional features are skipped.  With -a all tests
 425 are executed.
 426
 427 =item B<-p> print preface
 428
 429 Gives a description of each test prior to performing it.
 430
 431 =item B<-v> verbose
 432
 433 Gives more detailed information about each test, after it has been performed.
 434 Note that any failed tests ought to print out some extra information whether
 435 or not -v is thrown.
 436
 437 =back
 438
 439 =head1 DIAGNOSTICS
 440
 441 =over 4
 442
 443 =item * print "# Perl binary `$perlpath' does not appear executable.\n";
 444
 445 Likely to occur for a perl binary that was not properly installed.
 446 Correct by conducting a proper installation.
 447
 448 =item * print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
 449
 450 Likely to occur for a perl that was not properly installed.
 451 Correct by conducting a proper installation.
 452
 453 =item * print "# Perl \@INC directory `$_' does not appear to exist.\n";
 454
 455 Likely to occur for a perl library tree that was not properly installed.
 456 Correct by conducting a proper installation.
 457
 458 =item * print "# Needed module `$_' does not appear to be properly installed.\n";
 459
 460 One of the two modules that is used by perlivp was not present in the
 461 installation.  This is a serious error since it adversely affects perlivp's
 462 ability to function.  You may be able to correct this by performing a
 463 proper perl installation.
 464
 465 =item * print "# Required module `$_' does not appear to be properly installed.\n";
 466
 467 An attempt to C<eval "require $module"> failed, even though the list of
 468 extensions indicated that it should succeed.  Correct by conducting a proper
 469 installation.
 470
 471 =item * print "# Unnecessary module `bLuRfle' appears to be installed.\n";
 472
 473 This test not coming out ok could indicate that you have in fact installed
 474 a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
 475 test may give misleading results with your installation of perl.  If yours
 476 is the latter case then please let the author know.
 477
 478 =item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
 479
 480 One or more files turned up missing according to a run of
 481 C<ExtUtils::Installed -E<gt> validate()> over your installation.
 482 Correct by conducting a proper installation.
 483
 484 =item * print "# Perl header `$_' does not appear to be properly installed.\n";
 485
 486 Correct by running B<h2ph> over your system's C header files.  If necessary,
 487 edit the resulting *.ph files to eliminate perl syntax errors.
 488
 489 =back
 490
 491 For further information on how to conduct a proper installation consult the
 492 INSTALL file that comes with the perl source and the README file for your
 493 platform.
 494
 495 =head1 AUTHOR
 496
 497 Peter Prymmer
 498
 499 =cut
 500
 501 !NO!SUBS!
 502
 503 close OUT or die "Can't close $file: $!";
 504 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 505 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 506 chdir $origdir;
 507