← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/DB/Flat.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/Flat.pm
1
1
#
2
 
# $Id: Flat.pm,v 1.15 2003/11/21 03:03:38 lstein Exp $
 
2
# $Id: Flat.pm,v 1.24.4.1 2006/10/02 23:10:14 sendu Exp $
3
3
#
4
4
# BioPerl module for Bio::DB::Flat
5
5
#
44
44
Bioperl modules. Send your comments and suggestions preferably to one
45
45
of the Bioperl mailing lists.  Your participation is much appreciated.
46
46
 
47
 
  bioperl-l@bioperl.org             - General discussion
48
 
  http://bioperl.org/MailList.shtml - About the mailing lists
 
47
  bioperl-l@bioperl.org                  - General discussion
 
48
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
49
49
 
50
50
=head2 Reporting Bugs
51
51
 
52
52
Report bugs to the Bioperl bug tracking system to help us keep track
53
 
the bugs and their resolution.  Bug reports can be submitted via
54
 
email or the web:
 
53
the bugs and their resolution.  Bug reports can be submitted via the
 
54
web:
55
55
 
56
 
  bioperl-bugs@bio.perl.org
57
 
  http://bugzilla.bioperl.org/
 
56
  http://bugzilla.open-bio.org/
58
57
 
59
58
=head1 AUTHOR - Lincoln Stein
60
59
 
71
70
# Let the code begin...
72
71
package Bio::DB::Flat;
73
72
 
74
 
use Bio::DB::RandomAccessI;
75
 
use Bio::Root::Root;
76
73
use Bio::Root::IO;
77
 
use vars '@ISA';
78
74
 
79
 
@ISA = qw(Bio::Root::Root Bio::DB::RandomAccessI);
 
75
use base qw(Bio::Root::Root Bio::DB::RandomAccessI);
80
76
 
81
77
use constant CONFIG_FILE_NAME => 'config.dat';
82
78
 
135
131
  my $self = $class->SUPER::new(@_);
136
132
 
137
133
  # first we initialize ourselves
138
 
  my ($flat_directory,$dbname) = $self->_rearrange([qw(DIRECTORY DBNAME)],@_);
 
134
  my ($flat_directory,$dbname,$format) = 
 
135
    $self->_rearrange([qw(DIRECTORY DBNAME FORMAT)],@_);
139
136
 
140
137
  defined $flat_directory
141
138
    or $self->throw('Please supply a -directory argument');
166
163
  # now we figure out what subclass to instantiate
167
164
  my $index_type = $self->indexing_scheme eq 'BerkeleyDB/1' ? 'BDB'
168
165
                  :$self->indexing_scheme eq 'flat/1'       ? 'Binary'
169
 
                  :$self->throw("unknown indexing scheme: ".$self->indexing_scheme);
170
 
  my $format     = $self->file_format;
 
166
                  :$self->throw("unknown indexing scheme: " .
 
167
                                $self->indexing_scheme);
 
168
  $format = $self->file_format;
171
169
 
172
170
  # because Michele and Lincoln did it differently
173
171
  # Michele's way is via a standalone concrete class
175
173
    my $child_class = 'Bio::DB::Flat::BinarySearch';
176
174
    eval "use $child_class";
177
175
    $self->throw($@) if $@;
 
176
    push @_, ('-format', $format);
178
177
    return $child_class->new(@_);
179
178
  }
180
179
 
245
244
 
246
245
sub new_from_registry {
247
246
   my ($self,%config) =  @_;
248
 
   my $location = $config{'location'} or $self->throw('location tag must be specified.');
249
 
   my $dbname   = $config{'dbname'}   or $self->throw('dbname tag must be specified.');
250
 
   #my $index    = $self->new(-directory => $location,
251
 
   #                          -dbname    => $dbname,
252
 
   #                         );
253
 
   # my $index = $config{'protocol'} or $self->throw('index or protocol tag must be specified.');
 
247
   my $location = $config{'location'} or 
 
248
     $self->throw('location tag must be specified.');
 
249
   my $dbname   = $config{'dbname'}   or 
 
250
     $self->throw('dbname tag must be specified.');
 
251
 
254
252
   my $db = $self->new(-directory => $location,
255
253
                        -dbname    => $dbname,
256
 
                       # -index     => $index   LS: PROTOCOL DOES NOT SPECIFY INDEXING SCHEME
257
254
                      );
258
 
    $db;
 
255
   $db;
259
256
}
260
257
 
261
258
# accessors
378
375
  $self->write_flag or $self->throw("cannot write configuration file because write_flag is not set");
379
376
  my $path = $self->_config_path;
380
377
 
381
 
  open (F,">$path") or $self->throw("open error on $path: $!");
 
378
  open (my $F,">$path") or $self->throw("open error on $path: $!");
382
379
 
383
380
  my $index_type = $self->indexing_scheme;
384
 
  print F "index\t$index_type\n";
 
381
  print $F "index\t$index_type\n";
385
382
 
386
383
  my $format     = $self->file_format;
387
384
  my $alphabet   = $self->alphabet;
388
385
  my $alpha      = $alphabet ? "/$alphabet" : '';
389
 
  print F "format\tURN:LSID:open-bio.org:${format}${alpha}\n";
 
386
  print $F "format\tURN:LSID:open-bio.org:${format}${alpha}\n";
390
387
 
391
388
  my @filenos = $self->_filenos or $self->throw("cannot write config file because no flat files defined");
392
389
  for my $nf (@filenos) {
393
390
    my $path = $self->{flat_flat_file_path}{$nf};
394
391
    my $size = -s $path;
395
 
    print F join("\t","fileid_$nf",$path,$size),"\n";
 
392
    print $F join("\t","fileid_$nf",$path,$size),"\n";
396
393
  }
397
394
 
398
395
  # write primary namespace
399
396
  my $primary_ns = $self->primary_namespace
400
397
    or $self->throw('cannot write config file because no primary namespace defined');
401
398
 
402
 
  print F join("\t",'primary_namespace',$primary_ns),"\n";
 
399
  print $F join("\t",'primary_namespace',$primary_ns),"\n";
403
400
 
404
401
  # write secondary namespaces
405
402
  my @secondary = $self->secondary_namespaces;
406
 
  print F join("\t",'secondary_namespaces',@secondary),"\n";
 
403
  print $F join("\t",'secondary_namespaces',@secondary),"\n";
407
404
 
408
 
  close F or $self->throw("close error on $path: $!");
 
405
  close $F or $self->throw("close error on $path: $!");
409
406
}
410
407
 
411
408
sub files {
457
454
  my $path = $self->_config_path;
458
455
  return unless -e $path;
459
456
 
460
 
  open (F,$path) or $self->throw("open error on $path: $!");
 
457
  open (my $F,$path) or $self->throw("open error on $path: $!");
461
458
  my %config;
462
 
  while (<F>) {
 
459
  while (<$F>) {
463
460
    chomp;
464
461
    my ($tag,@values) = split "\t";
465
462
    $config{$tag} = \@values;
466
463
  }
467
 
  CORE::close F or $self->throw("close error on $path: $!");
 
464
  CORE::close $F or $self->throw("close error on $path: $!");
468
465
 
469
466
  $config{index}[0] =~ m~(flat/1|BerkeleyDB/1)~
470
467
    or $self->throw("invalid configuration file $path: no index line");
582
579
}
583
580
 
584
581
sub _store_index {
 
582
   my $self = shift;
585
583
   my ($ids,$file,$offset,$length) = @_;
586
584
   $self->throw_not_implemented;
587
585
}