t/Root/IO.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2
   3 use strict;
   4 use warnings;
   5
   6 BEGIN {
   7     use lib '.';
   8     use Bio::Root::Test;
   9     test_begin(-tests => 154);
  10     use_ok 'Bio::Root::IO';
  11 }
  12
  13
  14 ok my $obj = Bio::Root::IO->new();
  15 isa_ok $obj, 'Bio::Root::IO';
  16
  17
  18 #############################################
  19 # tests for exceptions/debugging/verbosity
  20 #############################################
  21
  22 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/, 'Throw';
  23
  24 $obj->verbose(-1);
  25 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;
  26
  27 eval { $obj->warn('Testing warn') };
  28 ok !$@, 'Warn';
  29
  30 $obj->verbose(1);
  31 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;
  32
  33 ok my @stack = $obj->stack_trace(), 'Stack trace';
  34 is scalar @stack, 2;
  35
  36 ok my $verbobj = Bio::Root::IO->new( -verbose => 1, -strict => 1 ), 'Verbosity';
  37 is $verbobj->verbose(), 1;
  38
  39 ok $obj->verbose(-1);
  40
  41
  42 #############################################
  43 # tests for finding executables
  44 #############################################
  45
  46 ok my $io = Bio::Root::IO->new();
  47
  48 # An executable file
  49 my $out_file = 'test_file.txt';
  50 my $out_fh;
  51 open  $out_fh, '>', $out_file or die "Could not write file '$out_file': $!\n";
  52 print $out_fh 'test';
  53 close $out_fh;
  54 # -X test file will fail in Windows regardless of chmod,
  55 # because it looks for the executable suffix (like ".exe")
  56 if ($^O =~ m/mswin/i) {
  57     # An executable file
  58     my $exec_file = 'test_exec.exe';
  59     open my $exe_fh, '>', $exec_file or die "Could not write file '$exec_file': $!\n";
  60     close $exe_fh;
  61     ok $obj->exists_exe($exec_file), 'executable file';
  62     unlink $exec_file or die "Could not delete file '$exec_file': $!\n";
  63
  64     # A not executable file
  65     ok (! $obj->exists_exe($out_file), 'non-executable file');
  66     unlink $out_file  or die "Could not delete file '$out_file': $!\n";
  67 }
  68 else {
  69     # An executable file
  70     chmod 0777, $out_file or die "Could not change permission of file '$out_file': $!\n";
  71     ok $obj->exists_exe($out_file), 'executable file';
  72
  73     # A not executable file
  74     chmod 0444, $out_file or die "Could not change permission of file '$out_file': $!\n";
  75     ok (! $obj->exists_exe($out_file), 'non-executable file');
  76     unlink $out_file or die "Could not delete file '$out_file': $!\n";
  77 }
  78
  79 # An executable dir
  80 my $out_dir = 'test_dir';
  81 mkdir $out_dir or die "Could not write dir '$out_dir': $!\n";
  82 chmod 0777, $out_dir or die "Could not change permission of dir '$out_dir': $!\n";
  83 ok (! $obj->exists_exe($out_dir), 'executable dir');
  84 rmdir $out_dir or die "Could not delete dir '$out_dir': $!\n";
  85
  86
  87 #############################################
  88 # tests for handle read and write abilities
  89 #############################################
  90
  91 # Test catfile
  92
  93 ok my $in_file = Bio::Root::IO->catfile(qw(t data test.waba));
  94 is $in_file, test_input_file('test.waba');
  95
  96 ok my $in_file_2 = Bio::Root::IO->catfile(qw(t data test.txt));
  97
  98 $out_file = test_output_file();
  99
 100
 101 # Test with files
 102
 103 ok my $rio = Bio::Root::IO->new( -input => $in_file ), 'Read from file';
 104 is $rio->file, $in_file;
 105 is_deeply [$rio->cleanfile], [undef, $in_file];
 106 is $rio->mode, 'r';
 107 ok $rio->close;
 108
 109 ok $rio = Bio::Root::IO->new( -file => '<'.$in_file );
 110 is $rio->file, '<'.$in_file;
 111 is_deeply [$rio->cleanfile], ['<', $in_file];
 112 1 while $rio->_readline; # read entire file content
 113 is $rio->mode, 'r';
 114 ok $rio->close;
 115
 116 ok my $wio = Bio::Root::IO->new( -file => ">$out_file" ), 'Write to file';
 117 is $wio->file, ">$out_file";
 118 is_deeply [$wio->cleanfile], ['>', $out_file];
 119 is $wio->mode, 'w';
 120 ok $wio->close;
 121
 122 ok $rio = Bio::Root::IO->new( -file => "+>$out_file" ), 'Read+write to file';
 123 is $rio->file, "+>$out_file";
 124 is_deeply [$rio->cleanfile], ['+>', $out_file];
 125 is $rio->mode, 'rw';
 126 ok $rio->close;
 127
 128
 129 # Test with handles
 130
 131 my $in_fh;
 132 open $in_fh , '<', $in_file  or die "Could not read file '$in_file': $!\n", 'Read from GLOB handle';
 133 ok $rio = Bio::Root::IO->new( -fh => $in_fh );
 134 is $rio->_fh, $in_fh;
 135 is $rio->mode, 'r';
 136 close $in_fh;
 137
 138 open $out_fh, '>', $out_file or die "Could not write file '$out_file': $!\n", 'Write to GLOB handle';
 139 ok $wio = Bio::Root::IO->new( -fh => $out_fh );
 140 is $wio->_fh, $out_fh;
 141 is $wio->mode, 'w';
 142 close $out_fh;
 143
 144 SKIP: {
 145     eval { require File::Temp; }
 146        or skip 'could not create File::Temp object, maybe your File::Temp is 10 years old', 4;
 147
 148     $out_fh = File::Temp->new;
 149     ok $wio = Bio::Root::IO->new( -fh => $out_fh ), 'Read from File::Temp handle';
 150     isa_ok $wio, 'Bio::Root::IO';
 151     is $wio->mode, 'rw', 'is a write handle';
 152     warnings_like sub { $wio->close }, '', 'no warnings in ->close()';
 153     ok $wio->close;
 154 }
 155
 156
 157 # Exclusive arguments
 158 open $in_fh , '<', $in_file  or die "Could not read file '$in_file': $!\n", 'Read from GLOB handle';
 159 throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -fh     => $in_fh     )} qr/Providing both a file and a filehandle for reading/, 'Exclusive arguments';
 160 throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -file   => $in_file_2 )} qr/Input file given twice/;
 161 throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -string => 'abcedf'   )} qr/File or filehandle provided with -string/;
 162 throws_ok {$rio = Bio::Root::IO->new( -fh    => $in_fh  , -file   => $in_file   )} qr/Providing both a file and a filehandle for reading/;
 163 throws_ok {$rio = Bio::Root::IO->new( -fh    => $in_fh  , -string => 'abcedf'   )} qr/File or filehandle provided with -string/;
 164 throws_ok {$rio = Bio::Root::IO->new( -file  => $in_file, -string => 'abcedf'   )} qr/File or filehandle provided with -string/;
 165 close $in_fh;
 166
 167 lives_ok  {$rio = Bio::Root::IO->new( -input => $in_file, -file   => $in_file   )} 'Same file';
 168
 169
 170 ##############################################
 171 # tests _pushback for multi-line buffering
 172 ##############################################
 173
 174 ok $rio = Bio::Root::IO->new( -file => $in_file ), 'Pushback';
 175
 176 ok my $line1 = $rio->_readline;
 177 ok my $line2 = $rio->_readline;
 178
 179 ok $rio->_pushback($line2);
 180 ok $rio->_pushback($line1);
 181
 182 ok my $line3 = $rio->_readline;
 183 ok my $line4 = $rio->_readline;
 184 ok my $line5 = $rio->_readline;
 185
 186 is $line1, $line3;
 187 is $line2, $line4;
 188 isnt $line5, $line4;
 189
 190 ok $rio->close;
 191
 192
 193 ##############################################
 194 # test _print and _insert
 195 ##############################################
 196
 197 ok my $fio = Bio::Root::IO->new( -file => ">$out_file" );
 198 ok $fio->_print("line 1\n"), '_print';
 199 ok $fio->_print("line 2\n");
 200 ok $fio->_insert("insertion at line 2\n",2), '_insert at middle of file';
 201 ok $fio->_print("line 3\n");
 202 ok $fio->_print("line 4\n");
 203 ok $fio->close;
 204
 205 open my $checkio, '<', $out_file or die "Could not read file '$out_file': $!\n";
 206 my @content = <$checkio>;
 207 close $checkio;
 208 is_deeply \@content, ["line 1\n","insertion at line 2\n","line 2\n","line 3\n","line 4\n"];
 209
 210 ok $fio = Bio::Root::IO->new(-file=>">$out_file");
 211 ok $fio->_insert("insertion at line 1\n",1), '_insert in empty file';
 212 ok $fio->close;
 213
 214 open $checkio, '<', $out_file or die "Could not read file '$out_file': $!\n";
 215 @content = <$checkio>;
 216 close $checkio;
 217 is_deeply \@content, ["insertion at line 1\n"];
 218
 219
 220 ##############################################
 221 # test Win vs UNIX line ending
 222 ##############################################
 223
 224 {
 225     ok my $unix_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.unix'));
 226     ok my $win_rio  = Bio::Root::IO->new(-file => test_input_file('U71225.gb.win' ));
 227     ok my $mac_rio  = Bio::Root::IO->new(-file => test_input_file('U71225.gb.mac' ));
 228
 229     my $expected = "LOCUS       U71225                  1164 bp    DNA     linear   VRT 27-NOV-2001\n";
 230     is $unix_rio->_readline, $expected;
 231     is $win_rio->_readline , $expected;
 232     like $mac_rio->_readline, qr#^LOCUS.*//\n$#ms;
 233     # line spans entire file because lines end with "\r" but $/ is "\n"
 234
 235     $expected = "DEFINITION  Desmognathus quadramaculatus 12S ribosomal RNA gene, partial\n";
 236     is $unix_rio->_readline, $expected;
 237     is $win_rio->_readline , $expected;
 238     is $mac_rio->_readline , undef;
 239
 240     $expected = "            sequence; tRNA-Val gene, complete sequence; and 16S ribosomal RNA\n";
 241     is $unix_rio->_readline, $expected;
 242     is $win_rio->_readline , $expected;
 243     is $mac_rio->_readline , undef;
 244
 245     $expected = "            gene, partial sequence, mitochondrial genes for mitochondrial RNAs.\n";
 246     is $unix_rio->_readline, $expected;
 247     is $win_rio->_readline , $expected;
 248     is $mac_rio->_readline , undef;
 249
 250     $expected = "ACCESSION   U71225\n";
 251     is $unix_rio->_readline, $expected;
 252     is $win_rio->_readline , $expected;
 253     is $mac_rio->_readline , undef;
 254
 255     # In Windows the "-raw" parameter has no effect, because Perl already discards
 256     # the '\r' from the line when reading in text mode from the filehandle
 257     # ($line = <$fh>), and put it back automatically when printing
 258     if ($^O =~ m/mswin/i) {
 259         is $win_rio->_readline( -raw => 1) , "VERSION     U71225.1  GI:2804359\n";
 260     }
 261     else {
 262         is $win_rio->_readline( -raw => 1) , "VERSION     U71225.1  GI:2804359\r\n";
 263     }
 264     is $win_rio->_readline( -raw => 0) , "KEYWORDS    .\n";
 265 }
 266
 267
 268 ##############################################
 269 # test Win vs UNIX line ending using PerlIO::eol
 270 ##############################################
 271
 272 SKIP: {
 273     test_skip(-tests => 20, -requires_module => 'PerlIO::eol');
 274
 275     local $Bio::Root::IO::HAS_EOL = 1;
 276     ok my $unix_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.unix'));
 277     ok my $win_rio  = Bio::Root::IO->new(-file => test_input_file('U71225.gb.win' ));
 278     ok my $mac_rio  = Bio::Root::IO->new(-file => test_input_file('U71225.gb.mac' ));
 279
 280     my $expected = "LOCUS       U71225                  1164 bp    DNA     linear   VRT 27-NOV-2001\n";
 281     is $unix_rio->_readline, $expected;
 282     is $win_rio->_readline , $expected;
 283     is $mac_rio->_readline , $expected;
 284
 285     $expected = "DEFINITION  Desmognathus quadramaculatus 12S ribosomal RNA gene, partial\n";
 286     is $unix_rio->_readline, $expected;
 287     is $win_rio->_readline , $expected;
 288     is $mac_rio->_readline , $expected;
 289
 290     $expected = "            sequence; tRNA-Val gene, complete sequence; and 16S ribosomal RNA\n";
 291     is $unix_rio->_readline, $expected;
 292     is $win_rio->_readline , $expected;
 293     is $mac_rio->_readline , $expected;
 294
 295     $expected = "            gene, partial sequence, mitochondrial genes for mitochondrial RNAs.\n";
 296     is $unix_rio->_readline, $expected;
 297     is $win_rio->_readline , $expected;
 298     is $mac_rio->_readline , $expected;
 299
 300     $expected = "ACCESSION   U71225\n";
 301     is $unix_rio->_readline, $expected;
 302     is $win_rio->_readline , $expected;
 303     is $mac_rio->_readline , $expected;
 304
 305     # $HAS_EOL ignores -raw
 306     is $win_rio->_readline( -raw => 1) , "VERSION     U71225.1  GI:2804359\n";
 307     is $win_rio->_readline( -raw => 0) , "KEYWORDS    .\n";
 308 }
 309
 310
 311 ##############################################
 312 # test Path::Class support
 313 ##############################################
 314
 315 SKIP: {
 316     test_skip(-tests => 2, -requires_module => 'Path::Class');
 317     my $f = sub { Bio::Root::IO->new( -file => Path::Class::file(test_input_file('U71225.gb.unix') ) ) };
 318     lives_ok(sub { $f->() } , 'Bio::Root::IO->new can handle a Path::Class object');
 319     isa_ok($f->(), 'Bio::Root::IO');
 320 }
 321
 322
 323 ##############################################
 324 # test -string
 325 ##############################################
 326
 327 my $teststring = "Foo\nBar\nBaz";
 328 ok $rio = Bio::Root::IO->new(-string => $teststring), 'Read string';
 329
 330 is $rio->mode, 'r';
 331
 332 ok $line1 = $rio->_readline;
 333 is $line1, "Foo\n";
 334
 335 ok $line2 = $rio->_readline;
 336 is $line2, "Bar\n";
 337 ok $rio->_pushback($line2);
 338
 339 ok $line3 = $rio->_readline;
 340 is $line3, "Bar\n";
 341 ok $line3 = $rio->_readline;
 342 is $line3, 'Baz';
 343
 344
 345 ##############################################
 346 # test tempfile()
 347 ##############################################
 348 {
 349 ok my $obj = Bio::Root::IO->new(-verbose => 0);
 350
 351 isa_ok $obj, 'Bio::Root::IO';
 352
 353 my $TEST_STRING = "Bioperl rocks!\n";
 354
 355 my ($tfh,$tfile);
 356
 357 eval {
 358     ($tfh, $tfile) = $obj->tempfile();
 359     isa_ok $tfh, 'GLOB';
 360     print $tfh $TEST_STRING;
 361     close $tfh;
 362     open my $IN, '<', $tfile or die "Could not read file '$tfile': $!\n";
 363     my $val = join '', <$IN>;
 364     is $val, $TEST_STRING;
 365     close $IN;
 366     ok -e $tfile;
 367     undef $obj;
 368 };
 369 undef $obj;
 370 if ( $@ ) {
 371     ok 0;
 372 } else {
 373     ok ! -e $tfile, 'auto UNLINK => 1';
 374 }
 375
 376 $obj = Bio::Root::IO->new();
 377
 378 eval {
 379     my $tdir = $obj->tempdir(CLEANUP=>1);
 380     ok -d $tdir;
 381     ($tfh, $tfile) = $obj->tempfile(dir => $tdir);
 382     close $tfh;
 383     ok -e $tfile;
 384     undef $obj; # see Bio::Root::IO::_io_cleanup
 385 };
 386
 387 if ( $@ ) {
 388     ok 0;
 389 } else {
 390     ok ! -e $tfile, 'tempfile deleted';
 391 }
 392
 393 eval {
 394     $obj = Bio::Root::IO->new(-verbose => 0);
 395     ($tfh, $tfile) = $obj->tempfile(UNLINK => 0);
 396     isa_ok $tfh, 'GLOB';
 397     close $tfh;
 398     ok -e $tfile;
 399     undef $obj; # see Bio::Root::IO::_io_cleanup
 400 };
 401
 402 if ( $@ ) {
 403    ok 0;
 404 } else {
 405    ok -e $tfile, 'UNLINK => 0';
 406 }
 407
 408 ok unlink( $tfile) == 1 ;
 409
 410
 411 ok $obj = Bio::Root::IO->new;
 412
 413 # check suffix is applied
 414 my ($fh1, $fn1) = $obj->tempfile(SUFFIX => '.bioperl');
 415 isa_ok $fh1, 'GLOB';
 416 like $fn1, qr/\.bioperl$/, 'tempfile suffix';
 417 ok close $fh1;
 418
 419 # check single return value mode of File::Temp
 420 my $fh2 = $obj->tempfile;
 421 isa_ok $fh2, 'GLOB';
 422 ok $fh2, 'tempfile() in scalar context';
 423 ok close $fh2;
 424 }
 425