new perldelta for 5.29.11, even though we won't see it
[perl.git] / 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 BEGIN { pop @INC if $INC[-1] eq '.' }
43
44 sub usage {
45     warn "@_\n" if @_;
46     print << "    EOUSAGE";
47 Usage:
48
49     $0 [-p] [-v] | [-h]
50
51     -p Print a preface before each test telling what it will test.
52     -v Verbose mode in which extra information about test results
53        is printed.  Test failures always print out some extra information
54        regardless of whether or not this switch is set.
55     -h Prints this help message.
56     EOUSAGE
57     exit;
58 }
59
60 use vars qw(%opt); # allow testing with older versions (do not use our)
61
62 @opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
63
64 while ($ARGV[0] =~ /^-/) {
65     $ARGV[0] =~ s/^-//; 
66     for my $flag (split(//,$ARGV[0])) {
67         usage() if '?' =~ /\Q$flag/;
68         usage() if 'h' =~ /\Q$flag/;
69         usage() if 'H' =~ /\Q$flag/;
70         usage("unknown flag: '$flag'") unless 'HhPpVv' =~ /\Q$flag/;
71         warn "$0: '$flag' flag already set\n" if $opt{$flag}++;
72     } 
73     shift;
74 }
75
76 $opt{p}++ if $opt{P};
77 $opt{v}++ if $opt{V};
78
79 my $pass__total = 0;
80 my $error_total = 0;
81 my $tests_total = 0;
82
83 !NO!SUBS!
84
85 # We cannot merely check the variable '$^X' in general since on many 
86 # Unixes it is the basename rather than the full path to the perl binary.
87 my $perlpath = '';
88 if (defined($Config{'perlpath'})) { $perlpath = $Config{'perlpath'}; }
89
90 # The useithreads Config variable plays a role in whether or not
91 # threads and threads/shared work when C<use>d.  They apparently always
92 # get installed on systems that can run Configure.
93 my $useithreads = '';
94 if (defined($Config{'useithreads'})) { $useithreads = $Config{'useithreads'}; }
95
96 print OUT <<"!GROK!THIS!";
97 my \$perlpath = '$perlpath';
98 my \$useithreads = '$useithreads';
99 !GROK!THIS!
100
101 print OUT <<'!NO!SUBS!';
102
103 print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'};
104
105 my $label = 'Executable perl binary';
106
107 if (-x $perlpath) {
108     print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'};
109     print "ok 1 $label\n";
110     $pass__total++;
111 }
112 else {
113     print "# Perl binary '$perlpath' does not appear executable.\n";
114     print "not ok 1 $label\n";
115     $error_total++;
116 }
117 $tests_total++;
118
119
120 print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'};
121
122 !NO!SUBS!
123
124 print OUT <<"!GROK!THIS!";
125 my \$ivp_VERSION = "$]";
126
127 !GROK!THIS!
128 print OUT <<'!NO!SUBS!';
129
130 $label = 'Perl version correct';
131 if ($ivp_VERSION eq $]) {
132     print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'};
133     print "ok 2 $label\n";
134     $pass__total++;
135 }
136 else {
137     print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
138     print "not ok 2 $label\n";
139     $error_total++;
140 }
141 $tests_total++;
142
143 # We have the right perl and version, so now reset @INC so we ignore
144 # PERL5LIB and '.'
145 {
146     local $ENV{PERL5LIB};
147     my $perl_V = qx($perlpath -V);
148     $perl_V =~ s{.*\@INC:\n}{}ms;
149     @INC = grep { length && $_ ne '.' } split ' ', $perl_V;
150 }
151
152 print "## Checking roots of the Perl library directory tree via variable '\@INC'.\n" if $opt{'p'};
153
154 my $INC_total = 0;
155 my $INC_there = 0;
156 foreach (@INC) {
157     next if $_ eq '.'; # skip -d test here
158     if (-d $_) {
159         print "## Perl \@INC directory '$_' exists.\n" if $opt{'v'};
160         $INC_there++;
161     }
162     else {
163         print "# Perl \@INC directory '$_' does not appear to exist.\n";
164     }
165     $INC_total++;
166 }
167
168 $label = '@INC directoreis exist';
169 if ($INC_total == $INC_there) {
170     print "ok 3 $label\n";
171     $pass__total++;
172 }
173 else {
174     print "not ok 3 $label\n";
175     $error_total++;
176 }
177 $tests_total++;
178
179
180 print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
181
182 my $needed_total = 0;
183 my $needed_there = 0;
184 foreach (qw(Config.pm ExtUtils/Installed.pm)) {
185     $@ = undef;
186     $needed_total++;
187     eval "require \"$_\";";
188     if (!$@) {
189         print "## Module '$_' appears to be installed.\n" if $opt{'v'};
190         $needed_there++;
191     }
192     else {
193         print "# Needed module '$_' does not appear to be properly installed.\n";
194     }
195     $@ = undef;
196 }
197 $label = 'Modules needed for rest of perlivp exist';
198 if ($needed_total == $needed_there) {
199     print "ok 4 $label\n";
200     $pass__total++;
201 }
202 else {
203     print "not ok 4 $label\n";
204     $error_total++;
205 }
206 $tests_total++;
207
208
209 print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
210
211 use Config;
212
213 my $extensions_total = 0;
214 my $extensions_there = 0;
215 if (defined($Config{'extensions'})) {
216     my @extensions = split(/\s+/,$Config{'extensions'});
217     foreach (@extensions) {
218         next if ($_ eq '');
219         if ( $useithreads !~ /define/i ) {
220             next if ($_ eq 'threads');
221             next if ($_ eq 'threads/shared');
222         }
223         # that's a distribution name, not a module name
224         next if $_ eq 'IO/Compress';
225         next if $_ eq 'Devel/DProf';
226         next if $_ eq 'libnet';
227         next if $_ eq 'Locale/Codes';
228         next if $_ eq 'podlators';
229         next if $_ eq 'perlfaq';
230         # test modules
231         next if $_ eq 'XS/APItest';
232         next if $_ eq 'XS/Typemap';
233            # VMS$ perl  -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
234            # \NT> perl  -e "eval \"require './Devel/DProf.pm'\"; print $@"
235            # DProf: run perl with -d to use DProf.
236            # Compilation failed in require at (eval 1) line 1.
237         eval " require \"$_.pm\"; ";
238         if (!$@) {
239             print "## Module '$_' appears to be installed.\n" if $opt{'v'};
240             $extensions_there++;
241         }
242         else {
243             print "# Required module '$_' does not appear to be properly installed.\n";
244             $@ = undef;
245         }
246         $extensions_total++;
247     }
248
249     # A silly name for a module (that hopefully won't ever exist).
250     # Note that this test serves more as a check of the validity of the
251     # actual required module tests above.
252     my $unnecessary = 'bLuRfle';
253
254     if (!grep(/$unnecessary/, @extensions)) {
255         $@ = undef;
256         eval " require \"$unnecessary.pm\"; ";
257         if ($@) {
258             print "## Unnecessary module '$unnecessary' does not appear to be installed.\n" if $opt{'v'};
259         }
260         else {
261             print "# Unnecessary module '$unnecessary' appears to be installed.\n";
262             $extensions_there++;
263         }
264     }
265     $@ = undef;
266 }
267 $label = 'All (and only) expected extensions installed';
268 if ($extensions_total == $extensions_there) {
269     print "ok 5 $label\n";
270     $pass__total++;
271 }
272 else {
273     print "not ok 5 $label\n";
274     $error_total++;
275 }
276 $tests_total++;
277
278
279 print "## Checking installations of later additional extensions.\n" if $opt{'p'};
280
281 use ExtUtils::Installed;
282
283 my $installed_total = 0;
284 my $installed_there = 0;
285 my $version_check = 0;
286 my $installed = ExtUtils::Installed -> new();
287 my @modules = $installed -> modules();
288 my @missing = ();
289 my $version = undef;
290 for (@modules) {
291     $installed_total++;
292     # Consider it there if it contains one or more files,
293     # and has zero missing files,
294     # and has a defined version
295     $version = undef;
296     $version = $installed -> version($_);
297     if ($version) {
298         print "## $_; $version\n" if $opt{'v'};
299         $version_check++;
300     }
301     else {
302         print "# $_; NO VERSION\n" if $opt{'v'};
303     }
304     $version = undef;
305     @missing = ();
306     @missing = $installed -> validate($_);
307
308     # .bs files are optional
309     @missing = grep { ! /\.bs$/ } @missing;
310     # man files are often compressed
311     @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
312
313     if ($#missing >= 0) {
314         print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
315         print '# ',join(' ',@missing),"\n";
316     }
317     elsif ($#missing == -1) {
318         $installed_there++;
319     }
320     @missing = ();
321 }
322 $label = 'Module files correctly installed';
323 if (($installed_total == $installed_there) && 
324     ($installed_total == $version_check)) {
325     print "ok 6 $label\n";
326     $pass__total++;
327 }
328 else {
329     print "not ok 6 $label\n";
330     $error_total++;
331 }
332 $tests_total++;
333
334 # Final report (rather than feed ousrselves to Test::Harness::runtests()
335 # we simply format some output on our own to keep things simple and
336 # easier to "fix" - at least for now.
337
338 if ($error_total == 0 && $tests_total) {
339     print "All tests successful.\n";
340 } elsif ($tests_total==0){
341         die "FAILED--no tests were run for some reason.\n";
342 } else {
343     my $rate = 0.0;
344     if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
345     printf " %d/%d subtests failed, %.2f%% okay.\n",
346                               $error_total, $tests_total, $rate;
347 }
348
349 =head1 NAME
350
351 perlivp - Perl Installation Verification Procedure
352
353 =head1 SYNOPSIS
354
355 B<perlivp> [B<-p>] [B<-v>] [B<-h>]
356
357 =head1 DESCRIPTION
358
359 The B<perlivp> program is set up at Perl source code build time to test the
360 Perl version it was built under.  It can be used after running:
361
362     make install
363
364 (or your platform's equivalent procedure) to verify that B<perl> and its
365 libraries have been installed correctly.  A correct installation is verified
366 by output that looks like:
367
368     ok 1
369     ok 2
370
371 etc.
372
373 =head1 OPTIONS
374
375 =over 5
376
377 =item B<-h> help
378
379 Prints out a brief help message.
380
381 =item B<-p> print preface
382
383 Gives a description of each test prior to performing it.
384
385 =item B<-v> verbose
386
387 Gives more detailed information about each test, after it has been performed.
388 Note that any failed tests ought to print out some extra information whether
389 or not -v is thrown.
390
391 =back
392
393 =head1 DIAGNOSTICS
394
395 =over 4
396
397 =item * print "# Perl binary '$perlpath' does not appear executable.\n";
398
399 Likely to occur for a perl binary that was not properly installed.
400 Correct by conducting a proper installation.
401
402 =item * print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
403
404 Likely to occur for a perl that was not properly installed.
405 Correct by conducting a proper installation.
406
407 =item * print "# Perl \@INC directory '$_' does not appear to exist.\n";
408
409 Likely to occur for a perl library tree that was not properly installed.
410 Correct by conducting a proper installation.
411
412 =item * print "# Needed module '$_' does not appear to be properly installed.\n";
413
414 One of the two modules that is used by perlivp was not present in the 
415 installation.  This is a serious error since it adversely affects perlivp's
416 ability to function.  You may be able to correct this by performing a
417 proper perl installation.
418
419 =item * print "# Required module '$_' does not appear to be properly installed.\n";
420
421 An attempt to C<eval "require $module"> failed, even though the list of 
422 extensions indicated that it should succeed.  Correct by conducting a proper 
423 installation.
424
425 =item * print "# Unnecessary module 'bLuRfle' appears to be installed.\n";
426
427 This test not coming out ok could indicate that you have in fact installed 
428 a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
429 test may give misleading results with your installation of perl.  If yours
430 is the latter case then please let the author know.
431
432 =item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
433
434 One or more files turned up missing according to a run of 
435 C<ExtUtils::Installed -E<gt> validate()> over your installation.
436 Correct by conducting a proper installation.
437
438 =back
439
440 For further information on how to conduct a proper installation consult the 
441 INSTALL file that comes with the perl source and the README file for your 
442 platform.
443
444 =head1 AUTHOR
445
446 Peter Prymmer
447
448 =cut
449
450 !NO!SUBS!
451
452 close OUT or die "Can't close $file: $!";
453 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
454 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
455 chdir $origdir;
456