File Coverage

blib/lib/Pod/ROBODoc.pm

Criterion	Covered	Total	%
statement	98	101	97.0
branch	26	34	76.4
condition	9	15	60.0
subroutine	12	12	100.0
pod	3	3	100.0
total	148	165	89.7

package Pod::ROBODoc;

use strict;
use warnings;

our $VERSION = '0.3';

use Carp;
use IO::File;
use IO::String;
use Params::Validate qw( :all );

my $EMPTY = q{};
my $RD_BEGIN_MARK = qr{
    ^ [*]{4}  # starts with 4 asterisks
    i?        # optional "internal" flag
    ([a-z*])  # header type
    [*]       # ends with an asterisk
    [ ]*      # optional trailing whitespace
    (.*)      # optional item name
}ox;
my $RD_END_MARK = qr{ \A [*]{4} \s* \z }ox;
my %RD_HEADERS  = (
    c    => 'Class',
    d    => 'Constant',
    f    => 'Function',
    h    => 'Module',
    m    => 'Method',
    s    => 'Structure',
    t    => 'Type',
    u    => 'Unit Test',
    v    => 'Variable',
    q{*} => $EMPTY,
);

my @RD_TAGS = (
    'NAME',          'COPYRIGHT',      'SYNOPSIS',    'USAGE',
    'FUNCTION',      'DESCRIPTION',    'PURPOSE',     'AUTHOR',
    'CREATION DATE', 'MODIFICATION HISTORY',          'INPUTS',
    'ARGUMENTS',     'OPTIONS',        'PARAMETERS',  'SWITCHES',
    'OUTPUT',        'SIDE EFFECTS',   'RESULT',      'RETURN VALUE',
    'EXAMPLE',       'NOTES',          'DIAGNOSTICS', 'WARNINGS',
    'ERRORS',        'BUGS',           'TODO',        'IDEAS',
    'PORTABILITY',   'SEE ALSO',       'METHODS',     'NEW METHODS',
    'ATTRIBUTES',    'NEW ATTRIBUTES', 'TAGS',        'COMMANDS',
    'DERIVED FROM',  'DERIVED BY',     'USES',        'CHILDREN',
    'USED BY',       'PARENTS',        'SOURCE',      'LICENSE',
);
my $RD_TAG_STRING;
my $RD_TAG_REGEX;

sub new
{
    my $class  = shift;
    my %params = validate( @_, {
        keepsource => { default => 0  },
        skipblanks => { default => 0  },
        customtags => { default => [], type => ARRAYREF },
    });

    my $self = bless { %params }, $class;

    $self->_load_custom_tags();

    return $self;
}

sub filter
{
    my $self   = shift;
    my %params = validate( @_, {
        input  => { default => undef, type => UNDEF | SCALAR },
        output => { default => undef, type => UNDEF | SCALAR },
    });

    ## Setup input file handle
    my $in_fh;

    if ( $params{input} ) {
        $in_fh = IO::File->new( $params{input}, '<' )
            or croak "Can't open input file '$params{input}': $!";
    }
    else {
        $in_fh = \*STDIN;
    }

    ## Setup output file handle
    my $out_fh;

    if ( $params{output} ) {
        $out_fh = IO::File->new( $params{output}, '>' )
            or croak "Can't open output file '$params{output}': $!";
    }
    else {
        $out_fh = \*STDOUT;
    }

    $self->_parse_robodoc( $in_fh  );
    $self->_write_pod    ( $out_fh ) if @{ $self->{_parsed} };

    $in_fh ->close or carp "Can't close input file: $!";
    $out_fh->close or carp "Can't close output file: $!";

    return;
}

sub convert
{
    my $self   = shift;
    my ( $rd ) = validate_pos( @_, { type => SCALAR } );

    my $in_fh  = IO::String->new( $rd );
    my $out_fh = IO::String->new();

    $self->_parse_robodoc( $in_fh  );
    $self->_write_pod    ( $out_fh ) if @{ $self->{_parsed} };

    return ${ $out_fh->string_ref() };
}

sub _load_custom_tags
{
    my ( $self ) = @_;

    push @RD_TAGS, grep { / [A-Z0-9\s_-]+ /x } @{ $self->{customtags} };

    $RD_TAG_STRING = join q{|}, @RD_TAGS;
    $RD_TAG_REGEX  = qr{\A[ ]*($RD_TAG_STRING)[ ]*\z}o;

    return;
}

sub _parse_robodoc
{
    my $self   = shift;
    my ( $fh ) = validate_pos( @_, { type => HANDLE } );

    my @parsed;
    my $inrobodoc;
    my $insource;
    my $tag;

    while ( $_ = $fh->getline() )
    {
        chomp;
        my $rawline = $_;

        s/^[ ]*#//;
        next if not $_ and $self->{skipblanks};

        $inrobodoc = 0 if /$RD_END_MARK/;

        if ( $inrobodoc and /$RD_TAG_REGEX/ )
        {
            $tag = $1;
            $insource = $tag eq 'SOURCE';

            next if $insource and not $self->{keepsource};

            push @{ $parsed[ -1 ]{ tags } }, { tag => $tag, text => [] };
            next;
        }

        if ( $inrobodoc and $tag )
        {
            next if $insource and not $self->{keepsource};

            push @{ $parsed[ -1 ]{ tags }->[ -1 ]->{ text } },
                ( $insource ? $rawline : $_ );
        }

        if ( /$RD_BEGIN_MARK/ )
        {
            $inrobodoc = 1;
            $tag = undef;

            push @parsed, { type => $RD_HEADERS{ $1 }, element => $2, tags => [] };
        }
    }

    $self->{_parsed} = \@parsed;
    return;
}

sub _write_pod
{
    my $self   = shift;
    my ( $fh ) = validate_pos( @_, { type => HANDLE } );

    my @pod;

    push @pod, sprintf '# Generated by %s version %s', __PACKAGE__, $VERSION;
    push @pod, '=pod';

    for my $doc ( @{ $self->{_parsed} } )
    {
        push @pod, $EMPTY, "=head1 $doc->{type} $doc->{element}", $EMPTY;

        for my $tag ( @{ $doc->{tags} } )
        {
            if ( $tag->{tag} eq 'SOURCE' ) {
                push @pod, $EMPTY, '=cut', $EMPTY;
            }
            else {
                push @pod, $EMPTY, "=head2 $tag->{tag}", $EMPTY;
            }

            push @pod, $_ for @{ $tag->{text} };
        }
    }

    push @pod, $EMPTY, '=cut', $EMPTY;

    print $fh "$_\n" for @pod;
    return;
}

1;

__END__