File Coverage

blib/lib/Perl/ToPerl6/Utils/POD.pm
Criterion Covered Total %
statement 111 129 86.0
branch 30 42 71.4
condition n/a
subroutine 28 36 77.7
pod 19 19 100.0
total 188 226 83.1


line stmt bran cond sub pod time code
1             package Perl::ToPerl6::Utils::POD;
2              
3 27     27   7810 use 5.006001;
  27         78  
4 27     27   108 use strict;
  27         37  
  27         547  
5 27     27   104 use warnings;
  27         37  
  27         776  
6              
7 27     27   114 use English qw< -no_match_vars >;
  27         34  
  27         192  
8              
9 27     27   10053 use IO::String ();
  27         2890  
  27         366  
10 27     27   14969 use Pod::PlainText ();
  27         168497  
  27         742  
11 27     27   220 use Pod::Select ();
  27         50  
  27         613  
12              
13             # TODO: non-fatal generic?
14 27     27   550 use Perl::ToPerl6::Exception::Fatal::Generic qw< throw_generic >;
  27         42  
  27         1831  
15 27     27   12768 use Perl::ToPerl6::Exception::IO qw< throw_io >;
  27         61  
  27         640  
16 27     27   1475 use Perl::ToPerl6::Utils qw< :characters >;
  27         46  
  27         1401  
17              
18 27     27   4868 use Exporter 'import';
  27         45  
  27         60009  
19              
20             our $VERSION = '0.03';
21              
22             #-----------------------------------------------------------------------------
23              
24             our @EXPORT_OK = qw(
25             get_pod_file_for_module
26             get_raw_pod_section_from_file
27             get_raw_pod_section_from_filehandle
28             get_raw_pod_section_from_string
29             get_raw_pod_section_for_module
30             get_pod_section_from_file
31             get_pod_section_from_filehandle
32             get_pod_section_from_string
33             get_pod_section_for_module
34             trim_raw_pod_section
35             trim_pod_section
36             get_raw_module_abstract_from_file
37             get_raw_module_abstract_from_filehandle
38             get_raw_module_abstract_from_string
39             get_raw_module_abstract_for_module
40             get_module_abstract_from_file
41             get_module_abstract_from_filehandle
42             get_module_abstract_from_string
43             get_module_abstract_for_module
44             );
45              
46             our %EXPORT_TAGS = (
47             all => \@EXPORT_OK,
48             );
49              
50             #-----------------------------------------------------------------------------
51              
52             sub get_pod_file_for_module {
53 344     344 1 301 my ($module_name) = @_;
54              
55             # No File::Spec: %INC always uses forward slashes.
56 344         1392 (my $relative_path = $module_name) =~ s< :: ></>xmsg;
57 344         547 $relative_path .= '.pm';
58              
59 344 100       1218 my $absolute_path = $INC{$relative_path} or return;
60              
61 343         2354 (my $pod_path = $absolute_path) =~ s< [.] [^.]+ \z><.pod>xms;
62 343 50       8248 return $pod_path if -f $pod_path;
63              
64 343         1066 return $absolute_path;
65             }
66              
67             #-----------------------------------------------------------------------------
68              
69             sub get_raw_pod_section_from_file {
70 0     0 1 0 my ($file_name, $section_name) = @_;
71              
72 0         0 return _get_pod_section_from_file(
73             $file_name,
74             $section_name,
75             Pod::Select->new(),
76             );
77             }
78              
79             #-----------------------------------------------------------------------------
80              
81             sub get_raw_pod_section_from_filehandle {
82 0     0 1 0 my ($file_handle, $section_name) = @_;
83              
84 0         0 return _get_pod_section_from_filehandle(
85             $file_handle,
86             $section_name,
87             Pod::Select->new(),
88             );
89             }
90              
91             #-----------------------------------------------------------------------------
92              
93             sub get_raw_pod_section_from_string {
94 7     7 1 9999 my ($source, $section_name) = @_;
95              
96 7         76 return _get_pod_section_from_string(
97             $source,
98             $section_name,
99             Pod::Select->new(),
100             );
101             }
102              
103             #-----------------------------------------------------------------------------
104              
105             sub get_raw_pod_section_for_module {
106 0     0 1 0 my ($module_name, $section_name) = @_;
107              
108 0 0       0 my $file_name = get_pod_file_for_module($module_name)
109             or throw_generic qq<Could not find POD for "$module_name".>;
110              
111 0         0 return get_raw_pod_section_from_file($file_name, $section_name);
112             }
113              
114             #-----------------------------------------------------------------------------
115              
116             sub get_pod_section_from_file {
117 1     1 1 2 my ($file_name, $section_name) = @_;
118              
119 1         31 return _get_pod_section_from_file(
120             $file_name,
121             $section_name,
122             Pod::PlainText->new(),
123             );
124             }
125              
126             #-----------------------------------------------------------------------------
127              
128             sub get_pod_section_from_filehandle {
129 0     0 1 0 my ($file_handle, $section_name) = @_;
130              
131 0         0 return _get_pod_section_from_filehandle(
132             $file_handle,
133             $section_name,
134             Pod::PlainText->new(),
135             );
136             }
137              
138             #-----------------------------------------------------------------------------
139              
140             sub get_pod_section_from_string {
141 7     7 1 2811 my ($source, $section_name) = @_;
142              
143 7         80 return _get_pod_section_from_string(
144             $source,
145             $section_name,
146             Pod::PlainText->new(),
147             );
148             }
149              
150             #-----------------------------------------------------------------------------
151              
152             sub get_pod_section_for_module {
153 2     2 1 3 my ($module_name, $section_name) = @_;
154              
155 2 100       8 my $file_name = get_pod_file_for_module($module_name)
156             or throw_generic qq<Could not find POD for "$module_name".>;
157              
158 1         4 return get_pod_section_from_file($file_name, $section_name);
159             }
160              
161             #-----------------------------------------------------------------------------
162              
163             sub _get_pod_section_from_file {
164 1     1   33 my ($file_name, $section_name, $parser) = @_;
165              
166 1 50       70 open my $file_handle, '<', $file_name
167             or throw_io
168             message => qq<Could not open "$file_name": $ERRNO>,
169             file_name => $file_name,
170             errno => $ERRNO;
171              
172 1         4 my $content =
173             _get_pod_section_from_filehandle(
174             $file_handle, $section_name, $parser,
175             );
176              
177 1 50       13 close $file_handle
178             or throw_io
179             message => qq<Could not close "$file_name": $ERRNO>,
180             file_name => $file_name,
181             errno => $ERRNO;
182              
183 1         5 return $content;
184             }
185              
186             #-----------------------------------------------------------------------------
187              
188             sub _get_pod_section_from_filehandle {
189 374     374   485 my ($file_handle, $section_name, $parser) = @_;
190              
191 374         2092 $parser->select($section_name);
192              
193 374         82433 my $content = $EMPTY;
194 374         2251 my $content_handle = IO::String->new( \$content );
195              
196 374         143601 $parser->parse_from_filehandle( $file_handle, $content_handle );
197              
198 374 100       376961 return if $content eq $EMPTY;
199 366         939 return $content;
200             }
201              
202             #-----------------------------------------------------------------------------
203              
204             sub _get_pod_section_from_string {
205 14     14   112 my ($source, $section_name, $parser) = @_;
206              
207 14         64 my $source_handle = IO::String->new( \$source );
208              
209             return
210 14         402 _get_pod_section_from_filehandle(
211             $source_handle, $section_name, $parser,
212             );
213             }
214              
215             #-----------------------------------------------------------------------------
216              
217             sub trim_raw_pod_section {
218 11     11 1 1115 my ($pod) = @_;
219              
220 11 50       29 return if not defined $pod;
221              
222 11         44 $pod =~ s< \A =head1 \b [^\n]* \n $ ><>xms;
223 11         29 $pod =~ s< \A \s+ ><>xms;
224 11         40 $pod =~ s< \s+ \z ><>xms;
225              
226 11         15 return $pod;
227             }
228              
229             #-----------------------------------------------------------------------------
230              
231             sub trim_pod_section {
232 353     353 1 1593 my ($pod) = @_;
233              
234 353 50       665 return if not defined $pod;
235              
236 353         1583 $pod =~ s< \A [^\n]* \n ><>xms;
237 353         747 $pod =~ s< \A \s* \n ><>xms;
238 353         1465 $pod =~ s< \s+ \z ><>xms;
239              
240 353         637 return $pod;
241             }
242              
243             #-----------------------------------------------------------------------------
244              
245             sub get_raw_module_abstract_from_file {
246 0     0 1 0 my ($file_name) = @_;
247              
248             return
249 0         0 _get_module_abstract_from_file(
250             $file_name,
251             Pod::Select->new(),
252             \&trim_raw_pod_section,
253             );
254             }
255              
256             #-----------------------------------------------------------------------------
257              
258             sub get_raw_module_abstract_from_filehandle {
259 0     0 1 0 my ($file_handle) = @_;
260              
261             return
262 0         0 _get_module_abstract_from_filehandle(
263             $file_handle,
264             Pod::Select->new(),
265             \&trim_raw_pod_section,
266             );
267             }
268              
269             #-----------------------------------------------------------------------------
270              
271             sub get_raw_module_abstract_from_string {
272 9     9 1 4291 my ($source) = @_;
273              
274             return
275 9         84 _get_module_abstract_from_string(
276             $source,
277             Pod::Select->new(),
278             \&trim_raw_pod_section,
279             );
280             }
281              
282             #-----------------------------------------------------------------------------
283              
284             sub get_raw_module_abstract_for_module {
285 0     0 1 0 my ($module_name) = @_;
286              
287 0 0       0 my $file_name = get_pod_file_for_module($module_name)
288             or throw_generic qq<Could not find POD for "$module_name".>;
289              
290 0         0 return get_raw_module_abstract_from_file($file_name);
291             }
292              
293             #-----------------------------------------------------------------------------
294              
295             sub get_module_abstract_from_file {
296 342     342 1 365 my ($file_name) = @_;
297              
298             return
299 342         3465 _get_module_abstract_from_file(
300             $file_name,
301             Pod::PlainText->new(),
302             \&trim_pod_section,
303             );
304             }
305              
306             #-----------------------------------------------------------------------------
307              
308             sub get_module_abstract_from_filehandle {
309 0     0 1 0 my ($file_handle) = @_;
310              
311             return
312 0         0 _get_module_abstract_from_filehandle(
313             $file_handle,
314             Pod::PlainText->new(),
315             \&trim_pod_section,
316             );
317             }
318              
319             #-----------------------------------------------------------------------------
320              
321             sub get_module_abstract_from_string {
322 8     8 1 3991 my ($source) = @_;
323              
324             return
325 8         85 _get_module_abstract_from_string(
326             $source,
327             Pod::PlainText->new(),
328             \&trim_pod_section,
329             );
330             }
331              
332             #-----------------------------------------------------------------------------
333              
334             sub get_module_abstract_for_module {
335 342     342 1 348 my ($module_name) = @_;
336              
337 342 50       595 my $file_name = get_pod_file_for_module($module_name)
338             or throw_generic qq<Could not find POD for "$module_name".>;
339              
340 342         789 return get_module_abstract_from_file($file_name);
341             }
342              
343             #-----------------------------------------------------------------------------
344              
345             sub _get_module_abstract_from_file {
346 342     342   5909 my ($file_name, $parser, $trimmer) = @_;
347              
348 342 50       13669 open my $file_handle, '<', $file_name
349             or throw_io
350             message => qq<Could not open "$file_name": $ERRNO>,
351             file_name => $file_name,
352             errno => $ERRNO;
353              
354 342         794 my $module_abstract =
355             _get_module_abstract_from_filehandle(
356             $file_handle, $parser, $trimmer,
357             );
358              
359 342 50       3807 close $file_handle
360             or throw_io
361             message => qq<Could not close "$file_name": $ERRNO>,
362             file_name => $file_name,
363             errno => $ERRNO;
364              
365 342         1787 return $module_abstract;
366             }
367              
368             #-----------------------------------------------------------------------------
369              
370             sub _get_module_abstract_from_filehandle {
371 359     359   511 my ($file_handle, $parser, $trimmer) = @_;
372              
373 359         576 my $name_section =
374             _get_pod_section_from_filehandle( $file_handle, 'NAME', $parser );
375 359 100       629 return if not $name_section;
376              
377 357         597 $name_section = $trimmer->($name_section);
378 357 100       631 return if not $name_section;
379              
380             # Testing for parser class, blech. But it's a lot simpler and it's all
381             # hidden in the implementation.
382 355 100       665 if ('Pod::Select' eq ref $parser) {
383 7 100       17 if ( $name_section =~ m< \n >xms ) {
384 1         7 throw_generic
385             qq<Malformed NAME section in "$name_section". >
386             . q<It must be on a single line>;
387             }
388             }
389             else {
390 348         2106 $name_section =~ s< \s+ >< >xmsg;
391              
392             # Ugh. Pod::PlainText splits up module names.
393 348 100       1838 if (
394             $name_section =~ m<
395             \A
396             \s*
397             (
398             \w [ \w:]+ \w
399             )
400             (
401             \s*
402             -
403             .*
404             )?
405             \z
406             >xms
407             ) {
408 347         832 my ($module_name, $rest) = ($1, $2);
409              
410 347         452 $module_name =~ s/ [ ] //xms;
411              
412 347 100       793 $name_section = $module_name . ( $rest ? $rest : $EMPTY );
413             }
414             }
415              
416 354 100       1588 if (
417             $name_section =~ m<
418             \A
419             \s*
420             [\w:]+ # Module name.
421             \s+
422             - # The required single hyphen.
423             \s+
424             (
425             \S # At least one non-whitespace.
426             (?: .* \S)? # Everything up to the last non-whitespace.
427             )
428             \s*
429             \z
430             >xms
431             ) {
432 337         526 my $module_abstract = $1;
433 337         627 return $module_abstract;
434             }
435              
436 17 100       91 if (
437             $name_section =~ m<
438             \A
439             \s*
440             [\w:]+ # Module name.
441             (?: \s* - )? # The single hyphen is now optional.
442             \s*
443             \z
444             >xms
445             ) {
446 13         28 return;
447             }
448              
449 4         18 throw_generic qq<Malformed NAME section in "$name_section".>;
450             }
451              
452             #-----------------------------------------------------------------------------
453              
454             sub _get_module_abstract_from_string {
455 17     17   151 my ($source, $parser, $trimmer) = @_;
456              
457 17         66 my $source_handle = IO::String->new( \$source );
458              
459             return
460 17         488 _get_module_abstract_from_filehandle(
461             $source_handle, $parser, $trimmer,
462             );
463             }
464              
465             #-----------------------------------------------------------------------------
466              
467             1;
468              
469             __END__
470              
471             #-----------------------------------------------------------------------------
472              
473             =pod
474              
475             =for stopwords
476              
477             =head1 NAME
478              
479             Perl::ToPerl6::Utils::POD - Utility functions for dealing with POD.
480              
481              
482             =head1 SYNOPSIS
483              
484             use Perl::ToPerl6::Utils::POD qw< get_pod_section_from_file >;
485              
486             my $synopsis =
487             get_pod_section_from_file('Perl/ToPerl6/Utils/POD.pm', 'SYNOPSIS');
488              
489             my $see_also =
490             get_pod_section_from_filehandle($file_handle, 'SEE ALSO');
491              
492              
493             my $see_also_content = trim_pod_section($see_also);
494              
495              
496             # "Utility functions for dealing with POD."
497             my $module_abstract =
498             get_module_abstract_from_file('Perl/ToPerl6/Utils/POD.pm');
499              
500             my $module_abstract =
501             get_module_abstract_from_filehandle($file_handle);
502              
503              
504             =head1 DESCRIPTION
505              
506             Provides means of accessing chunks of POD.
507              
508              
509             =head1 INTERFACE SUPPORT
510              
511             This is considered to be a public module. Any changes to its
512             interface will go through a deprecation cycle.
513              
514              
515             =head1 IMPORTABLE SUBROUTINES
516              
517             =over
518              
519             =item C<get_pod_file_for_module( $module_name )>
520              
521             Figure out where to find the POD for the parameter.
522              
523             This depends upon the module already being loaded; it will not find
524             the path for arbitrary modules.
525              
526             If there is a file with a ".pod" extension next to the real module
527             location, it will be returned in preference to the actual module.
528              
529              
530             =item C<get_raw_pod_section_from_file( $file_name, $section_name )>
531              
532             Retrieves the specified section of POD (i.e. something marked by
533             C<=head1>) from the file. This is uninterpreted; escapes are not
534             processed and any sub-sections will be present. E.g. if the content
535             contains "CZ<><$x>", the return value will contain "CZ<><$x>".
536              
537             Returns nothing if no such section is found.
538              
539             Throws a L<Perl::ToPerl6::Exception::IO|Perl::ToPerl6::Exception::IO> if
540             there's a problem with the file.
541              
542              
543             =item C<get_raw_pod_section_from_filehandle( $file_handle, $section_name )>
544              
545             Does the same as C<get_raw_pod_section_from_file()>, but with a file
546             handle.
547              
548              
549             =item C<get_raw_pod_section_from_string( $source, $section_name )>
550              
551             Does the same as C<get_raw_pod_section_from_file()>, but with a string
552             that contains the raw POD.
553              
554              
555             =item C<get_raw_pod_section_for_module( $module_name, $section_name )>
556              
557             Does the same as C<get_raw_pod_section_from_file()>, but with a module
558             name.
559              
560             Throws a
561             L<Perl::ToPerl6::Exception::Generic|Perl::ToPerl6::Exception::Generic>
562             if a file containing POD for the module can't be found.
563              
564              
565             =item C<get_pod_section_from_file( $file_name, $section_name )>
566              
567             Retrieves the specified section of POD (i.e. something marked by
568             C<=head1>) from the file. This is interpreted into plain text.
569              
570             Returns nothing if no such section is found.
571              
572             Throws a L<Perl::ToPerl6::Exception::IO|Perl::ToPerl6::Exception::IO> if
573             there's a problem with the file.
574              
575              
576             =item C<get_pod_section_from_filehandle( $file_handle, $section_name )>
577              
578             Does the same as C<get_pod_section_from_file()>, but with a file
579             handle.
580              
581              
582             =item C<get_pod_section_from_string( $source, $section_name )>
583              
584             Does the same as C<get_pod_section_from_file()>, but with a string
585             that contains the raw POD.
586              
587              
588             =item C<get_pod_section_for_module( $module_name, $section_name )>
589              
590             Does the same as C<get_pod_section_from_file()>, but with a module
591             name.
592              
593             Throws a
594             L<Perl::ToPerl6::Exception::Generic|Perl::ToPerl6::Exception::Generic>
595             if a file containing POD for the module can't be found.
596              
597              
598             =item C<trim_raw_pod_section( $pod_section )>
599              
600             Returns a copy of the parameter, with any starting C<=item1 BLAH>
601             removed and all leading and trailing whitespace (including newlines)
602             removed after that.
603              
604             For example, using one of the C<get_raw_pod_section_from_*> functions
605             to get the "NAME" section of this module and then calling
606             C<trim_raw_pod_section()> on the result would give you
607             "Perl::ToPerl6::Utils::POD - Utility functions for dealing with POD.".
608              
609              
610             =item C<trim_pod_section( $pod_section )>
611              
612             Returns a copy of the parameter, with any starting line removed and
613             leading blank lines and trailing whitespace (including newlines)
614             removed after that. Note that only leading whitespace on the first
615             real line of the section will remain.
616              
617             Since this cannot count upon a C<=item1> marker, this is much less
618             reliable than C<trim_raw_pod_section()>.
619              
620              
621             =item C<get_raw_module_abstract_from_file( $file_name )>
622              
623             Attempts to parse the "NAME" section of the specified file and get the
624             abstract of the module from that. If it succeeds, it returns the
625             abstract. If it fails, either because there is no "NAME" section or
626             there is no abstract after the module name, returns nothing. If it
627             looks like there's a malformed abstract, throws a
628             L<Perl::ToPerl6::Exception::Fatal::Generic|Perl::ToPerl6::Exception::Fatal::Generic>.
629              
630             Example "well formed" "NAME" sections without abstracts:
631              
632             Some::Module
633              
634             Some::Other::Module -
635              
636             Example "NAME" sections that will result in an exception:
637              
638             Some::Bad::Module This has no hyphen.
639              
640             Some::Mean::Module -- This has double hyphens.
641              
642             Some::Nasty::Module - This one attempts to
643             span multiple lines.
644              
645              
646             =item C<get_raw_module_abstract_from_filehandle( $file_handle )>
647              
648             Does the same as C<get_raw_module_abstract_from_file()>, but with a
649             file handle.
650              
651              
652             =item C<get_raw_module_abstract_from_string( $source )>
653              
654             Does the same as C<get_raw_module_abstract_from_file()>, but with a
655             string that contains the raw POD.
656              
657              
658             =item C<get_raw_module_abstract_for_module( $module_name )>
659              
660             Does the same as C<get_raw_module_abstract_from_file()>, but for a
661             module name.
662              
663              
664             =item C<get_module_abstract_from_file( $file_name )>
665              
666             Does the same as C<get_raw_module_abstract_from_file()>, but with
667             escapes interpreted.
668              
669              
670             =item C<get_module_abstract_from_filehandle( $file_handle )>
671              
672             Does the same as C<get_module_abstract_from_file()>, but with a file
673             handle.
674              
675              
676             =item C<get_module_abstract_from_string( $source )>
677              
678             Does the same as C<get_module_abstract_from_file()>, but with a string
679             that contains the raw POD.
680              
681              
682             =item C<get_module_abstract_for_module( $module_name )>
683              
684             Does the same as C<get_module_abstract_from_file()>, but for a module
685             name.
686              
687              
688             =back
689              
690              
691             =head1 AUTHOR
692              
693             Elliot Shank <perl@galumph.com>
694              
695              
696             =head1 COPYRIGHT
697              
698             Copyright (c) 2008-2011 Elliot Shank.
699              
700             This program is free software; you can redistribute it and/or modify
701             it under the same terms as Perl itself. The full text of this license
702             can be found in the LICENSE file included with this module.
703              
704             =cut
705              
706             # Local Variables:
707             # mode: cperl
708             # cperl-indent-level: 4
709             # fill-column: 78
710             # indent-tabs-mode: nil
711             # c-indentation-style: bsd
712             # End:
713             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :