File Coverage

blib/lib/Pod/Constant.pm

Criterion	Covered	Total	%
statement	71	72	98.6
branch	24	30	80.0
condition	9	10	90.0
subroutine	11	11	100.0
pod	0	1	0.0
total	115	124	92.7

package Pod::Constant;
our $VERSION = 0.1;
#PODNAME: Pod::Constant
#ABSTRACT: source constants from POD to avoid repetition


use 5.005;
use warnings;
use strict;
use Carp;
use Scalar::Util qw(looks_like_number);
use Text::Balanced qw(extract_delimited);

BEGIN {
    use Pod::Parser;
    our @ISA = qw(Pod::Parser);
};

sub import {
    my $caller = caller;
    my ($class, @args) = @_;
    my $pod_source = $0;

    my $parser = $class->new;
    $parser->{vars} = {};
    $parser->parse_from_file($pod_source, undef);

    my %vars = %{$parser->{vars}};
    my @export = (@args && lc $args[0] eq ':all') ? keys %vars : @args;

    for my $sym (@export) {
        $sym =~ /^[\w\$]/ or croak "Pod::Constant only supports scalar values";
        $sym =~ s/^(\$)//;
        my $sigil = $1 || '$';
        no strict 'refs';
        exists $vars{$sigil.$sym} or croak "No such constant '$sigil$sym' in POD";
        *{$caller . '::' . $sym} = \$vars{$sigil . $sym};
    }

    return;
}

# Pod::Parser hooks
sub textblock {
    my ($self, $block) = @_;
    my $tree = $self->parse_text($block);
    my @children = $tree->children;
    while ( my $item = shift @children ) {
        next unless ref $item && ref $item eq 'Pod::InteriorSequence';
        next unless $item->cmd_name eq 'X';

        my @ichildren = $item->parse_tree->children;
        next unless @ichildren == 1;
        next unless $ichildren[0] =~ /^\s*([\$\@%])?(\w*)\s*=\s*(.*)$/;
        my ($sigil, $var, $trailing) = ($1, $2, $3);
        $sigil ||= '$';
        $sigil eq '$' or croak "Pod::Constant only supports scalar values";
        $var = $sigil . $var;
        $trailing eq '' or croak "X<> tag should not include value";
        my $text = shift @children;
        ref $text eq '' or croak "Invalid POD: X<> followed by another POD construct";
        my $value = '';

        if ( $text =~ /^\s*(['"`])/ ) {
            $value = extract_delimited( $text, $1 );
            $value = substr $value, 1, -1;  # strip quotes
        }
        elsif ($text =~ /^\s*(\S+)/) {
            $value = $1;
            # This is a manual list because [[:punct:]] includes / and _
            $value =~ s/[!?,.:;]+$//;

            # If it looks like a number, strip commas
            my $number = $value;
            $number =~ tr/,//d;
            if (looks_like_number($number)) {
                $value = $number;
            }
        }
        else {
            croak "No value provided for '$var'";
        }

        if ( exists $self->{vars}{$var} ) {
            $self->{vars}{$var} eq $value
                or croak "Variable '$var' specified twice with two different values";
        }
        else {
            $self->{vars}{$var} = $value;
        }
    }
}

1;

__END__