File Coverage

blib/lib/Getopt/Long/DescriptivePod.pm
Criterion Covered Total %
statement 100 124 80.6
branch 29 44 65.9
condition 2 2 100.0
subroutine 13 14 92.8
pod 2 2 100.0
total 146 186 78.4


line stmt bran cond sub pod time code
1             package Getopt::Long::DescriptivePod; ## no critic (TidyCode)
2            
3 7     7   371642 use strict;
  7         11  
  7         264  
4 7     7   31 use warnings;
  7         11  
  7         304  
5            
6             our $VERSION = '0.03';
7            
8 7     7   35 use Carp qw(confess);
  7         15  
  7         463  
9 7     7   4081 use English qw(-no_match_vars $PROGRAM_NAME $OS_ERROR $INPUT_RECORD_SEPARATOR);
  7         29491  
  7         44  
10 7     7   3250 use Params::Validate qw(validate SCALAR SCALARREF CODEREF);
  7         21370  
  7         632  
11 7         92 use Sub::Exporter -setup => {
12             exports => [ qw( replace_pod trim_lines ) ],
13             groups => {
14             default => [ qw( replace_pod trim_lines ) ],
15             },
16 7     7   1465 };
  7         28098  
17            
18             sub _on_verbose {
19 6     6   10 my ($param_ref, $string) = @_;
20            
21 6 50       22 if ( $param_ref->{on_verbose} ) {
22 6         20 $param_ref->{on_verbose}->($string);
23             }
24            
25 6         2332 return;
26             }
27            
28             sub _close_data {
29             # after __END__ this handle is open
30 7     7   3854 no warnings qw(once); ## no critic (ProhibitNoWarnings)
  7         13  
  7         10634  
31            
32 5     5   12 return close ::DATA;
33             }
34            
35             sub _format_block {
36 5     5   10 my $block_ref = shift;
37            
38 5         9 for my $key ( keys %{$block_ref} ) {
  5         19  
39 15         25 VALUE: for my $value ( $block_ref->{$key} ) { # alias only
40 15 100       52 defined $value
41             or next VALUE;
42 7         92 $value =~ s{ \r\n | [\n\r] }{\n}xmsg; # compatible \n
43 7         87 $value =~ s{ \A \n* (.*?) \n* \z }{$1}xms; # trim
44 7 100       58 $value = [
    100          
45             ( $key eq 'after' ? q{} : () ),
46             ( split m{ \n }xms, $value ),
47             ( $key eq 'before' ? q{} : () ),
48             ];
49             }
50             }
51            
52 5         12 return;
53             }
54            
55             sub _read_file {
56 5     5   9 my $param_ref = shift;
57            
58 5 50       20 if ( ref $param_ref->{filename} ) {
59 5         7 return ${ $param_ref->{filename} };
  5         14  
60             }
61 0 0       0 if ( open my $file, '< :raw', $param_ref->{filename} ) {
62 0         0 local $INPUT_RECORD_SEPARATOR = ();
63 0         0 my $content = <$file>;
64 0         0 () = close $file;
65 0         0 return $content;
66             }
67 0         0 _verbose( $param_ref, "Can not open file $param_ref->{filename} $OS_ERROR" );
68            
69 0         0 return;
70             }
71            
72             sub _write_file {
73 3     3   5 my ($param_ref, $content) = @_;
74            
75 3 50       13 if ( ref $param_ref->{filename} ) {
76 3         5 ${ $param_ref->{filename} } = $content;
  3         7  
77 3         7 return;
78             }
79 0 0       0 open my $file, '> :raw', $param_ref->{filename}
80             or confess "Can not open file $param_ref->{filename} $OS_ERROR";
81 0 0       0 print {$file} $content
  0         0  
82             or confess "Can not write file $param_ref->{filename} $OS_ERROR";
83 0 0       0 close $file
84             or confess "Can not close file $param_ref->{filename} $OS_ERROR";
85            
86 0         0 return;
87             }
88            
89             sub replace_pod { ## no critic (ArgUnpacking)
90 8     8 1 9605 my %param_of = validate(
91             @_,
92             {
93             filename => { type => SCALAR | SCALARREF, default => $PROGRAM_NAME },
94             tag => { regex => qr{ \A = \w }xms },
95             before_code_block => { type => SCALAR, optional => 1 },
96             code_block => { type => SCALAR },
97             after_code_block => { type => SCALAR, optional => 1 },
98             indent => { regex => qr{ \A \d+ \z }xms, default => 1 },
99             on_verbose => { type => CODEREF, optional => 1 },
100             },
101             );
102            
103 8         337 BLOCK: for my $block ( qw(before_code_block code_block after_code_block) ) {
104 21 100       79 defined $param_of{$block}
105             or next BLOCK;
106 11 100       83 $param_of{$block} =~ m{ ^ = }xms
107             and confess "A Pod tag is not allowed in $block";
108             }
109            
110 5         23 _close_data;
111            
112             # clone
113 5         30 my %block_of = (
114             before => $param_of{before_code_block},
115             code => $param_of{code_block},
116             after => $param_of{after_code_block},
117             );
118            
119 5         35 _format_block( \%block_of );
120            
121 5         9 for my $line ( @{ $block_of{code} } ) {
  5         15  
122 16         35 $line = q{ } x $param_of{indent} . $line;
123             }
124            
125             # \t to indent, trim EOL
126 22         25 my @block = map { ## no critic (ComplexMappings)
127 5 100       87 my $value = $_;
128 22         33 $value =~ s{ \t }{ q{ } x $param_of{indent} }xmsge;
  12         35  
129 22         62 $value =~ s{ \s+ \z }{}xms;
130 22         37 $value;
131             } (
132 5         14 @{ $block_of{before} || [] },
133 5 100       28 @{ $block_of{code} },
134 5         12 @{ $block_of{after} || [] },
135             );
136            
137 5         24 my $current_content = _read_file( \%param_of );
138 5 100       17 if ( ! $current_content ) {
139 1         4 _on_verbose( \%param_of, 'Empty file detected' );
140 1         7 return;
141             }
142 4         98 my ($newline) = $current_content =~ m{ ( \r\n | [\n\r] ) }xms;
143 4         64 $current_content =~ s{ \r\n | [\n\r] }{\n}xmsg;
144 4         19 my ($newlines_at_eof) = $current_content =~ m{ ( \n+ ) \z }xms;
145 4   100     33 $newlines_at_eof = length +( $newlines_at_eof || q{} );
146 4         16 $current_content =~ s{ \n+ \z }{}xms;
147 4         20 my @content = split m{ \n }xms, $current_content;
148            
149             # replace Pod
150 4         6 my $is_found;
151 4         7 my $index = 0;
152 4         13 LINE: while ( $index < @content ) {
153 26         36 my $line = $content[$index];
154 26 100       46 if ( $is_found ) {
155 11 100       24 if ( $line =~ m{ \A = \w }xms ) { # stop deleting on next tag
156 4         6 $is_found = ();
157 4         6 last LINE;
158             }
159 7         8 splice @content, $index, 1; # delete current line
160 7         8 redo LINE;
161             }
162 15 100       104 if ( $line =~ m{ \A \Q$param_of{tag}\E \z }xms ) {
163 4         6 $is_found++;
164 4         19 splice @content, $index + 1, 0, q{}, @block, q{};
165 4         14 $index += 1 + @block + 1;
166             }
167 15         49 $index++;
168             }
169            
170             # check changes
171 4         16 my $new_content = join "\n", @content;
172 4 100       11 if ( $newlines_at_eof ) {
173             # restore current_content too
174 3         6 for my $content ( $current_content, $new_content ) {
175 6         16 $content .= "\n" x $newlines_at_eof;
176             }
177 3         14 _on_verbose( \%param_of, "$newlines_at_eof newline(s) at EOF detected" );
178             }
179             else {
180 1         5 _on_verbose( \%param_of, 'No newline at EOF detected' );
181             }
182 4 100       18 if ( $new_content eq $current_content ) {
183 1         3 _on_verbose( \%param_of, 'Equal content - nothing to do' );
184 1         9 return;
185             }
186            
187 3         22 $new_content =~ s{ \n }{$newline}xmsg;
188 3         19 _write_file( \%param_of, $new_content );
189            
190 3         25 return;
191             }
192            
193             sub trim_lines {
194 0     0 1   my ($text, $indent) = @_;
195            
196 0 0         if (! $indent) {
197 0           $text =~ s{ \s+ }{ }xmsg;
198 0           $text =~ s{ \A \s+ }{}xms;
199 0           $text =~ s{ \s+ \z }{}xms;
200 0           return $text;
201             }
202 0 0         $indent =~ m{ \A [1-9] \d* \z }xms
203             or confess "Indent $indent is not a positive integer";
204            
205             # measure the first line
206 0           ($indent) = $text =~ m{ \A ( (?: [ ]{$indent} )+ ) }xms;
207 0           $indent = length $indent;
208            
209 0           $text =~ s{ ^ [ ]{$indent} }{}xmsg;
210 0           $text =~ s{ [ ]+ $ }{}xmsg;
211            
212 0           return $text;
213             }
214            
215             # $Id: $
216            
217             1;
218            
219             __END__