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