[Bio] / FigKernelPackages / BerkTable.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/BerkTable.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download) (as text)

1 : olson 1.1 package BerkTable;
2 :    
3 :     # This is a SAS component.
4 :    
5 :     #
6 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
7 :     # for Interpretations of Genomes. All Rights Reserved.
8 :     #
9 :     # This file is part of the SEED Toolkit.
10 :     #
11 :     # The SEED Toolkit is free software. You can redistribute
12 :     # it and/or modify it under the terms of the SEED Toolkit
13 :     # Public License.
14 :     #
15 :     # You should have received a copy of the SEED Toolkit Public License
16 :     # along with this program; if not write to the University of Chicago
17 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
18 :     # Genomes at veronika@thefig.info or download a copy from
19 :     # http://www.theseed.org/LICENSE.TXT.
20 :     #
21 :    
22 :    
23 :    
24 :     use strict;
25 :     use DB_File;
26 :     use Data::Dumper;
27 :    
28 :     sub TIEHASH
29 :     {
30 :     my($class, $file, %opts ) = @_;
31 :    
32 :     my $self = {
33 :     file => $file,
34 :     hash => {},
35 :     tie => undef,
36 :     results_as_list => 0,
37 :     result_separator => "\n",
38 :     };
39 :     $self->{$_} = $opts{$_} for keys %opts;
40 :    
41 :     $self->{results_as_list} = 1 if $self->{-split_values};
42 :     return bless $self, $class;
43 :     }
44 :    
45 :     sub STORE
46 :     {
47 :     my($self, $key, $val) = @_;
48 :     $self->_ensure_tied();
49 :     $self->{hash}->{$key} = $val;
50 :     }
51 :    
52 :     sub FETCH
53 :     {
54 :     my($self, $key) = @_;
55 :     $self->_ensure_tied();
56 :     my @res = $self->{tie}->get_dup($key);
57 : olson 1.2 if ($self->{-split_values})
58 : olson 1.1 {
59 :     @res = map { [ split(/$;/, $_) ] } @res;
60 :     }
61 :     if ($self->{-results_as_list})
62 :     {
63 :     return \@res;
64 :     }
65 :     else
66 :     {
67 :     return join($self->{-result_separator}, @res);
68 :     }
69 :     }
70 :    
71 :     sub FIRSTKEY
72 :     {
73 :     my($self) = @_;
74 :     $self->_ensure_tied();
75 :     my $a = scalar keys %{$self->{hash}};
76 :     return each %{$self->{hash}};
77 :     }
78 :    
79 :     sub NEXTKEY
80 :     {
81 :     my($self) = @_;
82 :     $self->_ensure_tied();
83 :     return each %{$self->{hash}};
84 :     }
85 :    
86 :     sub EXISTS
87 :     {
88 :     my($self, $key) = @_;
89 :     $self->_ensure_tied();
90 :     return exists $self->{hash}->{$key};
91 :     }
92 :    
93 :     sub DELETE
94 :     {
95 :     my($self, $key) = @_;
96 :     $self->_ensure_tied();
97 :     return delete $self->{hash}->{$key};
98 :     }
99 :    
100 :     sub SCALAR
101 :     {
102 :     my($self, $key) = @_;
103 :     $self->_ensure_tied();
104 :     return scalar %{$self->{hash}->{$key}};
105 :     }
106 :    
107 :     sub _ensure_tied
108 :     {
109 :     my($self) = @_;
110 :     if (!$self->{tie})
111 :     {
112 :     $self->{tie} = tie %{$self->{hash}}, 'DB_File', $self->{file}, O_RDONLY, 0, $DB_BTREE;
113 :     }
114 :     }
115 :    
116 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3