bioperl-dev QRY
Other packages in the module: Bio::DB::HIV::HIVQueryHelper HIVSchema QRY R Q
Package variablesDescriptionGeneral documentationMethods
Toolbar
WebCvs
Package variables
No package variables defined.
Synopsis
No synopsis!
Description
Class R objects contain a list of atomic queries (class Q
objects). Each class R object represents a single HTTP request to the
LANL DB. When converted to a DB query, the class Q objects contained
by an R object are effectively ANDed.
Methods
_make_qDescriptionCode
_make_q_gutsDescriptionCode
_parse_qDescriptionCode
new
No description
Code
requestsDescriptionCode
put_requestsDescriptionCode
isnullDescriptionCode
ADescriptionCode
lenDescriptionCode
cloneDescriptionCode
OrDescriptionCode
AndDescriptionCode
BoolDescriptionCode
EqDescriptionCode
Methods description
_make_qcode    nextTop
 Title   : _make_q 
 Usage   : QRY::_make_q($parsetree)
 Function: creates hash structures suitable for HIVQuery from parse tree
           returned by QRY::_parse_q
 Example :
 Returns : array of hashrefs of query specs
 Args    : a hashref
_make_q_gutscodeprevnextTop
 Title   : _make_q_guts (Internal class method)
 Usage   : _make_q_guts($ptree, $q_expr, $qarry, $anarry)
 Function: traverses the parse tree returned from QRY::_parse_q, checking
           syntax and creating HIVQuery-compliant query structures
 Example :
 Returns : 
 Args    : $parse_tree (hashref), $query_expression (scalar string ref),
           $query_array (array ref : stack for returning query structures),
           $annotation_array (array ref : stack for returning annotation
           fields)
_parse_qcodeprevnextTop
 Title   : _parse_q 
 Usage   : QRY::_parse_q($query_string)
 Function: perform first pass parse of a query string with some syntax 
           checking, return a parse tree suitable for QRY::_make_q
 Example : QRY::_parse_q(" to[be] OR (not to)[be] ");
 Returns : hashref
 Args    : query string
requestscodeprevnextTop
 Title   : requests
 Usage   : $QRY->requests
 Function: get/set array of requests comprising this QRY object
 Example :
 Returns : 
 Args    : array of class R objects
put_requestscodeprevnextTop
 Title   : put_requests
 Usage   : $QRY->put_request(@R)
 Function: add object of class R to $QRY
 Example :
 Returns : 
 Args    : [an array of] of class R object[s]
isnullcodeprevnextTop
 Title   : isnull
 Usage   : $QRY->isnull
 Function: test if QRY object is null
 Example :
 Returns : 1 if null, 0 otherwise
 Args    :
AcodeprevnextTop
 Title   : A
 Usage   : print $QRY->A
 Function: get a string representation of QRY object
 Example :
 Returns : string scalar
 Args    :
lencodeprevnextTop
 Title   : len
 Usage   : $QRY->len
 Function: get number of class R objects contained by QRY object
 Example :
 Returns : scalar
 Args    :
clonecodeprevnextTop
 Title   : clone
 Usage   : $QRY2 = $QRY1->clone;
 Function: create and return a clone of the object
 Example :
 Returns : object of class QRY
 Args    :
OrcodeprevnextTop
 Title   : Or 
 Usage   : $QRY3 = QRY::Or($QRY1, $QRY2)
 Function: logical OR for QRY objects
 Example :
 Returns : a QRY object
 Args    : two class QRY objects
AndcodeprevnextTop
 Title   : And 
 Usage   : $QRY3 = QRY::And($QRY1, $QRY2)
 Function: logical AND for QRY objects
 Example :
 Returns : a QRY object
 Args    : two class QRY objects
BoolcodeprevnextTop
 Title   : Bool 
 Usage   : QRY::Bool($QRY1)
 Function: allows symbolic testing of QRY object when bool overloaded
 Example : do {stuff} if $QRY1 *same as* do {stuff} if !$QRY1->isnull
 Returns : 
 Args    : a class QRY object
EqcodeprevnextTop
 Title   : Eq 
 Usage   : QRY::Eq($QRY1, $QRY2)
 Function: test if R objects in two QRY objects are the same
           (irrespective of order)
 Example : 
 Returns : 1 if equal, 0 otherwise
 Args    : two class QRY objects
Methods code
_make_qdescriptionprevnextTop
sub _make_q {
    my $ptree = shift;
    my ($q_expr, @q, @an, $query, @dbq);
    _make_q_guts($ptree,\$ q_expr,\@ q,,\@ an);
    $query = eval $q_expr;
    throw Bio::Root::Root(-class=>'Bio::Root::Exception',
			  -text=>$@,
			  -value=>$q_expr) if $@;
    return {} if $query->isnull;
    foreach my $rq ($query->requests) {
	my $h = {'query'=>{}};
	foreach ($rq->atoms) {
	    my @d = split(/\s+/, $_->dta);
	    foreach my $d (@d) {
		$d =~ s/[+]/ /g; ###! _ to [+]
		$d =~ s/'//g;
	    }
	    $h->{'query'}{$_->fld} = (@d == 1) ? $d[0] : [@d];
	}
	$h->{'annot'} = [@an] if @an;
	push @dbq, $h;
    }
    return @dbq;
}
_make_q_gutsdescriptionprevnextTop
sub _make_q_guts {
    my ($ptree, $q_expr, $qarry, $anarry) = @_;
    my (@words, $o);
    eval { # catch
	foreach (@{$ptree->{cont}}) {
	    m{^AND$} && do {
		$$q_expr .= "&";
		next;
	    };
	    m{^OR$} && do {
		$$q_expr .= "|";
		next;
	    };
	    m{^HASH} && do {
		for my $dl ($_->{delim}) {
		    ($dl =~ m{\(}) && do {
			if (grep /^HASH/, @{$_->{cont}}) {
			    $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
			    $$q_expr .= "(";
			    _make_q_guts($_,$q_expr,$qarry,$anarry);
			    $$q_expr .= ")";
			}
			else {
			    my @c;
			    my $c = join(' ',@{$_->{cont}});
			    $c =~ s/,/ /g;
			    Bio::Root::Root->throw("query syntax error: unmatched ['\"]") if (@c = ($c =~ /(['"])/g)) % 2;
			    @c = split(/\s*(['"])\s*/, $c);
			    do {
				$c = shift @c;
				if ($c =~ m{['"]}) {
				    $c = join('', ($c, shift @c, shift @c));
				    $c =~ s/\s+/+/g; ###! _ to +
				    push @words, $c;
				}
				else { 
				    push @words, split(/\s+/,$c);
				}
			    } while @c;
			} 
			last;
		    };
		    ($dl =~ m{\[}) && do {
			Bio::Root::Root->throw("syntax error: empty field descriptor") unless @{$_->{cont}};
			Bio::Root::Root->throw("syntax error: more than one field descriptor in square brackets") unless @{$_->{cont}} == 1;
			
			push @{$qarry}, new QRY( new R( new Q( $_->{cont}->[0], @words)));
			# add default operation if nec
			$$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
			$$q_expr .= "\$q[".$#$qarry."]";
			@words = ();
			last;
		    };
		    ($dl =~ m{\{}) && do {
			foreach my $an (@{$_->{cont}}) {
			    ($an =~ /^HASH/) && do {
				if ($an->{delim} eq '[') {
				    push @$anarry, @{$an->{cont}};
				}
				else {
				    Bio::Root::Root->throw("query syntax error: only field descriptors (with or without square brackets) allowed in annotation spec");
				}
				next;
			    };
			    do { #else
				push @$anarry, $an;
				next;
			    };
			}
			last;
		    };
		    do {
			1; #else stub
		    };
		}
		next;
	    };
	    do { # else, bareword 
		if ($o) {
		    $words[-1] .= "+$_"; ####! _ to +
		} 
		else {
		    push @words, $_;
		}
		m/['"]/ && ($o = !$o);
	    };
	} # @{ptree->{cont}}
	Bio::Root::Root->throw("query syntax error: no search fields specified") 
	    unless $$q_expr =~ /q\[[0-9]+\]/;
    };
    $@ ?
	throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception',
			      -text=>$@,
			      -value=>$$q_expr)
	: return 1;
}
_parse_qdescriptionprevnextTop
sub _parse_q {
    local $_;
    my $qstr = shift;
    my $illegal = qr/[^a-zA-Z0-9-_<>=,\.\(\[\{\}\]\)\s'"]/;
    my $pdlm = qr/[\{\[\(\)\]\}]/;
    my %md = ('('=>')', '['=>']','{'=>'}');
    my @tok =  grep !/^\s*$/, split /($pdlm)/, $qstr;
    return {} unless @tok;
    my @pstack = ();
    my @dstack = ();
    my ($ptree, $p);
    
    eval { #catch
	Bio::Root::Root->throw("query syntax error: illegal character") if $qstr =~ /$illegal/;
	
	$ptree = $p = {'delim'=>'*'};
	foreach (@tok) {
	    #trim whsp
	    s/^\s+//;
	    s/\s+$//;
	    m{[\(\[\{]} && do {
		my $new = {'delim'=>$_};
		$p->{cont} = [] unless $p->{cont};
		push @{$p->{cont}}, $new;
		push @pstack, $p;
		push @dstack, $_;
		$p = $new;
		next;
	    };
	    m{[\)\]\}]} && do {
		my $d = pop @dstack;
		if ($md{$d} eq $_) {
		    $p = pop @pstack;
		    Bio::Root::Root->throw("query syntax error: unmatched\" $_\"") unless $p;
		}
		else {
		    Bio::Root::Root->throw("query syntax error: saw\" $_\" before matching\" $md{$d}\"");
		}
		next;
	    };
	    do { # else
		$p->{cont} = [] unless $p->{cont};
		push @{$p->{cont}}, split(/\s+/);
	    };
	}
    };
    $@ ? 
	throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception',
			      -text=>$@,
			      -value=>"")
	: return $ptree;
}

## QRY constructor
}
newdescriptionprevnextTop
sub new {
    my $class = shift; 
    my @args = @_;
    my $self = {};
    $self->{requests} = [];
    bless($self, $class);
    $self->put_requests(@args) if @args;
    return $self;
}

## QRY instance methods
}
requestsdescriptionprevnextTop
sub requests {
    my $self = shift;
    $self->put_requests(@_) if @_;
    return @{$self->{'requests'}};
}
put_requestsdescriptionprevnextTop
sub put_requests {
    my $self = shift;
    my @args = @_;
    foreach (@args) {
	Bio::Root::Root->throw('requires type R (request)') unless ref && $_->isa('R');
	push @{$self->{requests}}, $_;
    }
    return @args;
}
isnulldescriptionprevnextTop
sub isnull {
    my $self = shift;
    return ($self->requests) ? 0 : 1;
}
AdescriptionprevnextTop
sub A {
    my $self = shift;
    return join( "\n", map {$_->A} $self->requests );
}
lendescriptionprevnextTop
sub len {
    my $self = shift;
    return scalar @{$self->{'requests'}};
}
clonedescriptionprevnextTop
sub clone {
    local $_;
    my $self = shift;
    my $ret = new QRY();
    foreach ($self->requests) {
	$ret->put_requests($_->clone);
    }
    return $ret;
}

## QRY class methods
}
OrdescriptionprevnextTop
sub Or {
    local $_;
    my ($q, $r, $rev_f) = @_;
    Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
    Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
    if ($q->isnull) {
	return $r->clone;
    }
    elsif ($r->isnull) {
	return $q->clone;
    }
    do {my $qq = $q; $q=$r; $r=$qq} if ($q->len > $r->len);
    my @rq_r = $r->requests;
    my @rq_q = $q->requests;
    my (@cand_rq, @ret_rq);
    # search for simplifications
    my @now = @rq_q;
    my @nxt =();
    foreach (@rq_r) {
	my $found = 0;
	while (my $rq = pop @now) {
	    my @result = R::Or($rq, $_);
	    if (@result==1) {
		push @cand_rq, $result[0]->clone;
		$found = 1;
		last;
	    }
	    else {
		push @nxt, $rq;
	    }
	}
	push @cand_rq, $_->clone unless ($found);
	# @now becomes unexamined @rq_q's plus failed @rq_q's
	@now = (@now, @nxt);
    }
    push @cand_rq, map {$_->clone} @now; # add all failed @rq_q's
    # squeeze out redundant requests
    while (my $rq = pop @cand_rq) {
	push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq;
    }
    return new QRY( @ret_rq );
}
AnddescriptionprevnextTop
sub And {
    my ($q, $r, $rev_f) = @_;
    Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
    Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
    return ($QRY::NULL) if ($q->isnull || $r->isnull);
    my (@cand_rq, @ret_rq);
    foreach my $rq_r ($r->requests) {
	foreach my $rq_q ($q->requests) {
	    my ($rq) = R::And($rq_r, $rq_q);
	    push @cand_rq, $rq unless $rq->isnull;
	}
    }
    return $QRY::NULL unless @cand_rq;
    # squeeze out redundant requests
    while (my $rq = pop @cand_rq) {
	push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq;
    }
    return new QRY( @ret_rq );
}
BooldescriptionprevnextTop
sub Bool {
    my $q = shift;
    Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
    return $q->isnull ? 0 : 1;
}
EqdescriptionprevnextTop
sub Eq {
    my ($q, $r, $rev_f) = @_;
    Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
    Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
    return 0 unless $q->len == $r->len;
    foreach my $rq_q ($q->requests) {
	my $found = 0;
	foreach my $rq_r ($r->requests) {
	    if (R::Eq($rq_q,$rq_r)) {
		$found = 1;
		last;
	    }
	}
	return 0 unless $found;
    }
    return 1;
}

1;
}
General documentation
CLASS METHODS(1)Top
CONSTRUCTORTop
QRY ConstructorTop
 Title   : QRY constructor
 Usage   : $QRY = new QRY()
 Function:
 Example :
 Returns : 
 Args    : array of R objects, optional
INSTANCE METHODSTop
CLASS METHODS(2)Top
Class R - request objects for QRY algebraTop
SYNOPSIS Top
  $R = new R( $q1, $q2 );
  $R->put_atoms($q3);
  $R->del_atoms('coreceptor', 'phenotype');
  return $R->clone;
  $R1 = new R( new Q('subtype', 'B') );
  $R2 = new R( new Q('subtype', 'B C'), 
               new Q('country', 'US') );
  R::Eq( (R::And($R1, $R2))[0], 
         new R( new Q('subtype', 'B' ), 
                new Q('country', 'US') ));                 # returns 1
  QRY::Eq( new QRY(R::Or($R1, $R2)), new QRY($R1, $R2) );  # returns 1
  R::In( (R::And($R1, $R2))[0], $R1 );                     # returns 1