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
151sub get_and_sort_perls($)
152{
153    my $opt = shift;
154
155    my $starting;
156    $starting = int_parse_version($opt->{'debug-start'})
157                                                       if $opt->{'debug-start'};
158    my $skip_devels = $opt->{'skip-devels'} // 0;
159
160    # Uses the opt structure parameter to find the perl versions to use this
161    # run, and returns an array with a hash representing blead in the 0th
162    # element and the oldest in the final one.  Each entry looks like
163    #     {
164    #       'version' => '5.031002',
165    #       'file' => '5031002',
166    #       'path' => '/home/khw/devel/bin/perl5.31.2'
167    #     },
168    #
169    # Get blead and all other perls
170    my @perls = $opt->{blead};
171    for my $dir (split ",", $opt->{install}) {
172        push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
173    }
174
175    # Normalize version numbers into 5.xxxyyy, and convert each element
176    # describing the perl to be a hash with keys 'version' and 'path'
177    for (my $i = 0; $i < @perls; $i++) {
178        my $version = `$perls[$i] -e 'print \$]'`;
179        my $file = int_parse_version($version);
180        $version = format_version($version);
181
182        if ($skip_devels) {
183            my ($super, $major, $minor) = parse_version($version);
184
185            # If skipping development releases, we still use blead (0th entry).
186            # Devel releases are odd numbered ones 5.6 and above, but use every
187            # release for below 5.6
188            if ($i != 0 && $major >= 6 && $major % 2 != 0) {
189                splice @perls, $i, 1;
190                last if $i >= @perls;
191                redo;
192            }
193        }
194
195        # Make this entry a hash with its version, file name, and path
196        $perls[$i] = { version =>  $version,
197                       file    =>  $file,
198                       path    =>  $perls[$i],
199                     };
200    }
201
202    # Sort in descending order.  We start processing the most recent perl
203    # first.
204    @perls = sort { $b->{file} <=> $a->{file} } @perls;
205
206    # Override blead's version if specified.
207    if (exists $opt->{'blead-version'}) {
208        $perls[0]{version} = format_version($opt->{'blead-version'});
209    }
210
211    my %seen;
212
213    # blead's todo is its version plus 1.  Otherwise, each todo is the
214    # previous one's.  Also get rid of duplicate versions.
215    $perls[0]{todo} = $perls[0]{file} + 1;
216    $seen{$perls[0]{file}} = 1;
217    for my $i (1 .. $#perls) {
218        last unless defined $perls[$i];
219        if (    exists $seen{$perls[$i]{file}}
220            || ($starting && $perls[$i]{file} gt $starting)
221        ) {
222            splice @perls, $i, 1;
223            redo;
224        }
225
226        $seen{$perls[$i]{file}} = 1;
227        $perls[$i]{todo} = $perls[$i-1]{file};
228    }
229
230    # The earliest perl gets a special marker key, consisting of the proper
231    # file name
232    $perls[$#perls]{final} = $perls[$#perls]{file};
233
234    if ($opt{debug}) {
235        print STDERR "The perls returned are: ", Dumper \@perls;
236    }
237
238    return \@perls;
239}
240
2411;
242