view release on metacpan or  search on metacpan

lib/Bio/DB/SeqFeature/Store/Alias.pm  view on Meta::CPAN

sub _filter_ids_by_name {
    my $self = shift;
    my ($name,$ids) = @_;
    my $atts = $self->{attributes};
    my @result = grep {($atts->{$_}{display_name} || $atts->{$_}{name}) eq $name} @$ids;
    return @result;
}

sub _filter_ids_by_attribute {
    my $self = shift;
    my ($attributes,$ids) = @_;

    my @result;
    my %ids = map {$_=>1} @$ids;
    for my $att_name (keys %$attributes) {
	my @search_terms = ref($attributes->{$att_name}) && ref($attributes->{$att_name}) eq 'ARRAY'
	                   ? @{$attributes->{$att_name}} : $attributes->{$att_name};
	for my $id (keys %ids) {
	    my $ok;
	    
	    for my $v (@search_terms) {
		my $att = $self->{attributes}{$id} or next;
		my $val = $att->{lc $att_name}     or next;
		if (my $regexp = $self->glob_match($v)) {
		    $ok++ if $val =~ /$regexp/i;
		} else {
		    $ok++ if lc $val eq lc $v;
		}
	    }
	    delete $ids{$id} unless $ok;
	}
    }
    return keys %ids;
}

sub glob_match {
  my $self = shift;
  my $term = shift;
  return unless $term =~ /(?:^|[^\\])[*?]/;
  $term =~ s/(^|[^\\])([+\[\]^{}\$|\(\).])/$1\\$2/g;
  $term =~ s/(^|[^\\])\*/$1.*/g;
  $term =~ s/(^|[^\\])\?/$1./g;
  return $term;
}

sub _parse_metadb {
    my $self = shift;
    my $file = $self->index;

    my $f;
    if ($file =~ /^(ftp|http):/i) {
	eval "require LWP::UserAgent; 1"
	    or die "LWP::UserAgent module is required for remote metadata indexes"
	    unless LWP::UserAgent->can('new');
	my $ua = LWP::UserAgent->new;
	my $r  = $ua->get($file);
	die "Couldn't read $file: ",$r->status_line unless $r->is_success;
	eval "require IO::String; 1" 
	    or die "IO::String module is required for remote directories"
	    unless IO::String->can('new');
	$f = IO::String->new($r->decoded_content);
    }
    else {
	$f = IO::File->new($file) or die "$file: $!";
    }
    my ($current_feature,%features);

    while (<$f>) {
	chomp;
	s/\s+$//;   # strip whitespace at ends of lines
	# strip right-column comments unless they look like colors or html fragments
	s/\s*\#.*$// unless /\#[0-9a-f]{6,8}\s*$/i || /\w+\#\w+/ || /\w+\"*\s*\#\d+$/;   
	if (/^\[([^\]]+)\]/) {  # beginning of a configuration section
	    $current_feature = $1;
	}

	elsif ($current_feature && /^([\w: -]+?)\s*=\s*(.*)/) {  # key value pair
	    my $tag = lc $1;
	    my $value = defined $2 ? $2 : '';
	    $features{$current_feature}{$tag}=$value;
	}
    }

    for my $f (keys %features) {
	my $attributes = $features{$f};
	$self->set_feature_attributes($f,$attributes);
    }

    return $self->{attributes};
}

sub set_feature_attributes {
    my $self = shift;
    my ($feature,$attributes) = @_;
    if (my $old = $self->{attributes}{$feature}) {
	%$attributes = (%$old,%$attributes);  # merge
    }
    $self->{features}{$feature}    ||= undef;
    $self->{attributes}{$feature}    = $attributes;
}

package Bio::DB::SeqFeature::Store::Alias::Iterator;

sub new {
    my $class = shift;
    my ($db,$ids,$search_opts) = @_;
    return bless {db          => $db,
		  ids         => $ids,
		  search_opts => $search_opts,
    },ref $class || $class;
}

sub next_seq {
    my $self = shift;
    my $db   = $self->{db};
    my $opts = $self->{search_opts};
    while (1) {
	return unless @{$self->{ids}};
	my $name = shift @{$self->{ids}};
	
	my ($next) = $db->store->get_features_by_alias($name) or next;