Bio/DB/SeqFeature/Store/LoadHelper.pm

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