← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
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::Temp 'tempdir';
 
41
use File::Spec;
 
42
use Fcntl qw(O_CREAT O_RDWR);
 
43
 
 
44
sub new {
 
45
    my $class   = shift;
 
46
    my $tmpdir  = shift;
 
47
 
 
48
    my @tmpargs = $tmpdir ? (DIR=>$tmpdir) : ();
 
49
    my $tmppath = tempdir(@tmpargs,CLEANUP=>1);
 
50
    my $self    = $class->create_dbs($tmppath);
 
51
    return bless $self,$class;
 
52
}
 
53
 
 
54
sub create_dbs {
 
55
    my $self = shift;
 
56
    my $tmp  = shift;
 
57
    my %self;
 
58
 
 
59
    my $hash_options           = DB_File::HASHINFO->new();
 
60
 
 
61
    # Each of these hashes allow only unique keys
 
62
    for my $dbname qw(IndexIt TopLevel Local2Global) {
 
63
        my %h;
 
64
        tie(%h,'DB_File',File::Spec->catfile($tmp,$dbname),
 
65
            O_CREAT|O_RDWR,0666,$hash_options);
 
66
        $self{$dbname} = \%h;
 
67
    }
 
68
 
 
69
    # The Parent2Child hash allows duplicate keys, so we
 
70
    # create it with the R_DUP flag.
 
71
    my $btree_options           = DB_File::BTREEINFO->new();
 
72
    $btree_options->{flags}     = R_DUP;
 
73
    my %h;
 
74
    tie(%h,'DB_File',File::Spec->catfile($tmp,'Parent2Child'),
 
75
        O_CREAT|O_RDWR,0666,$btree_options);
 
76
    $self{Parent2Child} = \%h;
 
77
 
 
78
    return \%self;
 
79
}
 
80
 
 
81
sub indexit {
 
82
    my $self = shift;
 
83
    my $id   = shift;
 
84
    $self->{IndexIt}{$id} = shift if @_;
 
85
    return $self->{IndexIt}{$id};
 
86
}
 
87
 
 
88
sub toplevel {
 
89
    my $self = shift;
 
90
    my $id   = shift;
 
91
    $self->{TopLevel}{$id} = shift if @_;
 
92
    return $self->{TopLevel}{$id};
 
93
}
 
94
 
 
95
sub each_toplevel {
 
96
    my $self = shift;
 
97
    my ($id) = each %{$self->{TopLevel}};
 
98
    $id;
 
99
}
 
100
 
 
101
sub local2global {
 
102
    my $self = shift;
 
103
    my $id   = shift;
 
104
    $self->{Local2Global}{$id} = shift if @_;
 
105
    return $self->{Local2Global}{$id};
 
106
}
 
107
 
 
108
sub add_children {
 
109
    my $self      = shift;
 
110
    my $parent_id = shift;
 
111
    # (@children) = @_;
 
112
    $self->{Parent2Child}{$parent_id} = shift while @_;
 
113
}
 
114
 
 
115
sub children {
 
116
    my $self = shift;
 
117
    my $parent_id = shift;
 
118
 
 
119
    my @children;
 
120
 
 
121
    my $db        = tied(%{$self->{Parent2Child}});
 
122
    my $key       = $parent_id;
 
123
    my $value     = '';
 
124
    for (my $status = $db->seq($key,$value,R_CURSOR);
 
125
         $status    == 0 && $key eq $parent_id;
 
126
         $status    = $db->seq($key,$value,R_NEXT)
 
127
        ) {
 
128
        push @children,$value;
 
129
    }
 
130
    return wantarray ? @children: \@children;
 
131
}
 
132
 
 
133
# this acts like each() and returns each parent id and an array ref of children
 
134
sub each_family {
 
135
    my $self = shift;
 
136
 
 
137
    my $db        = tied(%{$self->{Parent2Child}});
 
138
 
 
139
    if ($self->{_cursordone}) {
 
140
        undef $self->{_cursordone};
 
141
        undef $self->{_parent};
 
142
        undef $self->{_child};
 
143
        return;
 
144
    }
 
145
 
 
146
    # do a slightly tricky cursor search
 
147
    unless (defined $self->{_parent}) {
 
148
        return unless $db->seq($self->{_parent},$self->{_child},R_FIRST) == 0;
 
149
    }
 
150
 
 
151
    my $parent   = $self->{_parent};
 
152
    my @children = $self->{_child};
 
153
 
 
154
    my $status;
 
155
    while (($status = $db->seq($self->{_parent},$self->{_child},R_NEXT)) == 0
 
156
           && $self->{_parent} eq $parent
 
157
        ) {
 
158
        push @children,$self->{_child};
 
159
    }
 
160
 
 
161
    $self->{_cursordone}++ if $status != 0;
 
162
    
 
163
    return ($parent,\@children);
 
164
}
 
165
 
 
166
1;