# -*- Mode: Cperl -*- # Query.pm -- # ITIID : $ITI$ $Header $__Header$ # Author : Ulrich Pfeifer # Created On : Fri Sep 13 13:05:52 1996 # Last Modified By: Ulrich Pfeifer # Last Modified On: Fri Apr 14 16:27:01 2000 # Language : CPerl # Update Count : 57 # Status : Unknown, Use with caution! # # Copyright (c) 1996-1997, Ulrich Pfeifer # package WAIT::Query::Base; sub new { my $type = shift; my $table = shift; my $self = {Table => $table}; bless $self, ref($type) || $type; if (@_) { $self->add(@_); } else { $self; } } sub add { my ($self, $fldorref, %parm) = @_; my @fld = (ref $fldorref)?@$fldorref:$fldorref; my $fld; for $fld (@fld) { if (defined $parm{Plain}) { if (defined $self->{Plain}->{$fld}) { $self->{Plain}->{$fld} .= ' ' . $parm{Plain}; } else { $self->{Plain}->{$fld} = $parm{Plain}; } } if (defined $parm{Raw}) { if (defined $self->{Raw}->{$fld}) { $self->{Raw}->{$fld}->merge($parm{Raw}); } else { $self->{Raw}->{$fld} = $parm{Raw}; } } } $self; } sub merge { my ($self, $other) = @_; my $fld; if (ref($self) ne ref($other)) { return $other->merge($self); } for $fld (keys %{$other->{Plain}}) { $self->add($fld, Plain => $other->{Plain}->{$fld}); } for $fld (keys %{$other->{Raw}}) { $self->add($fld, Raw => $other->{Raw}->{$fld}); } $self; } sub clone { my $self = shift; my %copy; my $fld; for $fld (keys %{$self->{Plain}}) { $copy{Plain}->{$fld} = $self->{Plain}->{$fld}; } for $fld (keys %{$self->{Raw}}) { next unless defined $self->{Raw}->{$fld}; # XXX bug elsewere $copy{Raw}->{$fld} = $self->{Raw}->{$fld}->clone; } $self; } sub execute { my $self = shift; my $tb = $self->{Table}; my %result; my $fld; for $fld (keys %{$self->{Plain}}, keys %{$self->{Raw}}) { %r = $tb->search( { attr => $fld, cont => $self->{Plain}->{$fld}, raw => $self->{Raw}->{$fld}, @_ } ); my ($key, $val); while (($key, $val) = each %r) { if (exists $result{$key}) { $result{$key} += $val; } else { $result{$key} = $val; } } } %result; } sub hilight { my $self = shift; $self->{Table}->hilight($_[0], $self->{Plain}, $self->{Raw}) } sub flatten { my $self = shift; #print STDERR "WAIT::Query::Base::flatten($self)\n"; $self->clone() } package WAIT::Query::bin; sub new { my $type = shift; my $self = [@_]; #print STDERR "WAIT::Query::bin::new $type $self\n"; bless $self, ref($type) || $type; } sub flatten { my $self = shift; #print STDERR "WAIT::Query::bin::flatten($self)\n"; $self->[0]->flatten->merge($self->[1]->flatten) } sub hilight { my $self = shift; my $query = $self->flatten(); $query->hilight(@_); } package WAIT::Query::and; @ISA = qw(WAIT::Query::bin); sub execute { my $self = shift; my %ra = $self->[0]->execute(); my %rb = $self->[1]->execute(); #print STDERR "WAIT::Query::and::execute\n"; for (keys %ra) { if (exists $rb{$_}) { $ra{$_} *= $rb{$_}; delete $ra{$_} if $ra{$_} <= 0; } else { delete $ra{$_}; } } %ra; } sub merge { #print STDERR "WAIT::Query::and::merge(@_)\n"; new WAIT::Query::or @_; # XXX } package WAIT::Query::or; @ISA = qw(WAIT::Query::bin); sub execute { my $self = shift; my %ra = $self->[0]->execute(); my %rb = $self->[1]->execute(); for (keys %ra) { if (exists $rb{$_}) { $ra{$_} += $rb{$_} } } for (keys %rb) { unless (exists $ra{$_}) { $ra{$_} = $rb{$_} } } %ra; } sub merge { my $self = shift; if (ref($_[0]) eq 'WAIT::Query::Base') { $self->[0] = $self->[0]->merge($_[0]); } else { new WAIT::Query::or $self, @_; # XXX } } package WAIT::Query::not; @ISA = qw(WAIT::Query::and WAIT::Query::bin); sub execute { my $self = shift; my %ra = $self->[0]->execute(); my %rb = $self->[1]->execute(); for (keys %ra) { if (exists $rb{$_}) { if (exists $ra{$_}) { $ra{$_} -= $rb{$_}; delete $ra{$_} if $ra{$_} <= 0; } } } %ra; } package WAIT::Query::Raw; use strict; use Carp; sub new { my $type = shift; my $self = shift; $self = {} unless defined $self; bless $self, ref($type) || $type; } sub clone { my $self = shift; my %copy; for (keys %$self) { $copy{$_} = [@{$self->{$_}}]; } $self->new(\%copy); } # Modifies first argument sub merge { my $self = shift; my $other = shift; croak "$other is not at 'WAIT::Query'" unless ref($other) =~ /^WAIT::Query/; for (keys %$other) { if (exists $self->{$_}) { push @{$self->{$_}}, @{$other->{$_}} } else { $self->{$_} = $other->{$_}; } } } 1;