1 package Maasha::Common;
4 # Copyright (C) 2006-2007 Martin A. Hansen.
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License
8 # as published by the Free Software Foundation; either version 2
9 # of the License, or (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
20 # http://www.gnu.org/copyleft/gpl.html
23 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
26 # This module contains commonly used routines
29 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
38 use Time::HiRes qw( gettimeofday );
43 use vars qw( @ISA @EXPORT @EXPORT_OK );
45 @ISA = qw( Exporter ) ;
47 use Inline ( C => <<'END_C', DIRECTORY => $ENV{ "BP_TMP" } );
49 int index_m( char *str, char *substr, size_t str_len, size_t substr_len, size_t offset, size_t max_mismatch )
51 /* Martin A. Hansen & Selene Fernandez, August 2008 */
53 /* Locates a substring within a string starting from offset and allowing for max_mismatch mismatches. */
54 /* The begin position of the substring is returned if found otherwise -1 is returned. */
59 size_t max_match = substr_len - max_mismatch;
63 while ( i < str_len - ( max_match + max_mismatch ) + 1 )
67 while ( j < substr_len - ( max_match + max_mismatch ) + 1 )
69 if ( match_m( str, substr, str_len, substr_len, i, j, max_match, max_mismatch ) != 0 ) {
83 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 )
85 /* Martin A. Hansen & Selene Fernandez, August 2008 */
87 /* Compares a string and substring starting at speficied string and substring offset */
88 /* positions allowing for a specified number of mismatches. Returns 1 if there is a */
89 /* match otherwise returns 0. */
94 while ( str_offset <= str_len && substr_offset <= substr_len )
96 if ( str[ str_offset ] == substr[ substr_offset ] )
100 if ( match >= max_match ) {
108 if ( mismatch > max_mismatch ) {
121 void str_analyze_C( const char *string )
123 /* Martin A. Hansen, July 2009 */
125 /* Scans a string incrementing the char count in an array. */
127 int count[ 256 ] = { 0 }; /* Integer array spanning the ASCII alphabet */
130 for ( i = 0; i < strlen( string ); i++ ) {
131 count[ ( int ) string[ i ] ]++;
137 for ( i = 0; i < 256; i++ ) {
138 Inline_Stack_Push( sv_2mortal( newSViv( count[ i ] ) ) );
149 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
154 # Martin A. Hansen, February 2008.
156 # Print error message and exit with stack trace.
158 my ( $msg, # Error message.
159 $no_stack, # disable stack trace - OPTIONAL
164 my ( $script, $error, @lines, $line, $routine, $file, $line_no, @table, $routine_max, $file_max, $line_max );
168 $script = get_scriptname();
170 $error = Carp::longmess();
172 @lines = split "\n", $error;
174 $line = shift @lines;
176 push @table, [ "Routine", "File", "Line" ];
177 push @table, [ "-------", "----", "----" ];
179 $routine_max = length "Routine";
180 $file_max = length "File";
181 $line_max = length "Line";
183 if ( $line =~ /^ at (.+) line (\d+)$/ )
188 $file_max = length $file if length $file > $file_max;
189 $line_max = length $line_no if length $line_no > $line_max;
191 push @table, [ "", $file, $line_no ];
195 die qq(ERROR: Unrecognized error line "$line"\n);
198 foreach $line ( @lines )
200 if ( $line =~ /^\s*(.+) called at (.+) line (\d+)\s*$/ )
206 $routine =~ s/\(.+\)$/ .../;
208 $routine_max = length $routine if length $routine > $routine_max;
209 $file_max = length $file if length $file > $file_max;
210 $line_max = length $line_no if length $line_no > $line_max;
212 push @table, [ $routine, $file, $line_no ];
216 die qq(ERROR: Unrecognized error line "$line"\n);
222 print STDERR qq(\nERROR!\n\nProgram \'$script\' failed: $msg.\n\n);
224 die( "MAASHA_ERROR" ) if $no_stack;
230 foreach $line ( @table ) {
231 printf( STDERR "%-${routine_max}s%-${file_max}s%s\n", @{ $line } );
236 die( "MAASHA_ERROR" );
242 # Martin A. Hansen, January 2004.
244 # Read opens a file and returns a filehandle.
246 my ( $path, # full path to file
253 $type = `file $path` if -f $path;
255 if ( $type =~ /gzip compressed/ ) {
256 $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
258 $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
267 # Martin A. Hansen, January 2004.
269 # write opens a file and returns a filehandle
271 my ( $path, # full path to file
272 $gzip, # flag if data is to be gzipped - OPRIONAL
280 $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
282 $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
291 # Martin A. Hansen, February 2006.
293 # append opens file and returns a filehandle
295 my ( $path, # path to file
302 $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
310 # Martin A. Hansen, January 2007.
312 # opens a pipe and returns a filehandle
316 $fh = new IO::File "-" or Maasha::Common::error( qq(Could not open pipe: $!) );
324 # Martin A. Hansen, December 2006
326 # reads arguments from @ARGV which is strictly formatted.
327 # three kind of argments are accepted:
328 # 1) file names [filename]
329 # 2) options with value [--option=value]
330 # 3) option without value [--option]
332 my ( $args, # list of arguments
333 $ok_args, # list of accepted arguments - OPTIONAL
338 my ( %ok_hash, $arg, @dirs, @files, %hash );
340 foreach $arg ( @{ $args } )
342 if ( $arg =~ /^--([^=]+)=(.+)$/ ) {
344 } elsif ( $arg =~ /^--(.+)$/ ) {
346 } elsif ( -d $arg ) {
348 } elsif ( -f $arg ) {
351 Maasha::Common::error( qq(Bad syntax in argument->"$arg") );
355 $hash{ "DIRS" } = \@dirs;
356 $hash{ "FILES" } = \@files;
360 map { $ok_hash{ $_ } = 1 } @{ $ok_args };
362 $ok_hash{ "DIRS" } = 1;
363 $ok_hash{ "FILES" } = 1;
365 map { Maasha::Common::error( qq(Unknown argument->"$_") ) if not exists $ok_hash{ $_ } } keys %hash;
368 return wantarray ? %hash : \%hash;
374 # Martin A. Hansen, July 2008.
376 # Get current time as a number.
386 # Martin A. Hansen, May 2008.
388 # Get current time in high resolution.
392 return gettimeofday();
398 # Martin A. Hansen, July 2008.
400 # Get process id for current process.
410 # Martin A. Hansen, April 2008.
412 # Create a session id based on time and pid.
416 return get_time . get_processid;
422 # Martin A. Hansen, July 2008.
424 # Return the user name of the current user.
428 return $ENV{ 'USER' };
434 # Martin A. Hansen, April 2008.
436 # Create a temporary directory based on
437 # $ENV{ 'BP_TMP' } and sessionid.
439 # this thing is a really bad solution and needs to be removed.
443 my ( $user, $sid, $pid, $path );
445 Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
447 $user = Maasha::Common::get_user();
448 $sid = Maasha::Common::get_sessionid();
449 $pid = Maasha::Common::get_processid();
451 $path = "$ENV{ 'BP_TMP' }/" . join( "_", $user, $sid, $pid, "bp_tmp" );
453 Maasha::Filesys::dir_create( $path );
461 # Martin A. Hansen, February 2007
463 # returns the script name
465 return ( split "/", $0 )[ -1 ];
471 # Martin A. Hansen, February 2007
473 # Given a full path to a file returns the basename,
474 # which is the part of the name before the last '.'.
476 my ( $path, # full path to filename
481 $basename = ( split "/", $path )[ -1 ];
483 $basename =~ s/(.+)\.?.*/$1/;
491 # Martin A. Hansen, July 2008.
493 # Given a filehandle to a file gets the
494 # next line which is split into a list of
495 # fields that is returned.
497 my ( $fh, # filehandle
498 $delimiter, # field seperator - OPTIONAL
503 my ( $line, @fields );
507 return if not defined $line;
513 @fields = split "$delimiter", $line;
515 return wantarray ? @fields : \@fields;
521 # Martin A. Hansen, April 2007.
523 # Run an execute with optional arguments.
525 my ( $exe, # executable to run
526 $args, # argument string
532 my ( $command_line, $result );
534 $command_line = Maasha::Config::get_exe( $exe );
535 $command_line .= " " . $args if $args;
536 $command_line = "nice -n19 " . $command_line if $nice;
538 system( $command_line ) == 0 or Maasha::Common::error( qq(Could not execute "$command_line": $?) );
544 # Martin A. Hansen, April 2008.
546 # Run an execute with optional arguments returning the output
549 my ( $exe, # executable to run
550 $args, # argument string
556 my ( $command_line, @result );
558 $command_line = Maasha::Config::get_exe( $exe );
559 $command_line .= " " . $args if $args;
560 $command_line = "nice -n19 " . $command_line if $nice;
562 @result = `$command_line`;
566 return wantarray ? @result : \@result;
572 # Martin A. Hansen, February 2006.
574 # returns timestamp for use in log file.
575 # format: YYYY-MM-DD HH:MM:SS
579 my ( $year, $mon, $day, $time );
581 ( undef, undef, undef, $day, $mon, $year, undef, undef ) = gmtime( time );
583 $mon += 1; # first month is 0, so we correct accordingly
586 $day = sprintf "%02d", $day;
587 $mon = sprintf "%02d", $mon;
591 $time =~ s/.*(\d{2}:\d{2}:\d{2}).*/$1/;
593 return "$year-$mon-$day $time";
599 # Martin A. Hansen, June 2009.
601 # Return the difference between two time stamps in
602 # the time stamp format.
604 my ( $t0, # time stamp 0
608 # Returns a time stamp string.
610 my ( $year0, $mon0, $day0, $hour0, $min0, $sec0,
611 $year1, $mon1, $day1, $hour1, $min1, $sec1,
612 $year, $mon, $day, $hour, $min, $sec );
614 $t0 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
622 $sec0 += $day0 * 24 * 60 * 60;
623 $sec0 += $hour0 * 60 * 60;;
626 $t1 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
634 $sec1 += $day1 * 24 * 60 * 60;
635 $sec1 += $hour1 * 60 * 60;;
638 $year = $year1 - $year0;
639 $mon = $mon1 - $mon0;
640 $day = $day1 - $day0;
642 $sec = $sec1 - $sec0;
644 $hour = int( $sec / ( 60 * 60 ) );
645 $sec -= $hour * 60 * 60;
647 $min = int( $sec / 60 );
650 return join( ":", sprintf( "%02d", $hour ), sprintf( "%02d", $min ), sprintf( "%02d", $sec ) );
656 # Martin A. Hansen, July 2008.
658 # Given a process ID check if it is running
659 # on the system. Return 1 if the process is
662 my ( $pid, # process ID to check.
669 @ps_table = run_and_return( "ps", " a" );
671 if ( grep /^\s*$pid\s+/, @ps_table ) {
681 # Martin A. Hansen, May 2005
683 # Takes a given line and wraps it to a given width,
684 # without breaking any words.
686 my ( $line, # line to wrap
690 # Returns a list of lines.
692 my ( @lines, $substr, $wrap_pos, $pos, $new_line );
696 while ( $pos < length $line )
698 $substr = substr $line, $pos, $width;
700 if ( length $substr == $width )
702 $substr = reverse $substr;
703 $wrap_pos = index $substr, " ";
705 $new_line = substr $line, $pos, $width - $wrap_pos;
708 $pos += $width - $wrap_pos;
717 push @lines, $new_line;
720 return wantarray ? @lines : \@lines;
726 # Martin A. Hansen, July 2009.
728 # Analyzes the string composition of a given string.
730 my ( $str, # string to analyze
735 my ( @composition, %hash, $i );
737 @composition = Maasha::Common::str_analyze_C( $str );
739 for ( $i = 32; $i < 128; $i++ ) { # Only include printable chars
740 $hash{ chr $i } = $composition[ $i ]
743 return wantarray ? %hash : \%hash;
747 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<