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 my @non_core_non_arch = ( $mod_files{'Devel/GlobalDestruction.pm'} );
  58 push @non_core_non_arch, grep +(
  59   not (
  60     #some of the config variables can be empty which will eval as a matching regex
  61     $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/
  62       or $Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/
  63       or $Config{vendorarchexp} ne '' && /^\Q$Config{vendorarchexp}/
  64       or $Config{sitearchexp} ne '' && /^\Q$Config{sitearchexp}/
  65   )
  66 ), grep !/\Q$Config{archname}/, grep !/\Q$Config{myarchname}/, keys %mods;
  67
  68 my @core_non_arch = grep +(
  69   $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/
  70   and not($Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/
  71     or /\Q$Config{archname}/ or /\Q$Config{myarchname}/)
  72 ), keys %mods;
  73
  74 #print STDERR "non-core non-arch ", Dumper(\@non_core_non_arch);
  75 #print STDERR "core non-arch ", Dumper(\@core_non_arch);
  76
  77 #TODO this is the wrong path to go down - fork() will bring
  78 #the env vars with it and the ssh connector can handle
  79 #forwarding the env vars
  80 my $env_pass = '';
  81 if (defined($ENV{OBJECT_REMOTE_LOG_LEVEL})) {
  82   my $level = $ENV{OBJECT_REMOTE_LOG_LEVEL};
  83   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_LEVEL} = "' . $level . "\";\n";
  84 }
  85 if (defined($ENV{OBJECT_REMOTE_LOG_FORMAT})) {
  86   my $format = $ENV{OBJECT_REMOTE_LOG_FORMAT};
  87   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_FORMAT} = "' . $format . "\";\n";
  88 }
  89 if (defined($ENV{OBJECT_REMOTE_LOG_SELECTIONS})) {
  90   my $selections = $ENV{OBJECT_REMOTE_LOG_SELECTIONS};
  91   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_SELECTIONS} = "' . $selections . "\";\n";
  92 }
  93 if (defined($ENV{OBJECT_REMOTE_LOG_FORWARDING})) {
  94   my $forwarding = $ENV{OBJECT_REMOTE_LOG_FORWARDING};
  95   $env_pass .= '$ENV{OBJECT_REMOTE_LOG_FORWARDING} = "' . $forwarding . "\";\n";
  96 }
  97 if (defined($ENV{OBJECT_REMOTE_PERL_BIN})) {
  98   my $perl_bin = $ENV{OBJECT_REMOTE_PERL_BIN};
  99   $env_pass .= '$ENV{OBJECT_REMOTE_PERL_BIN} = "' . $perl_bin . "\";\n";
 100 }
 101
 102 my $start = stripspace <<'END_START';
 103   # This chunk of stuff was generated by Object::Remote::FatNode. To find
 104   # the original file's code, look for the end of this BEGIN block or the
 105   # string 'FATPACK'
 106   BEGIN {
 107   my (%fatpacked,%fatpacked_extra);
 108 END_START
 109
 110 $start .= 'my %exclude = map { $_ => 1 } qw(' . join(' ', @exclude_mods) . ");\n";
 111
 112 my $end = stripspace <<'END_END';
 113   s/^  //mg for values %fatpacked, values %fatpacked_extra;
 114
 115 sub load_from_hash {
 116     if (my $fat = $_[0]->{$_[1]}) {
 117       if ($exclude{$_[1]}) {
 118         warn "Will not pre-load '$_[1]'";
 119         return undef;
 120       }
 121
 122       #warn "handling $_[1]";
 123       open my $fh, '<', \$fat;
 124       return $fh;
 125     }
 126
 127     #Uncomment this to find brokenness
 128     #warn "Missing $_[1]";
 129     return;
 130   }
 131
 132   unshift @INC, sub { load_from_hash(\%fatpacked, $_[1]) };
 133   push @INC, sub { load_from_hash(\%fatpacked_extra, $_[1]) };
 134
 135   } # END OF FATPACK CODE
 136
 137   use strictures 1;
 138   use Object::Remote::Node;
 139
 140   unless ($Object::Remote::FatNode::INHIBIT_RUN_NODE) {
 141     Object::Remote::Node->run(watchdog_timeout => $WATCHDOG_TIMEOUT);
 142   }
 143
 144 END_END
 145
 146 my %files = map +($mods{$_} => scalar do { local (@ARGV, $/) = ($_); <> }),
 147               @non_core_non_arch, @core_non_arch;
 148
 149 my %did_pack;
 150 sub generate_fatpack_hash {
 151   my ($hash_name, $orig) = @_;
 152   (my $stub = $orig) =~ s/\.pm$//;
 153   my $name = uc join '_', split '/', $stub;
 154   my $data = $files{$orig} or die $orig; $data =~ s/^/  /mg;
 155   return () if $did_pack{$hash_name}{$orig};
 156   $did_pack{$hash_name}{$orig} = 1;
 157   $data .= "\n" unless $data =~ m/\n$/;
 158   my $ret = '$'.$hash_name.'{'.perlstring($orig).qq!} = <<'${name}';\n!
 159     .qq!${data}${name}\n!;
 160 #  warn $ret;
 161   return $ret;
 162 }
 163
 164 my @segments = (
 165     map(generate_fatpack_hash('fatpacked', $_), sort map $mods{$_}, @non_core_non_arch),
 166     map(generate_fatpack_hash('fatpacked_extra', $_), sort map $mods{$_}, @core_non_arch),
 167 );
 168
 169 #print STDERR Dumper(\@segments);
 170 our $DATA = join "\n", $start, $env_pass, @segments, $end;
 171
 172 1;