1 package Maasha::Common;
4 # Copyright (C) 2006-2007 Martin A. Hansen.
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.
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.
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.
20 # http://www.gnu.org/copyleft/gpl.html
23 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
26 # This module contains commonly used routines
29 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
41 use vars qw( @ISA @EXPORT @EXPORT_OK );
43 @ISA = qw( Exporter ) ;
46 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
51 # Martin A. Hansen, February 2008.
53 # Print error message and exit with stack trace.
55 my ( $msg, # Error message.
56 $no_stack, # disable stack trace - OPTIONAL
61 my ( $script, $error, @lines, $line, $routine, $file, $line_no, @table, $routine_max, $file_max, $line_max );
65 $script = get_scriptname();
67 $error = Carp::longmess();
69 @lines = split "\n", $error;
73 push @table, [ "Routine", "File", "Line" ];
74 push @table, [ "-------", "----", "----" ];
76 $routine_max = length "Routine";
77 $file_max = length "File";
78 $line_max = length "Line";
80 if ( $line =~ /^ at (.+) line (\d+)$/ )
85 $file_max = length $file if length $file > $file_max;
86 $line_max = length $line_no if length $line_no > $line_max;
88 push @table, [ "", $file, $line_no ];
92 die qq(ERROR: Unrecognized error line "$line"\n);
95 foreach $line ( @lines )
97 if ( $line =~ /^\s*(.+) called at (.+) line (\d+)\s*$/ )
103 $routine =~ s/\(.+\)$/ .../;
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;
109 push @table, [ $routine, $file, $line_no ];
113 die qq(ERROR: Unrecognized error line "$line"\n);
119 print STDERR qq(\nERROR!\n\nProgram \'$script\' failed: $msg.\n\n);
121 die( "MAASHA_ERROR" ) if $no_stack;
127 foreach $line ( @table ) {
128 printf( STDERR "%-${routine_max}s%-${file_max}s%s\n", @{ $line } );
133 die( "MAASHA_ERROR" );
139 # Martin A. Hansen, January 2004.
141 # read opens a file and returns a filehandle.
143 my ( $path, # full path to file
150 $type = `file $path` if $path;
152 if ( $type =~ /gzip compressed/ ) {
153 $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
155 $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
164 # Martin A. Hansen, January 2004.
166 # write opens a file and returns a filehandle
168 my ( $path, # full path to file
169 $gzip, # flag if data is to be gzipped - OPRIONAL
177 $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
179 $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
188 # Martin A. Hansen, February 2006.
190 # append opens file and returns a filehandle
192 my ( $path, # path to file
199 $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
207 # Martin A. Hansen, January 2007.
209 # opens a pipe and returns a filehandle
213 $fh = new IO::File "-" or Maasha::Common::error( qq(Could not open pipe: $!) );
221 # Martin A. Hansen, July 2007.
223 # Returns a filehandle to STDIN
227 $fh = new IO::File "<&STDIN" or Maasha::Common::error( qq(Could not read from STDIN: $!) );
235 # Martin A. Hansen, July 2007.
237 # Returns a filehandle to STDOUT
241 $fh = new IO::File ">&STDOUT" or Maasha::Common::error( qq(Could not write to STDOUT: $!) );
249 # Martin A. Hansen, December 2004.
251 # writes a data structure to file.
253 my ( $path, # full path to file
254 $data, # data structure
257 Storable::store( $data, $path ) or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
263 # Martin A. Hansen, December 2004.
265 # retrieves hash data structure
266 # (this routines needs to test if its a hash, array or else)
268 my ( $path, # full path to data file
273 $data = Storable::retrieve( $path ) or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
275 return wantarray ? %{ $data } : $data;
281 # Martin A. Hansen, July 2007.
283 # Creates a directory.
285 my ( $path, # full path to dir
291 Maasha::Common::error( qq(Directory already exists "$path": $!) );
293 mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
298 sub dir_create_if_not_exists
300 # Martin A. Hansen, May 2008.
302 # Creates a directory if it does not already exists.
304 my ( $path, # full path to dir
309 if ( not -d $path ) {
310 mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
317 # Martin A. Hansen, April 2008.
319 # Removes a directory recursively.
321 my ( $path, # directory
324 Maasha::Common::run( "rm", "-rf $path" ) if -d $path;
330 # Martin A. Hansen, June 2007.
332 # returns all dirs in a given directory.
334 my ( $path, # full path to directory
337 # returns a list of filenames.
341 $dh = open_dir( $path );
343 @dirs = read_dir( $dh );
344 @dirs = grep { -d "$path/$_" } @dirs;
346 map { $_ = "$path/$_" } @dirs;
350 return wantarray ? @dirs : \@dirs;
356 # Martin A. Hansen, June 2007.
358 # returns all files in a given directory.
360 my ( $path, # full path to directory
363 # returns a list of filenames.
367 $dh = open_dir( $path );
369 @files = read_dir( $dh );
370 @files = grep { -f "$path/$_" } @files;
372 map { $_ = "$path/$_" } @files;
376 return wantarray ? @files : \@files;
382 # Martin A. Hansen, June 2007.
384 # open a directory and returns a directory handle
388 my ( $path, # full path to directory
395 $dh = IO::Dir->new( $path ) or Maasha::Common::error( qq(Could not open dir "$path": $!) );
403 # Martin A. Hansen, June 2007.
405 # read all files and directories from a directory.
407 my ( $dh, # directory handle object
412 my ( $elem, @elems );
414 while ( defined( $elem = $dh->read ) ) {
418 return wantarray ? @elems : \@elems;
424 # Martin A. Hansen, December 2006
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]
432 my ( $args, # list of arguments
433 $ok_args, # list of accepted arguments - OPTIONAL
438 my ( %ok_hash, $arg, @dirs, @files, %hash );
440 foreach $arg ( @{ $args } )
442 if ( $arg =~ /^--([^=]+)=(.+)$/ ) {
444 } elsif ( $arg =~ /^--(.+)$/ ) {
446 } elsif ( -d $arg ) {
448 } elsif ( -f $arg ) {
451 Maasha::Common::error( qq(Bad syntax in argument->"$arg") );
455 $hash{ "DIRS" } = \@dirs;
456 $hash{ "FILES" } = \@files;
460 map { $ok_hash{ $_ } = 1 } @{ $ok_args };
462 $ok_hash{ "DIRS" } = 1;
463 $ok_hash{ "FILES" } = 1;
465 map { Maasha::Common::error( qq(Unknown argument->"$_") ) if not exists $ok_hash{ $_ } } keys %hash;
468 return wantarray ? %hash : \%hash;
474 # Martin A. Hansen, July 2008.
476 # Get current time as a number.
486 # Martin A. Hansen, July 2008.
488 # Get process id for current process.
498 # Martin A. Hansen, April 2008.
500 # Create a session id based on time and pid.
504 return get_time . get_processid;
510 # Martin A. Hansen, July 2008.
512 # Return the user name of the current user.
516 return $ENV{ 'USER' };
522 # Martin A. Hansen, April 2008.
524 # Create a temporary directory based on
525 # $ENV{ 'BP_TMP' } and sessionid.
527 # this thing is a really bad solution and needs to be removed.
531 my ( $user, $sid, $pid, $path );
533 Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
535 $user = Maasha::Common::get_user();
536 $sid = Maasha::Common::get_sessionid();
537 $pid = Maasha::Common::get_processid();
539 $path = "$ENV{ 'BP_TMP' }/" . join( "_", $user, $sid, $pid, "bp_tmp" );
541 Maasha::Common::dir_create( $path );
549 # Martin A. Hansen, February 2007
551 # returns the script name
553 return ( split "/", $0 )[ -1 ];
559 # Martin A. Hansen, February 2007
561 # Given a full path to a file returns the basename,
562 # which is the part of the name before the last '.'.
564 my ( $path, # full path to filename
569 $basename = ( split "/", $path )[ -1 ];
571 $basename =~ s/(.+)\.?.*/$1/;
579 # Martin A. Hansen, July 2008.
581 # Given a filehandle to a file gets the
582 # next line which is split into a list of
583 # fields that is returned.
585 my ( $fh, # filehandle
586 $delimiter, # field seperator - OPTIONAL
591 my ( $line, @fields );
601 @fields = split "$delimiter", $line;
603 return wantarray ? @fields : \@fields;
609 # Martin A. Hansen, December 2004.
611 # given a file, a seek beg position and
612 # length, returns the corresponding string.
614 my ( $fh, # file handle to file
615 $beg, # read start in file
616 $len, # read length of block
623 Maasha::Common::error( qq(Negative length: $len) ) if $len < 0;
625 sysseek $fh, $beg, 0;
626 sysread $fh, $string, $len;
634 # Martin A. Hansen, March 2007
636 # returns the file size for a given file
638 my ( $path, # full path to file
643 my $file_size = ( stat ( $path ) )[ 7 ];
651 # Martin A. Hansen, April 2007.
653 # Run an execute with optional arguments.
655 my ( $exe, # executable to run
656 $args, # argument string
662 my ( $command_line, $result );
664 $command_line = Maasha::Config::get_exe( $exe );
665 $command_line .= " " . $args if $args;
666 $command_line = "nice -n19 " . $command_line if $nice;
668 system( $command_line ) == 0 or Maasha::Common::error( qq(Could not execute "$command_line": $?) );
674 # Martin A. Hansen, April 2008.
676 # Run an execute with optional arguments returning the output
679 my ( $exe, # executable to run
680 $args, # argument string
686 my ( $command_line, @result );
688 $command_line = Maasha::Config::get_exe( $exe );
689 $command_line .= " " . $args if $args;
690 $command_line = "nice -n19 " . $command_line if $nice;
692 @result = `$command_line`;
696 return wantarray ? @result : \@result;
702 # Martin A. Hansen, February 2006.
704 # returns timestamp for use in log file.
705 # format: YYYY-MM-DD HH:MM:SS
709 my ( $year, $mon, $day, $time );
711 ( undef, undef, undef, $day, $mon, $year, undef, undef ) = gmtime( time );
713 $mon += 1; # first month is 0, so we correct accordingly
716 $day = sprintf "%02d", $day;
717 $mon = sprintf "%02d", $mon;
721 $time =~ s/.*(\d{2}:\d{2}:\d{2}).*/$1/;
723 return "$year-$mon-$day $time";
729 # Martin A. Hansen, July 2008.
731 # Given a process ID check if it is running
732 # on the system. Return 1 if the process is
735 my ( $pid, # process ID to check.
742 @ps_table = run_and_return( "ps", " a" );
744 if ( grep /^\s*$pid\s+/, @ps_table ) {
754 # Martin A. Hansen, May 2005
756 # Takes a given line and wraps it to a given width,
757 # without breaking any words.
759 my ( $line, # line to wrap
763 # Returns a list of lines.
765 my ( @lines, $substr, $wrap_pos, $pos, $new_line );
769 while ( $pos < length $line )
771 $substr = substr $line, $pos, $width;
773 if ( length $substr == $width )
775 $substr = reverse $substr;
776 $wrap_pos = index $substr, " ";
778 $new_line = substr $line, $pos, $width - $wrap_pos;
781 $pos += $width - $wrap_pos;
790 push @lines, $new_line;
793 return wantarray ? @lines : \@lines;
797 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<