lib/Bio/DB/SeqFeature/Store/LoadHelper.pm

   1 package Bio::DB::SeqFeature::Store::LoadHelper;
   2
   3 =head1 NAME
   4
   5 Bio::DB::SeqFeature::Store::LoadHelper -- Internal utility for Bio::DB::SeqFeature::Store
   6
   7 =head1 SYNOPSIS
   8
   9   # For internal use only.
  10
  11 =head1 DESCRIPTION
  12
  13 For internal use only
  14
  15 =head1 SEE ALSO
  16
  17 L<bioperl>,
  18 L<Bio::DB::SeqFeature::Store>,
  19 L<Bio::DB::SeqFeature::Segment>,
  20 L<Bio::DB::SeqFeature::NormalizedFeature>,
  21 L<Bio::DB::SeqFeature::GFF2Loader>,
  22 L<Bio::DB::SeqFeature::Store::DBI::mysql>,
  23 L<Bio::DB::SeqFeature::Store::berkeleydb>
  24
  25 =head1 AUTHOR
  26
  27 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
  28
  29 Copyright (c) 2006 Cold Spring Harbor Laboratory.
  30
  31 This library is free software; you can redistribute it and/or modify
  32 it under the same terms as Perl itself.
  33
  34 =cut
  35
  36 use strict;
  37 use DB_File;
  38 use File::Path 'rmtree';
  39 use File::Temp 'tempdir';
  40 use File::Spec;
  41 use Fcntl qw(O_CREAT O_RDWR);
  42
  43 our $VERSION = '1.12';
  44
  45 my %DBHandles;
  46
  47 sub new {
  48     my $class   = shift;
  49     my $tmpdir  = shift;
  50
  51     my $template = 'SeqFeatureLoadHelper_XXXXXX';
  52
  53     my @tmpargs = $tmpdir ? ($template,DIR=>$tmpdir) : ($template);
  54     my $tmppath = tempdir(@tmpargs,CLEANUP=>1);
  55     my $self    = $class->create_dbs($tmppath);
  56     $self->{tmppath} = $tmppath;
  57     return bless $self,$class;
  58 }
  59
  60 sub DESTROY {
  61     my $self = shift;
  62     # Destroy all filehandle references
  63     # before trying to delete files and folder
  64     %DBHandles = ();
  65     undef $self->{IndexIt};
  66     undef $self->{TopLevel};
  67     undef $self->{Local2Global};
  68     undef $self->{Parent2Child};
  69     rmtree $self->{tmppath};
  70 #    File::Temp::cleanup() unless $self->{keep};
  71 }
  72
  73 sub create_dbs {
  74     my $self = shift;
  75     my $tmp  = shift;
  76     my %self;
  77     # experiment with caching these handles in memory
  78     my $hash_options           = DB_File::HASHINFO->new();
  79     # Each of these hashes allow only unique keys
  80     for my $dbname (qw(IndexIt TopLevel Local2Global)) {
  81         unless ($DBHandles{$dbname}) {
  82             my %h;
  83             tie(%h,'DB_File',File::Spec->catfile($tmp,$dbname),
  84                 O_CREAT|O_RDWR,0666,$hash_options);
  85             $DBHandles{$dbname} = \%h;
  86         }
  87         $self{$dbname} = $DBHandles{$dbname};
  88         %{$self{$dbname}} = ();
  89     }
  90
  91     # The Parent2Child hash allows duplicate keys, so we
  92     # create it with the R_DUP flag.
  93     my $btree_options           = DB_File::BTREEINFO->new();
  94     $btree_options->{flags}     = R_DUP;
  95     unless ($DBHandles{'Parent2Child'}) {
  96         my %h;
  97         tie(%h,'DB_File',File::Spec->catfile($tmp,'Parent2Child'),
  98             O_CREAT|O_RDWR,0666,$btree_options);
  99         $DBHandles{'Parent2Child'} = \%h;
 100     }
 101     $self{Parent2Child}    = $DBHandles{'Parent2Child'};
 102     %{$self{Parent2Child}} = ();
 103     return \%self;
 104 }
 105
 106 sub indexit {
 107     my $self = shift;
 108     my $id   = shift;
 109     $self->{IndexIt}{$id} = shift if @_;
 110     return $self->{IndexIt}{$id};
 111 }
 112
 113 sub toplevel {
 114     my $self = shift;
 115     my $id   = shift;
 116     $self->{TopLevel}{$id} = shift if @_;
 117     return $self->{TopLevel}{$id};
 118 }
 119
 120 sub each_toplevel {
 121     my $self = shift;
 122     my ($id) = each %{$self->{TopLevel}};
 123     $id;
 124 }
 125
 126 sub local2global {
 127     my $self = shift;
 128     my $id   = shift;
 129     $self->{Local2Global}{$id} = shift if @_;
 130     return $self->{Local2Global}{$id};
 131 }
 132
 133 sub add_children {
 134     my $self      = shift;
 135     my $parent_id = shift;
 136     # (@children) = @_;
 137     $self->{Parent2Child}{$parent_id} = shift while @_;
 138 }
 139
 140 sub children {
 141     my $self = shift;
 142     my $parent_id = shift;
 143
 144     my @children;
 145
 146     my $db        = tied(%{$self->{Parent2Child}});
 147     my $key       = $parent_id;
 148     my $value     = '';
 149     for (my $status = $db->seq($key,$value,R_CURSOR);
 150          $status    == 0 && $key eq $parent_id;
 151          $status    = $db->seq($key,$value,R_NEXT)
 152         ) {
 153         push @children,$value;
 154     }
 155     return wantarray ? @children: \@children;
 156 }
 157
 158 # this acts like each() and returns each parent id and an array ref of children
 159 sub each_family {
 160     my $self = shift;
 161
 162     my $db        = tied(%{$self->{Parent2Child}});
 163
 164     if ($self->{_cursordone}) {
 165         undef $self->{_cursordone};
 166         undef $self->{_parent};
 167         undef $self->{_child};
 168         return;
 169     }
 170
 171     # do a slightly tricky cursor search
 172     unless (defined $self->{_parent}) {
 173         return unless $db->seq($self->{_parent},$self->{_child},R_FIRST) == 0;
 174     }
 175
 176     my $parent   = $self->{_parent};
 177     my @children = $self->{_child};
 178
 179     my $status;
 180     while (($status = $db->seq($self->{_parent},$self->{_child},R_NEXT)) == 0
 181            && $self->{_parent} eq $parent
 182         ) {
 183         push @children,$self->{_child};
 184     }
 185
 186     $self->{_cursordone}++ if $status != 0;
 187
 188     return ($parent,\@children);
 189 }
 190
 191 sub local_ids {
 192     my $self = shift;
 193     my @ids  = keys %{$self->{Local2Global}}
 194                    if $self->{Local2Global};
 195     return \@ids;
 196 }
 197
 198 sub loaded_ids {
 199     my $self = shift;
 200     my @ids  = values %{$self->{Local2Global}}
 201                      if $self->{Local2Global};
 202     return \@ids;
 203 }
 204
 205 1;