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    $a = <>; }
124  while ($a !~ /^\s*([yn])\s*$/i);
125  return lc $1 eq 'y';
126}
127
128sub quit_now
129{
130  print "\nSorry, cannot continue.\n\n";
131  exit 1;
132}
133
134sub ask_or_quit
135{
136  quit_now unless &ask;
137}
138
139sub eta
140{
141  my($start, $i, $n) = @_;
142  return "--:--:--" if $i < 3;
143  my $elapsed = tv_interval($start);
144  my $h = int($elapsed*($n-$i)/$i);
145  my $s = $h % 60; $h /= 60;
146  my $m = $h % 60; $h /= 60;
147  return sprintf "%02d:%02d:%02d", $h, $m, $s;
148}
149
150sub get_and_sort_perls($)
151{
152    my $opt = shift;
153
154    my $starting;
155    $starting = int_parse_version($opt->{'debug-start'})
156                                                       if $opt->{'debug-start'};
157
158    # Uses the opt structure parameter to find the perl versions to use this
159    # run, and returns an array with a hash representing blead in the 0th
160    # element and the oldest in the final one.  Each entry looks like
161    #     {
162    #       'version' => '5.031002',
163    #       'file' => '5031002',
164    #       'path' => '/home/khw/devel/bin/perl5.31.2'
165    #     },
166    #
167    # Get blead and all other perls
168    my @perls = $opt->{blead};
169    for my $dir (split ",", $opt->{install}) {
170        push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
171    }
172
173    # Normalize version numbers into 5.xxxyyy, and convert each element
174    # describing the perl to be a hash with keys 'version' and 'path'
175    for (my $i = 0; $i < @perls; $i++) {
176        my $version = `$perls[$i] -e 'print \$]'`;
177        my $file = int_parse_version($version);
178        $version = format_version($version);
179
180        # Make this entry a hash with its version, file name, and path
181        $perls[$i] = { version =>  $version,
182                       file    =>  $file,
183                       path    =>  $perls[$i],
184                     };
185    }
186
187    # Sort in descending order.  We start processing the most recent perl
188    # first.
189    @perls = sort { $b->{file} <=> $a->{file} } @perls;
190
191    # Override blead's version if specified.
192    if (exists $opt->{'blead-version'}) {
193        $perls[0]{version} = format_version($opt->{'blead-version'});
194    }
195
196    my %seen;
197
198    # blead's todo is its version plus 1.  Otherwise, each todo is the
199    # previous one's.  Also get rid of duplicate versions.
200    $perls[0]{todo} = $perls[0]{file} + 1;
201    $seen{$perls[0]{file}} = 1;
202    for my $i (1 .. $#perls) {
203        last unless defined $perls[$i];
204        if (    exists $seen{$perls[$i]{file}}
205            || ($starting && $perls[$i]{file} gt $starting)
206        ) {
207            splice @perls, $i, 1;
208            redo;
209        }
210
211        $seen{$perls[$i]{file}} = 1;
212        $perls[$i]{todo} = $perls[$i-1]{file};
213    }
214
215    # The earliest perl gets a special marker key, consisting of the proper
216    # file name
217    $perls[$#perls]{final} = $perls[$#perls]{file};
218
219    if ($opt{debug}) {
220        print STDERR "The perls returned are: ", Dumper \@perls;
221    }
222
223    return \@perls;
224}
225
2261;
227