Commit | Line | Data |
0a7c7f4f |
1 | |
44284200 |
2 | # soak: Test Devel::PPPort with multiple versions of Perl. |
3 | # |
4 | # Author: Paul Marquess |
5 | # |
6 | |
7 | require 5.006001; |
dbda3434 |
8 | |
0a7c7f4f |
9 | use strict ; |
44284200 |
10 | use warnings ; |
dbda3434 |
11 | use ExtUtils::MakeMaker; |
44284200 |
12 | use Getopt::Long; |
13 | |
14 | my $VERSION = "1.000"; |
0a7c7f4f |
15 | |
dbda3434 |
16 | $| = 1 ; |
0a7c7f4f |
17 | my $verbose = 0 ; |
18 | |
dbda3434 |
19 | # TODO -- determine what "make" program to run. |
20 | my $MAKE = 'make'; |
21 | |
44284200 |
22 | my $result = GetOptions( |
23 | "verbose" => \$verbose, |
24 | "make=s" => \$MAKE, |
25 | ) or Usage(); |
dbda3434 |
26 | |
44284200 |
27 | my @GoodPerls = (); |
dbda3434 |
28 | |
44284200 |
29 | if (@ARGV) |
30 | { @GoodPerls = @ARGV } |
31 | else |
32 | { @GoodPerls = FindPerls() } |
0a7c7f4f |
33 | |
dbda3434 |
34 | my $maxlen = 0; |
44284200 |
35 | foreach (@GoodPerls) { |
36 | $maxlen = length $_ |
37 | if length $_ > $maxlen ; |
dbda3434 |
38 | } |
0a7c7f4f |
39 | $maxlen += 3 ; |
40 | |
41 | # run each through the test harness |
42 | |
43 | my $bad = 0 ; |
44 | my $good = 0 ; |
45 | my $total = 0 ; |
46 | |
dbda3434 |
47 | # prime the pump, so the first "make clean" will work. |
48 | runit("perl Makefile.PL") || die "Cannot run perl Makefile.PL\n" ; |
49 | |
50 | foreach my $perl (@GoodPerls) |
0a7c7f4f |
51 | { |
dbda3434 |
52 | my $prefix = "$perl -- " if $verbose ; |
0a7c7f4f |
53 | print "Testing $perl " . ('.' x ($maxlen - length $perl)) ; |
dbda3434 |
54 | |
55 | my $ok = runit("$MAKE clean") && |
56 | runit("$perl Makefile.PL") && |
57 | runit("$MAKE test") ; |
0a7c7f4f |
58 | |
59 | ++ $total; |
60 | if ($ok) { |
61 | ++ $good ; |
dbda3434 |
62 | print "${prefix}ok\n"; |
0a7c7f4f |
63 | } |
64 | else { |
65 | ++ $bad ; |
dbda3434 |
66 | print "${prefix}not ok\n" ; |
0a7c7f4f |
67 | } |
68 | |
69 | } |
70 | |
44284200 |
71 | print "\n\nPassed with $good of $total versions of Perl.\n\n"; |
0a7c7f4f |
72 | exit $bad ; |
73 | |
74 | |
75 | sub runit |
76 | { |
dbda3434 |
77 | # TODO -- portability alert!! |
78 | |
0a7c7f4f |
79 | my $cmd = shift ; |
dbda3434 |
80 | print "\n Running [$cmd]\n" if $verbose ; |
dbda3434 |
81 | my $output = `$cmd 2>&1` ; |
44284200 |
82 | $output = "\n" unless defined $output; |
dbda3434 |
83 | $output =~ s/^/ /gm; |
44284200 |
84 | print "\n Output\n$output\n" if $verbose || $? ; |
0a7c7f4f |
85 | if ($?) |
86 | { |
44284200 |
87 | warn " Running '$cmd' failed: $?\n" ; |
88 | return 0 ; |
0a7c7f4f |
89 | } |
0a7c7f4f |
90 | return 1 ; |
91 | } |
44284200 |
92 | |
93 | sub Usage |
94 | { |
95 | die <<EOM; |
96 | |
97 | usage: soak [OPT] [perl...] |
98 | |
99 | OPT |
100 | -m make - the name of the make program. Default "make" |
101 | -v - verbose |
102 | |
103 | EOM |
104 | |
105 | } |
106 | |
107 | sub FindPerls |
108 | { |
109 | # TODO -- need to decide how far back we go. |
110 | # TODO -- get list of user releases prior to 5.004 |
111 | |
112 | # find all version of Perl that are available |
113 | my @PerlBinaries = qw( |
114 | 5.000 |
115 | 5.001 |
116 | 5.002 |
117 | 5.003 |
118 | 5.004 |
119 | 5.00401 |
120 | 5.00402 |
121 | 5.00403 |
122 | 5.00404 |
123 | 5.00405 |
124 | 5.005 |
125 | 5.00501 |
126 | 5.00502 |
127 | 5.00503 |
128 | 5.6.0 |
129 | 5.6.1 |
130 | 5.7.0 |
131 | 5.7.1 |
132 | 5.7.2 |
133 | ); |
134 | |
135 | print "Searching for Perl binaries...\n" ; |
136 | my @GoodPerls = (); |
137 | my $maxlen = 0; |
138 | my $mm = MM->new( { NAME => 'dummy' }); |
139 | my @path = $mm->path(); |
140 | |
141 | # find_perl will send a warning to STDOUT if it can't find |
142 | # the requested perl, so need to temporarily silence STDOUT. |
143 | tie(*STDOUT, 'NoSTDOUT'); |
144 | |
145 | foreach my $perl (@PerlBinaries) { |
146 | if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) { |
147 | push @GoodPerls, $abs ; |
148 | } |
149 | } |
150 | untie *STDOUT; |
151 | |
152 | print "\n\nFound\n"; |
153 | foreach (@GoodPerls) { print " $_\n" } |
154 | print "\n\n"; |
155 | |
156 | return @GoodPerls; |
157 | } |
158 | |
159 | package NoSTDOUT; |
160 | |
161 | use Tie::Handle; |
162 | our @ISA = qw(Tie::Handle); |
163 | |
164 | sub TIEHANDLE |
165 | { |
166 | my ($class) = @_; |
167 | my $buf = ""; |
168 | bless \$buf, $class; |
169 | } |
170 | |
171 | sub PRINT |
172 | { |
173 | my $self = shift; |
174 | } |
175 | |
176 | sub WRITE |
177 | { |
178 | my $self = shift; |
179 | } |