view release on metacpan or  search on metacpan

Bio/Root/Utilities.pm  view on Meta::CPAN

    $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';
        }

        # Use double quotes if executable path have empty spaces
        if ($exe =~ m/ /) {
            $exe = "\"$exe\"";
        }

        if ($exe =~ /gunzip|bunzip2|uncompress/) {
            @cmd = ("$exe -f < \"$fileName\" > \"$uncompressed\"");
        } elsif ($exe =~ /gzip/) {
            @cmd = ("$exe -df < \"$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 =~ /gzip/) {
            @cmd = ($exe, '-df', $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

Bio/Root/Utilities.pm  view on Meta::CPAN

 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( my $line = <$PIPE> ) {
        chomp();
        $$href{-TOTAL}++;
        if( -T $dir.$line ) {
            $$href{-NUM_TEXT_FILES}++;
            push @{$$href{-T_FILE_NAMES}}, $line; }
        if( -B $dir.$line and not -d $dir.$line) {
            $$href{-NUM_BINARY_FILES}++;
            push @{$$href{-B_FILE_NAMES}}, $line; }
        if( -d $dir.$line ) {
            $$href{-NUM_DIRS}++;
            push @{$$href{-DIR_NAMES}}, $line; }
    }
    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;
    }
}

=head2 delete

 Title   : delete
 Purpose :

=cut

#------------
sub delete {
#------------
    my $self = shift;
    my $fileName = shift;
    if(not -e $fileName) {
        $self->throw("Could not delete file '$fileName': Does not exist.");
    } elsif(not -o $fileName) {
        $self->throw("Could not 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)