File Coverage

blib/lib/Perl6/Perldoc.pm

Criterion	Covered	Total	%
statement	24	24	100.0
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	32	32	100.0

=encoding ISO8859-1
=cut

package Perl6::Perldoc;

our $VERSION = '0.000012';
use warnings;
use strict;
use re 'eval';

use Filter::Simple;

my $IDENT            = qr{ (?> [^\W\d] \w* )              }xms;
my $QUAL_IDENT       = qr{ $IDENT (?: :: $IDENT)*         }xms;
my $TO_EOL           = qr{ (?> [^\n]* ) (?:\Z|\n)         }xms;
my $HWS              = qr{ (?> [^\S\n]+ )                 }xms;
my $OHWS             = qr{ (?> [^\S\n]* )                 }xms;
my $BLANK_LINE       = qr{ ^ $OHWS $ | (?= ^ = | \s* \z)  }xms;
my $DIRECTIVE        = qr{ config | encoding | use        }xms;
my $OPT_EXTRA_CONFIG = qr{ (?> (?: ^ = $HWS $TO_EOL)* )   }xms;


# Recursive matcher for =DATA sections...

my $DATA_PAT = qr{
    ^ =
    (?:
        begin $HWS DATA $TO_EOL
        $OPT_EXTRA_CONFIG
            (.*?)
        ^ =end $HWS DATA
    |
        for $HWS DATA $TO_EOL
        $OPT_EXTRA_CONFIG
            (.*?)
        $BLANK_LINE
    |
        DATA \s
            (.*?)
        $BLANK_LINE
    )
}xms;


# Recursive matcher for all other Perldoc sections...

use vars '$type';
my $POD_PAT; $POD_PAT = qr{
    ^ =
    (?:
        (?:(?:begin|for) $HWS)? END
        (?> .*) \z
    |
        begin $HWS ($IDENT) (?{ local $type = $^N}) $TO_EOL
        $OPT_EXTRA_CONFIG
            (?: ^ (??{$POD_PAT}) | . )*?
        ^ =end $HWS (??{$type}) $TO_EOL
    |
        for $HWS $TO_EOL
        $OPT_EXTRA_CONFIG
            .*?
        $BLANK_LINE
    |
        $DIRECTIVE $HWS $TO_EOL
        $OPT_EXTRA_CONFIG
    |
        (?! end) $IDENT $TO_EOL
            .*?
        $BLANK_LINE
    )
}xms;

FILTER {
    my @DATA;

    # Extract DATA sections, deleting them but preserving line numbering...
    s{ ($DATA_PAT) }{
        my ($data_block, $contents) = ($1,$+);

        # Special newline handling required under Windows...
        if ($^O =~ /MSWin/) {
            $contents =~ s{ \r\n }{\n}gxms;
        }

        # Save the data...
        push @DATA, $contents;

        # Delete it from the source code, but leave the newlines...
        $data_block =~ tr[\n\0-\377][\n]d;

        $data_block;
    }gxmse;

    # Collect all declared package names...
    my %packages = (main=>1);
    s{ (\s* package \s+ ($QUAL_IDENT)) }{
        my ($package_decl, $package_name) = ($1,$2);
        $packages{$package_name} = 1;
        $package_decl;
    }gxmse;

    # Delete all other pod sections, preserving newlines...
    { no warnings;
      s{ ($POD_PAT) }{ my $text = $1; $text =~ tr[\n\0-\377][\n]d; $text; }gxmse;
    }

    # Consolidate data and open a filehandle to it...
    local *DATA_glob;
    my $DATA_as_str = join q{}, @DATA;
    *DATA_glob = \$DATA_as_str;
    *DATA_glob = \@DATA;
    open *DATA_glob, '<', \$DATA_as_str
        or require Carp
        and croak( "Can't set up *DATA handle ($!)" );

    # Alias each package's *DATA, @DATA, and $DATA...
    for my $package (keys %packages) {
        no strict 'refs';
        *{$package.'::DATA'} = *DATA_glob;
    }
}

__END__