lib/Module/Build/PodParser.pm

   1 package Module::Build::PodParser;
   2
   3 use strict;
   4 use vars qw(@ISA);
   5
   6 sub new {
   7   # Perl is so fun.
   8   my $package = shift;
   9
  10   my $self;
  11
  12   # Try using Pod::Parser first
  13   if (eval{ require Pod::Parser; 1; }) {
  14     @ISA = qw(Pod::Parser);
  15     $self = $package->SUPER::new(@_);
  16     $self->{have_pod_parser} = 1;
  17   } else {
  18     @ISA = ();
  19     *parse_from_filehandle = \&_myparse_from_filehandle;
  20     $self = bless {have_pod_parser => 0, @_}, $package;
  21   }
  22
  23   unless ($self->{fh}) {
  24     die "No 'file' or 'fh' parameter given" unless $self->{file};
  25     $self->{fh} = IO::File->new($self->{file}) or die "Couldn't open $self->{file}: $!";
  26   }
  27
  28   return $self;
  29 }
  30
  31 sub _myparse_from_filehandle {
  32   my ($self, $fh) = @_;
  33
  34   local $_;
  35   while (<$fh>) {
  36     next unless /^=(?!cut)/ .. /^=cut/;  # in POD
  37     last if ($self->{abstract}) = /^  (?:  [a-z:]+  \s+ - \s+  )  (.*\S)  /ix;
  38   }
  39
  40   my @author;
  41   while (<$fh>) {
  42     next unless /^=head1\s+AUTHORS?/ ... /^=/;
  43     next if /^=/;
  44     push @author, $_ if /\@/;
  45   }
  46   return unless @author;
  47   s/^\s+|\s+$//g foreach @author;
  48
  49   $self->{author} = \@author;
  50
  51   return;
  52 }
  53
  54 sub get_abstract {
  55   my $self = shift;
  56   return $self->{abstract} if defined $self->{abstract};
  57
  58   $self->parse_from_filehandle($self->{fh});
  59
  60   return $self->{abstract};
  61 }
  62
  63 sub get_author {
  64   my $self = shift;
  65   return $self->{author} if defined $self->{author};
  66
  67   $self->parse_from_filehandle($self->{fh});
  68
  69   return $self->{author} || [];
  70 }
  71
  72 ################## Pod::Parser overrides ###########
  73 sub initialize {
  74   my $self = shift;
  75   $self->{_head} = '';
  76   $self->SUPER::initialize();
  77 }
  78
  79 sub command {
  80   my ($self, $cmd, $text) = @_;
  81   if ( $cmd eq 'head1' ) {
  82     $text =~ s/^\s+//;
  83     $text =~ s/\s+$//;
  84     $self->{_head} = $text;
  85   }
  86 }
  87
  88 sub textblock {
  89   my ($self, $text) = @_;
  90   $text =~ s/^\s+//;
  91   $text =~ s/\s+$//;
  92   if ($self->{_head} eq 'NAME') {
  93     my ($name, $abstract) = split( /\s+-\s+/, $text, 2 );
  94     $self->{abstract} = $abstract;
  95   } elsif ($self->{_head} =~ /^AUTHORS?$/) {
  96     push @{$self->{author}}, $text if $text =~ /\@/;
  97   }
  98 }
  99
 100 sub verbatim {}
 101 sub interior_sequence {}
 102
 103 1;