File Coverage

blib/lib/Pod/POM.pm

Criterion	Covered	Total	%
statement	174	221	78.7
branch	69	110	62.7
condition	11	24	45.8
subroutine	15	18	83.3
pod	4	11	36.3
total	273	384	71.0

#============================================================= -*-Perl-*-
#
# Pod::POM
#
# DESCRIPTION
#   Parses POD from a file or text string and builds a tree structure,
#   hereafter known as the POD Object Model (POM).
#
# AUTHOR
#   Andy Wardley
#
#   Andrew Ford     (co-maintainer as of 03/2009)
#
# COPYRIGHT
#   Copyright (C) 2000-2009 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 2009 Andrew Ford.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# REVISION
#   $Id: POM.pm 91 2013-12-31 07:36:02Z ford $
#
#========================================================================

package Pod::POM;
$Pod::POM::VERSION = '2.00';
require 5.006;

use strict;
use warnings;

use Pod::POM::Constants qw( :all );
use Pod::POM::Nodes;
use Pod::POM::View::Pod;

use parent qw( Exporter );

our $DEBUG   = 0 unless defined $DEBUG;
our $ROOT    = 'Pod::POM::Node::Pod';               # root node class
our $TEXTSEQ = 'Pod::POM::Node::Sequence';          # text sequence class
our $DEFAULT_VIEW = 'Pod::POM::View::Pod';          # default view class


#------------------------------------------------------------------------
# allow 'meta' to be specified as a load option to activate =meta tags
#------------------------------------------------------------------------

our @EXPORT_OK   = qw( meta );
our @EXPORT_FAIL = qw( meta );
our $ALLOW_META  = 0;

sub export_fail {
    my $class = shift;
    my $meta  = shift;
    return ($meta, @_) unless $meta eq 'meta';
    $ALLOW_META++;
    return @_;
}



#------------------------------------------------------------------------
# new(\%options)
#------------------------------------------------------------------------

sub new {
    my $class  = shift;
    my $config = ref $_[0] eq 'HASH' ? shift : { @_ };

    bless {
	CODE     => $config->{ code } || 0,
        WARN     => $config->{ warn } || 0,
	META     => $config->{ meta } || $ALLOW_META,
	WARNINGS => [ ],
	FILENAME => '',
	ERROR    => '',
    }, $class;
}


#------------------------------------------------------------------------
# parse($text_or_file)
#
# General purpose parse method which attempts to Do The Right Thing in
# calling parse_file() or parse_text() according to the argument
# passed.  A hash reference can be specified that contains a 'text'
# or 'file' key and corresponding value.  Otherwise, the argument can
# be a reference to an input handle which is passed off to parse_file().
# If the argument is a text string that contains '=' at the start of
# any line then it is treated as Pod text and passed to parse_text(),
# otherwise it is assumed to be a filename and passed to parse_file().
#------------------------------------------------------------------------

sub parse {
    my ($self, $input) = @_;
    my $result;

    if (ref $input eq 'HASH') {
	if ($input = $input->{ text }) {
	    $result = $self->parse_text($input, $input->{ name });
	}
	elsif ($input = $input->{ file }) {
	    $result = $self->parse_file($input);
	}
	else {
	    $result = $self->error("no 'text' or 'file' specified");
	}
    }
    elsif (ref $input || $input !~ /^=/m) {	# doesn't look like POD text
	$result = $self->parse_file($input);
    }
    else {					# looks like POD text
	$result = $self->parse_text($input);
    }

    return $result;
}


#------------------------------------------------------------------------
# parse_file($filename_or_handle)
#
# Reads the content of a Pod file specified by name or file handle, and
# passes it to parse_text() for parsing.
#------------------------------------------------------------------------

sub parse_file {
    my ($self, $file) = @_;
    my ($text, $name);

    if (ref $file) {		# assume open filehandle
	local $/ = undef;
	$name = '';
	$text = <$file>;
    }
    else {			# a file which must be opened
	local *FP;
	local $/ = undef;
	$name = ( $file eq '-' ? '' : $file );
	open(FP, $file) || return $self->error("$file: $!");
	$text = ;
	close(FP);
    }

    $self->parse_text($text, $name);
}


#------------------------------------------------------------------------
# parse_text($text, $name)
#
# Main parser method.  Scans the input text for Pod sections and splits
# them into paragraphs.  Builds a tree of Pod::POM::Node::* objects
# to represent the Pod document in object model form.
#------------------------------------------------------------------------

sub parse_text {
    my ($self, $text, $name) = @_;
    my ($para, $paralen, $gap, $type, $line, $inpod, $code, $result, $verbatim);
    my $warn = $self->{ WARNINGS } = [ ];

    my @stack = ( );
    my $item = $ROOT->new($self);
    return $self->error($ROOT->error())
	unless defined $item;
    push(@stack, $item);

    $name = '' unless defined $name;
    $self->{ FILENAME } = $name;

    $code   =  $self->{ CODE };
    $line   = \$self->{ LINE };
    $$line  = 1;
    $inpod  = 0;

    my @encchunks = split /^(=encoding.*)/m, $text;
    $text = shift @encchunks;
    while (@encchunks) {
        my($encline,$chunk) = splice @encchunks, 0, 2;
        require Encode;
        my($encoding) = $encline =~ /^=encoding\s+(\S+)/;
        if ($encoding ne 'utf8' || !Encode::is_utf8($chunk)) {
	        Encode::from_to($chunk, $encoding, "utf8");
	    }
        Encode::_utf8_on($chunk);
        # $text .= "xxx$encline";
        $text .= $chunk;
    }

# patch from JJ
#    while ($text =~ /(?:(.*?)(\n{2,}))|(.+$)/sg) {
    while ($text =~ /(?:(.*?)((?:\s*\n){2,}))|(.+$)/sg) {
	($para, $gap) = defined $1 ? ($1, $2) : ($3, '');

	if ($para =~ s/^==?(\w+)\s*//) {
	    $type = $1;
	    # switch on for =pod or any other =cmd, switch off for =cut
	    if    ($type eq 'pod') { $inpod = 1; next }
	    elsif ($type eq 'cut') { $inpod = 0; next }
	    else                   { $inpod = 1 };

	    if ($type eq 'meta') {
		$self->{ META }
		    ? $stack[0]->metadata(split(/\s+/, $para, 2))
		    : $self->warning("metadata not allowed", $name, $$line);
		next;
	    }
	}
	elsif (! $inpod) {
	    next unless $code;
	    $type  = 'code';
	    $para .= $gap;
	    $gap   = '';
	}
	elsif ($para =~ /^\s+/) {
            $verbatim .= $para;
            $verbatim .= $gap;
            next;
	}
	else {
	    $type = 'text';
	    chomp($para);	    # catches last line in file
	}

        if ($verbatim) {
    	    while(@stack) {
                $verbatim =~ s/\s+$//s;
       	        $result = $stack[-1]->add($self, 'verbatim', $verbatim);

	        if (! defined $result) {
                    $self->warning($stack[-1]->error(), $name, $$line);
                    undef $verbatim;
		    last;
	        }
	        elsif (ref $result) {
                    push(@stack, $result);
                    undef $verbatim;
		    last;
	        }
	        elsif ($result == REDUCE) {
                    pop @stack;
                    undef $verbatim;
		    last;
	        }
	        elsif ($result == REJECT) {
                    $self->warning($stack[-1]->error(), $name, $$line);
		    pop @stack;
	        }
	        elsif (@stack == 1) {
                    $self->warning("unexpected $type", $name, $$line);
                    undef $verbatim;
		    last;
	        }
	        else {
                    pop @stack;
	        }
	    }
        }

	while(@stack) {
	    $result = $stack[-1]->add($self, $type, $para);

	    if (! defined $result) {
		$self->warning($stack[-1]->error(), $name, $$line);
		last;
	    }
	    elsif (ref $result) {
		push(@stack, $result);
		last;
	    }
	    elsif ($result == REDUCE) {
		pop @stack;
		last;
	    }
	    elsif ($result == REJECT) {
		$self->warning($stack[-1]->error(), $name, $$line);
		pop @stack;
	    }
	    elsif (@stack == 1) {
		$self->warning("unexpected $type", $name, $$line);
		last;
	    }
	    else {
		pop @stack;
	    }
	}
    }
    continue {
	$$line += ($para =~ tr/\n//);
	$$line += ($gap  =~ tr/\n//);
    }

    if ($verbatim) {
	while(@stack) {
            $verbatim =~ s/\s+$//s;
	    $result = $stack[-1]->add($self, 'verbatim', $verbatim);

	    if (! defined $result) {
		$self->warning($stack[-1]->error(), $name, $$line);
                undef $verbatim;
		last;
	    }
	    elsif (ref $result) {
		push(@stack, $result);
                undef $verbatim;
		last;
	    }
	    elsif ($result == REDUCE) {
		pop @stack;
                undef $verbatim;
		last;
	    }
	    elsif ($result == REJECT) {
		$self->warning($stack[-1]->error(), $name, $$line);
		pop @stack;
	    }
	    elsif (@stack == 1) {
		$self->warning("unexpected $type", $name, $$line);
                undef $verbatim;
		last;
	    }
	    else {
		pop @stack;
	    }
	}
    }

    return $stack[0];
}


#------------------------------------------------------------------------
# parse_sequence($text)
#
# Parse a text paragraph to identify internal sequences (e.g. B)
# which may be nested within each other.  Returns a simple scalar (no
# embedded sequences) or a reference to a Pod::POM::Text object.
#------------------------------------------------------------------------

sub parse_sequence {
    my ($self, $text) = @_;
    my ($cmd, $lparen, $rparen, $plain);
    my ($name, $line, $warn) = @$self{ qw( FILENAME LINE WARNINGS ) };
    my @stack;

    push(@stack, [ '', '', 'EOF', $name, $line, [ ] ] );

    while ($text =~ /
                      (?: ([A-Z]) (< (?:<+\s)?) )	  # open
		    | ( (?:\s>+)? > )			  # or close
		    | (?: (.+?)				  # or text...
			    (?=				  # ...up to
				(?: [A-Z]< )              #   open
			      | (?: (?: \s>+)? > )        #   or close
                              | $                         #   or EOF
                            )
                      )
	   /gxs) {
	if (defined $1) {
	    ($cmd, $lparen) = ($1, $2);
	    $lparen =~ s/\s$//;
	    ($rparen = $lparen) =~ tr//;
	    push(@stack, [ $cmd, $lparen, $rparen, $name, $line, [ ] ]);
	}
	elsif (defined $3) {
	    $rparen = $3;
	    $rparen =~ s/^\s+//;
	    if ($rparen eq $stack[-1]->[RPAREN]) {
		$cmd = $TEXTSEQ->new(pop(@stack))
		    || return $self->error($TEXTSEQ->error());
		push(@{ $stack[-1]->[CONTENT] }, $cmd);
	    }
	    else {
		$self->warning((scalar @stack > 1
			      ? "expected '$stack[-1]->[RPAREN]' not '$rparen'"
			      : "spurious '$rparen'"), $name, $line);
		push(@{ $stack[-1]->[CONTENT] }, $rparen);
	    }
	}
	elsif (defined $4) {
	    $plain = $4;
	    push(@{ $stack[-1]->[CONTENT] }, $plain);
	    $line += ($plain =~ tr/\n//);
	}
	else {
	    $self->warning("unexpected end of input", $name, $line);
	    last;
	}
    }

    while (@stack > 1) {
	$cmd = pop @stack;
	$self->warning("unterminated '$cmd->[CMD]$cmd->[LPAREN]' starting",
		       $name, $cmd->[LINE]);
	$cmd = $TEXTSEQ->new($cmd)
	    || $self->error($TEXTSEQ->error());
	push(@{ $stack[-1]->[CONTENT] }, $cmd);
    }

    return $TEXTSEQ->new(pop(@stack))
	|| $self->error($TEXTSEQ->error());
}


#------------------------------------------------------------------------
# default_view($viewer)
#
# Accessor method to return or update the $DEFVIEW package variable,
# loading the module for any package name specified.
#------------------------------------------------------------------------

sub default_view {
    my ($self, $viewer) = @_;
    return $DEFAULT_VIEW unless $viewer;
    unless (ref $viewer) {
	my $file = $viewer;
	$file =~ s[::][/]g;
	$file .= '.pm';
	eval { require $file };
	return $self->error($@) if $@;
    }

    return ($DEFAULT_VIEW = $viewer);
}


#------------------------------------------------------------------------
# warning($msg, $file, $line)
#
# Appends a string of the form " at $file line $line" to $msg if
# $file is specified and then stores $msg in the internals
# WARNINGS list.  If the WARN option is set then the warning is
# raised, either via warn(), or by dispatching to a subroutine
# when WARN is defined as such.
#------------------------------------------------------------------------

sub warning {
    my ($self, $msg, $file, $line) = @_;
    my $warn = $self->{ WARN };
    $line = 'unknown' unless defined $line && length $line;
    $msg .= " at $file line $line" if $file;

    push(@{ $self->{ WARNINGS } }, $msg);

    if (ref $warn eq 'CODE') {
	&$warn($msg);
    }
    elsif ($warn) {
	warn($msg, "\n");
    }
}


#------------------------------------------------------------------------
# warnings()
#
# Returns a reference to the (possibly empty) list of warnings raised by
# the most recent call to any of the parse_XXX() methods
#------------------------------------------------------------------------

sub warnings {
    my $self = shift;
    return wantarray ? @{ $self->{ WARNINGS } } : $self->{ WARNINGS };
}


#------------------------------------------------------------------------
# error($msg)
#
# Sets the internal ERROR member and returns undef when called with an
# argument(s), returns the current value when called without.
#------------------------------------------------------------------------

sub error {
    my $self = shift;
    my $errvar;

    {
	no strict qw( refs );
	if (ref $self) {
	    $errvar = \$self->{ ERROR };
	}
	else {
	    $errvar = \${"$self\::ERROR"};
	}
    }
    if (@_) {
	$$errvar = ref($_[0]) ? shift : join('', @_);
	return undef;
    }
    else {
	return $$errvar;
    }
}



sub DEBUG {
    print STDERR "DEBUG: ", @_ if $DEBUG;
}

1;

__END__