File Coverage

blib/lib/Module/FatPack.pm
Criterion Covered Total %
statement 57 81 70.3
branch 22 44 50.0
condition 6 21 28.5
subroutine 4 4 100.0
pod 1 1 100.0
total 90 151 59.6


line stmt bran cond sub pod time code
1             package Module::FatPack;
2              
3             our $DATE = '2019-02-08'; # DATE
4             our $VERSION = '0.181'; # VERSION
5              
6 1     1   69033 use 5.010001;
  1         12  
7 1     1   5 use strict;
  1         2  
  1         21  
8 1     1   5 use warnings;
  1         2  
  1         1375  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(fatpack_modules);
13              
14             our %SPEC;
15              
16             my $mod_re = qr/\A[A-Za-z_][A-Za-z0-9_]*(::[A-Za-z0-9_]+)*\z/;
17             my $mod_pm_re = qr!\A[A-Za-z_][A-Za-z0-9_]*(/[A-Za-z0-9_]+)*\.pm\z!;
18              
19             $SPEC{fatpack_modules} = {
20             v => 1.1,
21             summary => 'Generate source code that contains fatpacked modules',
22             description => <<'_',
23              
24             This routine provides the same core technique employed by `App::FatPacker`
25             (which is putting modules' source code inside Perl variables and loading them
26             on-demand via require hook) without all the other stuffs. All you need is supply
27             the names of modules (or the modules' source code themselves) and you'll get the
28             output in a file or string.
29              
30             _
31             args_rels => {
32             req_one => ['module_names', 'module_srcs'],
33             'dep_any&' => [
34             ],
35             },
36             args => {
37             module_names => {
38             'x.name.is_plural' => 1,
39             'x.name.singular' => 'module_name',
40             summary => 'Module names to search',
41             schema => ['array*', of=>['str*', match=>$mod_re], min_len=>1],
42             tags => ['category:input'],
43             pos => 0,
44             greedy => 1,
45             'x.schema.element_entity' => 'modulename',
46             cmdline_aliases => {m=>{}},
47             },
48             module_srcs => {
49             'x.name.is_plural' => 1,
50             'x.name.singular' => 'module_src',
51             summary => 'Module source codes (a hash, keys are module names)',
52             schema => ['hash*', {
53             each_key=>['str*', match=>$mod_re],
54             each_value=>['str*'],
55             min_len=>1,
56             }],
57             tags => ['category:input'],
58             },
59             preamble => {
60             summary => 'Perl source code to add before the fatpack code',
61             schema => 'str*',
62             tags => ['category:input'],
63             },
64             postamble => {
65             summary => 'Perl source code to add after the fatpack code',
66             schema => 'str*',
67             tags => ['category:input'],
68             },
69              
70             output => {
71             summary => 'Output filename',
72             schema => 'str*',
73             cmdline_aliases => {o=>{}},
74             tags => ['category:output'],
75             'x.schema.entity' => 'filename',
76             },
77             overwrite => {
78             summary => 'Whether to overwrite output if previously exists',
79             'summary.alt.bool.yes' => 'Overwrite output if previously exists',
80             schema => [bool => default => 0],
81             tags => ['category:output'],
82             },
83              
84             assume_strict => {
85             summary => 'Assume code runs under stricture',
86             schema => 'bool',
87             default => 0,
88             },
89             line_prefix => {
90             schema => ['str*', min_len => 1],
91             },
92             put_hook_at_the_end => {
93             summary => 'Put the require hook at the end of @INC using "push" '.
94             'instead of at the front using "unshift"',
95             schema => ['bool*', is=>1],
96             },
97             add_begin_block => {
98             summary => 'Surround the code inside BEGIN { }',
99             schema => ['bool*'],
100             },
101              
102             pm => {
103             summary => "Make code suitable to put inside .pm file instead of script",
104             schema => ['bool*', is=>1],
105             description => <<'_',
106              
107             This setting adjusts the code so it is suitable to put one or several instances
108             of the code inside one or more .pm files. Also sets default for --line-prefix
109             '#' --no-add-begin-block --put-hook-at-the-end.
110              
111             _
112             },
113             },
114             examples => [
115             {
116             summary => 'Fatpack two modules',
117             src => 'fatpack-modules Text::Table::Tiny Try::Tiny',
118             src_plang => 'bash',
119             test => 0,
120             'x.doc.show_result' => 0,
121             },
122             ],
123             };
124             sub fatpack_modules {
125 3     3 1 7727 my %args = @_;
126              
127 3         5 my $pm = $args{pm};
128 3 100 33     19 my $line_prefix = $args{line_prefix} // ($pm ? '#':' ');
129 3 100 66     13 my $add_begin_block = $args{add_begin_block} // ($pm ? 0:1);
130 3 100 66     11 my $put_hook_at_the_end = $args{put_hook_at_the_end} // ($pm ? 1:0);
131              
132 3         4 my %module_srcs; # key: mod_pm
133             my %fatpack_keys;
134 3 50       7 if ($args{module_srcs}) {
135 3         6 for my $mod (keys %{ $args{module_srcs} }) {
  3         10  
136 5 50       10 my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm" unless $mod_pm =~ /\.pm\z/;
  5         14  
  5         15  
137 5         14 $module_srcs{$mod_pm} = $args{module_srcs}{$mod};
138 5         9 $fatpack_keys{$mod_pm}++;
139             }
140             } else {
141 0         0 require Module::Path::More;
142 0         0 for my $mod (@{ $args{module_names} }) {
  0         0  
143 0 0       0 my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm" unless $mod_pm =~ /\.pm\z/;
  0         0  
  0         0  
144 0 0       0 next if $module_srcs{$mod_pm};
145 0         0 my $path = Module::Path::More::module_path(
146             module => $mod, find_pmc=>0);
147 0 0       0 die "Can't find module '$mod_pm'" unless $path;
148 0         0 $module_srcs{$mod_pm} = do {
149 0         0 local $/;
150 0 0       0 open my($fh), "<", $path or die "Can't open $path: $!";
151 0         0 ~~<$fh>;
152             };
153 0         0 $fatpack_keys{$mod_pm}++;
154             }
155             }
156              
157 3 50       10 if ($args{stripper}) {
158 0         0 require Perl::Stripper;
159             my $stripper = Perl::Stripper->new(
160             maintain_linum => $args{stripper_maintain_linum} // 0,
161             strip_ws => $args{stripper_ws} // 1,
162             strip_comment => $args{stripper_comment} // 1,
163             strip_pod => $args{stripper_pod} // 1,
164 0   0     0 strip_log => $args{stripper_log} // 0,
      0        
      0        
      0        
      0        
165             );
166 0         0 for my $mod_pm (keys %module_srcs) {
167 0         0 $module_srcs{$mod_pm} = $stripper->strip($module_srcs{$mod_pm});
168             }
169             }
170              
171 3         6 my @res;
172              
173 3 50       18 push @res, $args{preamble} if defined $args{preamble};
174 3 100       7 if ($add_begin_block) {
175 1         3 push @res, 'BEGIN {', "\n";
176             } else {
177 2         11 push @res, "# BEGIN FATPACK CODE: ".join(" ", sort keys %fatpack_keys)."\n";
178 2         5 push @res, "{\n";
179             }
180 3 50 50     13 push @res, <<'_' if $args{assume_strict} // 0;
181             no strict 'refs';
182             _
183 3         11 for my $mod_pm (sort keys %module_srcs) {
184 5         10 my $label = uc($mod_pm); $label =~ s/\W+/_/g; $label =~ s/\_PM$//;
  5         24  
  5         15  
185 5         20 push @res, ' $main::fatpacked{"', $mod_pm, '"} = \'' . $line_prefix . q|#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'|, $label, "';\n";
186 5         16 $module_srcs{$mod_pm} =~ s/^/$line_prefix/gm;
187 5         12 push @res, $module_srcs{$mod_pm};
188 5 50       16 push @res, "\n" unless $module_srcs{$mod_pm} =~ /\R\z/;
189 5         13 push @res, "$label\n\n";
190             }
191 3 100       9 if ($pm) {
192 2         7 push @res, ' $main::fatpacked{$_} =~ s/^'.quotemeta($line_prefix).'//mg for ('.join(", ", map {"'$_'"} sort keys %fatpack_keys).');'."\n";
  3         12  
193             } else {
194 1         4 push @res, ' s/^'.quotemeta($line_prefix).'//mg for values %main::fatpacked;'."\n";
195             }
196 3         6 push @res, <<'_';
197             my $class = 'FatPacked::'.(0+\%main::fatpacked);
198             _
199              
200             # unneeded?
201             # push @res, <<'_';
202             # *{"${class}::files"} = sub { keys %{$_[0]} };
203             #_
204              
205 3         6 my $hook_src = <<'_';
206             unless (defined &{"${class}::INC"}) {
207             if ($] < 5.008) {
208             *{"${class}::INC"} = sub {
209             if (my $fat = $_[0]{$_[1]}) {
210             return sub {
211             return 0 unless length $fat;
212             $fat =~ s/^([^\n]*\n?)//;
213             $_ = $1;
214             return 1;
215             };
216             }
217             return;
218             };
219             } else {
220             *{"${class}::INC"} = sub {
221             if (my $fat = $_[0]{$_[1]}) {
222             open my $fh, '<', \$fat
223             or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
224             return $fh;
225             }
226             return;
227             };
228             }
229             }
230             _
231 3 100       7 if ($pm) { $hook_src =~ s/\R\s+/ /g }
  2         32  
232 3         6 push @res, $hook_src;
233 3         5 push @res, <<'_';
234             my $hook = bless(\%main::fatpacked, $class);
235             _
236 3 100       7 if ($put_hook_at_the_end) {
237 2         3 push @res, <<'_';
238             push @INC, $hook unless grep {ref($_) && "$_" eq "$hook"} @INC;
239             _
240             } else {
241 1         2 push @res, <<'_';
242             unshift @INC, $hook unless grep {ref($_) && "$_" eq "$hook"} @INC;
243             _
244             }
245 3         6 push @res, "}\n";
246 3         4 push @res, "# END OF FATPACK CODE\n\n";
247 3 50       8 push @res, $args{postamble} if defined $args{postamble};
248              
249 3 50       8 if ($args{output}) {
250 0         0 my $outfile = $args{output};
251 0 0       0 if (-f $outfile) {
252             return [409, "Won't overwrite existing file '$outfile'"]
253 0 0       0 unless $args{overwrite};
254             }
255 0 0       0 open my($fh), ">", $outfile or die "Can't write to '$outfile': $!";
256 0         0 print $fh join("", @res);
257 0         0 return [200, "OK, written to '$outfile'"];
258             } else {
259 3         28 return [200, "OK", join("", @res)];
260             }
261             }
262              
263             require PERLANCAR::AppUtil::PerlStripper; PERLANCAR::AppUtil::PerlStripper::_add_stripper_args_to_meta($SPEC{fatpack_modules});
264              
265             1;
266             # ABSTRACT: Generate source code that contains fatpacked modules
267              
268             __END__