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