File Coverage

blib/lib/Pod/Readme/Filter.pm
Criterion Covered Total %
statement 122 155 78.7
branch 40 68 58.8
condition 4 14 28.5
subroutine 31 32 96.8
pod 0 12 0.0
total 197 281 70.1


line stmt bran cond sub pod time code
1             package Pod::Readme::Filter;
2              
3 5     5   3139 use v5.10.1;
  5         16  
4              
5 5     5   604 use Moo;
  5         11057  
  5         25  
6              
7             our $VERSION = 'v1.2.1';
8              
9 5     5   4647 use MooX::HandlesVia;
  5         42837  
  5         30  
10             with 'Pod::Readme::Plugin';
11              
12 5     5   659 use Carp;
  5         10  
  5         278  
13 5     5   2508 use File::Slurp qw/ read_file /;
  5         54151  
  5         320  
14 5     5   35 use IO qw/ File Handle /;
  5         10  
  5         32  
15 5     5   2436 use Module::Load qw/ load /;
  5         1117  
  5         36  
16 5     5   380 use Path::Tiny;
  5         11  
  5         220  
17 5     5   479 use Try::Tiny;
  5         1390  
  5         236  
18 5     5   561 use Types::Standard qw/ Bool InstanceOf Int RegexpRef Str /;
  5         78370  
  5         48  
19              
20 5     5   5580 use Pod::Readme::Types qw/ Dir File ReadIO WriteIO TargetName DistZilla /;
  5         13  
  5         10002  
21              
22             =head1 NAME
23              
24             Pod::Readme::Filter - Filter README from POD
25              
26             =head1 SYNOPSIS
27              
28             use Pod::Readme::Filter;
29              
30             my $prf = Pod::Readme::Filter->new(
31             target => 'readme',
32             base_dir => '.',
33             input_file => 'lib/MyApp.pm',
34             output_file => 'README.pod',
35             );
36              
37             =head1 DESCRIPTION
38              
39             This module provides the basic filtering and minimal processing to
40             extract a F from a module's POD. It is used internally by
41             L.
42              
43             =cut
44              
45             has encoding => (
46             is => 'ro',
47             isa => Str,
48             default => ':utf8',
49             );
50              
51             has base_dir => (
52             is => 'ro',
53             isa => Dir,
54             coerce => sub { Dir->coerce(@_) },
55             default => '.',
56             );
57              
58             has input_file => (
59             is => 'ro',
60             isa => File,
61             required => 0,
62             coerce => sub { File->coerce(@_) },
63             );
64              
65             has output_file => (
66             is => 'ro',
67             isa => File,
68             required => 0,
69             coerce => sub { File->coerce(@_) },
70             );
71              
72             has input_fh => (
73             is => 'ro',
74             isa => ReadIO,
75             lazy => 1,
76             builder => '_build_input_fh',
77             coerce => sub { ReadIO->coerce(@_) },
78             );
79              
80             sub _build_input_fh {
81 2     2   107 my ($self) = @_;
82 2 50       20 if ( $self->input_file ) {
83 2         16 $self->input_file->openr;
84             }
85             else {
86 0         0 my $fh = IO::Handle->new;
87 0 0       0 if ( $fh->fdopen( fileno(STDIN), 'r' ) ) {
88 0         0 return $fh;
89             }
90             else {
91 0         0 croak "Cannot get a filehandle for STDIN";
92             }
93             }
94             }
95              
96             has output_fh => (
97             is => 'ro',
98             isa => WriteIO,
99             lazy => 1,
100             builder => '_build_output_fh',
101             coerce => sub { WriteIO->coerce(@_) },
102             );
103              
104             sub _build_output_fh {
105 4     4   9 my ($self) = @_;
106 4 50       67 if ( $self->output_file ) {
107 4         187 $self->output_file->openw;
108             }
109             else {
110 0         0 my $fh = IO::Handle->new;
111 0 0       0 if ( $fh->fdopen( fileno(STDOUT), 'w' ) ) {
112 0         0 return $fh;
113             }
114             else {
115 0         0 croak "Cannot get a filehandle for STDOUT";
116             }
117             }
118             }
119              
120             has target => (
121             is => 'ro',
122             isa => TargetName,
123             default => 'readme',
124             );
125              
126             has in_target => (
127             is => 'ro',
128             isa => Bool,
129             init_arg => undef,
130             default => 1,
131             writer => '_set_in_target',
132             );
133              
134             has _target_regex => (
135             is => 'ro',
136             isa => RegexpRef,
137             init_arg => undef,
138             lazy => 1,
139             default => sub {
140             my $self = shift;
141             my $target = $self->target;
142             qr/^[:]?${target}$/;
143             },
144             );
145              
146             has mode => (
147             is => 'rw',
148             isa => Str,
149             default => 'default',
150             init_arg => undef,
151             );
152              
153             has _line_no => (
154             is => 'ro',
155             isa => Int,
156             default => 0,
157             writer => '_set_line_no',
158             );
159              
160             sub _inc_line_no {
161 44     44   74 my ($self) = @_;
162 44         778 $self->_set_line_no( 1 + $self->_line_no );
163             }
164              
165             sub depends_on {
166 7     7 0 974 my ($self) = @_;
167 7         13 my @files;
168 7 100       61 push @files, $self->input_file if $self->input_file;
169 7         101 return @files;
170             }
171              
172             sub write {
173 117     117 0 600 my ( $self, $line ) = @_;
174 117         1792 my $fh = $self->output_fh;
175 117         838 print {$fh} $line;
  117         350  
176             }
177              
178             sub in_pod {
179 125     125 0 228 my ($self) = @_;
180 125         1968 $self->mode eq 'pod';
181             }
182              
183             has _for_buffer => (
184             is => 'rw',
185             isa => Str,
186             init_arg => undef,
187             default => '',
188             handles_via => 'String',
189             handles => {
190             _append_for_buffer => 'append',
191             _clear_for_buffer => 'clear',
192             },
193             );
194              
195             has _begin_args => (
196             is => 'rw',
197             isa => Str,
198             init_arg => undef,
199             default => '',
200             handles_via => 'String',
201             handles => { _clear_begin_args => 'clear', },
202             );
203              
204             has zilla => (
205             is => 'ro',
206             isa => InstanceOf[ 'Dist::Zilla' ],
207             );
208              
209             sub process_for {
210 18     18 0 187 my ( $self, $data ) = @_;
211              
212 18         96 my ( $target, @args ) = $self->_parse_arguments($data);
213              
214 18 50 33     403 if ( $target && $target =~ $self->_target_regex ) {
215 18 50       349 if ( my $cmd = shift @args ) {
216 18         35 $cmd =~ s/-/_/g;
217 18 50       181 if ( my $method = $self->can("cmd_${cmd}") ) {
218             try {
219 18     18   1665 $self->$method(@args);
220             }
221             catch {
222 4     4   92 s/\n$//;
223 4         80 die
224             sprintf( "\%s at input line \%d\n", $_, $self->_line_no );
225 18         157 };
226             }
227             else {
228 0         0 die sprintf( "Unknown command: '\%s' at input line \%d\n",
229             $cmd, $self->_line_no );
230             }
231              
232             }
233              
234             }
235 14         1039 $self->_clear_for_buffer;
236             }
237              
238             sub filter_line {
239 119     119 0 44738 my ( $self, $line ) = @_;
240              
241             # Modes:
242             #
243             # pod = POD mode
244             #
245             # pod:for = buffering text for =for command
246             #
247             # pod:begin = don't print this line, skip next line
248             #
249             # target:* = begin block for something other than readme
250             #
251             # default = code
252             #
253              
254 119         208 state $blank = qr/^\s*\n$/;
255              
256 119         2460 my $mode = $self->mode;
257              
258 119 100       862 if ( $mode eq 'pod:for' ) {
    100          
259 18 50       108 if ( $line =~ $blank ) {
260 18         285 $self->process_for( $self->_for_buffer );
261 14         1534 $mode = $self->mode('pod');
262             }
263             else {
264 0         0 $self->_append_for_buffer($line);
265             }
266 14         397 return 1;
267             }
268             elsif ( $mode eq 'pod:begin' ) {
269              
270 7 50       39 unless ( $line =~ $blank ) {
271 0         0 die sprintf( "Expected new paragraph after command at line \%d\n",
272             $self->_line_no );
273             }
274              
275 7         113 $self->mode('pod');
276 7         181 return 1;
277             }
278              
279 94 100       329 if ( my ($cmd) = ( $line =~ /^=(\w+)\s/ ) ) {
280 41 100       727 $mode = $self->mode( $cmd eq 'cut' ? 'default' : 'pod' );
281              
282 41 100       1160 if ( $self->in_pod ) {
283              
284 40 100       345 if ( $cmd eq 'for' ) {
    100          
    100          
285              
286 18         281 $self->mode('pod:for');
287 18         748 $self->_for_buffer( substr( $line, 4 ) );
288              
289             }
290             elsif ( $cmd eq 'begin' ) {
291              
292 4         17 my ( $target, @args ) =
293             $self->_parse_arguments( substr( $line, 6 ) );
294              
295 4 100       74 if ( $target =~ $self->_target_regex ) {
296              
297 3 100       41 if (@args) {
298              
299 1         6 my $buffer = join( ' ', @args );
300              
301 1 50       6 if ( substr( $target, 0, 1 ) eq ':' ) {
302 0         0 die sprintf( "Can only target POD at line \%d\n",
303             $self->_line_no + 1 );
304             }
305              
306 1         19 $self->write_begin( $self->_begin_args($buffer) );
307             }
308              
309 3         76 $self->mode('pod:begin');
310              
311             }
312             else {
313 1         31 $self->mode( 'target:' . $target );
314             }
315              
316             }
317             elsif ( $cmd eq 'end' ) {
318              
319 4         18 my ( $target, @args ) =
320             $self->_parse_arguments( substr( $line, 4 ) );
321              
322 4 100       70 if ( $target =~ $self->_target_regex ) {
323 3         88 my $buffer = $self->_begin_args;
324 3 100       25 if ( $buffer ne '' ) {
325 2         9 $self->write_end($buffer);
326 2         81 $self->_clear_begin_args;
327             }
328             }
329              
330 4         248 $self->mode('pod:begin');
331             }
332             }
333              
334             }
335              
336 94 100 100     1051 $self->write($line) if $self->in_target && $self->in_pod;
337              
338 94         682 return 1;
339             }
340              
341             sub filter_file {
342 4     4 0 9 my ($self) = @_;
343              
344 4         69 foreach
345             my $line ( read_file( $self->input_fh, binmode => $self->encoding ) )
346             {
347 44 50       1882 $self->filter_line($line)
348             or last;
349 44         94 $self->_inc_line_no;
350             }
351             }
352              
353             sub run {
354 4     4 0 8 my ($self) = @_;
355 4         17 $self->filter_file;
356             }
357              
358             sub cmd_continue {
359 2     2 0 604 my ($self) = @_;
360 2         5 $self->cmd_start;
361             }
362              
363             sub cmd_include {
364 0     0 0 0 my ( $self, @args ) = @_;
365              
366 0         0 my $res = $self->parse_cmd_args( [qw/ file type start stop /], @args );
367              
368 0         0 my $start = $res->{start};
369 0 0       0 $start = qr/${start}/ if $start;
370 0         0 my $stop = $res->{stop};
371 0 0       0 $stop = qr/${stop}/ if $stop;
372              
373 0   0     0 my $type = $res->{type} // 'pod';
374 0 0       0 unless ( $type =~ /^(?:text|pod)$/ ) {
375 0         0 die "Unsupported include type: '${type}'\n";
376             }
377              
378 0         0 my $file = $res->{file};
379 0 0       0 my $fh = IO::File->new( $file, 'r' )
380             or die "Unable to open file '${file}': $!\n";
381              
382 0         0 $self->write("\n");
383              
384 0         0 while ( my $line = <$fh> ) {
385              
386 0 0 0     0 next if ( $start && $line !~ $start );
387 0 0 0     0 last if ( $stop && $line =~ $stop );
388              
389 0         0 $start = undef;
390              
391 0 0       0 if ( $type eq 'text' ) {
392 0         0 $self->write_verbatim($line);
393             }
394             else {
395 0         0 $self->write($line);
396             }
397              
398             }
399              
400 0         0 $self->write("\n");
401              
402 0         0 close $fh;
403              
404             }
405              
406             sub cmd_start {
407 4     4 0 610 my ($self) = @_;
408 4         83 $self->_set_in_target(1);
409             }
410              
411             sub cmd_stop {
412 4     4 0 4009 my ($self) = @_;
413 4         104 $self->_set_in_target(0);
414             }
415              
416             sub _load_plugin {
417 6     6   18 my ( $self, $plugin ) = @_;
418             try {
419 6     6   488 my $module = "Pod::Readme::Plugin::${plugin}";
420 6         37 load $module;
421 4         6204 require Role::Tiny;
422 4         40 Role::Tiny->apply_roles_to_object( $self, $module );
423             }
424             catch {
425 2     2   859 die "Unable to locate plugin '${plugin}': $_";
426 6         66 };
427             }
428              
429             sub cmd_plugin {
430 14     14 0 38 my ( $self, $plugin, @args ) = @_;
431 14         32 my $name = "cmd_${plugin}";
432 14 100       120 $self->_load_plugin($plugin) unless $self->can($name);
433 12 50       3648 if ( my $method = $self->can($name) ) {
434 12         40 $self->$method(@args);
435             }
436             }
437              
438 5     5   528 use namespace::autoclean;
  5         11799  
  5         36  
439              
440             1;