File Coverage

blib/lib/Text/DelimMatch.pm

Criterion	Covered	Total	%
statement	315	381	82.6
branch	134	212	63.2
condition	40	72	55.5
subroutine	18	24	75.0
pod	19	19	100.0
total	526	708	74.2

package Text::DelimMatch;

use strict;
use vars qw($VERSION @ISA @EXPORT $case_sensitive);

require 5.000;
require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
$VERSION = '1.06';

sub new {
    my $type  = shift;
    my $start = shift;
    my $end   = shift || $start;
    my $esc   = shift;
    my $dblesc= shift;
    my $class = ref($type) || $type;
    my $self  = bless {}, $class;
    local $_  = "no -w warning in evals now";

    eval "/$start/" if defined($start);
    eval "/$end/" if !$@ && defined($end);

    $self->{'STARTREGEXP'} = $start;  # a regexp
    $self->{'ENDREGEXP'}   = $end;    # a regexp
    $self->{'QUOTE'}	   = {};      # a hash of regexp, start => end
    $self->{'ESCAPE'}	   = "";      # a regexp set of chars
    $self->{'DBLESCAPE'}   = "";      # a regexp set of chars

    $self->{'ERROR'}	   = $@;  # false if OK
    $self->{'DEBUG'}	   = 0;	  # boolean
    $self->{'CASESENSE'}   = 0;	  # boolean
    $self->{'FORCESLOW'}   = 0;	  # boolean
    $self->{'KEEP'}	   = 1;	  # boolean
    $self->{'RETURNDELIM'} = 1;   # boolean

    $self->{'BUFFER'}	   = "";
    $self->{'PRE'}	   = "";
    $self->{'MATCH'}	   = "";
    $self->{'POST'}	   = "";

    $self->escape($esc) if $esc;
    $self->double_escape($dblesc) if $dblesc;
    $self->quote(@_) if @_;

    return $self;
}

sub delim {
    my $self   = shift;
    my $start  = shift;
    my $end    = shift || $start;
    my $curs   = $self->{'STARTREGEXP'};
    my $cure   = $self->{'ENDREGEXP'};
    local $_   = "no -w warning in evals now";

    eval "/$start/" if defined($start);
    eval "/$end/" if !$@ && defined($end);

    $self->{'ERROR'}	   = $@;  # false if OK
    $self->{'STARTREGEXP'} = $start;
    $self->{'ENDREGEXP'}   = $end;

    if ($self->{'DEBUG'}) {
	print "DELIM : $start, $end";
	print ": ", $self->{'ERROR'} if $self->{'ERROR'};
	print "\n";
    }

    return ($curs, $cure);
}

sub quote {
    my $self   = shift;
    my (%oldq) = %{$self->{'QUOTE'}};
    local $_   = "no -w warning in evals now";
    my ($key, $val);

    $key = shift @_;

    if (!defined($key)) {
	$self->{'QUOTE'} = {};
    } else {
	while ($key) {
	    $val = shift @_ || $key;

	    eval "/$key/" if defined($key);
	    eval "/$val/" if !$@ && defined($val);
	    $self->{'ERROR'} = $@ if $@;

	    if ($self->{'DEBUG'}) {
		print "QUOTE : $key = $val";
		print ": ", $self->{'ERROR'} if $self->{'ERROR'};
		print "\n";
	    }

	    $self->{'QUOTE'}->{$key} = $val;
	    $key = shift @_;
	}
    }

    return %oldq;
}

sub escape {
    my $self   = shift;
    my $esc    = shift;
    my $curesc = $self->{'ESCAPE'};
    local $_   = "no -w warning in evals now";

    $esc = '[' . quotemeta($esc) . ']' if defined($esc) && ($esc ne "");

    if (defined($esc) && ($esc ne "")) {
	eval "/$esc/";
	$self->{'ERROR'} = $@ if $@;
    }

    $self->{'ESCAPE'} = $esc;

    if ($self->{'DEBUG'}) {
	print "ESCAPE: $esc";
	print ": ", $self->{'ERROR'} if $self->{'ERROR'};
	print "\n";
    }

    return $curesc;
}

sub double_escape {
    my $self   = shift;
    my $esc    = shift;
    my $curesc = $self->{'DBLESCAPE'};
    local $_   = "no -w warning in evals now";

    $esc = '[' . quotemeta($esc) . ']' if defined($esc) && ($esc ne "");

    if (defined($esc) && ($esc ne "")) {
	eval "/$esc/";
	$self->{'ERROR'} = $@ if $@;
    }

    $self->{'DBLESCAPE'} = $esc;

    if ($self->{'DEBUG'}) {
	print "DBLESC: $esc";
	print ": ", $self->{'ERROR'} if $self->{'ERROR'};
	print "\n";
    }

    return $curesc;
}

sub case_sensitive {
    my $self	 = shift;
    my $setsense = shift;
    my $cursense = $self->{'CASESENSE'};

    $self->{'CASESENSE'} = $setsense || !defined($setsense);

    print "CASE	 : ", $self->{'CASESENSE'}, "\n"
	if $self->{'DEBUG'};

    return $cursense;
}

sub slow {
    my $self	 = shift;
    my $setslow	 = shift;
    my $curslow	 = $self->{'FORCESLOW'};

    $self->{'FORCESLOW'} = $setslow || !defined($setslow);

    print "GOSLOW: ", $self->{'FORCESLOW'}, "\n"
	if $self->{'DEBUG'};

    return $curslow;
}

sub keep {
    my $self	 = shift;
    my $setkeep	 = shift;
    my $curkeep	 = $self->{'KEEP'};

    $self->{'KEEP'} = $setkeep || !defined($setkeep);

    print "KEEP	 : ", $self->{'KEEP'}, "\n"
	if $self->{'DEBUG'};

    return $curkeep;
}

sub returndelim {
    my $self	 = shift;
    my $setrd	 = shift;
    my $currd	 = $self->{'RETURNDELIM'};

    $self->{'RETURNDELIM'} = $setrd || !defined($setrd);

    print "RETURNDELIM : ", $self->{'RETURNDELIM'}, "\n"
	if $self->{'DEBUG'};

    return $currd;
}

sub debug {
    my $self	 = shift;
    my $setdebug = shift;
    my $curdebug = $self->{'DEBUG'};

    $self->{'DEBUG'} = $setdebug || !defined($setdebug);

    print "DEBUG : ", $self->{'DEBUG'}, "\n"
	if $self->{'DEBUG'};

    return $curdebug;
}

sub error {
    my $self	 = shift;
    my $seterr	 = shift;
    my $curerr	 = $self->{'ERROR'};

    $self->{'ERROR'} = $seterr if defined($seterr);
    return $curerr;
}

sub pre_matched {
    my $self	 = shift;
    $self->{'ERROR'} = "pre_matched requires keep" if !$self->{'KEEP'};
    return $self->{'PRE'};
}

sub matched {
    my $self	 = shift;
    $self->{'ERROR'} = "matched requires keep" if !$self->{'KEEP'};
    return $self->{'MATCH'};
}

sub post_matched {
    my $self	 = shift;
    $self->{'ERROR'} = "post_matched requires keep" if !$self->{'KEEP'};
    return $self->{'POST'};
}

sub dump {
    my $self	 = shift;
    my ($key, $val);

    print "Dump of Text::DelimMatch:\n";

    print "\n\tERROR : ", $self->{'ERROR'}, "\n"
	if $self->{'ERROR'};

    print "\tStart : ", $self->{'STARTREGEXP'}, "\n";
    print "\tEnd   : ", $self->{'ENDREGEXP'}, "\n";
    print "\tEscape: ", $self->{'ESCAPE'}, "\n";
    print "\tDblEsc: ", $self->{'DBLESCAPE'}, "\n";
    print "\tDebug : ", $self->{'DEBUG'}, "\n";
    print "\tCase  : ", $self->{'CASESENSE'}, "\n";
    print "\tSlow  : ", $self->{'FORCESLOW'}, "\n";
    print "\tKeep  : ", $self->{'KEEP'}, "\n";
    print "\tQuote :\n";
    while (($key, $val) = each %{$self->{'QUOTE'}}) {
	print "\t\t$key ... $val\n";
    }
    print "\tBuffer: ", $self->{'BUFFER'}, "\n";
    print "\tPrefix: ", $self->{'PRE'}, "\n";
    print "\tMatch : ", $self->{'MATCH'}, "\n";
    print "\tPost  : ", $self->{'POST'}, "\n\n";
}

sub match {
    my $self   = shift;
    my $string = shift;
    my $state  = 0;
    my $start  = $self->{'STARTREGEXP'};
    my $end    = $self->{'ENDREGEXP'};
    my %quote  = %{$self->{'QUOTE'}};
    my $escape = $self->{'ESCAPE'};
    my $dblesc = $self->{'DBLESCAPE'};
    my $debug  = $self->{'DEBUG'};
    my ($startq, $endq, $specialq) = ("", "", "");
    my ($done) = 0;
    my ($depth) = 0;
    my (@states) = ();
    my ($accum) = "";
    my ($regexp, $match, $pre, $matched, $post);
    my ($scratch);
    local $_   = "no -w warning in evals now";

    return if $self->{'ERROR'};

    if (defined($string)) {
	$self->{'BUFFER'} = $string;
    } else {
	# use post of previous match, if there was a match previously
	$self->{'BUFFER'} = $self->{'POST'} if $self->{'MATCH'}
    }

    $self->{'PRE'}    = "";
    $self->{'MATCH'}  = "";
    $self->{'POST'}   = "";

    if (!%quote && !$escape && !$dblesc && !$self->{'FORCESLOW'}) {
	print "FAST: $start, $end\n" if $debug;
	return $self->_fast0() if $start eq $end;
	return $self->_fast1();
    }

    # build the regexp that matches the next important thing

    if (%quote) {
	$startq = join (")|(", keys %quote);
	$startq = "($startq)";
    }

    if ($escape || $dblesc) {
	if ($escape && $dblesc) {
	    $specialq = "($escape)|($dblesc)";
	} elsif ($escape) {
	    $specialq = "($escape)";
	} else {
	    $specialq = "($dblesc)";
	}
    }

    $_ = $self->{'BUFFER'};
    $self->{'BUFFER'} = "";
    while ($state != 3) {
	if ($state == 0) {	     # before start tag
	    $regexp = "($start)";
	    $regexp .= "|$startq" if $startq;
	    $regexp .= "|($escape)" if $escape;
	} elsif ($state == 1) {	     # in start tag
	    $regexp = "($start)|($end)";
	    $regexp .= "|$startq" if $startq;
	    $regexp .= "|($escape)" if $escape;
	} elsif ($state == 2) {	     # in quote
	    $regexp = $endq;
	    $regexp .= "|$specialq" if $specialq;
	} else {
	    $self->{'ERROR'} = "BAD STATE!  THIS CAN'T HAPPEN!";
	    return;
	}

	print "STATE: $state: $regexp\n" if $debug;

	($pre, $matched, $post) = $self->_match($regexp, $_);

	print "\tSTR : $_\n" if $debug;
	print "\tPRE : $pre\n" if $debug;
	print "\tMTCH: $matched\n" if $debug;
	print "\tPOST: $post\n" if $debug;

	last if !$matched;

	# First things first, if we've encountered an escaped
	# character, move along
	if ($escape && $self->_match ($escape, $matched)) {
	    $accum .= $pre . $matched;
	    $accum .= substr($post, 0, 1);
	    $_ = substr ($post, 1);
	    next;
	}

	if ($state == 0) {	     # looking for start or startq
	    if ($self->_match($start, $matched)) { # matched start
		$state = 1;
		$depth++;
		print "START: $depth\n" if $debug;

		$self->{'PRE'} = $accum . $pre;
		$accum = $matched;
		$_ = $post;
	    } else {		     # (must have) matched startq
		push (@states, $state);
		$state = 2;
		$accum .= $pre . $matched;
		foreach $scratch (keys %quote) {
		    if ($self->_match ($scratch, $matched)) {
			$endq = $quote{$scratch};
			last;
		    }
		}
		$_ = $post;
	    }
	} elsif ($state == 1) {
	    if ($self->_match($end, $matched)) { # matched end
		$state = 1;
		$depth--;

		print "END : $depth\n" if $debug;
		$accum .= $pre . $matched;
		if ($depth == 0) {
		    $state = 3;
		    $self->{'MATCH'} = $accum;
		    $self->{'POST'} = $post;
		    $_ = "";
		} else {
		    $_ = $post;
		}
	    } elsif ($self->_match($start, $matched)) { # matched start
		$state = 1;
		$depth++;
		print "START: $depth\n" if $debug;

		$accum .= $pre . $matched;
		$_ = $post;
	    } else {		     # (must have) matched startq
		push (@states, $state);
		$state = 2;
		$accum .= $pre . $matched;
		foreach $scratch (keys %quote) {
		    if ($self->_match ($scratch, $matched)) {
			$endq = $quote{$scratch};
			last;
		    }
		}
		$_ = $post;
	    }
	} elsif ($state == 2) {
	    # case 1, matched dblesc and is a doubled char
	    if ($dblesc
		&& $self->_match ($dblesc, $matched)
		&& ($matched eq substr($post, 0, 1))) { # skip forward
		$accum .= $pre . $matched;
		$accum .= substr($post, 0, 1);
		$_ = substr($post, 1);
		next;
	    } # otherwise check for other things then revisit

	    if ($self->_match ($endq, $matched)) { # matched endq
		$state = pop (@states);
		$accum .= $pre . $matched;
		$_ = $post;
	    } else { # (must have) matched a undoubled dblesc
		     # usually this ends a quoted string
		     # (and we'd never get here)
		     # but since it didn't, just skip along
		$accum .= $pre . $matched;
		$_ = $post;
	    }
	} else {
	    $self->{'ERROR'} = "BAD STATE!  THIS CAN'T HAPPEN!";
	    return;
	}
    }

    if ($state == 3) {
	$pre   = $self->{'PRE'};
	$match = $self->{'MATCH'};
	$post  = $self->{'POST'};

	$match = $self->strip_delim($match) if !$self->{'RETURNDELIM'};
    } else {
	$self->{'PRE'}	 = "";
	$self->{'MATCH'} = "";
	$self->{'POST'}	 = "";
	undef $pre;
	undef $match;
	undef $post;
    }

    if (!$self->{'KEEP'}) {
	$self->{'PRE'}	 = "";
	$self->{'MATCH'} = "";
	$self->{'POST'}	 = "";
    }

    return wantarray ? ($pre, $match, $post) : $match;
}

sub _fast0 {
    my $self   = shift;
    my $delim  = $self->{'STARTREGEXP'};
    local $_   = $self->{'BUFFER'};
    my ($pre, $match, $post);

    if ($self->{'CASESENSE'}) {
	$match = /^(.*?)($delim.*?$delim)(.*)$/s;
	($pre, $match, $post) = ($1, $2, $3);
    } else {
	$match = /^(.*?)($delim.*?$delim)(.*)$/si;
	($pre, $match, $post) = ($1, $2, $3);
    }

    if ($match) {
	$match = $self->strip_delim($match) if !$self->{'RETURNDELIM'};

	if ($self->{'KEEP'}) {
	    $self->{'PRE'}   = $pre;
	    $self->{'MATCH'} = $match;
	    $self->{'POST'}  = $post;
	}

	return wantarray ? ($pre, $match, $post) : $match;
    } else {
	return wantarray ? (undef, undef, undef) : undef;
    }
}

sub _fast1 {
    my $self   = shift;
    my $string = $self->{'BUFFER'};
    my $start  = $self->{'STARTREGEXP'};
    my $end    = $self->{'ENDREGEXP'};
    my $regexp = "($start)|($end)";
    my $count  = 0;
    my ($match, $realpre, $pre, $post, $matched);

    ($realpre, $match, $post) = $self->_match($start, $string);

    if (defined($match)) {
	$matched = $match;
	$string	 = $post;
	$count++;

	($pre, $match, $post) = $self->_match($regexp, $string);

	while (defined($match)) {
	    $matched .= $pre . $match;

	    if ($self->_match($end, $match)) {
		$count--;
	    } else {
		$count++;
	    }

	    $string = $post;
	    last if $count == 0;

	    ($pre, $match, $post) = $self->_match($regexp, $string);
	}

	if ($count == 0) {
	    $matched = $self->strip_delim($matched) if !$self->{'RETURNDELIM'};

	    if ($self->{'KEEP'}) {
		$self->{'PRE'}	 = $realpre;
		$self->{'MATCH'} = $matched;
		$self->{'POST'}	 = $post;
	    }

	    return wantarray ? ($realpre, $matched, $post) : $matched;
	}
    }

    return wantarray ? (undef, undef, undef) : undef;
}

sub strip_delim {
    my $self   = shift;
    my $string = shift;
    my $start  = $self->{'STARTREGEXP'};
    my $end    = $self->{'ENDREGEXP'};
    my $ok     = 1;
    local $_   = "no -w warning in evals now";

    return if $self->{'ERROR'};

    $string = $self->{'MATCH'} if !defined($string);

    if ($string =~ /^$start/s) {
	my($rest) = $';
	if ($rest =~ /^(.*)$end$/s) {
	    return $1;
	} else {
	    $self->{'ERROR'} = "FAILED TO MATCH END DELIMITER";
	}
    } else {
	$self->{'ERROR'} = "FAILED TO MATCH START DELIMITER";
    }

    return;
}

sub _match {
    my $self   = shift;
    my $regexp = shift;
    local $_   = shift;
    my $match  = 0;
    my ($pre, $matched, $post);

    if ($self->{'CASESENSE'}) {
	$match = /$regexp/s;
	($pre, $matched, $post) = ($`, $&, $');
    } else {
	$match = /$regexp/si;
	($pre, $matched, $post) = ($`, $&, $');
    }

    if ($match) {
	wantarray ? ($pre, $matched, $post) : $matched;
    } else {
	wantarray ? (undef, undef, undef) : undef;
    }
}

sub nested_match {
    my ($search, $start, $end, $three) = @_;
    my $mc = new Text::DelimMatch $start, $end;
    my ($p, $m, $s) = $mc->match($search);

    if (defined($three)) {
	return wantarray ? ($p, $m, $s) : $m;
    } else {
	return wantarray ? ("$p$m", $s) : $m;
    }
}

sub skip_nested_match {
    my ($search, $start, $end, $three) = @_;
    my $mc = new Text::DelimMatch $start, $end;
    my ($p, $m, $s) = $mc->match($search);

    if (defined($three)) {
	return wantarray ? ($p, $m, $s) : $s;
    } else {
	return wantarray ? ("$p$m", $s) : $s;
    }
}

1;
__END__