view release on metacpan or  search on metacpan

inc/Parse/RecDescent.pm  view on Meta::CPAN

        $args, # \@args
        undef, # $_itempos
    );


    if (defined $retval)
    {
        foreach ( @{$_[0]->{deferred}} ) { &$_; }
    }
    else
    {
        foreach ( @{$_[0]->{errors}} ) { _error(@$_); }
    }

    if (ref $_[1] eq 'SCALAR') { ${$_[1]} = $text }

    $ERRORS = 0;
    return $retval;
}

sub _parserepeat($$$$$$$$$)    # RETURNS A REF TO AN ARRAY OF MATCHES
{
    my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode, $_itempos) = @_;
    my @tokens = ();

    my $itemposfirst;
    my $reps;
    for ($reps=0; $reps<$max;)
    {
        $expectation->at($text);
        my $_savetext = $text;
        my $prevtextlen = length $text;
        my $_tok;
        if (! defined ($_tok = &$prod($parser,$text,1,$_noactions,$argcode,$_itempos)))
        {
            $text = $_savetext;
            last;
        }

        if (defined($_itempos) and !defined($itemposfirst))
        {
            $itemposfirst = Parse::RecDescent::Production::_duplicate_itempos($_itempos);
        }

        push @tokens, $_tok if defined $_tok;
        last if ++$reps >= $min and $prevtextlen == length $text;
    }

    do { $expectation->failed(); return undef} if $reps<$min;

    if (defined $itemposfirst)
    {
        Parse::RecDescent::Production::_update_itempos($_itempos, $itemposfirst, undef, [qw(from)]);
    }

    $_[1] = $text;
    return [@tokens];
}

sub set_autoflush {
    my $orig_selected = select $_[0];
    $| = 1;
    select $orig_selected;
    return;
}

# ERROR REPORTING....

sub _write_ERROR {
    my ($errorprefix, $errortext) = @_;
    return if $errortext !~ /\S/;
    $errorprefix =~ s/\s+\Z//;
    local $^A = q{};

    formline(<<'END_FORMAT', $errorprefix, $errortext);
@>>>>>>>>>>>>>>>>>>>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
END_FORMAT
    formline(<<'END_FORMAT', $errortext);
~~                     ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
END_FORMAT
    print {*STDERR} $^A;
}

# TRACING

my $TRACE_FORMAT = <<'END_FORMAT';
@>|@|||||||||@^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
  | ~~       |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
END_FORMAT

my $TRACECONTEXT_FORMAT = <<'END_FORMAT';
@>|@|||||||||@                                      |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
  | ~~       |                                      |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
END_FORMAT

sub _write_TRACE {
    my ($tracelevel, $tracerulename, $tracemsg) = @_;
    return if $tracemsg !~ /\S/;
    $tracemsg =~ s/\s*\Z//;
    local $^A = q{};
    my $bar = '|';
    formline($TRACE_FORMAT, $tracelevel, $tracerulename, $bar, $tracemsg, $tracemsg);
    print {*STDERR} $^A;
}

sub _write_TRACECONTEXT {
    my ($tracelevel, $tracerulename, $tracecontext) = @_;
    return if $tracecontext !~ /\S/;
    $tracecontext =~ s/\s*\Z//;
    local $^A = q{};
    my $bar = '|';
    formline($TRACECONTEXT_FORMAT, $tracelevel, $tracerulename, $bar, $tracecontext, $tracecontext);
    print {*STDERR} $^A;
}

sub _verbosity($)
{
       defined $::RD_TRACE
    or defined $::RD_HINT    and  $::RD_HINT   and $_[0] =~ /ERRORS|WARN|HINT/
    or defined $::RD_WARN    and  $::RD_WARN   and $_[0] =~ /ERRORS|WARN/
    or defined $::RD_ERRORS  and  $::RD_ERRORS and $_[0] =~ /ERRORS/
}