This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move finding perl versions from mktodo to devtools.pl
[perl5.git] / dist / Devel-PPPort / devel / devtools.pl
1 ################################################################################
2 #
3 #  devtools.pl -- various utility functions
4 #
5 ################################################################################
6 #
7 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
8 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
9 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
10 #
11 #  This program is free software; you can redistribute it and/or
12 #  modify it under the same terms as Perl itself.
13 #
14 ################################################################################
15
16 use IO::File;
17
18 eval "use Term::ANSIColor";
19 $@ and eval "sub colored { pop; @_ }";
20
21 my @argvcopy = @ARGV;
22
23 sub verbose
24 {
25   if ($opt{verbose}) {
26     my @out = @_;
27     s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
28     print STDERR @out;
29   }
30 }
31
32 sub ddverbose
33 {
34   return $opt{verbose} ? ('--verbose') : ();
35 }
36
37 sub runtool
38 {
39   my $opt = ref $_[0] ? shift @_ : {};
40   my($prog, @args) = @_;
41   my $sysstr = join ' ', map { "'$_'" } $prog, @args;
42   $sysstr .= " >$opt->{'out'}"  if exists $opt->{'out'};
43   $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
44   verbose("running $sysstr\n");
45   my $rv = system $sysstr;
46   verbose("$prog => exit code $rv\n");
47   return not $rv;
48 }
49
50 sub runperl
51 {
52   my $opt = ref $_[0] ? shift @_ : {};
53   runtool($opt, $^X, @_);
54 }
55
56 sub run
57 {
58   my $prog = shift;
59   my @args = @_;
60
61   runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
62
63   my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
64   my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
65
66   my %rval = (
67     status    => $? >> 8,
68     stdout    => [<$out>],
69     stderr    => [<$err>],
70     didnotrun => 0,
71   );
72
73   unlink "tmp.out", "tmp.err";
74
75   $? & 128 and $rval{core}   = 1;
76   $? & 127 and $rval{signal} = $? & 127;
77
78   return \%rval;
79 }
80
81 sub ident_str
82 {
83   return "$^X $0 @argvcopy";
84 }
85
86 sub identify
87 {
88   verbose(ident_str() . "\n");
89 }
90
91 sub ask($)
92 {
93   my $q = shift;
94   my $a;
95   local $| = 1;
96   do {
97     print "\a\n$q [y/n] ";
98     $a = <>; }
99   while ($a !~ /^\s*([yn])\s*$/i);
100   return lc $1 eq 'y';
101 }
102
103 sub quit_now
104 {
105   print "\nSorry, cannot continue.\n\n";
106   exit 1;
107 }
108
109 sub ask_or_quit
110 {
111   quit_now unless &ask;
112 }
113
114 sub eta
115 {
116   my($start, $i, $n) = @_;
117   return "--:--:--" if $i < 3;
118   my $elapsed = tv_interval($start);
119   my $h = int($elapsed*($n-$i)/$i);
120   my $s = $h % 60; $h /= 60;
121   my $m = $h % 60; $h /= 60;
122   return sprintf "%02d:%02d:%02d", $h, $m, $s;
123 }
124
125 sub get_and_sort_perls($)
126 {
127     my $opt = shift;
128
129     # Get blead and all other perls
130     my @perls = $opt->{blead};
131     for my $dir (split ",", $opt->{install}) {
132         push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
133     }
134
135     # Sort in descending version order.  Each element is a hash describing a perl,
136     # with keys 'version' and 'path'
137     @perls = sort { $b->{version} <=> $a->{version} }
138
139                                 # Call the perl to get it to print out it's $]
140                                 # version
141                 map { { version => `$_ -e 'printf "%.6f", \$]'`,
142                         path => $_ }
143                     }
144                 @perls;
145
146     # Override blead's version if specified.
147     if (exists $opt->{'blead-version'}) {
148         $perls[0]{version} = $opt->{'blead-version'};
149     }
150
151     my %seen;
152
153     # blead's todo is its version plus 1.  Otherwise, each todo is the
154     # previous one's.  Also get rid of duplicate versions.
155     $perls[0]{todo} = $perls[0]{version} + 1;
156     $seen{$perls[0]{version}} = 1;
157     for my $i (1 .. $#perls) {
158         last unless defined $perls[$i];
159         if (    exists $seen{$perls[$i]{version}}) {
160             splice @perls, $i, 1;
161             redo;
162         }
163
164         $seen{$perls[$i]{version}} = 1;
165         $perls[$i]{todo} = $perls[$i-1]{version};
166     }
167
168     return \@perls;
169 }
170
171 1;