File Coverage

lib/Pod/Tidy.pm
Criterion Covered Total %
statement 126 134 94.0
branch 40 58 68.9
condition 11 19 57.8
subroutine 20 20 100.0
pod 7 7 100.0
total 204 238 85.7


line stmt bran cond sub pod time code
1             # Copyright (C) 2005 Joshua Hoblitt
2             #
3             # $Id: Tidy.pm,v 1.27 2009/02/17 21:49:37 jhoblitt Exp $
4              
5             package Pod::Tidy;
6              
7 9     9   844521 use strict;
  9         22  
  9         571  
8 9     9   56 use warnings FATAL => qw( all );
  9         17  
  9         521  
9              
10 9     9   50 use vars qw( $VERSION $columns );
  9         21  
  9         925  
11             $VERSION = '0.10';
12              
13 9     9   50 use Fcntl ':flock';
  9         16  
  9         1907  
14 9     9   57 use File::Basename qw( basename dirname );
  9         17  
  9         1288  
15 9     9   51 use File::Spec;
  9         20  
  9         309  
16 9     9   15693 use IO::String;
  9         41800  
  9         412  
17 9     9   11432 use File::Copy qw( cp );
  9         54713  
  9         1421  
18 9     9   86 use Pod::Find qw( contains_pod );
  9         21  
  9         579  
19 9     9   16810 use Pod::Simple;
  9         606472  
  9         822  
20 9     9   16473 use Pod::Wrap::Pretty;
  9         40  
  9         775  
21 9     9   145 use Text::Wrap qw($columns);
  9         19  
  9         2160  
22              
23             # Text::Wrap's default is 76, we are using 80 to maintain compatability with
24             # Pod::Tidy <= 0.09
25             $columns = 80;
26              
27 9     9   123 use vars qw( $BACKUP_POSTFIX);
  9         17  
  9         16161  
28             # used by backup_file
29             $BACKUP_POSTFIX = "~";
30              
31             sub tidy_files
32             {
33 7     7 1 20726 my %p = @_;
34              
35 7 50       32 $columns = $p{columns} if $p{columns};
36              
37 7         48 my $queue = build_pod_queue(
38             files => $p{files},
39             ignore => $p{ignore},
40             recursive => $p{recursive},
41             verbose => $p{verbose},
42             );
43              
44 7 100       43 return undef unless $queue;
45              
46 4         27 return process_pod_queue(
47             inplace => $p{inplace},
48             nobackup => $p{nobackup},
49             queue => $queue,
50             );
51             }
52              
53             sub tidy_filehandle
54             {
55 2     2 1 9852 my $input = shift;
56              
57 2 100       16 return undef unless $input;
58              
59 1         46 my $wrapper = Pod::Wrap::Pretty->new;
60 1         18 $wrapper->parse_from_filehandle($input);
61              
62 1         104 return 1;
63             }
64              
65             sub process_pod_queue
66             {
67 10     10 1 18057 my %p = @_;
68              
69 10         27 my $verbose = $p{verbose};
70 10         20 my $inplace = $p{inplace};
71 10         23 my $queue = $p{queue};
72 10         21 my $nobackup = $p{nobackup};
73              
74 10 100       77 return undef unless defined $queue;
75              
76             # count the number of files processed
77 8         15 my $processed = 0;
78 8         192 my $wrapper = Pod::Wrap::Pretty->new;
79              
80 8         18 foreach my $filename (@{ $queue }) {
  8         22  
81             # all files in queue should have already been checked to be readable
82 7 50 0     375 open(my $src, '+<', $filename) or warn "can't open file: $!" && next;
83              
84             # wait for an exclusive lock in case we want to modify the file
85 7         64 flock($src, LOCK_EX);
86              
87             # slurp the file into memory to avoid making a tmp file
88 7         13 my $doc = do { local $/; <$src> };
  7         31  
  7         229  
89              
90             # wrap the doc with a file handle
91 7         73 my $input = IO::String->new($doc);
92              
93             # modify in place?
94 7 100       353 if ($inplace) {
95 2         13 my $output = IO::String->new;
96 2         308 $wrapper->parse_from_filehandle($input, $output);
97              
98             # leave the mtime alone if we didn't change anything
99 2 50       107 next if ${$input->string_ref} eq ${$output->string_ref};
  2         10  
  2         13  
100              
101             # backup existing file
102 2 100       17 unless ($nobackup) {
103 1         5 backup_file($filename);
104             }
105              
106             # overwrite the original file
107 2         894 truncate($src, 0);
108 2         16 seek($src, 0, 0);
109 2         3 print $src ${$output->string_ref};
  2         11  
110             } else {
111             # send the output to STDOUT
112 5         374 $wrapper->parse_from_filehandle($input);
113             }
114              
115             # count of files actually processed
116             # note that this number will be different for 'inplace' as unmodified
117             # files will not be counted
118 7         552 $processed++;
119             }
120              
121 8         72 return $processed;
122             }
123              
124             sub build_pod_queue
125             {
126 24     24 1 20067 my %p = @_;
127              
128             # deref once
129 24         53 my $verbose = $p{verbose};
130 24         49 my $recursive = $p{recursive};
131 24         43 my $ignore = $p{ignore};
132              
133 24         30 my @queue;
134 24         31 PERITEM: foreach my $item (@{ $p{files} }) {
  24         66  
135             # FIXME do we need to add symlink handling options?
136 33         193 $item = File::Spec->canonpath($item);
137              
138 33         54 foreach my $pattern (@{ $ignore }) {
  33         66  
139             # try the absolute path, then the relative path, then the 'base'
140             # path
141 26 50 66     497 if (
      66        
142             (File::Spec->rel2abs($item) =~ $pattern)
143             or ($item =~ $pattern)
144             or (base($item) =~ $pattern)
145             ) {
146 6 50       18 warn "$0: omitting file \`$item\': matches ignore pattern: "
147             . "$pattern\n" if $verbose;
148 6         22 next PERITEM;
149             }
150             }
151            
152             # is it a file?
153 27 100       611 if (-f $item) {
154             # only check if we can read the file, we don't need to be able to
155             # write to it unless we're doing an inplace edit
156 16 50       311 unless (-r $item) {
157 0         0 warn "$0: omitting file \`$item\': permission denied\n";
158 0         0 next;
159             }
160              
161 16 50       1619 unless (contains_pod($item, 0)) {
162 0 0       0 warn "$0: omitting file \`$item\': does not contain Pod\n"
163             if $verbose;
164 0         0 next;
165             }
166              
167 16 100       49 unless (valid_pod_syntax($item, $verbose)) {
168 8 50       130 warn "$0: omitting file \`$item\': bad Pod syntax\n"
169             if $verbose;
170 8         22 next;
171             }
172              
173 8         124 push @queue, $item;
174              
175 8         18 next;
176             }
177              
178             # is it a dir?
179 11 50       211 if (-d $item) {
180 11 50 33     438 unless (-r $item and -x $item) {
181 0         0 warn "$0: omitting file \`$item\': permission denied\n";
182 0         0 next;
183             }
184              
185             # is recursion allowed?
186 11 100       31 if ($recursive) {
187             # It may be better to use File::Find or Pod::Find here.
188             # Initialiy I was using Pod::Find but I wanted explict control
189             # over warnings.
190 9 50 0     433 opendir(my $dir, $item) or warn "can't open dir: $!" && next;
191 9         354 my @files = grep !/^\.{1,2}$/, readdir($dir);
192 9         26 @files = map { "$item/$_" } @files;
  20         63  
193 9         63 my $pod_list = build_pod_queue(
194             files => \@files,
195             verbose => $verbose,
196             recursive => $recursive,
197             ignore => $ignore,
198             );
199 9 100       70 push(@queue, @{ $pod_list }) if $pod_list;
  6         152  
200             } else {
201             # ignoring $item, recursion not enabled
202 2 50       11 warn "$0: omitting direcotry \`$item\': recursion is not enabled\n"
203             if $verbose;
204             }
205 11         38 next;
206             }
207              
208             # it must be bogus
209 0 0       0 warn "$0: \`$item\': no such file or directory\n" if $verbose;
210             }
211              
212 24 100       133 return scalar @queue ? \@queue : undef;
213             }
214              
215             sub valid_pod_syntax
216             {
217 20     20 1 4271 my ($filename, $verbose) = @_;
218              
219 20 100 100     556 return undef unless defined $filename and -e $filename;
220              
221             # method for checking syntax stolen from Test::Pod
222 18         312 my $parser = Pod::Simple->new;
223              
224 18 50       642 $parser->complain_stderr(1) if $verbose;
225 18         82 $parser->parse_file($filename);
226              
227 18 100       33864 return $parser->any_errata_seen ? undef : 1;
228             }
229              
230             sub backup_file
231             {
232 4     4 1 3717 my $filename = shift;
233              
234 4 100 100     109 return undef unless defined $filename and -e $filename;
235 2         17 return cp($filename, $filename . $BACKUP_POSTFIX);
236             }
237              
238             sub base
239             {
240 20     20 1 33 my $path = shift;
241              
242 20 50       692 if (my $base = basename($path)) {
243 20         135 return $base;
244             } else {
245 0           return basename(dirname($path));
246             }
247             }
248              
249             1;
250              
251             __END__