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_sessionid
 471 {
 472     # Martin A. Hansen, April 2008.
 473
 474     # Create a session id based on time and pid.
 475
 476     # Returns a number
 477
 478     return time . $$;
 479 }
 480
 481
 482 sub get_tmpdir
 483 {
 484     # Martin A. Hansen, April 2008.
 485
 486     # Create a temporary directory based on
 487     # $ENV{ 'BP_TMP' } and sessionid.
 488
 489     # Returns a path.
 490
 491     my ( $user, $sid, $path );
 492
 493     &Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
 494
 495     $user = $ENV{ 'USER' };
 496     $user =~ s/\.//g;
 497
 498     $sid  = &Maasha::Common::get_sessionid();
 499
 500     $path = "$ENV{ 'BP_TMP' }/$user\_$sid";
 501
 502     &Maasha::Common::dir_create( $path );
 503
 504     return $path;
 505 }
 506
 507
 508 sub get_scriptname
 509 {
 510     # Martin A. Hansen, February 2007
 511
 512     # returns the script name
 513
 514     return ( split "/", $0 )[ -1 ];
 515 }
 516
 517
 518 sub get_basename
 519 {
 520     # Martin A. Hansen, February 2007
 521
 522     # Given a full path to a file returns the basename,
 523     # which is the part of the name before the last '.'.
 524
 525     my ( $path,   # full path to filename
 526        ) = @_;
 527
 528     my ( $basename );
 529
 530     $basename = ( split "/", $path )[ -1 ];
 531
 532     $basename =~ s/(.+)\.?.*/$1/;
 533
 534     return $basename
 535 }
 536
 537
 538 sub file_read
 539 {
 540     # Martin A. Hansen, December 2004.
 541
 542     # given a file, a seek beg position and
 543     # length, returns the corresponding string.
 544
 545     my ( $fh,     # file handle to file
 546          $beg,    # read start in file
 547          $len,    # read length of block
 548         ) = @_;
 549
 550     # returns string
 551
 552     my ( $string );
 553
 554     &Maasha::Common::error( qq(Negative length: $len) ) if $len < 0;
 555
 556     sysseek $fh, $beg, 0;
 557     sysread $fh, $string, $len;
 558
 559     return $string;
 560 }
 561
 562
 563 sub file_size
 564 {
 565     # Martin A. Hansen, March 2007
 566
 567     # returns the file size for a given file
 568
 569     my ( $path,   # full path to file
 570        ) = @_;
 571
 572     # returns integer
 573
 574     my $file_size = ( stat ( $path ) )[ 7 ];
 575
 576     return $file_size;
 577 }
 578
 579
 580 sub run
 581 {
 582     # Martin A. Hansen, April 2007.
 583
 584     # Run an execute with optional arguments.
 585
 586     my ( $exe,      # executable to run
 587          $args,     # argument string
 588          $nice,     # nice flag
 589        ) = @_;
 590
 591     # Returns nothing.
 592
 593     my ( $command_line, $result );
 594
 595     $command_line  = &Maasha::Config::get_exe( $exe );
 596     $command_line .= " " . $args if $args;
 597     $command_line  = "nice -n19 " . $command_line if $nice;
 598
 599     system( $command_line ) == 0 or &Maasha::Common::error( qq(Could not execute "$command_line": $?) );
 600 }
 601
 602
 603 sub run_and_return
 604 {
 605     # Martin A. Hansen, April 2008.
 606
 607     # Run an execute with optional arguments returning the output
 608     # as a list.
 609
 610     my ( $exe,      # executable to run
 611          $args,     # argument string
 612          $nice,     # nice flag
 613        ) = @_;
 614
 615     # Returns a list.
 616
 617     my ( $command_line, @result );
 618
 619     $command_line  = &Maasha::Config::get_exe( $exe );
 620     $command_line .= " " . $args if $args;
 621     $command_line  = "nice -n19 " . $command_line if $nice;
 622
 623     @result = `$command_line`;
 624
 625     chomp @result;
 626
 627     return wantarray ? @result : \@result;
 628 }
 629
 630
 631 sub time_stamp
 632 {
 633     # Martin A. Hansen, February 2006.
 634
 635     # returns timestamp for use in log file.
 636     # format: YYYY-MM-DD HH:MM:SS
 637
 638     # returns string
 639
 640     my ( $year, $mon, $day, $time );
 641
 642     ( undef, undef, undef, $day, $mon, $year, undef, undef ) = gmtime( time );
 643
 644     $mon  += 1;       # first month is 0, so we correct accordingly
 645     $year += 1900;
 646
 647     $day  = sprintf "%02d", $day;
 648     $mon  = sprintf "%02d", $mon;
 649
 650     $time = localtime;
 651
 652     $time =~ s/.*(\d{2}:\d{2}:\d{2}).*/$1/;
 653
 654     return "$year-$mon-$day $time";
 655 }
 656
 657
 658 sub wrap_line
 659 {
 660     # Martin A. Hansen, May 2005
 661
 662     # Takes a given line and wraps it to a given width,
 663     # without breaking any words.
 664
 665     my ( $line,   # line to wrap
 666          $width,  # wrap width
 667        ) = @_;
 668
 669     # Returns a list of lines.
 670
 671     my ( @lines, $substr, $wrap_pos, $pos, $new_line );
 672
 673     $pos = 0;
 674
 675     while ( $pos < length $line )
 676     {
 677         $substr = substr $line, $pos, $width;
 678
 679         if ( length $substr == $width )
 680         {
 681             $substr   = reverse $substr;
 682             $wrap_pos = index $substr, " ";
 683
 684             $new_line = substr $line, $pos, $width - $wrap_pos;
 685             $new_line =~ s/ $//;
 686
 687             $pos += $width - $wrap_pos;
 688         }
 689         else
 690         {
 691             $new_line = $substr;
 692
 693             $pos += $width;
 694         }
 695
 696         push @lines, $new_line;
 697     }
 698
 699     return wantarray ? @lines : \@lines;
 700 }
 701
 702
 703 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 704
 705 1;