vcs.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Utils/POD.pm

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