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