lib/Object/Remote/FatNode.pm

   1 package Object::Remote::FatNode;
   2
   3 use strictures 1;
   4 use Config;
   5 use B qw(perlstring);
   6
   7 my @exclude_mods = qw(XSLoader.pm DynaLoader.pm);
   8
   9 #used by t/watchdog_fatnode
  10 our $INHIBIT_RUN_NODE = 0;
  11
  12 sub stripspace {
  13   my ($text) = @_;
  14   $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
  15   $text;
  16 }
  17
  18 my %maybe_libs = map +($_ => 1), grep defined, (values %Config, '.');
  19
  20 my @extra_libs = grep not(ref($_) or $maybe_libs{$_}), @INC;
  21
  22 my $extra_libs = join '', map "  -I$_\n", @extra_libs;
  23
  24 my $command = qq(
  25   $^X
  26   $extra_libs
  27   -mObject::Remote
  28   -mObject::Remote::Connector::STDIO
  29   -mCPS::Future
  30   -mMRO::Compat
  31   -mClass::C3
  32   -mClass::C3::next
  33   -mAlgorithm::C3
  34   -mObject::Remote::ModuleLoader
  35   -mObject::Remote::Node
  36   -mMethod::Generate::BuildAll
  37   -mMethod::Generate::DemolishAll
  38   -mJSON::PP
  39   -e 'print join "\\n", \%INC'
  40 );
  41
  42 $command =~ s/\n/ /g;
  43
  44 #warn $command;
  45 chomp(my @inc = qx($command));
  46
  47 my %exclude = map { $_ => 1 } @exclude_mods;
  48 my %mod_files = @inc;
  49 my %mods = reverse @inc;
  50
  51 foreach(keys(%mods)) {
  52   if ($exclude{ $mods{$_} }) {
  53     delete($mods{$_});
  54   }
  55 }
  56
  57 #TODO quick and dirty mod for testing - vendorarchexp from a perlbrew build
  58 #was set to '' which evaluates as a true regex
  59
  60 #use Data::Dumper;
  61 #print STDERR Dumper([keys %mod_files]);
  62 #print STDERR Dumper([keys %mods]);
  63
  64 my @non_core_non_arch = ( $mod_files{'Devel/GlobalDestruction.pm'} );
  65 push @non_core_non_arch, grep +(
  66   not (
  67     $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/
  68       or $Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/
  69       or $Config{vendorarchexp} ne '' && /^\Q$Config{vendorarchexp}/
  70       or $Config{sitearchexp} ne '' && /^\Q$Config{sitearchexp}/
  71   )
  72 ), grep !/\Q$Config{archname}/, grep !/\Q$Config{myarchname}/, keys %mods;
  73
  74 my @core_non_arch = grep +(
  75   $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/
  76   and not($Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/
  77     or /\Q$Config{archname}/ or /\Q$Config{myarchname}/)
  78 ), keys %mods;
  79
  80 #print STDERR "non-core non-arch ", Dumper(\@non_core_non_arch);
  81 #print STDERR "core non-arch ", Dumper(\@core_non_arch);
  82
  83 #TODO this is the wrong path to go down - fork() will bring
  84 #the env vars with it and the ssh connector can handle
  85 #forwarding the env vars
  86 my $env_pass = '';
  87 if (defined($ENV{OBJECT_REMOTE_LOG_LEVEL})) {
  88   my $level = $ENV{OBJECT_REMOTE_LOG_LEVEL};
  89   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_LEVEL} = "' . $level . "\";\n";
  90 }
  91 if (defined($ENV{OBJECT_REMOTE_LOG_FORMAT})) {
  92   my $format = $ENV{OBJECT_REMOTE_LOG_FORMAT};
  93   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_FORMAT} = "' . $format . "\";\n";
  94 }
  95 if (defined($ENV{OBJECT_REMOTE_LOG_SELECTIONS})) {
  96   my $selections = $ENV{OBJECT_REMOTE_LOG_SELECTIONS};
  97   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_SELECTIONS} = "' . $selections . "\";\n";
  98 }
  99 if (defined($ENV{OBJECT_REMOTE_LOG_FORWARDING})) {
 100   my $forwarding = $ENV{OBJECT_REMOTE_LOG_FORWARDING};
 101   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_FORWARDING} = "' . $forwarding . "\";\n";
 102 }
 103 if (defined($ENV{OBJECT_REMOTE_PERL_BIN})) {
 104   my $perl_bin = $ENV{OBJECT_REMOTE_PERL_BIN};
 105   $env_pass .= '$ENV{OBJECT_REMOTE_PERL_BIN} = "' . $perl_bin . "\";\n";
 106 }
 107
 108 my $start = stripspace <<'END_START';
 109   # This chunk of stuff was generated by Object::Remote::FatNode. To find
 110   # the original file's code, look for the end of this BEGIN block or the
 111   # string 'FATPACK'
 112   BEGIN {
 113   my (%fatpacked,%fatpacked_extra);
 114 END_START
 115
 116 $start .= 'my %exclude = map { $_ => 1 } qw(' . join(' ', @exclude_mods) . ");\n";
 117
 118 my $end = stripspace <<'END_END';
 119   s/^  //mg for values %fatpacked, values %fatpacked_extra;
 120
 121 sub load_from_hash {
 122     if (my $fat = $_[0]->{$_[1]}) {
 123       if ($exclude{$_[1]}) {
 124         warn "Will not pre-load '$_[1]'";
 125         return undef;
 126       }
 127
 128       #warn "handling $_[1]";
 129       open my $fh, '<', \$fat;
 130       return $fh;
 131     }
 132
 133     #Uncomment this to find brokenness
 134     #warn "Missing $_[1]";
 135     return;
 136   }
 137
 138   unshift @INC, sub { load_from_hash(\%fatpacked, $_[1]) };
 139   push @INC, sub { load_from_hash(\%fatpacked_extra, $_[1]) };
 140
 141   } # END OF FATPACK CODE
 142
 143   use strictures 1;
 144   use Object::Remote::Node;
 145
 146   unless ($Object::Remote::FatNode::INHIBIT_RUN_NODE) {
 147     Object::Remote::Node->run(watchdog_timeout => $WATCHDOG_TIMEOUT);
 148   }
 149
 150 END_END
 151
 152 my %files = map +($mods{$_} => scalar do { local (@ARGV, $/) = ($_); <> }),
 153               @non_core_non_arch, @core_non_arch;
 154
 155 my %did_pack;
 156 sub generate_fatpack_hash {
 157   my ($hash_name, $orig) = @_;
 158   (my $stub = $orig) =~ s/\.pm$//;
 159   my $name = uc join '_', split '/', $stub;
 160   my $data = $files{$orig} or die $orig; $data =~ s/^/  /mg;
 161   return () if $did_pack{$hash_name}{$orig};
 162   $did_pack{$hash_name}{$orig} = 1;
 163   return '$'.$hash_name.'{'.perlstring($orig).qq!} = <<'${name}';\n!
 164   .qq!${data}${name}\n!;
 165 }
 166
 167 my @segments = (
 168     map(generate_fatpack_hash('fatpacked', $_), sort map $mods{$_}, @non_core_non_arch),
 169     map(generate_fatpack_hash('fatpacked_extra', $_), sort map $mods{$_}, @core_non_arch),
 170 );
 171
 172 #print STDERR Dumper(\@segments);
 173 our $DATA = join "\n", $start, $env_pass, @segments, $end;
 174
 175 1;