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