1################################################################################
2#
3#  devtools.pl -- various utility functions
4#
5#  NOTE: This will only be called by the overarching (modern) perl
6#
7################################################################################
8#
9#  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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 Data::Dumper;
19$Data::Dumper::Sortkeys = 1;
20use IO::File;
21use warnings;   # Can't use strict because of %opt passed from caller
22require "./parts/inc/inctools";
23
24eval "use Term::ANSIColor";
25$@ and eval "sub colored { pop; @_ }";
26
27my @argvcopy = @ARGV;
28
29sub verbose
30{
31  if ($opt{verbose}) {
32    my @out = @_;
33    s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
34    print STDERR @out;
35  }
36}
37
38sub ddverbose
39{
40  return $opt{verbose} ? ('--verbose') : ();
41}
42
43sub runtool
44{
45  my $opt = ref $_[0] ? shift @_ : {};
46  my($prog, @args) = @_;
47  my $sysstr = join ' ', map { "'$_'" } $prog, @args;
48  $sysstr .= " >$opt->{'out'}"  if exists $opt->{'out'};
49  $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
50  verbose("running $sysstr\n");
51  my $rv = system $sysstr;
52  verbose("$prog => exit code $rv\n");
53  return not $rv;
54}
55
56sub runperl
57{
58  my $opt = ref $_[0] ? shift @_ : {};
59  runtool($opt, $^X, @_);
60}
61
62sub run
63{
64  my $prog = shift;
65  my @args = @_;
66
67  runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
68
69  my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
70  my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
71
72  my %rval = (
73    status    => $? >> 8,
74    stdout    => [<$out>],
75    stderr    => [<$err>],
76    didnotrun => 0,         # Note that currently this will always be 0
77                            # This must have been used in earlier versions
78  );
79
80  unlink "tmp.out", "tmp.err";
81
82  $? & 128 and $rval{core}   = 1;
83  $? & 127 and $rval{signal} = $? & 127;
84
85  # This is expected and isn't an error.
86  @{$rval{stderr}} = grep { $_ !~ /make.*No rule .*realclean/ } @{$rval{stderr}};
87
88  if (    exists $rval{core}
89      ||  exists $rval{signal}
90      || ($opt{debug} > 2 && @{$rval{stderr}} && $rval{status})
91      || ($opt{debug} > 3 && @{$rval{stderr}})
92      || ($opt{debug} > 4 && @{$rval{stdout}}))
93  {
94    print STDERR "Returning\n", Dumper \%rval;
95
96    # Under verbose, runtool already output the call string
97    unless ($opt{verbose}) {
98        print STDERR "from $prog ", join ", ", @args;
99        print STDERR "\n";
100    }
101  }
102
103  return \%rval;
104}
105
106sub ident_str
107{
108  return "$^X $0 @argvcopy";
109}
110
111sub identify
112{
113  verbose(ident_str() . "\n");
114}
115
116sub ask($)
117{
118  my $q = shift;
119  my $a;
120  local $| = 1;
121  do {
122    print "\a\n$q [y/n] ";
123    return unless -t;   # Fail if no tty input
124    $a = <>; }
125  while ($a !~ /^\s*([yn])\s*$/i);
126  return lc $1 eq 'y';
127}
128
129sub quit_now
130{
131  print "\nSorry, cannot continue.\a\n\n";
132  exit 1;
133}
134
135sub ask_or_quit
136{
137  quit_now unless &ask;
138}
139
140sub eta
141{
142  my($start, $i, $n) = @_;
143  return "--:--:--" if $i < 3;
144  my $elapsed = tv_interval($start);
145  my $h = int($elapsed*($n-$i)/$i);
146  my $s = $h % 60; $h /= 60;
147  my $m = $h % 60; $h /= 60;
148  return sprintf "%02d:%02d:%02d", $h, $m, $s;
149}
150
151# Devel releases are odd numbered ones 5.6 and above, but use every
152# release for below 5.6
153sub is_devel_release ($) {
154    my (undef, $major, $minor) = parse_version(shift);
155    return $major >= 6 && $major % 2 != 0;
156}
157
158
159sub get_and_sort_perls($)
160{
161    my $opt = shift;
162
163    my $starting;
164    $starting = int_parse_version($opt->{'debug-start'})
165                                                       if $opt->{'debug-start'};
166    my $skip_devels = $opt->{'skip-devels'} // 0;
167
168    # Uses the opt structure parameter to find the perl versions to use this
169    # run, and returns an array with a hash representing blead in the 0th
170    # element and the oldest in the final one.  Each entry looks like
171    #     {
172    #       'version' => '5.031002',
173    #       'file' => '5031002',
174    #       'path' => '/home/khw/devel/bin/perl5.31.2'
175    #     },
176    #
177    # Get blead and all other perls
178    my @perls = $opt->{blead};
179    for my $dir (split ",", $opt->{install}) {
180        push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
181    }
182
183    # Normalize version numbers into 5.xxxyyy, and convert each element
184    # describing the perl to be a hash with keys 'version' and 'path'
185    for (my $i = 0; $i < @perls; $i++) {
186        my $version = `$perls[$i] -e 'print \$]'`;
187        my $file = int_parse_version($version);
188        $version = format_version($version);
189
190        if ($skip_devels) {
191            # If skipping development releases, we still use blead (0th entry).
192            if ($i != 0 && is_devel_release($version)) {
193                splice @perls, $i, 1;
194                last if $i >= @perls;
195                redo;
196            }
197        }
198
199        # Make this entry a hash with its version, file name, and path
200        $perls[$i] = { version =>  $version,
201                       file    =>  $file,
202                       path    =>  $perls[$i],
203                     };
204    }
205
206    # Sort in descending order.  We start processing the most recent perl
207    # first.
208    @perls = sort { $b->{file} <=> $a->{file} } @perls;
209
210    # Override blead's version if specified.
211    if (exists $opt->{'blead-version'}) {
212        $perls[0]{version} = format_version($opt->{'blead-version'});
213    }
214
215    my %seen;
216
217    # blead's todo is its version plus 1.  Otherwise, each todo is the
218    # previous one's.  Also get rid of duplicate versions.
219    $perls[0]{todo} = $perls[0]{file} + 1;
220    $seen{$perls[0]{file}} = 1;
221    for my $i (1 .. $#perls) {
222        last unless defined $perls[$i];
223        if (    exists $seen{$perls[$i]{file}}
224            || ($starting && $perls[$i]{file} gt $starting)
225        ) {
226            splice @perls, $i, 1;
227            redo;
228        }
229
230        $seen{$perls[$i]{file}} = 1;
231        $perls[$i]{todo} = $perls[$i-1]{file};
232    }
233
234    # The earliest perl gets a special marker key, consisting of the proper
235    # file name
236    $perls[$#perls]{final} = $perls[$#perls]{file};
237
238    if ($opt{debug}) {
239        print STDERR "The perls returned are: ", Dumper \@perls;
240    }
241
242    return \@perls;
243}
244
2451;
246