File Coverage

blib/lib/Perl6/Pod/Utl.pm

Criterion	Covered	Total	%
statement	57	61	93.4
branch	9	14	64.2
condition	2	5	40.0
subroutine	12	12	100.0
pod	3	3	100.0
total	83	95	87.3

#===============================================================================
#
#  DESCRIPTION:  Utils for Perl6 Pod
#
#       AUTHOR:  Aliaksandr P. Zahatski,
#===============================================================================
package Perl6::Pod::Utl;
use strict;
use warnings;
use utf8;
our $VERSION = '0.01';


=head2  parse_pod [default_pod => 0 ]

=item * default_pod => 0/1 ,

switch on/off ambient mode for para out of =pod blocks. Default 0 (ambient mode)
return ref to tree

=cut

sub parse_pod {
    my ( $src, %args ) = @_;
    my $r = do {
    use Regexp::Grammars;
    use Perl6::Pod::Grammars;

    qr{


        \A  \Z
    }xms;
    };
    my $tree;
    if ( $src =~ $r ) {
        use Perl6::Pod::Lex;
        $tree = Perl6::Pod::Lex->new(%args)->make_tree( $/{File} );
    }
    else {
        return undef;
    }
    $tree;
}

=head2 strip_vmargin $vmargin, $txt

  =begin pod
   =para
                  text
  =end pod

=cut

sub strip_vmargin {
    my ( $vmargin, $content ) = @_;

    #get min margin of text
    my $min = $vmargin;
    foreach ( split( /[\n\r]/, $content ) ) {
        if (m/(\s+)/) {
            my $length = length($1);
            $min = $length if $length < $min;
        }
    }

    #remove only if $min > 0
    if ( $min > 0 ) {
        my $new_content = '';
        foreach ( split( /[\n\r]/, $content ) ) {
            $new_content .= substr( $_, $min ) . "\n";
        }
        $content = $new_content;
    }
    return $content;
}

=head2  parse_para $text

parse formatting codes

Optrions:

=item * allow=>[ 'A', 'B']


=cut

sub parse_para {
    use Perl6::Pod::Codeactions;
    my $text = shift || return [];
    my %delim = ( '<' => '>', '«' => '»', '<<' => '>>' );
    my %allow = ( '*' => 1 );

    my %args = @_;
    if ( my $allow = $args{allow} ) {
        my @list = ref($allow) ? @$allow : ($allow);
        %allow = ();

        #fill allowed fcodes
        @allow{@list} = ();
    }
    my $DEFER_REGEX_COMPILATION = "";
    my $r = $args{reg} || do {
        use Regexp::Grammars;
        use Perl6::Pod::Grammars;
    qr{




       \A    \Z
     <[content]>+
      .+?
    [ \t]*
     \#

                    |
                    |
                    |
                    |
                    |
                    | <.text>
     <%delim>
     (??{ quotemeta $delim{$ARG{ldelim}} })


            ( $ARG{name} && ( $ARG{name} eq  uc($ARG{name} ) ) )
                        &&
            ( exists $allow{'*'} ||  exists $allow{$ARG{name}} )

            })>
    (?! \s+)


    (?! \s+)

               (?: \| <[syns=(\S+)]>+ % ;)?
    (?! \s+)



    (?! \s+)


            #alternate presentation
     (?:  \| )? #(.*) \| not work for
    #L< http://cpan.org > B L< haname | http:perl.html  >
    # '' => 'L< http://cpan.org > B L< haname | http:perl.html  >'

    #        (?:)? #hack

                ? #scheme specifier

                (?:  )?
                  ?
                 (?: )? #internal addresses

     <[entry=([^,\;]+?)]>* % (\s*,\s*)
    (?! \s+)


          # X
          ( (?{$MATCH{entry}=$MATCH{text}; $MATCH{form} = 1  })
          |
            ? \| <[entries=X_code_entry]>* % (\s*\;\s*)
            (?{$MATCH{form} = 2})
             )




              <.hs>
                ? #scheme specifier
                (?:  )?

            <.hs>



             <.hs> <[content]>*? <.hs>
    $DEFER_REGEX_COMPILATION
}xms;
      };

    if ( $text =~ $r->with_actions( Perl6::Pod::Codeactions->new ) ) {
       return $/{Text};
    }
    else {
        return undef;
    }

}

1;