code_perl/Maasha/Common.pm

   1 package Maasha::Common;
   2
   3
   4 # Copyright (C) 2006-2007 Martin A. Hansen.
   5
   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.
  10
  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.
  15
  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.
  19
  20 # http://www.gnu.org/copyleft/gpl.html
  21
  22
  23 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  24
  25
  26 # This module contains commonly used routines
  27
  28
  29 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  30
  31
  32 use warnings;
  33 use strict;
  34 use Carp;
  35 use Data::Dumper;
  36 use Storable;
  37 use IO::File;
  38 use Time::HiRes qw( gettimeofday );
  39 use Maasha::Config;
  40
  41 use Exporter;
  42
  43 use vars qw( @ISA @EXPORT @EXPORT_OK );
  44
  45 @ISA = qw( Exporter ) ;
  46
  47 use Inline ( C => <<'END_C', DIRECTORY => $ENV{ "BP_TMP" } );
  48
  49 int index_m( char *str, char *substr, size_t str_len, size_t substr_len, size_t offset, size_t max_mismatch )
  50 {
  51     /* Martin A. Hansen & Selene Fernandez, August 2008 */
  52
  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. */
  55
  56     int i = 0;
  57     int j = 0;
  58
  59     size_t max_match = substr_len - max_mismatch;
  60
  61     i = offset;
  62
  63     while ( i < str_len - ( max_match + max_mismatch ) + 1 )
  64     {
  65         j = 0;
  66
  67         while ( j < substr_len - ( max_match + max_mismatch ) + 1 )
  68         {
  69             if ( match_m( str, substr, str_len, substr_len, i, j, max_match, max_mismatch ) != 0 ) {
  70                 return i;
  71             }
  72
  73             j++;
  74         }
  75
  76         i++;
  77     }
  78
  79     return -1;
  80 }
  81
  82
  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 )
  84 {
  85     /* Martin A. Hansen & Selene Fernandez, August 2008 */
  86
  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. */
  90
  91     size_t match    = 0;
  92     size_t mismatch = 0;
  93
  94     while ( str_offset <= str_len && substr_offset <= substr_len )
  95     {
  96         if ( str[ str_offset ] == substr[ substr_offset ] )
  97         {
  98             match++;
  99
 100             if ( match >= max_match ) {
 101                 return 1;
 102             };
 103         }
 104         else
 105         {
 106             mismatch++;
 107
 108             if ( mismatch > max_mismatch ) {
 109                 return 0;
 110             }
 111         }
 112
 113         str_offset++;
 114         substr_offset++;
 115     }
 116
 117     return 0;
 118 }
 119
 120
 121 void str_analyze_C( const char *string )
 122 {
 123     /* Martin A. Hansen, July 2009 */
 124
 125     /* Scans a string incrementing the char count in an array. */
 126
 127     int count[ 256 ] = { 0 };   /* Integer array spanning the ASCII alphabet */
 128     int i;
 129
 130     for ( i = 0; i < strlen( string ); i++ ) {
 131         count[ ( int ) string[ i ] ]++;
 132     }
 133
 134     Inline_Stack_Vars;
 135     Inline_Stack_Reset;
 136
 137     for ( i = 0; i < 256; i++ ) {
 138         Inline_Stack_Push( sv_2mortal( newSViv( count[ i ] ) ) );
 139     }
 140
 141     Inline_Stack_Done;
 142 }
 143
 144
 145 END_C
 146
 147
 148
 149 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 150
 151
 152 sub error
 153 {
 154     # Martin A. Hansen, February 2008.
 155
 156     # Print error message and exit with stack trace.
 157
 158     my ( $msg,        # Error message.
 159          $no_stack,   # disable stack trace - OPTIONAL
 160        ) = @_;
 161
 162     # Returns nothing.
 163
 164     my ( $script, $error, @lines, $line, $routine, $file, $line_no, @table, $routine_max, $file_max, $line_max );
 165
 166     chomp $msg;
 167
 168     $script = get_scriptname();
 169
 170     $error  = Carp::longmess();
 171
 172     @lines  = split "\n", $error;
 173
 174     $line   = shift @lines;
 175
 176     push @table, [ "Routine", "File", "Line" ];
 177     push @table, [ "-------", "----", "----" ];
 178
 179     $routine_max = length "Routine";
 180     $file_max    = length "File";
 181     $line_max    = length "Line";
 182
 183     if ( $line =~ /^ at (.+) line (\d+)\.?$/ )
 184     {
 185         $file    = $1;
 186         $line_no = $2;
 187
 188         $file_max = length $file    if length $file    > $file_max;
 189         $line_max = length $line_no if length $line_no > $line_max;
 190
 191         push @table, [ "", $file, $line_no ];
 192     }
 193     else
 194     {
 195         die qq(ERROR: Unrecognized error line "$line"\n);
 196     }
 197
 198     foreach $line ( @lines )
 199     {
 200         if ( $line =~ /^\s*(.+) called at (.+) line (\d+)\s*$/ )
 201         {
 202             $routine = $1;
 203             $file    = $2;
 204             $line_no = $3;
 205
 206             $routine =~ s/\(.+\)$/ .../;
 207
 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;
 211
 212             push @table, [ $routine, $file, $line_no ];
 213         }
 214         else
 215         {
 216             die qq(ERROR: Unrecognized error line "$line"\n);
 217         }
 218     }
 219
 220     $msg =~ s/\.$//;
 221
 222     print STDERR qq(\nERROR!\n\nProgram \'$script\' failed: $msg.\n\n);
 223
 224     die( "MAASHA_ERROR" ) if $no_stack;
 225
 226     $routine_max += 3;
 227     $file_max    += 3;
 228     $line_max    += 3;
 229
 230     foreach $line ( @table ) {
 231         printf( STDERR "%-${routine_max}s%-${file_max}s%s\n", @{ $line } );
 232     }
 233
 234     print STDERR "\n";
 235
 236     die( "MAASHA_ERROR" );
 237 }
 238
 239
 240 sub read_open
 241 {
 242     # Martin A. Hansen, January 2004.
 243
 244     # Read opens a file and returns a filehandle.
 245
 246     my ( $path,   # full path to file
 247        ) = @_;
 248
 249     # returns filehandle
 250
 251     my ( $fh, $type );
 252
 253     $type = `file $path` if -f $path;
 254
 255     if ( $type =~ /gzip compressed/ ) {
 256         $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
 257     } else {
 258         $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
 259     }
 260
 261     return $fh;
 262 }
 263
 264
 265 sub write_open
 266 {
 267     # Martin A. Hansen, January 2004.
 268
 269     # write opens a file and returns a filehandle
 270
 271     my ( $path,   # full path to file
 272          $gzip,   # flag if data is to be gzipped - OPRIONAL
 273        ) = @_;
 274
 275     # returns filehandle
 276
 277     my ( $fh );
 278
 279     if ( $gzip ) {
 280         $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 281     } else {
 282         $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 283     }
 284
 285     return $fh;
 286 }
 287
 288
 289 sub append_open
 290 {
 291     # Martin A. Hansen, February 2006.
 292
 293     # append opens file and returns a filehandle
 294
 295     my ( $path,     # path to file
 296        ) = @_;
 297
 298     # returns filehandle
 299
 300     my ( $fh );
 301
 302     $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
 303
 304     return $fh;
 305 }
 306
 307
 308 sub pipe_open
 309 {
 310     # Martin A. Hansen, January 2007.
 311
 312     # opens a pipe and returns a filehandle
 313
 314     my ( $fh );
 315
 316     $fh = new IO::File "-" or Maasha::Common::error( qq(Could not open pipe: $!) );
 317
 318     return $fh;
 319 }
 320
 321
 322 sub read_args
 323 {
 324     # Martin A. Hansen, December 2006
 325
 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]
 331
 332     my ( $args,      # list of arguments
 333          $ok_args,   # list of accepted arguments - OPTIONAL
 334        ) = @_;
 335
 336     # returns a hashref
 337
 338     my ( %ok_hash, $arg, @dirs, @files, %hash );
 339
 340     foreach $arg ( @{ $args } )
 341     {
 342         if ( $arg =~ /^--([^=]+)=(.+)$/ ) {
 343             $hash{ $1 } = $2;
 344         } elsif ( $arg =~ /^--(.+)$/ ) {
 345             $hash{ $1 } = 1;
 346         } elsif ( -d $arg ) {
 347             push @dirs, $arg;
 348         } elsif ( -f $arg ) {
 349             push @files, $arg;
 350         } else {
 351             Maasha::Common::error( qq(Bad syntax in argument->"$arg") );
 352         }
 353     }
 354
 355     $hash{ "DIRS" }  = \@dirs;
 356     $hash{ "FILES" } = \@files;
 357
 358     if ( $ok_args )
 359     {
 360         map { $ok_hash{ $_ } = 1 } @{ $ok_args };
 361
 362         $ok_hash{ "DIRS" }  = 1;
 363         $ok_hash{ "FILES" } = 1;
 364
 365         map { Maasha::Common::error( qq(Unknown argument->"$_") ) if not exists $ok_hash{ $_ } } keys %hash;
 366     }
 367
 368     return wantarray ? %hash : \%hash;
 369 }
 370
 371
 372 sub get_time
 373 {
 374     # Martin A. Hansen, July 2008.
 375
 376     # Get current time as a number.
 377
 378     # Returns a number.
 379
 380     return time;
 381 }
 382
 383
 384 sub get_time_hires
 385 {
 386     # Martin A. Hansen, May 2008.
 387
 388     # Get current time in high resolution.
 389
 390     # Returns a float.
 391
 392     return gettimeofday();
 393 }
 394
 395
 396 sub get_processid
 397 {
 398     # Martin A. Hansen, July 2008.
 399
 400     # Get process id for current process.
 401
 402     # Returns a number.
 403
 404     return $$;
 405 }
 406
 407
 408 sub get_sessionid
 409 {
 410     # Martin A. Hansen, April 2008.
 411
 412     # Create a session id based on time and pid.
 413
 414     # Returns a number
 415
 416     return get_time . get_processid;
 417 }
 418
 419
 420 sub get_user
 421 {
 422     # Martin A. Hansen, July 2008.
 423
 424     # Return the user name of the current user.
 425
 426     # Returns a string.
 427
 428     return $ENV{ 'USER' };
 429 }
 430
 431
 432 sub get_tmpdir
 433 {
 434     # Martin A. Hansen, April 2008.
 435
 436     # Create a temporary directory based on
 437     # $ENV{ 'BP_TMP' } and sessionid.
 438
 439     # this thing is a really bad solution and needs to be removed.
 440
 441     # Returns a path.
 442
 443     my ( $user, $sid, $pid, $path );
 444
 445     Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
 446
 447     $user = Maasha::Common::get_user();
 448     $sid  = Maasha::Common::get_sessionid();
 449     $pid  = Maasha::Common::get_processid();
 450
 451     $path = "$ENV{ 'BP_TMP' }/" . join( "_", $user, $sid, $pid, "bp_tmp" );
 452
 453     Maasha::Filesys::dir_create( $path );
 454
 455     return $path;
 456 }
 457
 458
 459 sub get_scriptname
 460 {
 461     # Martin A. Hansen, February 2007
 462
 463     # returns the script name
 464
 465     return ( split "/", $0 )[ -1 ];
 466 }
 467
 468
 469 sub get_basename
 470 {
 471     # Martin A. Hansen, February 2007
 472
 473     # Given a full path to a file returns the basename,
 474     # which is the part of the name before the last '.'.
 475
 476     my ( $path,   # full path to filename
 477        ) = @_;
 478
 479     my ( $basename );
 480
 481     $basename = ( split "/", $path )[ -1 ];
 482
 483     $basename =~ s/(.+)\.?.*/$1/;
 484
 485     return $basename
 486 }
 487
 488
 489 sub get_fields
 490 {
 491     # Martin A. Hansen, July 2008.
 492
 493     # Given a filehandle to a file gets the
 494     # next line which is split into a list of
 495     # fields that is returned.
 496
 497     my ( $fh,          # filehandle
 498          $delimiter,   # field seperator - OPTIONAL
 499        ) = @_;
 500
 501     # Returns a list.
 502
 503     my ( $line, @fields );
 504
 505     $line = <$fh>;
 506
 507     return if not defined $line;
 508
 509     chomp $line;
 510
 511     $delimiter ||= "\t";
 512
 513     @fields = split "$delimiter", $line;
 514
 515     return wantarray ? @fields : \@fields;
 516 }
 517
 518
 519 sub run
 520 {
 521     # Martin A. Hansen, April 2007.
 522
 523     # Run an execute with optional arguments.
 524
 525     my ( $exe,      # executable to run
 526          $args,     # argument string
 527          $nice,     # nice flag
 528        ) = @_;
 529
 530     # Returns nothing.
 531
 532     my ( $command_line, $result );
 533
 534     $command_line  = Maasha::Config::get_exe( $exe );
 535     $command_line .= " " . $args if $args;
 536     $command_line  = "nice -n19 " . $command_line if $nice;
 537
 538     system( $command_line ) == 0 or Maasha::Common::error( qq(Could not execute "$command_line": $?) );
 539 }
 540
 541
 542 sub run_and_return
 543 {
 544     # Martin A. Hansen, April 2008.
 545
 546     # Run an execute with optional arguments returning the output
 547     # as a list.
 548
 549     my ( $exe,      # executable to run
 550          $args,     # argument string
 551          $nice,     # nice flag
 552        ) = @_;
 553
 554     # Returns a list.
 555
 556     my ( $command_line, @result );
 557
 558     $command_line  = Maasha::Config::get_exe( $exe );
 559     $command_line .= " " . $args if $args;
 560     $command_line  = "nice -n19 " . $command_line if $nice;
 561
 562     @result = `$command_line`;
 563
 564     chomp @result;
 565
 566     return wantarray ? @result : \@result;
 567 }
 568
 569
 570 sub time_stamp
 571 {
 572     # Martin A. Hansen, February 2006.
 573
 574     # returns timestamp for use in log file.
 575     # format: YYYY-MM-DD HH:MM:SS
 576
 577     # returns string
 578
 579     my ( $year, $mon, $day, $time );
 580
 581     ( undef, undef, undef, $day, $mon, $year, undef, undef ) = gmtime( time );
 582
 583     $mon  += 1;       # first month is 0, so we correct accordingly
 584     $year += 1900;
 585
 586     $day  = sprintf "%02d", $day;
 587     $mon  = sprintf "%02d", $mon;
 588
 589     $time = localtime;
 590
 591     $time =~ s/.*(\d{2}:\d{2}:\d{2}).*/$1/;
 592
 593     return "$year-$mon-$day $time";
 594 }
 595
 596
 597 sub time_stamp_diff
 598 {
 599     # Martin A. Hansen, June 2009.
 600
 601     # Return the difference between two time stamps in
 602     # the time stamp format.
 603
 604     my ( $t0,   # time stamp 0
 605          $t1,   # time stamp 1
 606        ) = @_;
 607
 608     # Returns a time stamp string.
 609
 610     my ( $year0, $mon0, $day0, $hour0, $min0, $sec0,
 611          $year1, $mon1, $day1, $hour1, $min1, $sec1,
 612          $year,  $mon,  $day,  $hour,  $min,  $sec );
 613
 614     $t0 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
 615     $year0 = $1;
 616     $mon0  = $2;
 617     $day0  = $3;
 618     $hour0 = $4;
 619     $min0  = $5;
 620     $sec0  = $6;
 621
 622     $sec0 += $day0 * 24 * 60 * 60;
 623     $sec0 += $hour0 * 60 * 60;;
 624     $sec0 += $min0  * 60;
 625
 626     $t1 =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
 627     $year1 = $1;
 628     $mon1  = $2;
 629     $day1  = $3;
 630     $hour1 = $4;
 631     $min1  = $5;
 632     $sec1  = $6;
 633
 634     $sec1 += $day1 * 24 * 60 * 60;
 635     $sec1 += $hour1 * 60 * 60;;
 636     $sec1 += $min1  * 60;
 637
 638     $year = $year1 - $year0;
 639     $mon  = $mon1  - $mon0;
 640     $day  = $day1  - $day0;
 641
 642     $sec  = $sec1 - $sec0;
 643
 644     $hour = int( $sec / ( 60 * 60 ) );
 645     $sec -= $hour * 60 * 60;
 646
 647     $min  = int( $sec / 60 );
 648     $sec -= $min * 60;
 649
 650     return join( ":", sprintf( "%02d", $hour ), sprintf( "%02d", $min ), sprintf( "%02d", $sec ) );
 651 }
 652
 653
 654 sub process_running
 655 {
 656     # Martin A. Hansen, July 2008.
 657
 658     # Given a process ID check if it is running
 659     # on the system. Return 1 if the process is
 660     # running else 0.
 661
 662     my ( $pid,   # process ID to check.
 663        ) = @_;
 664
 665     # Returns boolean
 666
 667     my ( @ps_table );
 668
 669     @ps_table = run_and_return( "ps", " a" );
 670
 671     if ( grep /^\s*$pid\s+/, @ps_table ) {
 672         return 1;
 673     } else {
 674         return 0;
 675     }
 676 }
 677
 678
 679 sub wrap_line
 680 {
 681     # Martin A. Hansen, May 2005
 682
 683     # Takes a given line and wraps it to a given width,
 684     # without breaking any words.
 685
 686     my ( $line,   # line to wrap
 687          $width,  # wrap width
 688        ) = @_;
 689
 690     # Returns a list of lines.
 691
 692     my ( @lines, $substr, $wrap_pos, $pos, $new_line );
 693
 694     $pos = 0;
 695
 696     while ( $pos < length $line )
 697     {
 698         $substr = substr $line, $pos, $width;
 699
 700         if ( length $substr == $width )
 701         {
 702             $substr   = reverse $substr;
 703             $wrap_pos = index $substr, " ";
 704
 705             $new_line = substr $line, $pos, $width - $wrap_pos;
 706             $new_line =~ s/ $//;
 707
 708             $pos += $width - $wrap_pos;
 709         }
 710         else
 711         {
 712             $new_line = $substr;
 713
 714             $pos += $width;
 715         }
 716
 717         push @lines, $new_line;
 718     }
 719
 720     return wantarray ? @lines : \@lines;
 721 }
 722
 723
 724 sub str_analyze
 725 {
 726     # Martin A. Hansen, July 2009.
 727
 728     # Analyzes the string composition of a given string.
 729
 730     my ( $str,   # string to analyze
 731        ) = @_;
 732
 733     # Returns hash
 734
 735     my ( @composition, %hash, $i );
 736
 737     @composition = Maasha::Common::str_analyze_C( $str );
 738
 739     for ( $i = 32; $i <= 126; $i++ ) {          # Only include printable chars
 740         $hash{ chr $i } = $composition[ $i ]
 741     }
 742
 743     return wantarray ? %hash : \%hash;
 744 }
 745
 746
 747 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 748
 749 1;