File Coverage

blib/lib/String/Pattern.pm

Criterion	Covered	Total	%
statement	9	119	7.5
branch	0	30	0.0
condition	0	11	0.0
subroutine	3	13	23.0
pod	5	10	50.0
total	17	183	9.2

# Copyright (c) 2000 Ivo Zdravkov. All rights reserved.  This program is
# free software; you can redistribute it and/or modify it under the same terms
# as Perl itself.

package Pattern;

	use strict;
	use overload
		'""' => "to_string";
	use vars qw($VERSION);
	$VERSION='0.90';

	sub new{
        my $proto = shift;
		my $pattern = shift;

        my $class = ref($proto) || $proto;

		my $self = {};
		$self->{PATTERN} = undef;
		$self->{MATCHES} = undef;
		$self->{DATA} = {}; # tag => {REX => '.+', VAR_REF => variable ref}
		$self->{PREPARED} = undef;

		bless($self, $class);
		$self->pattern($pattern) if $pattern;
		return $self
	}

	sub bind{
		my $self = shift;
		my $tag = shift; my $var_ref = shift; my $rex=shift;

		if ($rex and $rex=~/\((..)/ and  $1 ne '?:') {
			warn "Bind failed for tag $tag \n".
				"Brackets are not allowed in regular expression, excep like these : (?:..)";
			return undef
		}

		$self->{DATA}->{$tag}->{VAR_REF} = $var_ref;
		$self->{DATA}->{$tag}->{REX} = $rex || '.*';
		$self->{PREPARED} = 0;

		my $q_tag = $self->quote($tag);
		warn "There is no $tag tag in the pattern \n"
			unless $self->{PATTERN} =~/$q_tag/;

		return 1
	}

	sub bind_like{
		my $self = shift;
		my $other = shift;

		unless ( ref($other) eq ref($self) ) {
			warn "Not same object type: ".ref($self)."\n";
			return undef
		}

		my $success = 1;
		my ($tag, $info);
		while ( ($tag, $info) = each %{$other->{DATA}} ) {
			$self->bind( $tag => $info->{VAR_REF}, $info->{REX})
				or $success = 0;
		}

		return $success
	}

	sub pattern{
		my $self = shift;
		my $pattern = shift;

		if (defined $pattern) {
			$self->{PATTERN}=$pattern;
			$self->{PREPARED} = 0;
			return 1
		}else{
			return $self->{PATTERN}
		}
	}

	sub prepare{
		my $self = shift;

		my $index=0;
		my $pattern=$self->{PATTERN};

		# clear old indexes
		$self->{DATA}->{$_}->{APPEARANCE}=[] for (keys %{$self->{DATA}});

		# create indexes
		my $s_p = join('|', map {'(?:'.$self->quote($_).')'} keys %{$self->{DATA}} );
		die "There is no any bindings defined" unless $s_p;

		while ($pattern=~/($s_p)/gs){
			push @{$self->{DATA}->{$1}->{APPEARANCE}}, $index++
		}

		# compile rex
		$self->{REX} = $self->to_rex;;
		$self->{PREPARED}=1;

		return 1
	}

	sub identify{
		my $self = shift;
		my $string = shift;

		$self->prepare unless $self->{PREPARED};

		my $identical=1;
		my $tag; my $first;	my @appearances;
		my $rex=$self->{REX};

		if (@{$self->{MATCHES}} = $string=~/$rex/s) {
			$identical=1
		}else{
			return 0
		}

		# check for identical repetitions
		for $tag (keys %{$self->{DATA}} ){
			($first, @appearances)=@{$self->{DATA}->{$tag}->{APPEARANCE}};
			next unless defined $first;

			for (@appearances) {
				$identical=0 if $self->{MATCHES}[$first] ne $self->{MATCHES}[$_] ;
			}
			last unless $identical
		}

		# set bounded variables
		if ($identical) {
			for $tag (keys %{$self->{DATA}} ){
				if (@{$self->{DATA}->{$tag}->{APPEARANCE}}) {
					${$self->{DATA}->{$tag}->{VAR_REF}}=
						$self->{MATCHES}[$self->{DATA}->{$tag}->{APPEARANCE}[0]]
				}else{
					next
				}
			}
		}
		return $identical
	}

	sub quote{
		my $self = shift;
		my $rex = shift;

		$rex=~s/([\$\?@\[\]{}*+\.^|\\])/\\$1/g;

		return $rex
	}

	sub dequote{
		my $self = shift;
		my $string = shift;

		$string =~ s/\\(.)/$1/g;
		return $string;
	}

	sub to_rex{
		my $self = shift;

		my $rex=$self->quote($self->{PATTERN});
		my $s_p = join('|', map {'(?:'.$self->quote($self->quote($_)).')'} keys %{$self->{DATA}} );

		$rex=~s/($s_p)/
			if (exists $self->{DATA}->{$self->dequote($1)}) {
				"(".$self->{DATA}->{$self->dequote($1)}->{REX}.")"
			}else{
				warn "problems with rex creation for tag $1"
			}
		/ge;

		return '^'.$rex.'$';
	}

	sub to_string{
		my $self = shift;

		my $result = $self->{PATTERN};

		for my $tag (keys %{ $self->{DATA} }) {
			$result =~ s/$tag/${$self->{DATA}->{$tag}->{VAR_REF}}/g;
		}

		return $result
	}
1;
__END__