package Lire::FilterExpr;

use strict;

use Carp;

use vars qw( $VERSION );

BEGIN {
    ($VERSION)	= '$Revision: 1.8 $' =~ m!Revision: ([.\d]+)!;
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my %args = @_;

    croak "container argument must be of type Lire::XMLSpecContainer"
      unless UNIVERSAL::isa( $args{container}, "Lire::XMLSpecContainer" );

    my $self = bless { container => $args{container},
		     }, $class;

    $self;
}

sub check_value {
    my ( $self, $value ) = @_;

    # Make sure that value references defined field or param
    if ( $value =~ /^\$/ ) {
	my $n = substr $value, 1;

	croak "$n isn't a defined field name or param name"
	  unless $self->{container}->has_param( $n ) ||
	    $self->{container}->schema()->has_field( $n );
    }
}

sub field_from_var {
    my ( $self, $value ) = @_;

    if ( $value =~ /^\$/ ) {
	my $n = substr $value, 1;

	return undef
	  if $self->{container}->has_param( $n );

	return $self->{container}->schema()->field( $n );
    }
    return undef;
}

sub print {
    die __PACKAGE__  . ": unimplemented abstract method";
}

package Lire::FilterExpr::BinaryExpr;

use vars qw( @ISA );

use Lire::XMLUtils qw/xml_encode/;

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ );

    my %args = @_;
    croak "missing 'arg1' argument to " . __PACKAGE__ . "::new"
      unless exists $args{arg1};
    croak "missing 'arg2' argument to " . __PACKAGE__ . "::new"
      unless exists $args{arg1};
    croak "missing 'op' argument to " . __PACKAGE__ . "::new"
      unless exists $args{arg1};

    $self->{op}	  = $args{op};
    $self->arg1(  $args{arg1} );
    $self->arg2(  $args{arg2} );

    $self;
}

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

    if ( defined $arg1) {
	$self->check_value( $arg1 );
	$self->{arg1} = $arg1;
    }

    $self->{arg1};
}

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

    if ( defined $arg2) {
	$self->check_value( $arg2 );
	$self->{arg2} = $arg2;
    }

    $self->{arg2};
}

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

    my @fields = ();
    my $field1 = $self->field_from_var( $self->arg1 );
    push @fields, $field1
      if defined $field1;

    my $field2 = $self->field_from_var( $self->arg2 );
    push @fields, $field2
      if defined $field2;

    @fields;
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    my $pfx = " " x $prefix;
    my $arg1 = xml_encode( $self->{arg1} );
    my $arg2 = xml_encode( $self->{arg2} );

    print $fh $pfx,
      qq{<lire:$self->{op} arg1="$arg1" arg2="$arg2"/>\n};
}

package Lire::FilterExpr::Eq;

use vars qw( @ISA );

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "eq" );
}

package Lire::FilterExpr::Ne;

use vars qw( @ISA );

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "ne" );
}

package Lire::FilterExpr::BinaryNumericExpr;

use vars qw( @ISA );

use Lire::DataTypes qw( check_number );

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryExpr );
}

sub check_value {
    my ( $self, $value ) = @_;
    $self->SUPER::check_value( @_ );

    if ( $value =~ /^$/) {
	my $name = substr $value, 1;
	my $type;
	# Make sure it has the proper type
	if ( $self->{container}->has_param( $name ) ) {
	    $type = $self->{container}->param( $name )->type;
	} else {
	    $type = $self->{container}->schema()->field( $name )->type;
	}
	croak "variable must be a numeric type"
	  unless is_numeric_type( $type );
    } else {
	croak "literal isn't an int or number"
	  unless check_number( $value );
    }
}

package Lire::FilterExpr::Lt;

use vars qw( @ISA );

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryNumericExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "lt" );
}

package Lire::FilterExpr::Le;

use vars qw( @ISA );

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryNumericExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "le" );
}

package Lire::FilterExpr::Gt;

use vars qw( @ISA );

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryNumericExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "gt" );
}

package Lire::FilterExpr::Ge;

use vars qw( @ISA );

use Lire::XMLUtils qw/xml_encode/;

BEGIN {
    @ISA = qw( Lire::FilterExpr::BinaryNumericExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ , op => "ge" );
}

package Lire::FilterExpr::Match;

use vars qw( @ISA );

use Lire::DataTypes qw( check_bool eval_bool );
use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ );

    my %args = @_;
    croak "missing 'value' argument to " . __PACKAGE__ . "::new"
      unless exists $args{value};
    croak "missing 're' argument to " . __PACKAGE__ . "::new"
      unless exists $args{re};

    $self->value( $args{value} );
    $self->re( $args{re} );
    $self->case_sensitive( $args{'case-sensitive'} || 0 );

    $self;
}

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

    if ( defined $value) {
	$self->check_value( $value );
	$self->{value} = $value;
    }

    $self->{value};
}

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

    if ( defined $re) {
	$self->check_value( $re );
	$self->{re} = $re;
    }

    $self->{re};
}

sub case_sensitive {
    my ( $self, $cs ) = @_;

    if ( defined $cs ) {
	croak "invalid bool value : $cs"
	  unless check_bool( $cs );
	$self->{case_sensitive} = $cs;
    }

    eval_bool( $self->{case_sensitive});
}

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

    my @fields = ();

    my $value_field = $self->field_from_var( $self->value );
    push @fields, $value_field if defined $value_field;

    my $re_field = $self->field_from_var( $self->re );
    push @fields, $re_field if defined $re_field;

    @fields;
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    my $pfx = " " x $prefix;
    my $value = xml_encode( $self->{value} );
    my $re    = xml_encode( $self->{re} );

    print $fh $pfx, qq{<lire:match value="$value" re="$re"};
    if (defined $self->{case_sensitive}) {
	    print $fh qq{ case-sensitive="$self->{case_sensitive}"};
    }
    print $fh "/>\n";
}

package Lire::FilterExpr::Value;

use vars qw( @ISA );

use Lire::XMLUtils qw/xml_encode/;

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = $class->SUPER::new( @_ );

    my %args = @_;
    croak "missing 'value' argument to " . __PACKAGE__ . "::new"
      unless exists $args{value};

    $self->value( $args{value} );

    $self;
}

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

    if ( defined $value) {
	$self->check_value( $value );

	$self->{value} = $value;
    }

    $self->{value};
}

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

    my @fields = ();

    my $value_field = $self->field_from_var( $self->value );
    if ( defined $value_field ) {
	return ( $value_field );
    } else {
	return ();
    }
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    my $pfx = " " x $prefix;
    my $value = xml_encode( $self->{value} );
    print $fh $pfx, qq{<lire:value value="$value"/>\n};
}

package Lire::FilterExpr::Not;

use vars qw( @ISA );

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

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

    if (defined $expr ) {
	croak "$expr isn't an expression"
	  unless UNIVERSAL::isa( $expr, 'Lire::FilterExpr' );
	$self->{expr} = $expr;
    }

    $self->{expr};
}

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

    return $self->expr->needed_fields();
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    croak "invalid not expression: missing child"
      unless defined $self->{expr};

    my $pfx = " " x $prefix;
    print $fh $pfx, "<lire:not>\n";
    $self->{expr}->print( $fh, $prefix + 1 );
    print $fh $pfx, "</lire:not>\n";
}

package Lire::FilterExpr::And;

use vars qw( @ISA );

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

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

    if (defined $expr ) {
	croak "$expr should be an array reference of expressions"
	  unless UNIVERSAL::isa( $expr, 'ARRAY' );

	croak "and must contains at leat one expression" unless @$expr;

	foreach my $e ( @$expr) {
	    croak "$e isn't an expression"
	      unless UNIVERSAL::isa( $e, 'Lire::FilterExpr' );
	}
	$self->{expr} = $expr;
    }

    $self->{expr};
}

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

    my @fields = ();

    foreach my $e ( @{$self->expr}) {
	push @fields, $e->needed_fields;
    }

    @fields;
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    croak "invalid and expression: missing children"
      unless ref $self->{expr} eq 'ARRAY' &&
	@{$self->{expr}};

    my $pfx = " " x $prefix;
    print $fh $pfx, "<lire:and>\n";
    foreach my $e ( @{$self->{expr}}) {
	$e->print( $fh, $prefix + 1 );
    }
    print $fh $pfx, "</lire:and>\n";
}

package Lire::FilterExpr::Or;

use vars qw( @ISA );

use Carp;

BEGIN {
    @ISA = qw( Lire::FilterExpr );
}

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

    if (defined $expr ) {
	croak "$expr should be an array reference of expressions"
	  unless UNIVERSAL::isa( $expr, 'ARRAY' );
	croak "or must contains at leat one expression" unless @$expr;

	foreach my $e ( @$expr) {
	    croak "$e isn't an expression"
	      unless UNIVERSAL::isa( $e, 'Lire::FilterExpr' );
	}
	$self->{expr} = $expr;
    }

    $self->{expr};
}

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

    my @fields = ();

    foreach my $e ( @{$self->expr}) {
	push @fields, $e->needed_fields;
    }

    @fields;
}

sub print {
    my ($self,$fh, $prefix) = @_;
    $fh	    ||= \*STDOUT;
    $prefix ||= 0;

    croak "invalid or expression: missing children"
      unless ref $self->{expr} eq 'ARRAY' &&
	@{$self->{expr}};

    my $pfx = " " x $prefix;
    print $fh $pfx, "<lire:or>\n";
    foreach my $e ( @{$self->{expr}}) {
	$e->print( $fh, $prefix + 1 );
    }
    print $fh $pfx, "</lire:or>\n";
}

# keep perl happy
1;

__END__

=pod

=head1 NAME

Lire::FilterExpr -

=head1 SYNOPSIS


=head1 DESCRIPTION

=head1 VERSION

$Id: FilterExpr.pm,v 1.8 2002/03/16 18:53:09 flacoste Exp $

=head1 COPYRIGHT

Copyright (C) 2001 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire 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 of the License, or
(at your option) any later version.

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 (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html or write to the Free Software 
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111, USA.

=head1 AUTHOR

Francis J. Lacoste <flacoste@logreport.org>

=cut
