packages/perl-modules/lib/BuildHelper.pm

   1 package BuildHelper;
   2
   3 use warnings;
   4 use strict;
   5 use Config;
   6 use Data::Dumper;
   7 use Storable qw/lock_store lock_retrieve/;
   8 use Cwd;
   9
  10 ####################################
  11 # Settings
  12 $Data::Dumper::Sortkeys = 1;
  13 my $verbose = 0;
  14 my $additional_deps = {
  15   'IO'                 => { 'ExtUtils::ParseXS' => '3.21' },
  16   'Class::MethodMaker' => { 'Fatal'             => '1' },
  17 };
  18 # override which dependencies should not be considered a core module
  19 my $no_core_dependency = {
  20   'Fatal' => 1,
  21 };
  22
  23 ####################################
  24 # is this a core module?
  25 sub is_core_module {
  26     my($module, $perl_version) = @_;
  27     eval {
  28         require Module::CoreList;
  29         Module::CoreList->import();
  30     };
  31     return if $@;
  32     my @v = split/\./, $Config{'version'};
  33     my $v = $perl_version || $v[0] + $v[1]/1000;
  34     #my $v = "5.020000";
  35     return if defined $no_core_dependency->{$module};
  36     if(exists $Module::CoreList::version{$v}{$module}) {
  37         return($Module::CoreList::version{$v}{$module});
  38     }
  39     return;
  40 }
  41
  42 ####################################
  43 # execute a command
  44 sub cmd {
  45     my($cmd,$force) = @_;
  46     print "[INFO] cmd: $cmd\n" if $verbose;
  47     my $out = "";
  48     open(my $ph, '-|', $cmd." 2>&1") or die("cannot execute cmd: $cmd");
  49     while(my $line = <$ph>) {
  50         $out .= $line;
  51     }
  52     close($ph);
  53     if($? != 0 and !defined $force) { my $rc = $?>>8; die("cmd failed (rc:$rc): $cmd\n$out") };
  54     return $out;
  55 }
  56
  57 ####################################
  58 # get all dependencies for a tarball
  59 # needs a filename like: Storable-2.21.tar.gz
  60 sub get_deps {
  61     my($file, $download, $quiet) = @_;
  62     $quiet = 0 unless defined $quiet;
  63
  64     our %deps_cache;
  65     our %deps_files;
  66     our %already_checked;
  67     return if defined $already_checked{$file};
  68     $already_checked{$file} = 1;
  69
  70     print "checking dependecies for: $file\n" unless $quiet;
  71     print "." if $quiet == 1;
  72     my $meta = get_meta_for_tarball($file);
  73
  74     my $deps = get_deps_from_meta($meta);
  75     add_additional_deps($file, $deps);
  76     $deps_cache{$file} = $deps;
  77     for my $dep (keys %{$deps}) {
  78         my $depv = $deps->{$dep};
  79         my $cv   = is_core_module($dep);
  80         if($cv and version_compare($cv, $depv)) {
  81             print "   -> $dep ($depv) skipped core dependency\n" unless $quiet;
  82             next;
  83         }
  84         print "   -> $dep ($depv)\n" unless $quiet;
  85         if($download) {
  86             download_module($dep, $depv);
  87         }
  88     }
  89     return \%deps_cache;
  90 }
  91
  92 ####################################
  93 # download all dependencies for a tarball
  94 # needs a filename like: Storable-2.21.tar.gz
  95 sub download_deps {
  96     my $file = shift;
  97     return get_deps($file, 1);
  98 }
  99
 100 ####################################
 101 # download a module
 102 # needs a module name like: IO::All
 103 sub download_module {
 104     my $mod    = shift;
 105     my $ver    = shift || 0;
 106     my $no_dep = shift || 0;
 107     my $quiet  = shift || 0;
 108
 109     print "[INFO] download_module($mod, $ver)\n" if $verbose;
 110
 111     our %already_downloaded;
 112     our %deps_checked;
 113     our @downloaded;
 114     return \@downloaded if defined $already_downloaded{$mod.$ver};
 115     $already_downloaded{$mod.$ver} = 1;
 116
 117     # we dont need core modules or perl dependency
 118     if($mod eq 'perl') { return \@downloaded; }
 119
 120     my $urlpath = get_url_for_module($mod);
 121     return \@downloaded if defined $already_downloaded{$urlpath};
 122     if($urlpath =~ m/\/perl\-[\d\.]+\.tar\.gz/) {
 123         $already_downloaded{$urlpath} = 1;
 124         print "     -> links to perl\n";
 125         return \@downloaded;
 126     }
 127     my $tarball=$urlpath; $tarball =~ s/^.*\///g;
 128
 129     if( ! -f $tarball and !defined $already_downloaded{$urlpath}) {
 130         cmd('wget --retry-connrefused -q "http://search.cpan.org'.$urlpath.'"');
 131         $already_downloaded{$urlpath} = 1;
 132         download_deps($tarball) unless $no_dep == 1;
 133         push @downloaded, $tarball;
 134         print "downloaded $tarball\n" unless $quiet;
 135     } else {
 136         if(!defined $deps_checked{$tarball}) {
 137             print "$tarball already downloaded\n";
 138             #print "rechecking dependency\n";
 139             #download_deps($tarball);
 140             $deps_checked{$tarball} = 1;
 141         } else {
 142             print "$tarball already downloaded\n";
 143         }
 144     }
 145     return \@downloaded;
 146 }
 147
 148 ####################################
 149 sub download_src {
 150     my $module = shift;
 151     cmd('wget --retry-connrefused -q "http://thruk.org/libs/src/'.$module.'"');
 152     return;
 153 }
 154
 155 ####################################
 156 # download a module
 157 # needs a filename like: Storable-2.21.tar.gz
 158 # returns module name and version
 159 sub file_to_module {
 160     my $file = shift;
 161     my($module,$version) = ($file, 0);
 162
 163     if($file =~ m/\-([0-9\.]*)(\.[\w\d]+)*(\.tar\.gz|\.tgz|\.zip)/) {
 164         $version = $1;
 165     }
 166
 167     $module =~ s/\-[0-9\.\w]*(\.tar\.gz|\.tgz|\.zip)//g;
 168     $module =~  s/\-/::/g;
 169     $module = translate_module_name($module);
 170
 171     return($module,$version);
 172 }
 173
 174 ####################################
 175 # return real module name
 176 # TODO: get real name from http://search.cpan.org/search?mode=dist&query=<module>
 177 sub translate_module_name {
 178     my $name = shift;
 179     my $tr = {
 180         'Filter'                => 'Filter::exec',
 181         'IO::Compress'          => 'IO::Compress::Base',
 182         'IO::stringy'           => 'IO::Scalar',
 183         'Scalar::List::Utils'   => 'List::Util::XS',
 184         'libwww::perl'          => 'LWP',
 185         'Template::Toolkit'     => 'Template',
 186         'TermReadKey'           => 'Term::ReadKey',
 187         'Gearman'               => 'Gearman::Client',
 188         'PathTools'             => 'File::Spec',
 189         'libnet'                => 'Net::Cmd',
 190         'podlators'             => 'Pod::Man',
 191         'Text::Tabs+Wrap'       => 'Text::Tabs',
 192     };
 193     $name =~ s/^inc::Module::Install.*?/Module::Install/g;
 194     return $tr->{$name} if defined $tr->{$name};
 195     return $name;
 196 }
 197
 198 ####################################
 199 # return filename from list
 200 sub module_to_file {
 201     my($mod, $files, $version) = @_;
 202     $version = 0 unless defined $version;
 203     if($version > 0 and defined $files->{$mod}) {
 204         my($m,$v) = file_to_module($files->{$mod});
 205         return $files->{$mod} if version_compare($v, $version);
 206     }
 207     return $files->{$mod} if defined $files->{$mod};
 208     return;
 209 }
 210
 211 ####################################
 212 # get dependencies
 213 sub get_all_deps {
 214     my($quiet) = @_;
 215     our %deps_cache;
 216     our %deps_files;
 217     alarm(60);
 218     my $data;
 219     if(-f '.deps.cache') {
 220         # this may fail due to mismatching hosts systems
 221         eval {
 222             $data = lock_retrieve('.deps.cache') or die("cannot read .deps.cache: $!");
 223         };
 224         warn($@) if $@;
 225
 226         # remove all tarballs from cache which no longer exist
 227         for my $tf (keys %{$data->{'deps'}}) {
 228             if(!-e 'src/'.$tf) {
 229                 delete $data->{'deps'}->{$tf};
 230                 for my $key (keys %{$data->{'files'}}) {
 231                     delete $data->{'files'}->{$key} if $data->{'files'}->{$key} eq $tf;
 232                 }
 233                 print " -> cleaned dependecies for: $tf because tarball does not exist anymore\n" unless $quiet;
 234             }
 235         }
 236     }
 237     alarm(0);
 238     my $cwd = cwd();
 239     chdir("src") or die("cannot change to src dir");
 240     my @tarballs = glob("*.tgz *.tar.gz *.zip");
 241
 242     %deps_cache = %{$data->{'deps'}}  if defined $data->{'deps'};
 243     %deps_files = %{$data->{'files'}} if defined $data->{'files'};
 244     my($x,$max) = (1, scalar @tarballs);
 245     for my $tarball (sort @tarballs) {
 246         if(!defined $deps_cache{$tarball}) {
 247             printf("*** (%3s/%s) ", $x, $max) if($max > 1 and !$quiet);
 248             get_deps($tarball, undef, $quiet);
 249         }
 250         $x++;
 251     }
 252
 253     chdir($cwd) or die("cannot change dir back");
 254     alarm(60);
 255     lock_store({'files' => \%deps_files, 'deps' => \%deps_cache}, '.deps.cache');
 256     alarm(0);
 257     return(\%deps_cache, \%deps_files);
 258 }
 259
 260 ####################################
 261 sub sort_by_dependency {
 262     my $modules = shift;
 263
 264     my @sorted;
 265
 266     # ExtUtils-MakeMaker has to go first
 267     for my $m (sort keys %{$modules}) {
 268         if($m =~ m/^ExtUtils\-MakeMaker\-\d+/) {
 269             push @sorted, $m;
 270             delete $modules->{$m};
 271         }
 272     }
 273
 274     my $num = scalar keys %{$modules};
 275     while($num > 0) {
 276         for my $m (sort keys %{$modules}) {
 277             for my $s (sort keys %{$modules->{$m}}) {
 278                 if(grep {/$s/} @sorted) {
 279                     delete $modules->{$m}->{$s};
 280                 }
 281             }
 282             if(scalar keys %{$modules->{$m}} == 0) {
 283                 push @sorted, $m;
 284                 delete $modules->{$m};
 285             }
 286         }
 287         my $new = scalar keys %{$modules};
 288         if($new == $num) {
 289             print Dumper $modules;
 290             die("circular dependency");
 291         }
 292         $num = $new;
 293     }
 294
 295     return @sorted;
 296 }
 297
 298 ####################################
 299 # compare two version strings
 300 # return 1 if $v1 >= $v2
 301 sub version_compare {
 302     my($v1,$v2) = @_;
 303     return 0 if !defined $v1 or $v1 eq 'undef';
 304     return 1 if !defined $v2 or $v2 eq 'undef';
 305     $v1 =~ s/^(\d+\.\d+).*$/$1/;
 306     $v2 =~ s/^(\d+\.\d+).*$/$1/;
 307     return 1 if $v1 >= $v2;
 308     return 0;
 309 }
 310
 311 ####################################
 312 # sort dependencies
 313 sub sort_deps {
 314     my $deps  = shift;
 315     my $files = shift;
 316     my $already_printed = {};
 317
 318     # 1st clean up and resolve modules to files
 319     our $modules = {};
 320     for my $file (keys %{$deps}) {
 321         $modules->{$file} = {};
 322         for my $dep (keys %{$deps->{$file}}) {
 323             next if $dep eq 'perl';
 324             next if $dep eq 'strict';
 325             next if $dep eq 'warnings';
 326             next if $dep eq 'lib';
 327             next if $dep eq 'blib';
 328             next if $dep eq 'utf8';
 329             next if $dep eq 'v';
 330             next if $dep eq 'IPC::Open'; # core module but not recognized
 331             my $cv = is_core_module($dep, 5.008);
 332             next if $cv;
 333             my $fdep = module_to_file($dep, $files, $deps->{$file}->{$dep});
 334             if(defined $fdep) {
 335                 next if $fdep eq $file;
 336                 $modules->{$file}->{$fdep} = 1
 337             } else {
 338                 if($dep !~ m/^Test::/ and $dep !~ m/^Devel::/) {
 339                     warn("cannot resolve dependency '$dep' to file, referenced by: $file\n") unless $already_printed->{$dep};
 340                     $already_printed->{$dep} = 1;
 341                 }
 342             }
 343         }
 344     }
 345
 346     my @sorted = sort_by_dependency($modules);
 347
 348     return \@sorted;
 349 }
 350
 351 ####################################
 352 # get url for module
 353 sub get_url_for_module {
 354     my $mod = shift;
 355     our %url_cache;
 356     $mod = translate_module_name($mod);
 357     return $url_cache{$mod} if exists $url_cache{$mod};
 358     for my $url ('http://search.cpan.org/perldoc?'.$mod, 'http://search.cpan.org/dist/'.$mod) {
 359         my $out = cmd("wget --retry-connrefused -O - '".$url."'", 1);
 360         if($out =~ m/href="(\/CPAN\/authors\/id\/.*?\/.*?(\.tar\.gz|\.tgz|\.zip))">/) {
 361             $url_cache{$mod} = $1;
 362             return($1);
 363         }
 364     }
 365     print "cannot find $mod on cpan\n";
 366     exit;
 367 }
 368
 369 ####################################
 370 sub install_module {
 371     my $file    = shift;
 372     my $TARGET  = shift;
 373     my $PERL    = shift || '/usr/bin/perl';
 374     my $verbose = shift || 0;
 375     my $x       = shift || 1;
 376     my $max     = shift || 1;
 377     my $force   = shift;
 378     die("error: $file does not exist in ".`pwd`) unless -e $file;
 379     die("error: module name missing") unless defined $file;
 380
 381     my $LOG = "install.log";
 382     printf("*** (%3s/%s) ", $x, $max);
 383     printf("%-55s", $file);
 384
 385     my($modname, $modvers) = file_to_module($file);
 386
 387     if( $modname eq "DBD::Oracle") {
 388         if(defined $ENV{'ORACLE_HOME'} and -f $ENV{'ORACLE_HOME'}."/lib/libclntsh.so") {
 389             $ENV{'LD_LIBRARY_PATH'} = $ENV{'ORACLE_HOME'}."/lib";
 390             $ENV{'PATH'}            = $ENV{'PATH'}.":".$ENV{'ORACLE_HOME'}."/bin";
 391         } else {
 392             print "skipped\n";
 393             return 1;
 394         }
 395     }
 396
 397     unless($force) {
 398         my $core = is_core_module($modname);
 399         if(version_compare($core, $modvers)) {
 400             print "skipped core module $core >= $modvers\n";
 401             return 1;
 402         }
 403     }
 404
 405     my $installed = 0;
 406     `grep $file $TARGET/modlist.txt 2>&1`;
 407     $installed = 1 if $? == 0;
 408     if( $installed and $modname ne 'parent' ) {
 409         print "already installed\n";
 410         return 1;
 411     }
 412
 413     my $start = time();
 414     my $dir   = _unpack($file);
 415     my $cwd   = cwd();
 416     chdir($dir);
 417     `rm -f $LOG`;
 418     print "installing... ";
 419
 420     my $makefile_opts = '';
 421     if($modname eq 'XML::LibXML') {
 422         $makefile_opts = 'FORCE=1';
 423     }
 424     if($modname eq 'List::MoreUtils') {
 425         system("sed -i -e '/url\\s*=>.*github/d' -e '/perl.*=>\\s*\\\$^V/d' Makefile.PL");
 426     }
 427     if($modname eq 'GD') {
 428         system("sed -i 's|-Wformat=0||g' Makefile.PL");
 429     }
 430
 431     eval {
 432         local $SIG{ALRM} = sub { die "timeout on: $file\n" };
 433         alarm(120); # single module should not take longer than 1 minute
 434         if( -f "Build.PL" ) {
 435             `$PERL Build.PL >> $LOG 2>&1 && $PERL ./Build >> $LOG 2>&1 && $PERL ./Build install >> $LOG 2>&1`;
 436             if($? != 0 ) { die("error: rc $?\n".`cat $LOG`."\n"); }
 437         } elsif( -f "Makefile.PL" ) {
 438             `sed -i -e 's/auto_install;//g' Makefile.PL`;
 439             my $rc;
 440             # retry because sometimes Makefile.PL will be rebuild due to broken time
 441             for my $retry (1..3) {
 442                 `echo "\n\n\n" | $PERL Makefile.PL $makefile_opts >> $LOG 2>&1 && make -j 5 >> $LOG 2>&1 && make install >> $LOG 2>&1`;
 443                 $rc = $?;
 444                 last if $rc == 0;
 445             }
 446             if($rc != 0 ) { die("error: rc $rc\n".`cat $LOG`."\n"); }
 447         } else {
 448             die("error: no Build.PL or Makefile.PL found in $file!\n");
 449         }
 450         `grep '^==> Auto-install the' $LOG >/dev/null 2>&1 | grep -v optional`;
 451         if($? == 0 ) { die("dependency error: rc $?\n".`cat $LOG`."\n"); }
 452         alarm(0);
 453     };
 454     if($@) {
 455         die("error: $@\n");
 456     } else {
 457         `echo $file >> $TARGET/modlist.txt`;
 458     }
 459
 460     my $end = time();
 461     my $duration = $end - $start;
 462     print "ok (".$duration."s)\n";
 463     my $grepv = "grep -v 'Test::' | grep -v 'Linux::Inotify2' | grep -v 'IO::KQueue' | grep -v 'prerequisite Carp' | grep -v ExtUtils::Install | grep -v ^Add | grep -v 'We have '";
 464     system("grep 'Warning: prerequisite' $LOG         | $grepv"); # or die('dependency error');
 465     system("grep 'is not installed' $LOG | grep ' ! ' | $grepv"); # or die('dependency error');
 466     system("grep 'is installed, but we need version' $LOG | grep ' ! ' | $grepv"); # or die('dependency error');
 467     system("grep 'is not a known MakeMaker parameter' $LOG | grep INSTALL_BASE | $grepv") or die('build error');
 468     chdir($cwd);
 469     if($duration > 60) {
 470         chomp(my $pwd = `pwd`);
 471         print "installation took too long, see $pwd/$dir/$LOG for details\n";
 472     } else {
 473         `rm -rf $dir`;
 474     }
 475
 476     # makes Module::Build 1000 times faster
 477     if($modname eq 'JSON::XS') {
 478         $ENV{'PERL_JSON_BACKEND'} = 'JSON::XS';
 479     }
 480
 481     return 1;
 482 }
 483
 484 ####################################
 485 # return meta content from unpacked package
 486 sub get_meta_for_dir {
 487     my($dir) = @_;
 488
 489     # create Makefile
 490     my $cwd = cwd();
 491     chdir($dir);
 492     alarm(120);
 493     eval {
 494         cmd("yes n | perl Makefile.PL", 1) if -e 'Makefile.PL';
 495         cmd("yes n | perl Build.PL", 1)    if -e 'Build.PL';
 496     };
 497     warn($@) if $@;
 498     alarm(0);
 499     chdir($cwd);
 500
 501     my $meta = {};
 502     if(-s "$dir/MYMETA.json") {
 503         eval {
 504             require JSON;
 505             $meta = JSON::from_json(`cat $dir/MYMETA.json | tr '\n' ' '`);
 506         };
 507         print Dumper $@ if $@;
 508     }
 509     elsif(-s "$dir/MYMETA.yml") {
 510         eval {
 511             $meta = YAML::LoadFile("$dir/META.yml");
 512         };
 513         print Dumper $@ if $@;
 514     }
 515     elsif(-s "$dir/META.json") {
 516         eval {
 517             require JSON;
 518             $meta = JSON::from_json(`cat $dir/META.json | tr '\n' ' '`);
 519         };
 520         print Dumper $@ if $@;
 521     }
 522     elsif(-s "$dir/META.yml") {
 523         eval {
 524             require YAML;
 525             $meta = YAML::LoadFile("$dir/META.yml");
 526         };
 527         print Dumper $@ if $@;
 528     }
 529     $meta->{requires} = {} unless defined $meta->{requires};
 530     if(-s "$dir/Makefile.PL") {
 531         my $content = `cat $dir/Makefile.PL`;
 532         if($content =~ m/WriteMakefile\s*\(/) {
 533             if($content =~ m/'PREREQ_PM'\s*=>\s*\{(.*?)}/) {
 534                 my $mod_str = $1;
 535                 $mod_str    =~ s/\n/ /g;
 536                 my %modules = $mod_str =~ m/\'(.*?)'\s*=>\s*\'(.*?)\'/;
 537                 %{$meta->{requires}} = (%{$meta->{requires}}, %modules);
 538             }
 539         }
 540         if($content =~ m/^\s*requires\s+/m) {
 541             my %modules = $content =~ m/^\s*requires\s+(.*?)\s*=>\s*(.*?);/gm;
 542             %{$meta->{requires}} = (%{$meta->{requires}}, %modules);
 543         }
 544         if($content =~ m/^\s*use\s+[a-zA-Z:]+\s*/m) {
 545             my %modules = $content =~ m/^\s*use\s+([a-zA-Z:]+)\s*([\d\.]+)/gm;
 546             delete $modules{'inc::Module::Install'};
 547             delete $modules{'inc::Module::Install::DSL'};
 548             %{$meta->{requires}} = (%{$meta->{requires}}, %modules);
 549         }
 550     }
 551
 552     # add deps from the Makefile
 553     if(-s "$dir/Makefile") {
 554         my $prereq = `grep PREREQ_PM $dir/Makefile`;
 555         chomp($prereq);
 556         $prereq =~ s/^#\s+PREREQ_PM\s*=>\s*({.*}).*$/\$req = $1;/g;
 557         $prereq =~ s/([\w:]+)=/'$1'=/g;
 558         my $req;
 559         eval($prereq);
 560         if(defined $req) {
 561             for my $mod (keys %{$req}) {
 562                 $meta->{requires}->{$mod} = $req->{$mod};
 563             }
 564         }
 565     }
 566
 567     $meta->{requires}           = {} unless defined $meta->{requires};
 568     $meta->{build_requires}     = {} unless defined $meta->{build_requires};
 569     $meta->{configure_requires} = {} unless defined $meta->{configure_requires};
 570     $meta->{prereqs}->{'build'}->{'requires'}     = {} unless defined $meta->{prereqs}->{'build'}->{'requires'};
 571     $meta->{prereqs}->{'configure'}->{'requires'} = {} unless defined $meta->{prereqs}->{'configure'}->{'requires'};
 572     $meta->{prereqs}->{'runtime'}->{'requires'}   = {} unless defined $meta->{prereqs}->{'runtime'}->{'requires'};
 573
 574     $meta->{requires}->{'Module::Build'} = 1 if -s $dir.'/Build.PL';
 575
 576     if(!defined $meta->{name}) {
 577         $meta->{name} = $dir;
 578         $meta->{name} =~ s/^(.*)\-.*?$/$1/;
 579         $meta->{name} =~ s/\-/::/g;
 580     }
 581
 582     return $meta;
 583 }
 584
 585 ####################################
 586 # return dependencies from meta data
 587 sub get_deps_from_meta {
 588     my($meta, $all) = @_;
 589     my %deps = (%{$meta->{requires}},
 590                 %{$meta->{build_requires}},
 591                 %{$meta->{configure_requires}},
 592                 %{$meta->{prereqs}->{'build'}->{'requires'}},
 593                 %{$meta->{prereqs}->{'configure'}->{'requires'}},
 594                 %{$meta->{prereqs}->{'runtime'}->{'requires'}},
 595                );
 596     my $stripped_deps = {};
 597     for my $dep (keys %deps) {
 598         my $val = $deps{$dep};
 599         $dep =~ s/('|")//gmx;
 600         $val =~ s/('|")//gmx;
 601         next if $val =~ m/win32/;
 602         next if $dep eq 'perl';
 603         next if $dep eq 'warnings';
 604         next if $dep eq 'strict';
 605         next if $dep eq 'lib';
 606         next if $dep eq 'v';
 607         if(!$all) {
 608             next if $dep eq 'IPC::Open'; # core module but not recognized
 609             next if $dep =~ m/^Test::/;
 610             next if $dep eq 'Test';
 611         }
 612         $stripped_deps->{$dep} = $val;
 613     }
 614     return $stripped_deps;
 615 }
 616
 617 ####################################
 618 # add additional dependencies
 619 sub add_additional_deps {
 620     my($file, $deps) = @_;
 621     my($modname, $modvers) = file_to_module($file);
 622     if($additional_deps->{$modname}) {
 623         for my $key (keys %{$additional_deps->{$modname}}) {
 624             $deps->{$key} = $additional_deps->{$modname}->{$key};
 625         }
 626     }
 627     return $deps;
 628 }
 629
 630 ####################################
 631 # return dependencies from meta data
 632 sub _unpack {
 633     my $file = shift;
 634     if($file =~ m/\.zip$/gmx) {
 635         cmd("unzip $file");
 636     } else {
 637         cmd("tar zxf $file");
 638     }
 639     my $dir = $file;
 640     $dir =~  s/(\.tar\.gz|\.tgz|\.zip)//g;
 641     $dir =~  s/.*\///g;
 642     $dir =~  s/\-src//g;
 643     return $dir;
 644 }
 645
 646 ####################################
 647 # find orphaned packages
 648 sub get_orphaned {
 649     my($deps, $files, $verbose) = @_;
 650     my $orphaned = {};
 651     for my $file (keys %{$deps}) {
 652         # verify this module is used somewhere
 653         my $found = 0;
 654         for my $file2 (keys %{$deps}) {
 655             next if $file eq $file2;
 656             for my $dep2 (keys %{$deps->{$file2}}) {
 657                 next if $dep2 eq 'perl';
 658                 next if $dep2 eq 'strict';
 659                 next if $dep2 eq 'warnings';
 660                 next if $dep2 eq 'lib';
 661                 next if $dep2 eq 'v';
 662                 my $fdep2 = module_to_file($dep2, $files, $deps->{$file2}->{$dep2});
 663                 next unless $fdep2;
 664                 $found = 1 if $fdep2 eq $file;
 665                 if($found && $verbose) { print "$file is used by $file2\n"; }
 666                 last if $found;
 667             }
 668             last if $found;
 669         }
 670         $orphaned->{$file} = 1 unless $found;
 671     }
 672     return $orphaned;
 673 }
 674
 675 ####################################
 676 sub get_meta {
 677     my($in) = @_;
 678     my $meta = {};
 679     if($in =~ m/Makefile\.PL$/mx) {
 680         my $dir = $in;
 681         $dir    =~ s/Makefile\.PL$//gmx;
 682         $meta   = get_meta_for_dir($dir);
 683     }
 684     elsif($in =~ m/(\.tar.gz|\.tgz|\.zip)$/mx) {
 685         $meta = get_meta_for_tarball($in);
 686     }
 687     else {
 688         die("unsupported file: ".$in);
 689     }
 690     return $meta;
 691 }
 692
 693 ####################################
 694 sub get_meta_for_tarball {
 695     my($file) = @_;
 696
 697     our %deps_files;
 698
 699     my $dir  = _unpack($file);
 700     my $meta = get_meta_for_dir($dir);
 701
 702     for my $f (split/\n/,`find -name \*.pm; find -name \*.PL`) {
 703         next if $f =~ m|/inc/|mxo; # skip inc modules included by Module::Install packaged modules
 704         open(my $fh, '<', $f);
 705         while(my $line = <$fh>) {
 706             if($line =~ m/^package\s+(.*?)(\s|;|#)/) {
 707                 $deps_files{$1} = $file;
 708             }
 709         }
 710         if($f =~ m/\.pm$/mx) {
 711             $f =~ s|^/||gmx;
 712             $f =~ s|b?lib/||gmx;
 713             $f =~ s|/|::|gmx;
 714             $f =~ s|\.pm||gmx;
 715             $deps_files{$f} = $file;
 716         }
 717         close($fh);
 718     }
 719
 720     cmd("rm -fr $dir");
 721     return($meta);
 722 }
 723
 724 1;