This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
devel/devtools.pl: Comments
[perl5.git] / dist / Devel-PPPort / devel / devtools.pl
CommitLineData
0c96388f
MHM
1################################################################################
2#
3# devtools.pl -- various utility functions
4#
0a18d4db
KW
5# NOTE: This will only be called by the overarching (modern) perl
6#
0c96388f
MHM
7################################################################################
8#
b2049988 9# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
0c96388f
MHM
10# Version 2.x, Copyright (C) 2001, Paul Marquess.
11# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
12#
13# This program is free software; you can redistribute it and/or
14# modify it under the same terms as Perl itself.
15#
16################################################################################
17
18use IO::File;
26df2d75 19require "./parts/inc/inctools";
0c96388f
MHM
20
21eval "use Term::ANSIColor";
22$@ and eval "sub colored { pop; @_ }";
23
24my @argvcopy = @ARGV;
25
26sub verbose
27{
28 if ($opt{verbose}) {
29 my @out = @_;
30 s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
31 print STDERR @out;
32 }
33}
34
35sub ddverbose
36{
37 return $opt{verbose} ? ('--verbose') : ();
38}
39
40sub runtool
41{
42 my $opt = ref $_[0] ? shift @_ : {};
43 my($prog, @args) = @_;
44 my $sysstr = join ' ', map { "'$_'" } $prog, @args;
45 $sysstr .= " >$opt->{'out'}" if exists $opt->{'out'};
46 $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
47 verbose("running $sysstr\n");
48 my $rv = system $sysstr;
49 verbose("$prog => exit code $rv\n");
50 return not $rv;
51}
52
53sub runperl
54{
55 my $opt = ref $_[0] ? shift @_ : {};
56 runtool($opt, $^X, @_);
57}
58
59sub run
60{
61 my $prog = shift;
62 my @args = @_;
63
64 runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
65
ba120f6f
MHM
66 my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
67 my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
0c96388f
MHM
68
69 my %rval = (
70 status => $? >> 8,
71 stdout => [<$out>],
72 stderr => [<$err>],
0a18d4db
KW
73 didnotrun => 0, # Note that currently this will always be 0
74 # This must have been used in earlier versions
0c96388f
MHM
75 );
76
77 unlink "tmp.out", "tmp.err";
78
79 $? & 128 and $rval{core} = 1;
80 $? & 127 and $rval{signal} = $? & 127;
81
82 return \%rval;
83}
84
85sub ident_str
86{
87 return "$^X $0 @argvcopy";
88}
89
90sub identify
91{
92 verbose(ident_str() . "\n");
93}
94
95sub ask($)
96{
97 my $q = shift;
98 my $a;
99 local $| = 1;
673c041a
KW
100 do {
101 print "\a\n$q [y/n] ";
102 $a = <>; }
103 while ($a !~ /^\s*([yn])\s*$/i);
0c96388f
MHM
104 return lc $1 eq 'y';
105}
106
107sub quit_now
108{
109 print "\nSorry, cannot continue.\n\n";
110 exit 1;
111}
112
113sub ask_or_quit
114{
115 quit_now unless &ask;
116}
117
118sub eta
119{
120 my($start, $i, $n) = @_;
121 return "--:--:--" if $i < 3;
122 my $elapsed = tv_interval($start);
123 my $h = int($elapsed*($n-$i)/$i);
124 my $s = $h % 60; $h /= 60;
125 my $m = $h % 60; $h /= 60;
126 return sprintf "%02d:%02d:%02d", $h, $m, $s;
127}
128
200199be
KW
129sub get_and_sort_perls($)
130{
131 my $opt = shift;
132
a58fa8f3
KW
133 my $starting;
134 $starting = int_parse_version($opt->{'debug-start'})
135 if $opt->{'debug-start'};
136
0a18d4db
KW
137 # Uses the opt structure parameter to find the perl versions to use this
138 # run, and returns an array with a hash representing blead in the 0th
139 # element and the oldest in the final one. Each entry looks like
140 # {
141 # 'version' => '5.031002',
142 # 'file' => '5031002',
143 # 'path' => '/home/khw/devel/bin/perl5.31.2'
144 # },
145 #
200199be
KW
146 # Get blead and all other perls
147 my @perls = $opt->{blead};
148 for my $dir (split ",", $opt->{install}) {
149 push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
150 }
151
26df2d75
KW
152 # Normalize version numbers into 5.xxxyyy, and convert each element
153 # describing the perl to be a hash with keys 'version' and 'path'
154 for (my $i = 0; $i < @perls; $i++) {
155 my $version = `$perls[$i] -e 'print \$]'`;
156 my $file = int_parse_version($version);
157 $version = format_version($version);
158
159 # Make this entry a hash with its version, file name, and path
160 $perls[$i] = { version => $version,
161 file => $file,
162 path => $perls[$i],
163 };
164 }
200199be 165
26df2d75
KW
166 # Sort in descending order. We start processing the most recent perl
167 # first.
168 @perls = sort { $b->{file} <=> $a->{file} } @perls;
200199be
KW
169
170 # Override blead's version if specified.
171 if (exists $opt->{'blead-version'}) {
fe387f38 172 $perls[0]{version} = format_version($opt->{'blead-version'});
200199be
KW
173 }
174
175 my %seen;
176
177 # blead's todo is its version plus 1. Otherwise, each todo is the
178 # previous one's. Also get rid of duplicate versions.
26df2d75
KW
179 $perls[0]{todo} = $perls[0]{file} + 1;
180 $seen{$perls[0]{file}} = 1;
200199be
KW
181 for my $i (1 .. $#perls) {
182 last unless defined $perls[$i];
a58fa8f3
KW
183 if ( exists $seen{$perls[$i]{file}}
184 || ($starting && $perls[$i]{file} gt $starting)
185 ) {
200199be
KW
186 splice @perls, $i, 1;
187 redo;
188 }
189
26df2d75
KW
190 $seen{$perls[$i]{file}} = 1;
191 $perls[$i]{todo} = $perls[$i-1]{file};
200199be
KW
192 }
193
194 return \@perls;
195}
196
0c96388f 1971;