# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+use warnings;
use strict;
use Carp;
use Data::Dumper;
use Storable;
use IO::File;
+use Time::HiRes qw( gettimeofday );
use Maasha::Config;
use Exporter;
@ISA = qw( Exporter ) ;
+use Inline ( C => <<'END_C', DIRECTORY => $ENV{ "BP_TMP" } );
+
+int index_m( char *str, char *substr, size_t str_len, size_t substr_len, size_t offset, size_t max_mismatch )
+{
+ /* Martin A. Hansen & Selene Fernandez, August 2008 */
+
+ /* Locates a substring within a string starting from offset and allowing for max_mismatch mismatches. */
+ /* The begin position of the substring is returned if found otherwise -1 is returned. */
+
+ int i = 0;
+ int j = 0;
+
+ size_t max_match = substr_len - max_mismatch;
+
+ i = offset;
+
+ while ( i < str_len - ( max_match + max_mismatch ) + 1 )
+ {
+ j = 0;
+
+ while ( j < substr_len - ( max_match + max_mismatch ) + 1 )
+ {
+ if ( match_m( str, substr, str_len, substr_len, i, j, max_match, max_mismatch ) != 0 ) {
+ return i;
+ }
+
+ j++;
+ }
+
+ i++;
+ }
+
+ return -1;
+}
+
+
+int match_m( char *str, char *substr, size_t str_len, size_t substr_len, size_t str_offset, size_t substr_offset, size_t max_match, size_t max_mismatch )
+{
+ /* Martin A. Hansen & Selene Fernandez, August 2008 */
+
+ /* Compares a string and substring starting at speficied string and substring offset */
+ /* positions allowing for a specified number of mismatches. Returns 1 if there is a */
+ /* match otherwise returns 0. */
+
+ size_t match = 0;
+ size_t mismatch = 0;
+
+ while ( str_offset <= str_len && substr_offset <= substr_len )
+ {
+ if ( str[ str_offset ] == substr[ substr_offset ] )
+ {
+ match++;
+
+ if ( match >= max_match ) {
+ return 1;
+ };
+ }
+ else
+ {
+ mismatch++;
+
+ if ( mismatch > max_mismatch ) {
+ return 0;
+ }
+ }
+
+ str_offset++;
+ substr_offset++;
+ }
+
+ return 0;
+}
+
+
+void str_analyze_C( const char *string )
+{
+ /* Martin A. Hansen, July 2009 */
+
+ /* Scans a string incrementing the char count in an array. */
+
+ int count[ 256 ] = { 0 }; /* Integer array spanning the ASCII alphabet */
+ int i;
+
+ for ( i = 0; i < strlen( string ); i++ ) {
+ count[ ( int ) string[ i ] ]++;
+ }
+
+ Inline_Stack_Vars;
+ Inline_Stack_Reset;
+
+ for ( i = 0; i < 256; i++ ) {
+ Inline_Stack_Push( sv_2mortal( newSViv( count[ i ] ) ) );
+ }
+
+ Inline_Stack_Done;
+}
+
+
+END_C
+
+
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
chomp $msg;
- $script = &get_scriptname();
+ $script = get_scriptname();
- $error = &Carp::longmess();
+ $error = Carp::longmess();
@lines = split "\n", $error;
$file_max = length "File";
$line_max = length "Line";
- if ( $line =~ /^ at (.+) line (\d+)$/ )
+ if ( $line =~ /^ at (.+) line (\d+)\.?$/ )
{
$file = $1;
$line_no = $2;
$file = $2;
$line_no = $3;
+ $routine =~ s/\(.+\)$/ .../;
+
$routine_max = length $routine if length $routine > $routine_max;
$file_max = length $file if length $file > $file_max;
$line_max = length $line_no if length $line_no > $line_max;
{
# Martin A. Hansen, January 2004.
- # read opens a file and returns a filehandle.
+ # Read opens a file and returns a filehandle.
my ( $path, # full path to file
) = @_;
my ( $fh, $type );
- $type = `file $path` if $path;
+ $type = `file $path` if -f $path;
if ( $type =~ /gzip compressed/ ) {
- $fh = new IO::File "zcat $path|" or &Maasha::Common::error( qq(Could not read-open file "$path": $!) );
+ $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
} else {
- $fh = new IO::File $path, "r" or &Maasha::Common::error( qq(Could not read-open file "$path": $!) );
+ $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
}
return $fh;
my ( $fh );
if ( $gzip ) {
- $fh = new IO::File "|gzip -f>$path" or &Maasha::Common::error( qq(Could not write-open file "$path": $!) );
+ $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
} else {
- $fh = new IO::File $path, "w" or &Maasha::Common::error( qq(Could not write-open file "$path": $!) );
+ $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
}
return $fh;
my ( $fh );
- $fh = new IO::File $path, "a" or &Maasha::Common::error( qq(Could not append-open file "$path": $!) );
+ $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
return $fh;
}
my ( $fh );
- $fh = new IO::File "-" or &Maasha::Common::error( qq(Could not open pipe: $!) );
-
- return $fh;
-}
-
-
-sub read_stdin
-{
- # Martin A. Hansen, July 2007.
-
- # Returns a filehandle to STDIN
-
- my ( $fh );
-
- $fh = new IO::File "<&STDIN" or &Maasha::Common::error( qq(Could not read from STDIN: $!) );
+ $fh = new IO::File "-" or Maasha::Common::error( qq(Could not open pipe: $!) );
return $fh;
}
-sub write_stdout
-{
- # Martin A. Hansen, July 2007.
-
- # Returns a filehandle to STDOUT
-
- my ( $fh );
-
- $fh = new IO::File ">&STDOUT" or &Maasha::Common::error( qq(Could not write to STDOUT: $!) );
-
- return $fh;
-}
-
-
-sub file_store
-{
- # Martin A. Hansen, December 2004.
-
- # writes a data structure to file.
-
- my ( $path, # full path to file
- $data, # data structure
- ) = @_;
-
- &Storable::store( $data, $path ) or &Maasha::Common::error( qq(Could not write-open file "$path": $!) );
-}
-
-
-sub file_retrieve
-{
- # Martin A. Hansen, December 2004.
-
- # retrieves hash data structure
- # (this routines needs to test if its a hash, array or else)
-
- my ( $path, # full path to data file
- ) = @_;
-
- my ( $data );
-
- $data = &Storable::retrieve( $path ) or &Maasha::Common::error( qq(Could not read-open file "$path": $!) );
-
- return wantarray ? %{ $data } : $data;
-}
-
-
-sub dir_create
-{
- # Martin A. Hansen, July 2007.
-
- # Creates a directory.
-
- my ( $path, # full path to dir
- ) = @_;
-
- # Returns nothing.
-
- if ( -d $path ) {
- &Maasha::Common::error( qq(Directory already exists "$path": $!) );
- } else {
- mkdir $path or &Maasha::Common::error( qq(Could not create directory "$path": $!) );
- }
-}
-
-
-sub dir_create_if_not_exists
-{
- # Martin A. Hansen, May 2008.
-
- # Creates a directory if it does not already exists.
-
- my ( $path, # full path to dir
- ) = @_;
-
- # Returns nothing.
-
- if ( not -d $path ) {
- mkdir $path or &Maasha::Common::error( qq(Could not create directory "$path": $!) );
- }
-}
-
-
-sub dir_remove
-{
- # Martin A. Hansen, April 2008.
-
- # Removes a directory recursively.
-
- my ( $path, # directory
- ) = @_;
-
- &Maasha::Common::run( "rm", "-rf $path" ) if -d $path;
-}
-
-
-sub ls_dirs
-{
- # Martin A. Hansen, June 2007.
-
- # returns all dirs in a given directory.
-
- my ( $path, # full path to directory
- ) = @_;
-
- # returns a list of filenames.
-
- my ( $dh, @dirs );
-
- $dh = &open_dir( $path );
-
- @dirs = &read_dir( $dh );
- @dirs = grep { -d "$path/$_" } @dirs;
-
- map { $_ = "$path/$_" } @dirs;
-
- close $dh;
-
- return wantarray ? @dirs : \@dirs;
-}
-
-
-sub ls_files
-{
- # Martin A. Hansen, June 2007.
-
- # returns all files in a given directory.
-
- my ( $path, # full path to directory
- ) = @_;
-
- # returns a list of filenames.
-
- my ( $dh, @files );
-
- $dh = &open_dir( $path );
-
- @files = &read_dir( $dh );
- @files = grep { -f "$path/$_" } @files;
-
- map { $_ = "$path/$_" } @files;
-
- close $dh;
-
- return wantarray ? @files : \@files;
-}
-
-
-sub open_dir
-{
- # Martin A. Hansen, June 2007.
-
- # open a directory and returns a directory handle
-
- use IO::Dir;
-
- my ( $path, # full path to directory
- ) = @_;
-
- # returns object
-
- my $dh;
-
- $dh = IO::Dir->new( $path ) or &Maasha::Common::error( qq(Could not open dir "$path": $!) );
-
- return $dh;
-}
-
-
-sub read_dir
-{
- # Martin A. Hansen, June 2007.
-
- # read all files and directories from a directory.
-
- my ( $dh, # directory handle object
- ) = @_;
-
- # returns list
-
- my ( $elem, @elems );
-
- while ( defined( $elem = $dh->read ) ) {
- push @elems, $elem;
- }
-
- return wantarray ? @elems : \@elems;
-}
-
-
sub read_args
{
# Martin A. Hansen, December 2006
} elsif ( -f $arg ) {
push @files, $arg;
} else {
- &Maasha::Common::error( qq(Bad syntax in argument->"$arg") );
+ Maasha::Common::error( qq(Bad syntax in argument->"$arg") );
}
}
$ok_hash{ "DIRS" } = 1;
$ok_hash{ "FILES" } = 1;
- map { &Maasha::Common::error( qq(Unknown argument->"$_") ) if not exists $ok_hash{ $_ } } keys %hash;
+ map { Maasha::Common::error( qq(Unknown argument->"$_") ) if not exists $ok_hash{ $_ } } keys %hash;
}
return wantarray ? %hash : \%hash;
}
+sub get_time
+{
+ # Martin A. Hansen, July 2008.
+
+ # Get current time as a number.
+
+ # Returns a number.
+
+ return time;
+}
+
+
+sub get_time_hires
+{
+ # Martin A. Hansen, May 2008.
+
+ # Get current time in high resolution.
+
+ # Returns a float.
+
+ return gettimeofday();
+}
+
+
+sub get_processid
+{
+ # Martin A. Hansen, July 2008.
+
+ # Get process id for current process.
+
+ # Returns a number.
+
+ return $$;
+}
+
+
sub get_sessionid
{
# Martin A. Hansen, April 2008.
# Returns a number
- return time . $$;
+ return get_time . get_processid;
+}
+
+
+sub get_user
+{
+ # Martin A. Hansen, July 2008.
+
+ # Return the user name of the current user.
+
+ # Returns a string.
+
+ return $ENV{ 'USER' };
}
# Create a temporary directory based on
# $ENV{ 'BP_TMP' } and sessionid.
- # Returns a path.
+ # this thing is a really bad solution and needs to be removed.
- my ( $user, $sid, $path );
+ # Returns a path.
- &Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
+ my ( $user, $sid, $pid, $path );
- $user = $ENV{ 'USER' };
- $user =~ s/\.//g;
+ Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
- $sid = &Maasha::Common::get_sessionid();
+ $user = Maasha::Common::get_user();
+ $sid = Maasha::Common::get_sessionid();
+ $pid = Maasha::Common::get_processid();
- $path = "$ENV{ 'BP_TMP' }/$user\_$sid";
+ $path = "$ENV{ 'BP_TMP' }/" . join( "_", $user, $sid, $pid, "bp_tmp" );
- &Maasha::Common::dir_create( $path );
+ Maasha::Filesys::dir_create( $path );
return $path;
}
}
-sub file_read
+sub get_fields
{
- # Martin A. Hansen, December 2004.
+ # Martin A. Hansen, July 2008.
- # given a file, a seek beg position and
- # length, returns the corresponding string.
-
- my ( $fh, # file handle to file
- $beg, # read start in file
- $len, # read length of block
- ) = @_;
+ # Given a filehandle to a file gets the
+ # next line which is split into a list of
+ # fields that is returned.
- # returns string
+ my ( $fh, # filehandle
+ $delimiter, # field seperator - OPTIONAL
+ ) = @_;
- my ( $string );
+ # Returns a list.
- &Maasha::Common::error( qq(Negative length: $len) ) if $len < 0;
+ my ( $line, @fields );
- sysseek $fh, $beg, 0;
- sysread $fh, $string, $len;
+ $line = <$fh>;
- return $string;
-}
+ return if not defined $line;
+ chomp $line;
-sub file_size
-{
- # Martin A. Hansen, March 2007
+ $delimiter ||= "\t";
- # returns the file size for a given file
+ @fields = split "$delimiter", $line;
- my ( $path, # full path to file
- ) = @_;
-
- # returns integer
-
- my $file_size = ( stat ( $path ) )[ 7 ];
-
- return $file_size;
+ return wantarray ? @fields : \@fields;
}
my ( $command_line, $result );
- $command_line = &Maasha::Config::get_exe( $exe );
+ $command_line = Maasha::Config::get_exe( $exe );
$command_line .= " " . $args if $args;
$command_line = "nice -n19 " . $command_line if $nice;
- system( $command_line ) == 0 or &Maasha::Common::error( qq(Could not execute "$command_line": $?) );
+ system( $command_line ) == 0 or Maasha::Common::error( qq(Could not execute "$command_line": $?) );
}
my ( $command_line, @result );
- $command_line = &Maasha::Config::get_exe( $exe );
+ $command_line = Maasha::Config::get_exe( $exe );
$command_line .= " " . $args if $args;
$command_line = "nice -n19 " . $command_line if $nice;
}
+sub time_stamp_diff
+{
+ # Martin A. Hansen, June 2009.
+
+ # Return the difference between two time stamps in
+ # the time stamp format.
+
+ my ( $t0, # time stamp 0
+ $t1, # time stamp 1
+ ) = @_;
+
+ # Returns a time stamp string.
+
+ my ( $year0, $mon0, $day0, $hour0, $min0, $sec0,
+ $year1, $mon1, $day1, $hour1, $min1, $sec1,
+ $year, $mon, $day, $hour, $min, $sec );
+
+ $t0 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
+ $year0 = $1;
+ $mon0 = $2;
+ $day0 = $3;
+ $hour0 = $4;
+ $min0 = $5;
+ $sec0 = $6;
+
+ $sec0 += $day0 * 24 * 60 * 60;
+ $sec0 += $hour0 * 60 * 60;;
+ $sec0 += $min0 * 60;
+
+ $t1 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
+ $year1 = $1;
+ $mon1 = $2;
+ $day1 = $3;
+ $hour1 = $4;
+ $min1 = $5;
+ $sec1 = $6;
+
+ $sec1 += $day1 * 24 * 60 * 60;
+ $sec1 += $hour1 * 60 * 60;;
+ $sec1 += $min1 * 60;
+
+ $year = $year1 - $year0;
+ $mon = $mon1 - $mon0;
+ $day = $day1 - $day0;
+
+ $sec = $sec1 - $sec0;
+
+ $hour = int( $sec / ( 60 * 60 ) );
+ $sec -= $hour * 60 * 60;
+
+ $min = int( $sec / 60 );
+ $sec -= $min * 60;
+
+ return join( ":", sprintf( "%02d", $hour ), sprintf( "%02d", $min ), sprintf( "%02d", $sec ) );
+}
+
+
+sub process_running
+{
+ # Martin A. Hansen, July 2008.
+
+ # Given a process ID check if it is running
+ # on the system. Return 1 if the process is
+ # running else 0.
+
+ my ( $pid, # process ID to check.
+ ) = @_;
+
+ # Returns boolean
+
+ my ( @ps_table );
+
+ @ps_table = run_and_return( "ps", " a" );
+
+ if ( grep /^\s*$pid\s+/, @ps_table ) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+
sub wrap_line
{
# Martin A. Hansen, May 2005
}
+sub str_analyze
+{
+ # Martin A. Hansen, July 2009.
+
+ # Analyzes the string composition of a given string.
+
+ my ( $str, # string to analyze
+ ) = @_;
+
+ # Returns hash
+
+ my ( @composition, %hash, $i );
+
+ @composition = Maasha::Common::str_analyze_C( $str );
+
+ for ( $i = 32; $i <= 126; $i++ ) { # Only include printable chars
+ $hash{ chr $i } = $composition[ $i ]
+ }
+
+ return wantarray ? %hash : \%hash;
+}
+
+
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1;
projects / biopieces.git / blobdiff