view release on metacpan or  search on metacpan

PatternMatcher.pm  view on Meta::CPAN

}

sub segment_match {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings, $start) = @_;
    my $var = $pattern->[0]->[0] ;
    my $pat = rest $pattern ;

    if (!defined($pat)) {
	DTRACE "not defined pat";
	return DVAL match_variable($var,$input,$bindings) ;
    } else {
	DTRACE "    defined pat";
	my $pos = first_match_pos($pat->[0], $input, $start) ;

	if (!defined($pos)) {
	    DTRACE "no first match pos";
	    return DVAL undef;
	} else {
	    DTRACE "there is a first match pos ($pos)";
	    # if it does have a match
	    my $match_variable_subseq_end = (!$pos) ? 0 : $pos - 1 ;
	    my $b2 = pat_match($pat, subseq($input,$pos),
			       match_variable($var, subseq($input,0,$match_variable_subseq_end), $bindings));
	    if ($b2) {
		DTRACE "found our match ($b2)";
		return DVAL $b2;
	    } else {
		DTRACE "incrementing and attempting again";
		return DVAL (segment_match($pattern, $input, $bindings,
			     (1+$pos)));
	    }
	}
    }
}
		
sub segment_match_plus {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings) = @_;
    return DVAL segment_match $pattern, $input, $bindings, 1 ;
}

sub segment_match_optional {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings) = @_ ;
    my $var = $pattern->[0][0] ;
    my $pat = rest $pattern ;

    return DVAL (
		 (pat_match ( [($var, @$pat)], $input, $bindings) ) ||
		 (pat_match            $pat  , $input, $bindings) 
		 ) ;
}


sub pat_match ;
sub single_match_is {
    DFEATURE my $f_;
    my ($is_var_and_pred, $input, $bindings) = @_ ;

    DTRACE "INPUT ", Data::Dumper::Dumper(\@_) ;
    my ($var,$pred)  = ($is_var_and_pred->[1],$is_var_and_pred->[2]) ;
    my $new_bindings = pat_match $var, $input, $bindings ;
    DTRACE "NEW_BINDINGS ", Data::Dumper::Dumper($new_bindings) ;

    if (!defined($new_bindings) or !defined($pred->($input))) {
	DTRACE "pred FAILED";
	return DVOID ;
    } else {
	my $result = $pred->($input) ;
	DTRACE "pred result: $result";
	if ($result) {
	    return DVAL $bindings ;
	} else {
	    return DVOID;
	}
    }
}

sub single_match_or ;
sub single_match_not {
    DFEATURE my $f_;    

    my ($pattern,$input,$bindings) = @_;
    my $o = single_match_or $pattern, $input, $bindings ;
    if ($o) { 
	return DVOID ;
    } else {
	return DVAL $bindings ;
    }
}

sub match_or;
sub single_match_or {
    DFEATURE my $f_;    

    my ($pattern,$input,$bindings) = @_;

    DTRACE "smor_input: ", Data::Dumper::Dumper($input) ;

    if (!defined($pattern) or (scalar @$pattern == 0)) { return DVOID }
    my $input_copy = Storable::dclone($input);
    my $rest_pattern = rest $pattern;
    my $new_bindings = pat_match $pattern->[0], $input, $bindings ;
    if (!defined($new_bindings)) { 
	my $r = single_match_or $rest_pattern, $input_copy, $bindings ;
    } else {
	return DVAL $new_bindings ;
    }
}

sub single_match_and {
    DFEATURE my $f_;    

    my ($meta_pattern,$input,$bindings) = @_;
    DTRACE "single_match_and meta_p: i: b:", Data::Dumper::Dumper($meta_pattern,$input,$bindings) ;

    if (!defined($bindings)) { return DVOID }
    if (!defined($meta_pattern) or !@$meta_pattern) { return DVAL $bindings }
    my $rest_meta_pattern = rest $meta_pattern ;