This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
devel/devtools.pl: Add an element to a hash
[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 require "./parts/inc/inctools";
18
19 eval "use Term::ANSIColor";
20 $@ and eval "sub colored { pop; @_ }";
21
22 my @argvcopy = @ARGV;
23
24 sub verbose
25 {
26   if ($opt{verbose}) {
27     my @out = @_;
28     s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
29     print STDERR @out;
30   }
31 }
32
33 sub ddverbose
34 {
35   return $opt{verbose} ? ('--verbose') : ();
36 }
37
38 sub runtool
39 {
40   my $opt = ref $_[0] ? shift @_ : {};
41   my($prog, @args) = @_;
42   my $sysstr = join ' ', map { "'$_'" } $prog, @args;
43   $sysstr .= " >$opt->{'out'}"  if exists $opt->{'out'};
44   $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
45   verbose("running $sysstr\n");
46   my $rv = system $sysstr;
47   verbose("$prog => exit code $rv\n");
48   return not $rv;
49 }
50
51 sub runperl
52 {
53   my $opt = ref $_[0] ? shift @_ : {};
54   runtool($opt, $^X, @_);
55 }
56
57 sub run
58 {
59   my $prog = shift;
60   my @args = @_;
61
62   runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
63
64   my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
65   my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
66
67   my %rval = (
68     status    => $? >> 8,
69     stdout    => [<$out>],
70     stderr    => [<$err>],
71     didnotrun => 0,
72   );
73
74   unlink "tmp.out", "tmp.err";
75
76   $? & 128 and $rval{core}   = 1;
77   $? & 127 and $rval{signal} = $? & 127;
78
79   return \%rval;
80 }
81
82 sub ident_str
83 {
84   return "$^X $0 @argvcopy";
85 }
86
87 sub identify
88 {
89   verbose(ident_str() . "\n");
90 }
91
92 sub ask($)
93 {
94   my $q = shift;
95   my $a;
96   local $| = 1;
97   do {
98     print "\a\n$q [y/n] ";
99     $a = <>; }
100   while ($a !~ /^\s*([yn])\s*$/i);
101   return lc $1 eq 'y';
102 }
103
104 sub quit_now
105 {
106   print "\nSorry, cannot continue.\n\n";
107   exit 1;
108 }
109
110 sub ask_or_quit
111 {
112   quit_now unless &ask;
113 }
114
115 sub eta
116 {
117   my($start, $i, $n) = @_;
118   return "--:--:--" if $i < 3;
119   my $elapsed = tv_interval($start);
120   my $h = int($elapsed*($n-$i)/$i);
121   my $s = $h % 60; $h /= 60;
122   my $m = $h % 60; $h /= 60;
123   return sprintf "%02d:%02d:%02d", $h, $m, $s;
124 }
125
126 sub get_and_sort_perls($)
127 {
128     my $opt = shift;
129
130     # Get blead and all other perls
131     my @perls = $opt->{blead};
132     for my $dir (split ",", $opt->{install}) {
133         push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
134     }
135
136     # Normalize version numbers into 5.xxxyyy, and convert each element
137     # describing the perl to be a hash with keys 'version' and 'path'
138     for (my $i = 0; $i < @perls; $i++) {
139         my $version = `$perls[$i] -e 'print \$]'`;
140         my $file = int_parse_version($version);
141         $version = format_version($version);
142
143         # Make this entry a hash with its version, file name, and path
144         $perls[$i] = { version =>  $version,
145                        file    =>  $file,
146                        path    =>  $perls[$i],
147                      };
148     }
149
150     # Sort in descending order.  We start processing the most recent perl
151     # first.
152     @perls = sort { $b->{file} <=> $a->{file} } @perls;
153
154     # Override blead's version if specified.
155     if (exists $opt->{'blead-version'}) {
156         $perls[0]{version} = format_version($opt->{'blead-version'});
157     }
158
159     my %seen;
160
161     # blead's todo is its version plus 1.  Otherwise, each todo is the
162     # previous one's.  Also get rid of duplicate versions.
163     $perls[0]{todo} = $perls[0]{file} + 1;
164     $seen{$perls[0]{file}} = 1;
165     for my $i (1 .. $#perls) {
166         last unless defined $perls[$i];
167         if (    exists $seen{$perls[$i]{file}}) {
168             splice @perls, $i, 1;
169             redo;
170         }
171
172         $seen{$perls[$i]{file}} = 1;
173         $perls[$i]{todo} = $perls[$i-1]{file};
174     }
175
176     return \@perls;
177 }
178
179 1;