bin/installed-perls-overview.pl

   1 #!/usr/bin/perl
   2
   3 # arguments can be package names: their versions are appended to each line, space separated
   4
   5 =head1 NAME
   6
   7 ....pl -
   8
   9 =head1 SYNOPSIS
  10
  11
  12
  13 =head1 OPTIONS
  14
  15 =over 8
  16
  17 =cut
  18
  19
  20 my $optpod = <<'=back';
  21
  22 =item B<--eval=s>
  23
  24 TBD: Code to eval and print the output.
  25
  26 =item B<--help|h!>
  27
  28 This help
  29
  30 =item B<--hostname=s>
  31
  32 when determining the config file, use this hostname.
  33
  34 =item B<--max=i>
  35
  36 stop output after that many perls
  37
  38 =item B<--maxperl=s>
  39
  40 skip perls above
  41
  42 =item B<--minperl=s>
  43
  44 skip perls below
  45
  46 =item B<--show=s@>
  47
  48 Config attributes to be included in the table. Defaults to
  49 C<useithreads>, C<uselongdouble>, and C<config_args~EBUGGING=both>.
  50
  51 Config attributes are mostly reported with their own value with two
  52 exceptions:
  53
  54   define  becomes  D
  55   undef   becomes  u
  56
  57 If the expression contains a tilde, it's a primitive matching. RTFS.
  58
  59 =item B<--sprintfwidth|w=i>
  60
  61 Width reserved for the versions. Defaults to 8. If there is one
  62 spielverderber with a version number of 20110324.1600_001, you can set
  63 it to 17 to get the columns aligned.
  64
  65 =item B<--verbose!>
  66
  67 Include the module names in the output
  68
  69 =back
  70
  71 =head1 DESCRIPTION
  72
  73 Lookss which perls we have in
  74 C</home/sand/src/perl/repoperls/installed-perls/perl/> and reports
  75 about the two significant directory levels in their paths, ordered
  76 according to perl's git conventions, e.g.:
  77
  78 v5.17.7.0-15-ge2beedf/a2da
  79 v5.17.7.0-15-ge2beedf/9980
  80 v5.17.7.0-15-ge2beedf/127ecf
  81 v5.17.7.0-15-ge2beedf/127ec
  82 v5.17.7.0-15-ge2beedf/127e
  83 v5.17.6-424-ge2beedf/127e
  84 v5.17.6-423-g67e0a0c/9980
  85 v5.17.6-422-gc2219ca/a2da
  86 v5.17.6-421-gd1bee06/165a
  87 v5.17.6-416-g9a90211/127e
  88 v5.17.6-415-gbfd14e5/9980
  89 v5.17.6-413-g2e1be9f/a2da
  90 v5.17.6-412-g6e0a4ea/165a
  91 v5.17.6-408-g3cf48ca/127e
  92 v5.17.6-306-g23b7025/9980
  93 v5.17.6-98-gcd298ce/127e
  94 v5.17.6-97-gf5a0fd1/9980
  95 v5.17.6-97-gf5a0fd1/127e
  96 v5.17.6-92-g00f6437/127e
  97
  98
  99 =head1 TODO
 100
 101
 102 =head1 AUTHOR
 103
 104 =cut
 105
 106 use strict;
 107 use Getopt::Long;
 108 use Pod::Usage qw(pod2usage);
 109
 110 $ENV{HARNESS_ACTIVE} = 1;
 111
 112 my @opt = $optpod =~ /B<--(\S+)>/g;
 113 our %Opt;
 114 GetOptions
 115     (
 116      \%Opt,
 117      @opt,
 118     ) or pod2usage(1);
 119
 120 pod2usage(0) if $Opt{help};
 121
 122 use Sys::Hostname qw(hostname);
 123 use Sort::Versions;
 124 use Time::HiRes qw(sleep);
 125
 126 my $hostname = $Opt{hostname} || hostname();
 127
 128 my $perls_config_file = "/home/sand/src/andk/andk-cpan-tools/bin/loop-over-recent.pl.otherperls.$hostname";
 129 my @perls;
 130 my $perlhomepath = "perl";
 131 unless ($hostname eq "k83") {
 132     $perlhomepath = "host/$hostname";
 133 }
 134 if (open my $fh2, $perls_config_file) {
 135     while (<$fh2>) {
 136         chomp;
 137         s/#.*//; # remove comments
 138         s/\s+\z//; # remove trailing spaces
 139         next if /^\s*$/; # remove empty/white lines
 140         unless (m|/.+/|) {
 141             s|^|/home/sand/src/perl/repoperls/installed-perls/$perlhomepath/|;
 142             s|$|/bin/perl|;
 143         }
 144         next unless -x $_;
 145         push @perls, $_;
 146     }
 147 }
 148 my %testperl = map {
 149     ($_ => 1)
 150 } @perls;
 151 my @L = glob("/home/sand/src/perl/repoperls/installed-perls/$perlhomepath/*/*/bin/perl");
 152 my %firstlettermap = ( p=>1, G=>2, v=>3 );
 153 @L = sort {
 154     my $aXX = substr($a,47+length($perlhomepath));
 155     my $bXX = substr($b,47+length($perlhomepath));
 156     my $ret = $firstlettermap{substr($bXX,0,1)} <=> $firstlettermap{substr($aXX,0,1)};
 157     unless ($ret) {
 158         for ($aXX,$bXX) {
 159             s|/.*||;
 160         }
 161         if ($aXX =~ /(.+)-RC(\d+)/) {
 162             if ($bXX =~ /(.+)-RC(\d+)/) {
 163             } elsif (substr($bXX,0,length($1)) eq $1) {
 164                 $ret = 1;
 165             }
 166         } elsif ($bXX =~ /(.+)-RC(\d+)/) {
 167             if ($aXX =~ /(.+)-RC(\d+)/) {
 168             } elsif (substr($aXX,0,length($1)) eq $1) {
 169                 $ret = -1;
 170             }
 171         }
 172     }
 173     unless ($ret) {
 174         for ($aXX,$bXX) {
 175             s|^v||;
 176             s|^perl-||;
 177             s|-g.*||;
 178             s|-|.|g;
 179         }
 180         $ret = versioncmp($bXX,$aXX);
 181     }
 182     unless ($ret) {
 183         my $aXX = substr($a,47+length($perlhomepath));
 184         my $bXX = substr($b,47+length($perlhomepath));
 185         $ret = $bXX cmp $aXX;
 186     }
 187     # warn sprintf "%-12s %-12s %s\n", $aXX, $bXX, $ret;
 188     $ret;
 189     } @L;
 190 my %globperl = map {
 191     ($_ => 1)
 192 } @L;
 193 my @testperl_not_in_globperl = grep { !$globperl{$_} } keys %testperl;
 194 unshift @L, @testperl_not_in_globperl;
 195 if ($Opt{max} && $Opt{max} < @L) {
 196     pop @L while $Opt{max} < @L;
 197 }
 198
 199 my @Showconfig = qw(useithreads uselongdouble config_args~EBUGGING=both);
 200 for my $showconfig (@{$Opt{show}||[]}) {
 201     push @Showconfig, $showconfig;
 202 }
 203 $Opt{sprintfwidth} ||= 8;
 204 # this string is injected into the small program that every perl has to execute:
 205 my $sprintfshowconfig = "%1s%1s%1s " . join " ", ("%-$Opt{sprintfwidth}s") x (@Showconfig-3);
 206 # this string is injected into the small program that every perl has to execute:
 207 my $showconfigvalues = join " ", @Showconfig;
 208 my $modules_differs_from_args = 0;
 209 my @modules = map {
 210     if (/::/) {
 211     } elsif (s/\.pm$//) {
 212         s|/|::|g;
 213         $modules_differs_from_args++;
 214     } elsif (/-/) {
 215         s|-|::|g;
 216         $modules_differs_from_args++;
 217     }
 218     $_;
 219 } map {
 220     if (/,/) {
 221         split /,/, $_;
 222     } else {
 223         $_;
 224     }
 225 }
 226 @ARGV;
 227 if ($modules_differs_from_args++) {
 228     warn "@modules\n";
 229 }
 230 # some day try with IPC::System::Simple for better signal handling? I
 231 # mean for delivering ^C to the right process(es)?
 232 my $SIGNAL = 0;
 233 $SIG{INT} = sub {
 234     my($sig) = shift;
 235     warn "Saw signal '$sig', will stop asap";
 236     $SIGNAL++;
 237 };
 238 PERL: for my $p (@L) {
 239     # my($path) = $p =~ m{/([^/\-]+(?:[\d\.]{4,}|blead)(-(?:\d+-g[[:xdigit:]]+|RC\d+))?)/};
 240     my $aXX = substr($p,47+length($perlhomepath));
 241     my($path,$sha) = $aXX =~ m|([^/]+)/([^/]+)/|;
 242     my $vpath = $path; # version-relevant-path
 243     $vpath =~ s/-g[[:xdigit:]]{7,10}//; # recently git started to use 10 digits instead of 7
 244     if ($Opt{minperl}){
 245         my $vcmp = versioncmp($vpath,$Opt{minperl});
 246         #warn "vcmp[$vcmp]vpath[$vpath]minperl[$Opt{minperl}]\n";
 247         next PERL if $vcmp<0;
 248     }
 249     if ($Opt{maxperl}){
 250         my $vcmp = versioncmp($vpath,$Opt{maxperl});
 251         #warn "vcmp[$vcmp]vpath[$vpath]maxperl[$Opt{maxperl}]\n";
 252         next PERL if $vcmp>0;
 253     }
 254     $testperl{$p} ||= 0;
 255     my $program = <<'EOP';
 256     no lib ".";
 257     my $SIGNAL = 0;
 258     $SIG{INT} = sub {
 259       my($sig) = shift;
 260       warn "Inner perl saw signal '$sig', will stop asap";
 261       $SIGNAL++;
 262     };
 263     my $testperl = shift;
 264     my $verbose = shift;
 265     my $path = shift;
 266     my @v;
 267     for my $m (@ARGV) {
 268                   eval "use $m ()";
 269                   my $v;
 270                   if ($@) {
 271                     #eval "require $m";
 272                     #$v = eval {$m->VERSION();};
 273
 274                     eval "require Module::Info";
 275                     if ($@) {
 276                       $v="!noMI";
 277                     } else {
 278                       $v=eval "Module::Info->new_from_module(q{$m})->version";
 279                       $v = "_n/a_" unless defined $v;
 280                     }
 281                   } elsif (defined $m) {
 282                     local($SIG{__WARN__}) = sub {}; # silence List::Gen
 283                     $v = eval {$m->VERSION();};
 284                     if (!defined($v) or !length($v) or $@) {
 285                       $v = eval "\$$m\::VERSION";
 286                       $v =~ s/\s//g;
 287                       $v = '_n\a_' unless length $v;
 288                     }
 289                   } else {
 290                     $v = "?n-a?"
 291                   }
 292                   push @v, $verbose ? ("X$m" => $v) : $v
 293                  };
 294     if ($SIGNAL){
 295       warn "Exiting due signal" ;
 296       exit 42;
 297     }
 298     use Config;
 299     unless ($path) {
 300       $path=$^X;
 301       if (length $path > 21){
 302           for ($path){
 303               s{^/home/sand/src/perl/repoperls/installed-perls/<PERLHOMEPATH>/}{};
 304           }
 305       }
 306     }
 307     if (length $path > 21){
 308       for ($path){
 309         s{perl-}{p'};
 310       }
 311     }
 312     #no warnings "uninitialized";
 313     my @showconfigvalues = map {
 314         if (my($name,$qr)=/(.+?)~(.+)/) {
 315             my $cqr = eval "qr{$qr}";
 316             $Config{$name} =~ $qr ? 1 : 0;
 317         } elsif (!defined($Config{$_})) {
 318             "u";
 319         } else {
 320             "define" eq $Config{$_} ? "D" : $Config{$_}
 321         }
 322     } qw(<SHOWCONFIGVALUES>);
 323     printf "%-28s %s%-8s<SPRINTFSHOWCONFIG> %s\n", $path, $testperl?"*":" ", $Config{version}, @showconfigvalues, join(" ",map {sprintf "<SPRINTFWIDTH>", $_} @v);
 324 EOP
 325     $program =~ s/<SPRINTFSHOWCONFIG>/$sprintfshowconfig/g;
 326     $program =~ s/<SHOWCONFIGVALUES>/$showconfigvalues/;
 327     $program =~ s/<SPRINTFWIDTH>/%-$Opt{sprintfwidth}s/;
 328     $program =~ s/<PERLHOMEPATH>/$perlhomepath/g;
 329     sleep 0.01;
 330     last PERL if $SIGNAL;
 331     my @system = ($p, '-e', $program, $testperl{$p}, $Opt{verbose}, "$path/$sha", @modules);
 332     # some day try with IPC::System::Simple for better signal handling?
 333     my $ret = system @system;
 334     $SIGNAL++ if $ret>>8 == 42;
 335     last PERL if $SIGNAL;
 336     sleep 0.02;
 337     last PERL if $SIGNAL;
 338 }