File Coverage

blib/lib/Text/Query.pm

Criterion	Covered	Total	%
statement	52	67	77.6
branch	15	26	57.6
condition	4	5	80.0
subroutine	10	15	66.6
pod	5	12	41.6
total	86	125	68.8

#
#   Copyright (C) 1999 Eric Bohlman, Loic Dachary
#   Copyright (C) 2013 Jon Jensen
#
#   This program is free software; you can redistribute it and/or modify it
#   under the terms of the GNU General Public License as published by the
#   Free Software Foundation; either version 2, or (at your option) any
#   later version.  You may also use, redistribute and/or modify it
#   under the terms of the Artistic License supplied with your Perl
#   distribution
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

package Text::Query;

use strict;

use vars qw($VERSION);

$VERSION = '0.09';

use Carp;

sub new {
  my($class) = shift;
  my($self) = {};
  bless $self,$class;
  if(@_ % 2) {
      my($qstring) = shift;
      $self->configure(@_);
      return defined($qstring) ? $self->prepare($qstring, @_) : $self;
  } else {
      $self->configure(@_);
      return $self;
  }
}

sub configure {
    my($self, %args) = @_;

    $self->{-verbose} = $args{-verbose} || 0 if(!defined($self->{-verbose}));

    my(%defconfigs) = (
      simple_text =>
        { -parse => 'Text::Query::ParseSimple',
          -build => 'Text::Query::BuildSimpleString',
          -optimize => 'Text::Query::Optimize',
          -solve => 'Text::Query::SolveSimpleString'
        },
       advanced_text =>
        { -parse => 'Text::Query::ParseAdvanced',
          -build => 'Text::Query::BuildAdvancedString',
          -optimize => 'Text::Query::Optimize',
          -solve => 'Text::Query::SolveAdvancedString'
        },
    );

    my $default=(defined $args{-mode})?$args{-mode}:'simple_text';
    my($key);
    foreach $key (keys(%{$defconfigs{$default}})) {
        my($package) = $args{$key} ? $args{$key} : $defconfigs{$default}{$key};
	my($load) = !exists($self->{'packages'}{$key}) || $self->{'packages'}{$key} ne $package;

	if($load) {
	    $self->{$key} = $self->loader($package);
	    $self->{$key}->{-verbose} = $self->{-verbose};
	    warn("loaded $package => $self->{$key}") if($self->{-verbose});
	    $self->{'packages'}{$key} = $package;
	}
    }
    $self->{-parse}->{-build} = $self->{-build};
}

sub loader {
    my($self, $package) = @_;

    eval "package Text::Query::_firesafe; require $package";

    if ($@) {
	my($advice) = "";
	if($@ =~ /Can't find loadable object/) {
	    $advice = "Perhaps $package was statically linked into a new perl binary."
		 ."\nIn which case you need to use that new perl binary."
		 ."\nOr perhaps only the .pm file was installed but not the shared object file."
	} elsif ($@ =~ /Can't locate.*?.pm/) {
	    $advice = "Perhaps the $package perl module hasn't been installed\n";
	}
	croak("$package failed: $@$advice\n");
    }
    my($object);
    $object = eval { $package->new() };
    croak("$@") if(!defined($object));

    return $object;
}

sub matchexp {
    my($self) = @_;

    return $self->{matchexp};
}

sub matchstring {
    my($self) = @_;

    return $self->{-build}->matchstring();
}

#
# Parse interface
#

sub prepare {
  my($self) = shift;

  $self->{matchexp} = $self->{-optimize}->optimize($self->{-parse}->prepare(@_));

  return $self;
}

#
# Solve interface
#

sub match {
    my($self) = shift;

    croak("solve undefined") if(!$self->{-solve});

    return $self->{-solve}->match($self->{matchexp}, @_);
}

sub matchscalar {
    my($self) = shift;

    croak("solve undefined") if(!$self->{-solve});

    return $self->{-solve}->matchscalar($self->{matchexp}, @_);
}

#
# Accessors
#

sub build {
    my($self) = shift;
    return $self->{-build};
}

sub parse {
    my($self) = shift;
    return $self->{-parse};
}

sub solve {
    my($self) = shift;
    return $self->{-solve};
}

sub optimize {
    my($self) = shift;
    return $self->{-optimize};
}

1;

__END__