view release on metacpan or  search on metacpan

lib/Class/DBI/ConceptSearch.pm  view on Meta::CPAN

           this instance.  See CONFIGURATION


=cut

sub new {
  my($class,%arg) = @_;

  my $self = bless {}, $class;
  $self->_init(%arg);

  die(__PACKAGE__.' requires an "xml" argument.') unless $self->xml;

  return $self;
}

=head2 _init

 Title   : _init
 Usage   : $obj->_init(%arg);
 Function: internal method.  initializes a new Class::DBI::ConceptSearch object
 Returns : true on success
 Args    : args passed to new()


=cut

sub _init {
  my($self,%arg) = @_;

  foreach my $arg (keys %arg){
    $self->$arg($arg{$arg}) if $self->can($arg);
  }

  *Class::DBI::_do_search = sub {
	my ($proto, $search_type, @args) = @_;
	my $class = ref $proto || $proto;

	@args = %{ $args[0] } if ref $args[0] eq "HASH";
	my (@cols, @vals);
	my $search_opts = @args % 2 ? pop @args : {};
	while (my ($col, $val) = splice @args, 0, 2) {
		#this regex allows the field being searched to be transformed,
		#which can be useful for certain indexes, eg, in postgres:
		#  SELECT * FROM book WHERE lower(title) LIKE 'symbolic logic'
		#can use a functional index defined as:
		#  CREATE INDEX ON book(lower(title))
		#which performs much better than the ILIKE version of the same query:
		#  SELECT * FROM book WHERE title ILIKE 'symbolic logic';

		my($x,$y,$z) = $col =~ /^(.+\()(.+)(\))$/;
		$col = $y if $y;

		my $column = $class->find_column($col)
			|| (List::Util::first { $_->accessor eq $col } $class->columns)
			|| $class->_croak("$col is not a column of $class");
                push @cols, $y ? "$x$col$z" : $col;
		push @vals, $class->_deflated_column($column, $val);
	}

	my $frag = join " AND ",
		map defined($vals[$_]) ? "$cols[$_] $search_type ?" : "$cols[$_] IS NULL",
		0 .. $#cols;
	$frag .= " ORDER BY $search_opts->{order_by}"
		if $search_opts->{order_by};
	return $class->sth_to_objects($class->sql_Retrieve($frag),
		[ grep defined, @vals ]);
  };

  return 1;
}

=head2 search

  Title   : search
  Usage   : $cs->search(concept => 'gene', pattern => 'GH1');
  Function:
  Returns : a (possibly heterogenous) list of objects inheriting from
            Class::DBI.
  Args    : concept (required): conceptual domain to be searched
            pattern (required): pattern to match in each source
            table.field of concept search, as configured.  See CONFIGURATION


=cut

sub search {
  #FIXME: the pod doc for this sub says args should come in as a hash but here they are used as an array.
  my($self,$category,$pattern,$page_num) = @_;

  $page_num = 1 unless defined($page_num);

  return () unless defined($category) and defined($pattern);

  my $search_strategy;

  if(($pattern =~ /\*/s and $self->use_wildcards) or $self->use_implicit_wildcards){
    $pattern =~ s/\*/%/gs;

    $pattern = '%'.$pattern.'%' if $self->use_implicit_wildcards;
  }

  if($self->use_search_ilike){
    $search_strategy = 'search_ilike';
  } elsif($self->use_search_lower){
    $search_strategy = 'search_lower';
  } elsif($pattern =~ /%/) {
    $search_strategy = 'search_like';
  } else {
    $search_strategy = 'search';
  }

  my $config = XML::XPath->new( xml => $self->xml ) or die "couldn't instantiate XML::XPath: $!";

  my @concepts;
  my @hits;
  my @concept_hits =();
  my $page_size = 20;

  #find the page_size for Class::DBI objects that support paging
  foreach my $conceptsearch ($config->find('/conceptsearch')->get_nodelist){
    if(defined($conceptsearch->getAttribute('page_size'))) { $page_size = $conceptsearch->getAttribute('page_size'); }
  }

  #a driver to test the search
  warn "iterate over concepts using $search_strategy" if DEBUG;
  foreach my $concept ($config->find('/conceptsearch/concept')->get_nodelist){
    warn "concept: $category" if DEBUG;
    next unless $category eq $concept->getAttribute('name');
    warn "  searching..." if DEBUG;

    foreach my $source ($concept->find('source')->get_nodelist){
      my $sourceclass = $source->getAttribute('class');
      my $sourcefield = $source->getAttribute('field');

      warn "searching: $sourceclass.$sourcefield for '$pattern' with $search_strategy" if DEBUG;

      my @source_matches;
      # check if the targetclass is able to use the Class::DBI::Pager API
      if ($sourceclass->can("pager")) {
        my $pager = $sourceclass->pager($page_size,$page_num);
        $self->pager($pager);
        (@source_matches) = $pager->$search_strategy($sourcefield => $pattern);
      } else {
        (@source_matches) = $sourceclass->$search_strategy($sourcefield => $pattern);
      } 

      #my(@source_matches) = $sourceclass->$search_strategy( $sourcefield => $pattern );

      if(@source_matches){
        warn "xforms start" if DEBUG;

        foreach my $transform ($source->find('transform')->get_nodelist){
          warn "xform" if DEBUG;

          my $t_sourceclass = $transform->getAttribute('sourceclass'); #unused;
          my $t_sourcefield = $transform->getAttribute('sourcefield');
          my $t_targetclass = $transform->getAttribute('targetclass');
          my $t_targetfield = $transform->getAttribute('targetfield');

          my @t = ();

          foreach my $source_match (@source_matches){
            warn Data::Dumper::Dumper($source_match) if DEBUG;
            warn "$t_targetclass->search( $t_targetfield => ".$source_match->$t_sourcefield." );" if DEBUG;

            my $v =  ref($source_match->$t_sourcefield)
              ? $source_match->$t_sourcefield->id
              : scalar($source_match->$t_sourcefield);

            warn $v if DEBUG;

            # this call is fragile, handle it with care
            #
            # it would add power to allow search_like, search_ilike, or fuzzy searches (eg soundex) here
            # but requires extension of the xml format and *a lot* more code
            my @u = $t_targetclass->search( $t_targetfield => $v );
            push @t, @u;
          }
          @source_matches = @t;
        }

        push @concept_hits, @source_matches;
      }
      warn "xforms end" if DEBUG;
    }

    my %unique_hits = ();
    $unique_hits{ref($_).'_'.$_->id} = $_ foreach @concept_hits;
    push @hits, values %unique_hits;
  }
  # FIXME: should I close the db connection here???
  return @hits;
}

=head2 pager

  Title   : pager
  Usage   : $obj->pager($newval)
  Function: sets/returns the pager object, useful for getting information
            about the complete set of results
  Returns : value of pager
  Args    : on set, new value (a scalar or undef, optional)


=cut

sub pager {
  my $self = shift;

  return $self->{'pager'} = shift if @_;
  return $self->{'pager'};
}

=head2 use_wildcards

  Title   : use_wildcards
  Usage   : $obj->use_wildcards($newval)
  Function: when true, enables search_like/search_ilike from
            search()
  Returns : value of use_wildcards (a scalar)
  Args    : on set, new value (a scalar or undef, optional)


=cut

sub use_wildcards {
  my $self = shift;

  return $self->{'use_wildcards'} = shift if @_;
  return $self->{'use_wildcards'};
}