Benchmark-Perl-Formance-Cargo

 view release on metacpan or  search on metacpan

share/P6STD/CursorBase.pmc  view on Meta::CPAN

#############################################################

sub callm { my $self = shift;
    my $arg = shift;
    my $class = ref($self) || $self;

    my $lvl = 0;
    my $extralvl = 0;
    my @subs;
    if (DEBUG & DEBUG::callm_show_subnames) {
        while (my @c = caller($lvl)) {
            $lvl++;
            my $s = $c[3];
            if ($s =~ /::_/) {
                next;
            }
            elsif ($s =~ /^(?:Cursor|CursorBase)?::/) {
                next;
            }
            elsif ($s =~ /^LazyMap::/) {
                next;

share/P6STD/CursorBase.pmc  view on Meta::CPAN

                next;
            }
            else {
                $extralvl = $lvl unless $extralvl;
                $s =~ s/.*:://;
                push @subs, $s;
            }
        }
    }
    else {
        while (my @c = caller($lvl)) { $lvl++; }
    }
    my ($package, $file, $line, $subname, $hasargs) = caller(1);
    my $name = $subname;
    if (defined $arg) { 
        $name .= " " . $arg;
    }
    my $pos = '?';
    $self->deb($name, " [", $file, ":", $line, "] $class") if DEBUG & DEBUG::trace_call;
    if (DEBUG & DEBUG::callm_show_subnames) {
        $RED . join(' ', reverse @subs) . $CLEAR . ':' x $extralvl;
    }
    else {
        ':' x $lvl;
    }
}

sub retm {
    return $_[0] unless DEBUG & DEBUG::trace_call;
    my $self = shift;
    warn "Returning non-Cursor: $self\n" unless exists $self->{_pos};
    my ($package, $file, $line, $subname, $hasargs) = caller(1);
    $self->deb($subname, " returning @{[$self->{_pos}]}");
    $self;
}

sub _MATCHIFY { my $self = shift;
    my $S = shift;
    my $name = shift;
    return () unless @_;
    my $xact = $self->{_xact};
    my @result = lazymap( sub { my $x = shift; $x->{_xact} = $xact; $x->_REDUCE($S, $name)->retm() }, @_);

share/P6STD/CursorBase.pmc  view on Meta::CPAN

        if (@$isa != 1) {
            $self->deb("\tcannot reuse $key; multiply inherited") if DEBUG & DEBUG::autolexer;
            last;
        }

        my $super = $isa->[0];

        my $dic = $ast->{dic} //= do {
            my $i = 1; # skip _AUTOLEXpeek;
            my $pkg = 'CursorBase';
            $pkg = caller($i++) while $pkg eq 'CursorBase';
            #print STDERR "dic run: $pkg\n";
            $self->deb("\tdeclared in class $pkg") if DEBUG & DEBUG::autolexer;
            $pkg;
        };

        my $ar = ${ $lang . "::ALLROLES" } //= do {
            +{ map { $_->name, 1 } ($lang->meta, $lang->meta->calculate_all_roles) }
        };

        # It doesn't make sense to float a lexer above Cursor, or (for 'has'

share/P6STD/RE_ast.pmc  view on Meta::CPAN

	elsif ($_ eq '<' | $_ eq '>') { $r .= $_ }
	else { $r .= '\\' . $_ }
    }
    $r;
}

sub here {
    return unless $::DEBUG & DEBUG::longest_token_pattern_generation;
    my $arg = shift;
    my $lvl = 0;
    while (caller($lvl)) { $lvl++ }
    my ($package, $file, $line, $subname, $hasargs) = caller(0);

    my $name = $package;   # . '::' . substr($subname,1);
    if (defined $arg) { 
	$name .= " " . $arg;
    }
    ::deb("\t", ':' x $lvl, ' ', $name, " [", $file, ":", $line, "]") if $::DEBUG & DEBUG::longest_token_pattern_generation;
}

{ package nfa;

share/PerlCritic/Critic/Policy.pm  view on Meta::CPAN

    my ($self) = @_;

    return throw_policy_definition
        $self->get_short_name() . q/ does not implement violates()./;
}

#-----------------------------------------------------------------------------

sub violation {  ## no critic (ArgUnpacking)
    my ( $self, $desc, $expl, $elem ) = @_;
    # HACK!! Use goto instead of an explicit call because P::C::V::new() uses caller()
    my $sev = $self->get_severity();
    @_ = ('Perl::Critic::Violation', $desc, $expl, $elem, $sev );
    goto &Perl::Critic::Violation::new;
}

#-----------------------------------------------------------------------------

sub new_parameter_value_exception {
    my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_;