/
Utilities.pm
1351 lines (1091 loc) · 43.7 KB
/
Utilities.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
package Bio::Root::Utilities;
use strict;
# $Id$
=head1 NAME
Bio::Root::Utilities - General-purpose utility module
=head1 SYNOPSIS
=head2 Object Creation
# Using the supplied singleton object:
use Bio::Root::Utilities qw(:obj);
$Util->some_method();
# Create an object manually:
use Bio::Root::Utilities;
my $util = Bio::Root::Utilities->new();
$util->some_method();
$date_stamp = $Util->date_format('yyy-mm-dd');
$clean = $Util->untaint($dirty);
$compressed = $Util->compress('/home/me/myfile.txt')
my ($mean, $stdev) = $Util->mean_stdev( @data );
$Util->authority("me@example.com");
$Util->mail_authority("Something you should know about...");
...and a host of other methods. See below.
=head1 DESCRIPTION
Provides general-purpose utilities of potential interest to any Perl script.
The C<:obj> tag is a convenience that imports a $Util symbol into your
namespace representing a Bio::Root::Utilities object. This saves you
from creating your own Bio::Root::Utilities object via
C<Bio::Root::Utilities-E<gt>new()> or from prefixing all method calls with
C<Bio::Root::Utilities>, though feel free to do these things if desired.
Since there should normally not be a need for a script to have more
than one Bio::Root::Utilities object, this module thus comes with it's
own singleton.
=head1 INSTALLATION
This module is included with the central Bioperl distribution:
http://www.bioperl.org/wiki/Getting_BioPerl
ftp://bio.perl.org/pub/DIST
Follow the installation instructions included in the README file.
=head1 DEPENDENCIES
Inherits from L<Bio::Root::Root>, and uses L<Bio::Root::IO>
and L<Bio::Root::Exception>.
Relies on external executables for file compression/uncompression
and sending mail. No paths to these are hard coded but are located
as needed.
=head1 SEE ALSO
http://bioperl.org - Bioperl Project Homepage
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the evolution of this and other Bioperl modules.
Send your comments and suggestions preferably to one of the Bioperl mailing lists.
Your participation is much appreciated.
bioperl-l@bioperl.org - General discussion
http://bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Support
Please direct usage questions or support issues to the mailing list:
I<bioperl-l@bioperl.org>
rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution. Bug reports can be submitted via the
web:
http://bugzilla.open-bio.org/
=head1 AUTHOR
Steve Chervitz E<lt>sac@bioperl.orgE<gt>
See L<the FEEDBACK section | FEEDBACK> for where to send bug reports and comments.
=head1 ACKNOWLEDGEMENTS
This module was originally developed under the auspices of the
Saccharomyces Genome Database: http://www.yeastgenome.org/
=head1 COPYRIGHT
Copyright (c) 1996-2007 Steve Chervitz. All Rights Reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
=head1 APPENDIX
Methods beginning with a leading underscore are considered private
and are intended for internal use by this module. They are
B<not> considered part of the public interface and are described here
for documentation purposes only.
=cut
# Let the code begin...
use Bio::Root::IO;
use Bio::Root::Exception;
use vars qw(@EXPORT_OK %EXPORT_TAGS);
use base qw(Bio::Root::Root Exporter);
@EXPORT_OK = qw($Util);
%EXPORT_TAGS = ( obj => [qw($Util)],
std => [qw($Util)],);
use vars qw($ID $Util $GNU_PATH $TIMEOUT_SECS
@COMPRESSION_UTILS @UNCOMPRESSION_UTILS
$DEFAULT_NEWLINE $NEWLINE $AUTHORITY
@MONTHS @DAYS $BASE_YEAR $DEFAULT_CENTURY
);
$ID = 'Bio::Root::Utilities';
# Number of seconds to wait before timing out when reading input (taste_file())
$TIMEOUT_SECS = 30;
$NEWLINE = $ENV{'NEWLINE'} || undef;
$BASE_YEAR = 1900; # perl's localtime() assumes this for it's year data.
# TODO: update this every hundred years. Y2K-sensitive code.
$DEFAULT_CENTURY = $BASE_YEAR + 100;
@MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@DAYS = qw(Sun Mon Tue Wed Thu Fri Sat);
# Sets the preference for compression utilities to be used by compress().
# The first executable in this list to be found in the current PATH will be used,
# unless overridden in the call to that function. See docs for details.
@COMPRESSION_UTILS = qw(gzip bzip2 zip compress);
@UNCOMPRESSION_UTILS = qw(gunzip bunzip2 unzip uncompress);
# Default person to receive feedback from users and possibly automatic error messages.
$AUTHORITY = '';
# Note: $GNU_PATH is now deprecated, shouldn't be needed since now this module
# will automatically locate the compression utility in the current PATH.
# Retaining $GNU_PATH for backward compatibility.
#
# $GNU_PATH points to the directory containing the gzip and gunzip
# executables. It may be required for executing gzip/gunzip
# in some situations (e.g., when $ENV{PATH} doesn't contain this dir.
# Customize $GNU_PATH for your site if the compress() or
# uncompress() functions are generating exceptions.
$GNU_PATH = '';
#$GNU_PATH = '/tools/gnu/bin/';
$DEFAULT_NEWLINE = "\012"; # \n (used if get_newline() fails for some reason)
## Static UTIL object.
$Util = Bio::Root::Root->new();
=head2 date_format
Title : date_format
Usage : $Util->date_format( [FMT], [DATE])
Purpose : -- Get a string containing the formated date or time
: taken when this routine is invoked.
: -- Provides a way to avoid using `date`.
: -- Provides an interface to localtime().
: -- Interconverts some date formats.
:
: (For additional functionality, use Date::Manip or
: Date::DateCalc available from CPAN).
Example : $Util->date_format();
: $date = $Util->date_format('yyyy-mmm-dd', '11/22/92');
Returns : String (unless 'list' is provided as argument, see below)
:
: 'yyyy-mm-dd' = 1996-05-03 # default format.
: 'yyyy-dd-mm' = 1996-03-05
: 'yyyy-mmm-dd' = 1996-May-03
: 'd-m-y' = 3-May-1996
: 'd m y' = 3 May 1996
: 'dmy' = 3may96
: 'mdy' = May 3, 1996
: 'ymd' = 96may3
: 'md' = may3
: 'year' = 1996
: 'hms' = 23:01:59 # when not converting a format, 'hms' can be
: # tacked on to any of the above options
: # to add the time stamp: eg 'dmyhms'
: 'full' | 'unix' = UNIX-style date: Tue May 5 22:00:00 1998
: 'list' = the contents of localtime(time) in an array.
Argument : (all are optional)
: FMT = yyyy-mm-dd | yyyy-dd-mm | yyyy-mmm-dd |
: mdy | ymd | md | d-m-y | hms | hm
: ('hms' may be appended to any of these to
: add a time stamp)
:
: DATE = String containing date to be converted.
: Acceptable input formats:
: 12/1/97 (for 1 December 1997)
: 1997-12-01
: 1997-Dec-01
Throws :
Comments : If you don't care about formatting or using backticks, you can
: always use: $date = `date`;
:
: For more features, use Date::Manip.pm, (which I should
: probably switch to...)
See Also : L<file_date()|file_date>, L<month2num()|month2num>
=cut
#---------------'
sub date_format {
#---------------
my $self = shift;
my $option = shift;
my $date = shift; # optional date to be converted.
my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
$option ||= 'yyyy-mm-dd';
my ($month_txt, $day_txt, $month_num, $fullYear);
my ($converting, @date);
# Load a supplied date for conversion:
if(defined($date) && ($date =~ /[\D-]+/)) {
$converting = 1;
if( $date =~ m{/}) {
($mon,$mday,$year) = split(m{/}, $date);
} elsif($date =~ /(\d{4})-(\d{1,2})-(\d{1,2})/) {
($year,$mon,$mday) = ($1, $2, $3);
} elsif($date =~ /(\d{4})-(\w{3,})-(\d{1,2})/) {
($year,$mon,$mday) = ($1, $2, $3);
$mon = $self->month2num($2);
} else {
print STDERR "\n*** Unsupported input date format: $date\n";
}
if(length($year) == 4) {
$fullYear = $year;
$year = substr $year, 2;
} else {
# Heuristics to guess what century was intended when a 2-digit year is given
# If number is over 50, assume it's for prev century; under 50 = default century.
# TODO: keep an eye on this Y2K-sensitive code
if ($year > 50) {
$fullYear = $DEFAULT_CENTURY + $year - 100;
} else {
$fullYear = $DEFAULT_CENTURY + $year;
}
}
$mon -= 1;
} else {
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @date =
localtime(($date ? $date : time()));
return @date if $option =~ /list/i;
$fullYear = $BASE_YEAR+$year;
}
$month_txt = $MONTHS[$mon];
$day_txt = $DAYS[$wday] if defined $wday;
$month_num = $mon+1;
# print "sec: $sec, min: $min, hour: $hour, month: $mon, m-day: $mday, year: $year\nwday: $wday, yday: $yday, dst: $isdst";<STDIN>;
if( $option =~ /yyyy-mm-dd/i ) {
$date = sprintf "%4d-%02d-%02d",$fullYear,$month_num,$mday;
} elsif( $option =~ /yyyy-dd-mm/i ) {
$date = sprintf "%4d-%02d-%02d",$fullYear,$mday,$month_num;
} elsif( $option =~ /yyyy-mmm-dd/i ) {
$date = sprintf "%4d-%3s-%02d",$fullYear,$month_txt,$mday;
} elsif( $option =~ /full|unix/i ) {
$date = sprintf "%3s %3s %2d %02d:%02d:%02d %d",$day_txt, $month_txt, $mday, $hour, $min, $sec, $fullYear;
} elsif( $option =~ /mdy/i ) {
$date = "$month_txt $mday, $fullYear";
} elsif( $option =~ /ymd/i ) {
$date = $year."\l$month_txt$mday";
} elsif( $option =~ /dmy/i ) {
$date = $mday."\l$month_txt$year";
} elsif( $option =~ /md/i ) {
$date = "\l$month_txt$mday";
} elsif( $option =~ /d-m-y/i ) {
$date = "$mday-$month_txt-$fullYear";
} elsif( $option =~ /d m y/i ) {
$date = "$mday $month_txt $fullYear";
} elsif( $option =~ /year/i ) {
$date = $fullYear;
} elsif( $option =~ /dmy/i ) {
$date = $mday.'-'.$month_txt.'-'.$fullYear;
} elsif($option and $option !~ /hms/i) {
print STDERR "\n*** Unrecognized date format request: $option\n";
}
if( $option =~ /hms/i and not $converting) {
$date .= " $hour:$min:$sec" if $date;
$date ||= "$hour:$min:$sec";
}
return $date || join(" ", @date);
}
=head2 month2num
Title : month2num
Purpose : Converts a string containing a name of a month to integer
: representing the number of the month in the year.
Example : $Util->month2num("march"); # returns 3
Argument : The string argument must contain at least the first
: three characters of the month's name. Case insensitive.
Throws : Exception if the conversion fails.
=cut
#--------------'
sub month2num {
#--------------
my ($self, $str) = @_;
# Get string in proper format for conversion.
$str = substr($str, 0, 3);
for(0..$#MONTHS) {
return $_+1 if $str =~ /$MONTHS[$_]/i;
}
$self->throw("Invalid month name: $str");
}
=head2 num2month
Title : num2month
Purpose : Does the opposite of month2num.
: Converts a number into a string containing a name of a month.
Example : $Util->num2month(3); # returns 'Mar'
Throws : Exception if supplied number is out of range.
=cut
#-------------
sub num2month {
#-------------
my ($self, $num) = @_;
$self->throw("Month out of range: $num") if $num < 1 or $num > 12;
return $MONTHS[$num-1];
}
=head2 compress
Title : compress
Usage : $Util->compress(full-path-filename);
: $Util->compress(<named parameters>);
Purpose : Compress a file.
Example : $Util->compress("/usr/people/me/data.txt");
: $Util->compress(-file=>"/usr/people/me/data.txt",
: -tmp=>1,
: -outfile=>"/usr/people/share/data.txt.gz",
: -exe=>"/usr/local/bin/fancyzip");
Returns : String containing full, absolute path to compressed file
Argument : Named parameters (case-insensitive):
: -FILE => String (name of file to be compressed, full path).
: If the supplied filename ends with '.gz' or '.Z',
: that extension will be removed before attempting to compress.
: Optional:
: -TMP => boolean. If true, (or if user is not the owner of the file)
: the file is compressed to a temp file. If false, file may be
: clobbered with the compressed version (if using a utility like
: gzip, which is the default)
: -OUTFILE => String (name of the output compressed file, full path).
: -EXE => Name of executable for compression utility to use.
: Will supercede those in @COMPRESSION_UTILS defined by
: this module. If the absolute path to the executable is not provided,
: it will be searched in the PATH env variable.
Throws : Exception if file cannot be compressed.
: If user is not owner of the file, generates a warning and compresses to
: a tmp file. To avoid this warning, use the -o file test operator
: and call this function with -TMP=>1.
Comments : Attempts to compress using utilities defined in the @COMPRESSION_UTILS
: defined by this module, in the order defined. The first utility that is
: found to be executable will be used. Any utility defined in optional -EXE param
: will be tested for executability first.
: To minimize security risks, the -EXE parameter value is untained using
: the untaint() method of this module (in 'relaxed' mode to permit path separators).
See Also : L<uncompress()|uncompress>
=cut
#------------'
sub compress {
#------------
my ($self, @args) = @_;
# This method formerly didn't use named params and expected fileName, tmp
# in that order. This should be backward compatibile.
my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args);
my ($file, $get, $fmt);
# in case the supplied name already has a compressed extension
if($fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName =~ s/$1$//; };
$self->debug("compressing file $fileName");
my @util_to_use = @COMPRESSION_UTILS;
if (defined $exe){
$exe = $self->untaint($exe, 1);
unshift @util_to_use, $exe;
}
my @checked = @util_to_use;
$exe ||= '';
while (not -x $exe and scalar(@util_to_use)) {
$exe = $self->find_exe(shift @util_to_use);
}
unless (-x $exe) {
$self->throw("Can't find compression utility. Looked for @checked");
}
my ($compressed, @cmd, $handle);
if(defined($outfile) or $tmp or not -o $fileName) {
if (defined $outfile) {
$compressed = $outfile;
} else {
# obtain a temporary file name (not using the handle)
# and insert some special text to flag it as a bioperl-based temp file
my $io = Bio::Root::IO->new();
($handle, $compressed) = $io->tempfile();
$compressed .= '.tmp.bioperl.gz';
}
if ($exe =~ /gzip|bzip2|compress/) {
@cmd = ("$exe -f < \"$fileName\" > \"$compressed\"");
} elsif ($exe eq 'zip') {
@cmd = ("$exe -r \"$fileName.zip\" \"$fileName\"");
}
not $tmp and
$self->warn("Not owner of file $fileName. Compressing to temp file $compressed.");
$tmp = 1;
} else {
# Need to compute the compressed name based on exe since we're returning it.
$compressed = $fileName;
if ($exe =~ /gzip/) {
$compressed .= '.gz';
} elsif ($exe =~ /bzip2/) {
$compressed .= '.bz2';
} elsif ($exe =~ /zip/) {
$compressed .= '.zip';
} elsif ($exe =~ /compress/) {
$compressed .= '.Z';
}
if ($exe =~ /gzip|bzip2|compress/) {
@cmd = ($exe, '-f', $fileName);
} elsif ($exe eq 'zip') {
@cmd = ($exe, '-r', "$compressed", $fileName);
}
}
if(system(@cmd) != 0) {
$self->throw( -class => 'Bio::Root::SystemException',
-text => "Failed to compress file $fileName using $exe: $!");
}
return $compressed;
}
=head2 uncompress
Title : uncompress
Usage : $Util->uncompress(full-path-filename);
: $Util->uncompress(<named parameters>);
Purpose : Uncompress a file.
Example : $Util->uncompress("/usr/people/me/data.txt");
: $Util->uncompress(-file=>"/usr/people/me/data.txt.gz",
: -tmp=>1,
: -outfile=>"/usr/people/share/data.txt",
: -exe=>"/usr/local/bin/fancyzip");
Returns : String containing full, absolute path to uncompressed file
Argument : Named parameters (case-insensitive):
: -FILE => String (name of file to be uncompressed, full path).
: If the supplied filename ends with '.gz' or '.Z',
: that extension will be removed before attempting to uncompress.
: Optional:
: -TMP => boolean. If true, (or if user is not the owner of the file)
: the file is uncompressed to a temp file. If false, file may be
: clobbered with the uncompressed version (if using a utility like
: gzip, which is the default)
: -OUTFILE => String (name of the output uncompressed file, full path).
: -EXE => Name of executable for uncompression utility to use.
: Will supercede those in @UNCOMPRESSION_UTILS defined by
: this module. If the absolute path to the executable is not provided,
: it will be searched in the PATH env variable.
Throws : Exception if file cannot be uncompressed.
: If user is not owner of the file, generates a warning and uncompresses to
: a tmp file. To avoid this warning, use the -o file test operator
: and call this function with -TMP=>1.
Comments : Attempts to uncompress using utilities defined in the @UNCOMPRESSION_UTILS
: defined by this module, in the order defined. The first utility that is
: found to be executable will be used. Any utility defined in optional -EXE param
: will be tested for executability first.
: To minimize security risks, the -EXE parameter value is untained using
: the untaint() method of this module (in 'relaxed' mode to permit path separators).
See Also : L<compress()|compress>
=cut
#------------'
sub uncompress {
#------------
my ($self, @args) = @_;
# This method formerly didn't use named params and expected fileName, tmp
# in that order. This should be backward compatibile.
my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args);
my ($file, $get, $fmt);
# in case the supplied name lacks a compressed extension
if(not $fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName .= $1; };
$self->debug("uncompressing file $fileName");
my @util_to_use = @UNCOMPRESSION_UTILS;
if (defined $exe){
$exe = $self->untaint($exe, 1);
unshift @util_to_use, $exe;
}
$exe ||= '';
while (not -x $exe and scalar(@util_to_use)) {
$exe = $self->find_exe(shift @util_to_use);
}
unless (-x $exe) {
$self->throw("Can't find compression utility. Looked for @util_to_use");
}
my ($uncompressed, @cmd, $handle);
$uncompressed = $fileName;
$uncompressed =~ s/\.\w+$//;
if(defined($outfile) or $tmp or not -o $fileName) {
if (defined $outfile) {
$uncompressed = $outfile;
} else {
# obtain a temporary file name (not using the handle)
my $io = Bio::Root::IO->new();
($handle, $uncompressed) = $io->tempfile();
# insert some special text to flag it as a bioperl-based temp file
$uncompressed .= '.tmp.bioperl';
}
if ($exe =~ /gunzip|bunzip2|uncompress/) {
@cmd = ("$exe -f < \"$fileName\" > \"$uncompressed\"");
} elsif ($exe eq 'unzip') {
@cmd = ("$exe -p \"$fileName\" > \"$uncompressed\"");
}
not $tmp and
$self->warn("Not owner of file $fileName. Uncompressing to temp file $uncompressed.");
$tmp = 1;
} else {
if ($exe =~ /gunzip|bunzip2|uncompress/) {
@cmd = ($exe, '-f', $fileName);
} elsif ($exe eq 'zip') {
@cmd = ($exe, $fileName);
}
}
if(system(@cmd) != 0) {
$self->throw( -class => 'Bio::Root::SystemException',
-text => "Failed to uncompress file $fileName using $exe: $!");
}
return $uncompressed;
}
=head2 file_date
Title : file_date
Usage : $Util->file_date( filename [,date_format])
Purpose : Obtains the date of a given file.
: Provides flexible formatting via date_format().
Returns : String = date of the file as: yyyy-mm-dd (e.g., 1997-10-15)
Argument : filename = string, full path name for file
: date_format = string, desired format for date (see date_format()).
: Default = yyyy-mm-dd
Thows : Exception if no file is provided or does not exist.
Comments : Uses the mtime field as obtained by stat().
=cut
#--------------
sub file_date {
#--------------
my ($self, $file, $fmt) = @_;
$self->throw("No such file: $file") if not $file or not -e $file;
$fmt ||= 'yyyy-mm-dd';
my @file_data = stat($file);
return $self->date_format($fmt, $file_data[9]); # mtime field
}
=head2 untaint
Title : untaint
Purpose : To remove nasty shell characters from untrusted data
: and allow a script to run with the -T switch.
: Potentially dangerous shell meta characters: &;`'\"|*?!~<>^()[]{}$\n\r
: Accept only the first block of contiguous characters:
: Default allowed chars = "-\w.', ()"
: If $relax is true = "-\w.', ()\/=%:^<>*"
Usage : $Util->untaint($value, $relax)
Returns : String containing the untained data.
Argument: $value = string
: $relax = boolean
Comments:
This general untaint() function may not be appropriate for every situation.
To allow only a more restricted subset of special characters
(for example, untainting a regular expression), then using a custom
untainting mechanism would permit more control.
Note that special trusted vars (like $0) require untainting.
=cut
#------------`
sub untaint {
#------------
my($self,$value,$relax) = @_;
$relax ||= 0;
my $untainted;
$self->debug("\nUNTAINT: $value\n");
unless (defined $value and $value ne '') {
return $value;
}
if( $relax ) {
$value =~ /([-\w.\', ()\/=%:^<>*]+)/;
$untainted = $1
# } elsif( $relax == 2 ) { # Could have several degrees of relax.
# $value =~ /([-\w.\', ()\/=%:^<>*]+)/;
# $untainted = $1
} else {
$value =~ /([-\w.\', ()]+)/;
$untainted = $1
}
$self->debug("UNTAINTED: $untainted\n");
$untainted;
}
=head2 mean_stdev
Title : mean_stdev
Usage : ($mean, $stdev) = $Util->mean_stdev( @data )
Purpose : Calculates the mean and standard deviation given a list of numbers.
Returns : 2-element list (mean, stdev)
Argument : list of numbers (ints or floats)
Thows : n/a
=cut
#---------------
sub mean_stdev {
#---------------
my ($self, @data) = @_;
return (undef,undef) if not @data; # case of empty @data list
my $mean = 0;
my $N = 0;
foreach (@data) { $mean += $_; $N++ }
$mean /= $N;
my $sum_diff_sqd = 0;
foreach (@data) { $sum_diff_sqd += ($mean - $_) * ($mean - $_); }
# if only one element in @data list, unbiased stdev is undefined
my $stdev = $N <= 1 ? undef : sqrt( $sum_diff_sqd / ($N-1) );
return ($mean, $stdev);
}
=head2 count_files
Title : count_files
Purpose : Counts the number of files/directories within a given directory.
: Also reports the number of text and binary files in the dir
: as well as names of these files and directories.
Usage : count_files(\%data)
: $data{-DIR} is the directory to be analyzed. Default is ./
: $data{-PRINT} = 0|1; if 1, prints results to STDOUT, (default=0).
Argument : Hash reference (empty)
Returns : n/a;
: Modifies the hash ref passed in as the sole argument.
: $$href{-TOTAL} scalar
: $$href{-NUM_TEXT_FILES} scalar
: $$href{-NUM_BINARY_FILES} scalar
: $$href{-NUM_DIRS} scalar
: $$href{-T_FILE_NAMES} array ref
: $$href{-B_FILE_NAMES} array ref
: $$href{-DIRNAMES} array ref
=cut
#----------------
sub count_files {
#----------------
my $self = shift;
my $href = shift; # Reference to an empty hash.
my( $name, @fileLine);
my $dir = $$href{-DIR} || './'; # THIS IS UNIX SPECIFIC? FIXME/TODO
my $print = $$href{-PRINT} || 0;
### Make sure $dir ends with /
$dir !~ m{/$} and do{ $dir .= '/'; $$href{-DIR} = $dir; };
open ( my $PIPE, "ls -1 $dir |" ) || $self->throw("Can't open input pipe: $!");
### Initialize the hash data.
$$href{-TOTAL} = 0;
$$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} = $$href{-NUM_DIRS} = 0;
$$href{-T_FILE_NAMES} = [];
$$href{-B_FILE_NAMES} = [];
$$href{-DIR_NAMES} = [];
while( <$PIPE> ) {
chomp();
$$href{-TOTAL}++;
if( -T $dir.$_ ) {
$$href{-NUM_TEXT_FILES}++; push @{$$href{-T_FILE_NAMES}}, $_; }
if( -B $dir.$_ and not -d $dir.$_) {
$$href{-NUM_BINARY_FILES}++; push @{$$href{-B_FILE_NAMES}}, $_; }
if( -d $dir.$_ ) {
$$href{-NUM_DIRS}++; push @{$$href{-DIR_NAMES}}, $_; }
}
close $PIPE;
if( $print) {
printf( "\n%4d %s\n", $$href{-TOTAL}, "total files+dirs in $dir");
printf( "%4d %s\n", $$href{-NUM_TEXT_FILES}, "text files");
printf( "%4d %s\n", $$href{-NUM_BINARY_FILES}, "binary files");
printf( "%4d %s\n", $$href{-NUM_DIRS}, "directories");
}
}
#=head2 file_info
#
# Title : file_info
# Purpose : Obtains a variety of date for a given file.
# : Provides an interface to Perl's stat().
# Status : Under development. Not ready. Don't use!
#
#=cut
#--------------
sub file_info {
#--------------
my ($self, %param) = @_;
my ($file, $get, $fmt) = $self->_rearrange([qw(FILE GET FMT)], %param);
$get ||= 'all';
$fmt ||= 'yyyy-mm-dd';
my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
$atime, $mtime, $ctime, $blksize, $blocks) = stat $file;
if($get =~ /date/i) {
## I can get the elapsed time since the file was modified but
## it's not so straightforward to get the date in a nice format...
## Think about using a standard CPAN module for this, like
## Date::Manip or Date::DateCalc.
my $date = $mtime;
my $elsec = time - $mtime;
printf "\nFile age: %.0f sec %.0f hrs %.0f days", $elsec, $elsec/3600, $elsec/(3600*24);<STDIN>;
my $days = sprintf "%.0f", $elsec/(3600*24);
} elsif($get eq 'all') {
return stat $file;
}
}
#------------
sub delete {
#------------
my $self = shift;
my $fileName = shift;
if(not -e $fileName) {
$self->throw("Can't delete file $fileName: Does not exist.");
} elsif(not -o $fileName) {
$self->throw("Can't delete file $fileName: Not owner.");
}
my $ulval = unlink($fileName) > 0 or
$self->throw("Failed to delete file $fileName: $!");
}
=head2 create_filehandle
Usage : $object->create_filehandle(<named parameters>);
Purpose : Create a FileHandle object from a file or STDIN.
: Mainly used as a helper method by read() and get_newline().
Example : $data = $object->create_filehandle(-FILE =>'usr/people/me/data.txt')
Argument : Named parameters (case-insensitive):
: (all optional)
: -CLIENT => object reference for the object submitting
: the request. Default = $Util.
: -FILE => string (full path to file) or a reference
: to a FileHandle object or typeglob. This is an
: optional parameter (if not defined, STDIN is used).
Returns : Reference to a FileHandle object.
Throws : Exception if cannot open a supplied file or if supplied with a
: reference that is not a FileHandle ref.
Comments : If given a FileHandle reference, this method simply returns it.
: This method assumes the user wants to read ascii data. So, if
: the file is binary, it will be treated as a compressed (gzipped)
: file and access it using gzip -ce. The problem here is that not
: all binary files are necessarily compressed. Therefore,
: this method should probably have a -mode parameter to
: specify ascii or binary.
See Also : L<get_newline()|get_newline>
=cut
#---------------------
sub create_filehandle {
#---------------------
my($self, @param) = @_;
my($client, $file, $handle) =
$self->_rearrange([qw( CLIENT FILE HANDLE )], @param);
if(not ref $client) { $client = $self; }
$file ||= $handle;
if( $client->can('file')) {
$file = $client->file($file);
}
my $FH;
my ($handle_ref);
if($handle_ref = ref($file)) {
if($handle_ref eq 'FileHandle') {
$FH = $file;
$client->{'_input_type'} = "FileHandle";
} elsif($handle_ref eq 'GLOB') {
$FH = $file;
$client->{'_input_type'} = "Glob";
} else {
$self->throw(-class=>'Bio::Root::IOException',
-text =>"Can't read from $file: Not a FileHandle or GLOB ref.");
}
$self->verbose > 0 and printf STDERR "$ID: reading data from FileHandle\n";
} elsif($file) {
$client->{'_input_type'} = "FileHandle for $file";
# Use gzip -cd to access compressed data.
if( -B $file ) {
$client->{'_input_type'} .= " (compressed)";
my $gzip = $self->find_exe('gzip');
$file = "$gzip -cd $file |"
}
require FileHandle;
$FH = new FileHandle;
open ($FH, $file) || $self->throw(-class=>'Bio::Root::FileOpenException',
-text =>"Can't access data file: $file: $!");
$self->verbose > 0 and printf STDERR "$ID: reading data from file $file\n";
} else {
# Read from STDIN.
$FH = \*STDIN;
$self->verbose > 0 and printf STDERR "$ID: reading data from STDIN\n";
$client->{'_input_type'} = "STDIN";
}
return $FH;
}
=head2 get_newline
Usage : $object->get_newline(<named parameters>);
Purpose : Determine the character(s) used for newlines in a given file or
: input stream. Delegates to Bio::Root::Utilities::get_newline()
Example : $data = $object->get_newline(-CLIENT => $anObj,
: -FILE =>'usr/people/me/data.txt')
Argument : Same arguemnts as for create_filehandle().
Returns : Reference to a FileHandle object.
Throws : Propogates any exceptions thrown by Bio::Root::Utilities::get_newline().
See Also : L<taste_file()|taste_file>, L<create_filehandle()|create_filehandle>
=cut
#-----------------
sub get_newline {
#-----------------
my($self, @param) = @_;
return $NEWLINE if defined $NEWLINE;
my($client ) =
$self->_rearrange([qw( CLIENT )], @param);
my $FH = $self->create_filehandle(@param);
if(not ref $client) { $client = $self; }
if($client->{'_input_type'} =~ /STDIN|Glob|compressed/) {
# Can't taste from STDIN since we can't seek 0 on it.
# Are other non special Glob refs seek-able?
# Attempt to guess newline based on platform.
# Not robust since we could be reading Unix files on a Mac, e.g.
if(defined $ENV{'MACPERL'}) {
$NEWLINE = "\015"; # \r
} else {
$NEWLINE = "\012"; # \n
}
} else {
$NEWLINE = $self->taste_file($FH);
}
close ($FH) unless ($client->{'_input_type'} eq 'STDIN' ||
$client->{'_input_type'} eq 'FileHandle' ||
$client->{'_input_type'} eq 'Glob' );
delete $client->{'_input_type'};
return $NEWLINE || $DEFAULT_NEWLINE;
}
=head2 taste_file
Usage : $object->taste_file( <FileHandle> );
: Mainly a utility method for get_newline().
Purpose : Sample a filehandle to determine the character(s) used for a newline.
Example : $char = $Util->taste_file($FH)
Argument : Reference to a FileHandle object.
Returns : String containing an octal represenation of the newline character string.
: Unix = "\012" ("\n")
: Win32 = "\012\015" ("\r\n")
: Mac = "\015" ("\r")
Throws : Exception if no input is read within $TIMEOUT_SECS seconds.
: Exception if argument is not FileHandle object reference.
: Warning if cannot determine neewline char(s).
Comments : Based on code submitted by Vicki Brown (vlb@deltagen.com).
See Also : L<get_newline()|get_newline>
=cut
#---------------
sub taste_file {
#---------------
my ($self, $FH) = @_;
my $BUFSIZ = 256; # Number of bytes read from the file handle.
my ($buffer, $octal, $str, $irs, $i);
ref($FH) eq 'FileHandle' or $self->throw("Can't taste file: not a FileHandle ref");
$buffer = '';
# this is a quick hack to check for availability of alarm(); just copied
# from Bio/Root/IOManager.pm HL 02/19/01
my $alarm_available = 1;
eval {
alarm(0);
};
if($@) {
# alarm() not available (ActiveState perl for win32 doesn't have it.
# See jitterbug PR#98)