← Back to branch summary

~ubuntu-branches/ubuntu/precise/bioperl/precise

« back to all changes in this revision

Viewing changes to Bio/DB/SeqFeature/Store/berkeleydb.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2011-06-17 13:51:18 UTC
  • mfrom: (3.1.6 sid)
  • Revision ID: james.westby@ubuntu.com-20110617135118-hncy38e0134j8oi5
Tags: 1.6.901-1
* New upstream release.
* Point debian/watch to search.cpan.org.
* Build using dh and overrides:
  - Use Debhelper 8 (debian/rules, debian/control).
  - Simplified debian/rules.
* Split into libbio-perl-perl, as discussed with the Debian Perl team.
  (debian/control, debian/bioperl.install, debian libbio-perl-perl.install)
* debian/control:
  - Incremented Standards-Version to reflect conformance with Policy 3.9.2.
    No other changes needed.
  - Vcs-Browser URL made redirectable to viewvc.
  - Removed useless ‘svn’ in the Vcs-Svn URL.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/SeqFeature/Store/berkeleydb.pm
1
1
package Bio::DB::SeqFeature::Store::berkeleydb;
2
2
 
3
 
# $Id: berkeleydb.pm 16091 2009-09-15 22:11:15Z cjfields $
4
 
 
5
3
use strict;
6
4
use base 'Bio::DB::SeqFeature::Store';
7
5
use Bio::DB::GFF::Util::Rearrange 'rearrange';
646
644
    for my $idx ($self->_index_files) {
647
645
        my $path = $self->_qualify("$idx.idx");
648
646
        my %db;
649
 
        tie(%db,'DB_File',$path,$flags,0666,$DB_BTREE)
650
 
            or $self->throw("Couldn't tie $path: $!");
 
647
        my $result = tie(%db,'DB_File',$path,$flags,0666,$DB_BTREE);
 
648
        # for backward compatibility, allow a failure when trying to open the is_indexed index.
 
649
        $self->throw("Couldn't tie $path: $!") unless $result || $idx eq 'is_indexed';
651
650
        %db = () if $create;
652
651
        $self->index_db($idx=>\%db);
653
652
    }
732
731
  my $self    = shift;
733
732
  my $indexed = shift;
734
733
  my $db   = $self->db;
 
734
  my $is_indexed = $self->index_db('is_indexed');
735
735
  my $count = 0;
736
736
  for my $obj (@_) {
737
737
    my $primary_id = $obj->primary_id;
738
738
    $self->_delete_indexes($obj,$primary_id)  if $indexed && $primary_id;
739
739
    $primary_id    = $db->{'.next_id'}++      unless defined $primary_id;
740
740
    $db->{$primary_id} = $self->freeze($obj);
 
741
    $is_indexed->{$primary_id} = $indexed if $is_indexed;
741
742
    $obj->primary_id($primary_id);
742
743
    $self->_update_indexes($obj)              if $indexed;
743
744
    $count++;
775
776
  for my $child (@children) {
776
777
    my $child_id = ref $child ? $child->primary_id : $child;
777
778
    defined $child_id or $self->throw("no primary ID known for $child");
778
 
    $p->{$parent_id} = $child_id;
 
779
    $p->{$parent_id} = $child_id if tied(%$p)->find_dup($parent_id,$child_id);
779
780
  }
 
781
  return scalar @children;
780
782
}
781
783
 
782
784
sub _fetch_SeqFeatures {
791
793
  my @children      = map {$self->fetch($_)} @children_ids;
792
794
 
793
795
  if (@types) {
794
 
    my $regexp = join '|',map {quotemeta($_)} $self->find_types(@types);
795
 
    return grep {($_->primary_tag.':'.$_->source_tag) =~ /^$regexp$/i} @children;
 
796
      foreach (@types) { 
 
797
          my ($a,$b) = split ':',$_,2;
 
798
          $_  = quotemeta($a);
 
799
          if (length $b) {
 
800
              $_ .= ":".quotemeta($b).'$';
 
801
          } else {
 
802
              $_ .= ':';
 
803
          }
 
804
      }
 
805
      my $regexp = join '|', @types;
 
806
      return grep {($_->primary_tag.':'.$_->source_tag) =~ /^($regexp)/i} @children;
796
807
  } else {
797
 
    return @children;
 
808
      return @children;
798
809
  }
799
810
}
800
811
 
934
945
  $d;
935
946
}
936
947
 
 
948
# the is_indexed_db 
 
949
sub is_indexed_db {
 
950
  my $self = shift;
 
951
  my $d = $self->setting('is_indexed_db');
 
952
  $self->setting(is_indexed_db=>shift) if @_;
 
953
  $d;
 
954
}
 
955
 
937
956
# The indicated index berkeley db
938
957
sub index_db {
939
958
  my $self = shift;
952
971
 
953
972
# return names of all the indexes
954
973
sub _index_files {
955
 
  return qw(names types locations attributes);
 
974
  return qw(names types locations attributes is_indexed);
956
975
}
957
976
 
958
977
# the directory in which we store our indexes
1045
1064
 
1046
1065
  my @result;
1047
1066
  unless (defined $name or defined $seq_id or defined $types or defined $attributes) {
1048
 
    @result = grep {!/^\./} keys %{$self->db};
 
1067
      my $is_indexed = $self->index_db('is_indexed');
 
1068
      @result = $is_indexed ? grep {$is_indexed->{$_}} keys %{$self->db}
 
1069
                            : grep { !/^\./ }keys %{$self->db};
1049
1070
  }
1050
1071
 
1051
1072
  my %found = ();
1428
1449
sub DESTROY {
1429
1450
  my $self = shift;
1430
1451
  $self->_close_databases();
1431
 
  rmtree($self->directory,0,1) if $self->temporary;
 
1452
  rmtree($self->directory,0,1) if $self->temporary && -e $self->directory;
1432
1453
}
1433
1454
 
1434
1455
# TIE interface -- a little annoying because we are storing magic ".variable"
1467
1488
  my $obj  = $self->fetch($id) or return;
1468
1489
  $self->_delete_indexes($obj,$id);
1469
1490
  delete $self->db->{$id};
 
1491
  1;
1470
1492
}
1471
1493
 
1472
1494
sub _clearall {