code_perl/Maasha/Biopieces.pm

   1 package Maasha::Biopieces;
   2
   3
   4 # Copyright (C) 2007-2009 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 # Routines for manipulation, parsing and emitting of human/machine readable biopieces records.
  27
  28
  29 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  30
  31
  32 use Getopt::Long qw( :config bundling );
  33 use Data::Dumper;
  34 use Maasha::Match;
  35 use Maasha::Common;
  36 use Maasha::Filesys;
  37 use vars qw( @ISA @EXPORT_OK );
  38
  39 require Exporter;
  40
  41 @ISA = qw( Exporter );
  42
  43 @EXPORT_OK = qw(
  44     read_stream
  45     write_stream
  46     get_record
  47     put_record
  48 );
  49
  50
  51 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> SIGNAL HANDLER <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  52
  53
  54 $SIG{ '__DIE__' } = \&sig_handler;
  55 $SIG{ 'INT' }     = \&sig_handler;
  56 $SIG{ 'TERM' }    = \&sig_handler;
  57
  58
  59 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> SUBROUTINES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  60
  61
  62 sub status_set
  63 {
  64     my ( $time_stamp, $script, $user, $pid, $file, $fh );
  65
  66     $time_stamp = Maasha::Common::time_stamp();
  67     $user       = Maasha::Common::get_user();
  68     $script     = Maasha::Common::get_scriptname();
  69     $pid        = Maasha::Common::get_processid();
  70
  71     $file = bp_tmp() . "/" . join( ".", $user, $script, $pid ) . ".status";
  72     $fh   = Maasha::Filesys::file_write_open( $file );
  73     flock($fh, 2);
  74
  75     print $fh join( ";", $time_stamp, join( " ", @ARGV ) ) . "\n";
  76
  77     close $fh;
  78 }
  79
  80
  81 sub status_log
  82 {
  83     # Martin A. Hansen, June 2009.
  84
  85     # Retrieves initial status information written with status_set and uses this
  86     # to write a status entry to the log file.
  87
  88     my ( $status,   # status - OPTIONAL
  89        ) = @_;
  90
  91     # Returns nothing.
  92
  93     my ( $time0, $time1, $script, $user, $pid, $file, $fh, $elap, $fh_global, $fh_local, $line, $args, $tmp_dir );
  94
  95     $status ||= "OK";
  96
  97     $time1      = Maasha::Common::time_stamp();
  98     $user       = Maasha::Common::get_user();
  99     $script     = Maasha::Common::get_scriptname();
 100     $pid        = Maasha::Common::get_processid();
 101
 102     $file = bp_tmp() . "/" . join( ".", $user, $script, $pid ) . ".status";
 103
 104     return if not -f $file;
 105
 106     $fh   = Maasha::Filesys::file_read_open( $file );
 107     flock($fh, 1);
 108     $line = <$fh>;
 109     chomp $line;
 110     close $fh;
 111
 112     unlink $file;
 113
 114     ( $time0, $args, $tmp_dir ) = split /;/, $line;
 115
 116     Maasha::Filesys::dir_remove( $tmp_dir ) if defined $tmp_dir;
 117
 118     $elap = Maasha::Common::time_stamp_diff( $time0, $time1 );
 119
 120     $fh_global = Maasha::Filesys::file_append_open( "$ENV{ 'BP_LOG' }/biopieces.log" );
 121     flock($fh_global, 2);
 122     $fh_local  = Maasha::Filesys::file_append_open( "$ENV{ 'HOME' }/.biopieces.log" );
 123     flock($fh_local, 2);
 124
 125     print $fh_global join( "\t", $time0, $time1, $elap, $user, $status, "$script $args" ) . "\n";
 126     print $fh_local  join( "\t", $time0, $time1, $elap, $user, $status, "$script $args" ) . "\n";
 127
 128     $fh_global->autoflush( 1 );
 129     $fh_local->autoflush( 1 );
 130
 131     close $fh_global;
 132     close $fh_local;
 133 }
 134
 135
 136 sub log_biopiece
 137 {
 138     # Martin A. Hansen, January 2008.
 139
 140     # Log messages to logfile.
 141
 142     # Returns nothing.
 143
 144     my ( $time_stamp, $user, $script, $fh );
 145
 146     $time_stamp = Maasha::Common::time_stamp();
 147     $user       = Maasha::Common::get_user();
 148     $script     = Maasha::Common::get_scriptname();
 149
 150     $fh = Maasha::Filesys::file_append_open( "$ENV{ 'BP_LOG' }/biopieces.log" );
 151     flock($fh, 2);
 152
 153     print $fh "$time_stamp\t$user\t$script ", join( " ", @ARGV ), "\n";
 154
 155     $fh->autoflush( 1 );
 156
 157     close $fh;
 158 }
 159
 160
 161 sub read_stream
 162 {
 163     # Martin A. Hansen, July 2007.
 164
 165     # Opens a stream to STDIN or a file,
 166
 167     my ( $file,   # file - OPTIONAL
 168        ) = @_;
 169
 170     # Returns filehandle.
 171
 172     my ( $fh );
 173
 174     if ( not -t STDIN ) {
 175         $fh = Maasha::Filesys::stdin_read();
 176     } elsif ( not $file ) {
 177         # Maasha::Common::error( qq(no data stream) );
 178     } else {
 179         $fh = Maasha::Filesys::file_read_open( $file );
 180     }
 181
 182     return $fh;
 183 }
 184
 185
 186 sub write_stream
 187 {
 188     # Martin A. Hansen, August 2007.
 189
 190     # Opens a stream to STDOUT or a file.
 191
 192     my ( $path,   # path          - OPTIONAL
 193          $gzip,   # compress data - OPTIONAL
 194        ) = @_;
 195
 196     # Returns filehandle.
 197
 198     my ( $fh );
 199
 200     if ( $path ) {
 201         $fh = Maasha::Filesys::file_write_open( $path, $gzip );
 202     } else {
 203         $fh = Maasha::Filesys::stdout_write();
 204     }
 205
 206     return $fh;
 207 }
 208
 209
 210 sub close_stream
 211 {
 212     # Martin A. Hansen, May 2009.
 213
 214     # Close stream if open.
 215
 216     my ( $fh,   # filehandle
 217        ) = @_;
 218
 219     # Returns nothing.
 220
 221     close $fh if defined $fh;
 222 }
 223
 224
 225 sub get_record
 226 {
 227     # Martin A. Hansen, July 2007.
 228
 229     # Reads one record at a time and converts that record
 230     # to a Perl data structure (a hash) which is returned.
 231
 232     my ( $fh,   # handle to stream
 233        ) = @_;
 234
 235     # Returns a hash.
 236
 237     my ( $block, @lines, $line, $key, $value, %record );
 238
 239     return if not defined $fh;
 240
 241     local $/ = "\n---\n";
 242
 243     $block = <$fh>;
 244
 245     return if not defined $block;
 246
 247     chomp $block;
 248
 249     @lines = split "\n", $block;
 250
 251     foreach $line ( @lines )
 252     {
 253         ( $key, $value ) = split ": ", $line, 2;
 254
 255         $record{ $key } = $value;
 256     }
 257
 258     return wantarray ? %record : \%record;
 259 }
 260
 261
 262 sub put_record
 263 {
 264     # Martin A. Hansen, July 2007.
 265
 266     # Given a Perl datastructure (a hash ref) emits this to STDOUT or a filehandle.
 267
 268     my ( $data,   # data structure
 269          $fh,     # file handle - OPTIONAL
 270        ) = @_;
 271
 272     # Returns nothing.
 273
 274     if ( scalar keys %{ $data } )
 275     {
 276         if ( $fh )
 277         {
 278             map { print $fh "$_: $data->{ $_ }\n" } keys %{ $data };
 279             print $fh "---\n";
 280         }
 281         else
 282         {
 283             map { print "$_: $data->{ $_ }\n" } keys %{ $data };
 284             print "---\n";
 285         }
 286     }
 287
 288     undef $data;
 289 }
 290
 291
 292 sub parse_options
 293 {
 294     # Martin A. Hansen, May 2009
 295
 296     # Parses and checks options for Biopieces.
 297
 298     # First the argument list is checked for duplicates and then
 299     # options are parsed from ARGV after which it is checked if
 300     # the Biopieces usage information should be printed. Finally,
 301     # all options from ARGV are checked according to the argument list.
 302
 303     my ( $arg_list,   # data structure with argument description
 304        ) = @_;
 305
 306     # Returns hashref.
 307
 308     my ( $arg, @list, $options );
 309
 310     # ---- Adding the mandatory arguments to the arg_list ----
 311
 312     push @{ $arg_list }, (
 313         { long => 'help',       short => '?', type => 'flag',  mandatory => 'no', default => undef, allowed => undef, disallowed => undef },
 314         { long => 'stream_in',  short => 'I', type => 'file!', mandatory => 'no', default => undef, allowed => undef, disallowed => undef },
 315         { long => 'stream_out', short => 'O', type => 'file',  mandatory => 'no', default => undef, allowed => undef, disallowed => undef },
 316         { long => 'verbose',    short => 'v', type => 'flag',  mandatory => 'no', default => undef, allowed => undef, disallowed => undef },
 317     );
 318
 319     check_duplicates_args( $arg_list );
 320
 321     # ---- Compiling options list ----
 322
 323     foreach $arg ( @{ $arg_list } )
 324     {
 325         if ( $arg->{ 'type' } eq 'flag' ) {
 326             push @list, "$arg->{ 'long' }|$arg->{ 'short' }";
 327         } else {
 328             push @list, "$arg->{ 'long' }|$arg->{ 'short' }=s";
 329         }
 330     }
 331
 332     # ---- Parsing options from @ARGV ----
 333
 334     $options = {};
 335
 336     Getopt::Long::GetOptions( $options, @list );
 337
 338     # print Dumper( $options );
 339
 340     check_print_usage( $options );
 341
 342     # ---- Expanding and checking options ----
 343
 344     foreach $arg ( @{ $arg_list } )
 345     {
 346         check_mandatory(  $arg, $options );
 347         set_default(      $arg, $options );
 348         check_uint(       $arg, $options );
 349         check_int(        $arg, $options );
 350         set_list(         $arg, $options );
 351         check_dir(        $arg, $options );
 352         check_file(       $arg, $options );
 353         set_files(        $arg, $options );
 354         check_files(      $arg, $options );
 355         check_allowed(    $arg, $options );
 356         check_disallowed( $arg, $options );
 357     }
 358
 359     # print Dumper( $options );
 360
 361     # return wantarray ? $options : %{ $options }; # WTF! Someone changed the behaviour of wantarray???
 362
 363     return $options;
 364 }
 365
 366
 367 sub check_duplicates_args
 368 {
 369     # Martin A. Hansen, May 2009
 370
 371     # Check if there are duplicate long or short arguments,
 372     # and raise an error if so.
 373
 374     my ( $arg_list,   # List of argument hashrefs,
 375        ) = @_;
 376
 377     # Returns nothing.
 378
 379     my ( $arg, %check_hash );
 380
 381     foreach $arg ( @{ $arg_list } )
 382     {
 383         Maasha::Common::error( qq(Duplicate long argument: $arg->{ 'long' }) )   if exists $check_hash{ $arg->{ 'long' } };
 384         Maasha::Common::error( qq(Duplicate short argument: $arg->{ 'short' }) ) if exists $check_hash{ $arg->{ 'short' } };
 385
 386         $check_hash{ $arg->{ 'long' } } = 1;
 387         $check_hash{ $arg->{ 'short' } } = 1;
 388     }
 389 }
 390
 391
 392 sub check_print_usage
 393 {
 394     # Martin A. Hansen, May 2009.
 395
 396     # Check if we need to print usage and print usage
 397     # and exit if that is the case.
 398
 399     my ( $options,   # option hash
 400        ) = @_;
 401
 402     # Returns nothing.
 403
 404     my ( %options, $help, $script, $wiki );
 405
 406     %options = %{ $options };
 407     $help    = $options{ 'help' };
 408     delete $options{ 'help' };
 409
 410     $script = Maasha::Common::get_scriptname();
 411
 412     if ( $script ne 'print_wiki' )
 413     {
 414         if ( $help or -t STDIN )
 415         {
 416             if ( not ( exists $options{ 'stream_in' } or $options{ 'data_in' } ) )
 417             {
 418                 if ( scalar keys %options == 0 )
 419                 {
 420                     $wiki = $ENV{ 'BP_DIR' } . "/bp_usage/$script.wiki";
 421
 422                     if ( $help ) {
 423                         `print_wiki --data_in=$wiki --help`;
 424                     } elsif ( $script =~ /^(list_biopieces|list_genomes|list_mysql_databases|biostat)$/ ) {
 425                         return;
 426                     } else {
 427                         `print_wiki --data_in=$wiki`;
 428                     }
 429
 430                     exit;
 431                 }
 432             }
 433         }
 434     }
 435 }
 436
 437
 438 sub check_mandatory
 439 {
 440     # Martin A. Hansen, May 2009.
 441
 442     # Check if mandatory arguments are set and raises an error if not.
 443
 444     my ( $arg,       # hashref
 445          $options,   # options hash
 446        ) = @_;
 447
 448     # Returns nothing.
 449
 450     if ( $arg->{ 'mandatory' } eq 'yes' and not defined $options->{ $arg->{ 'long' } } ) {
 451         Maasha::Common::error( qq(Argument --$arg->{ 'long' } is mandatory) );
 452     }
 453 }
 454
 455
 456 sub set_default
 457 {
 458     # Martin A. Hansen, May 2009.
 459
 460     # Set default values in option hash.
 461
 462     my ( $arg,      # hashref
 463          $options,  # options hash
 464        ) = @_;
 465
 466     # Returns nothing.
 467
 468     if ( not defined $options->{ $arg->{ 'long' } } ) {
 469         $options->{ $arg->{ 'long' } } = $arg->{ 'default' }
 470     }
 471 }
 472
 473
 474 sub check_uint
 475 {
 476     # Martin A. Hansen, May 2009.
 477
 478     # Check if value to argument is an unsigned integer and
 479     # raises an error if not.
 480
 481     my ( $arg,      # hashref
 482          $options,  # options hash
 483        ) = @_;
 484
 485     # Returns nothing.
 486
 487     if ( $arg->{ 'type' } eq 'uint' and defined $options->{ $arg->{ 'long' } } )
 488     {
 489         if ( $options->{ $arg->{ 'long' } } !~ /^\d+$/ ) {
 490             Maasha::Common::error( qq(Argument --$arg->{ 'long' } must be an unsigned integer - not $options->{ $arg->{ 'long' } }) );
 491         }
 492     }
 493 }
 494
 495
 496 sub check_int
 497 {
 498     # Martin A. Hansen, May 2009.
 499
 500     # Check if value to argument is an integer and
 501     # raises an error if not.
 502
 503     my ( $arg,      # hashref
 504          $options,  # options hash
 505        ) = @_;
 506
 507     # Returns nothing.
 508
 509     if ( $arg->{ 'type' } eq 'int' and defined $options{ $arg->{ 'long' } } )
 510     {
 511         if ( $options->{ $arg->{ 'long' } } !~ /^-?\d+$/ ) {
 512             Maasha::Common::error( qq(Argument --$arg->{ 'long' } must be an integer - not $options->{ $arg->{ 'long' } }) );
 513         }
 514     }
 515 }
 516
 517
 518 sub set_list
 519 {
 520     # Martin A. Hansen, May 2009.
 521
 522     # Splits an argument of type 'list' into a list that is put
 523     # in the options hash.
 524
 525     my ( $arg,      # hashref
 526          $options,  # options hash
 527        ) = @_;
 528
 529     # Returns nothing.
 530
 531     if ( $arg->{ 'type' } eq 'list' and defined $options->{ $arg->{ 'long' } } ) {
 532         $options->{ $arg->{ 'long' } } = [ split /,/, $options->{ $arg->{ 'long' } } ];
 533     }
 534 }
 535
 536
 537 sub check_dir
 538 {
 539     # Martin A. Hansen, May 2009.
 540
 541     # Check if an argument of type 'dir!' truly is a directory and
 542     # raises an error if not.
 543
 544     my ( $arg,      # hashref
 545          $options,  # options hash
 546        ) = @_;
 547
 548     # Returns nothing.
 549
 550     if ( $arg->{ 'type' } eq 'dir!' and defined $options->{ $arg->{ 'long' } } )
 551     {
 552         if ( not -d $options->{ $arg->{ 'long' } } ) {
 553             Maasha::Common::error( qq(No such directory: "$options->{ $arg->{ 'long' } }") );
 554         }
 555     }
 556 }
 557
 558
 559 sub check_file
 560 {
 561     # Martin A. Hansen, May 2009.
 562
 563     # Check if an argument of type 'file!' truly is a file and
 564     # raises an error if not.
 565
 566     my ( $arg,      # hashref
 567          $options,  # options hash
 568        ) = @_;
 569
 570     # Returns nothing.
 571
 572     if ( $arg->{ 'type' } eq 'file!' and defined $options->{ $arg->{ 'long' } } )
 573     {
 574         if ( not -f $options->{ $arg->{ 'long' } } ) {
 575             Maasha::Common::error( qq(No such file: "$options->{ $arg->{ 'long' } }") );
 576         }
 577     }
 578 }
 579
 580
 581 sub set_files
 582 {
 583     # Martin A. Hansen, May 2009.
 584
 585     # Split the argument to 'files' into a list that is put on the options hash.
 586
 587     my ( $arg,      # hashref
 588          $options,  # options hash
 589        ) = @_;
 590
 591     # Returns nothing.
 592
 593     if ( $arg->{ 'type' } eq 'files' and defined $options->{ $arg->{ 'long' } } ) {
 594         $options->{ $arg->{ 'long' } } = [ split /,/, $options->{ $arg->{ 'long' } } ];
 595     }
 596 }
 597
 598
 599 sub check_files
 600 {
 601     # Martin A. Hansen, May 2009.
 602
 603     # Split the argument to 'files!' and check if each file do exists before adding
 604     # the file list to the options hash.
 605
 606     my ( $arg,      # hashref
 607          $options,  # options hash
 608        ) = @_;
 609
 610     # Returns nothing.
 611
 612     my ( $elem, @files );
 613
 614     if ( $arg->{ 'type' } eq 'files!' and defined $options->{ $arg->{ 'long' } } )
 615     {
 616         foreach $elem ( split /,/, $options->{ $arg->{ 'long' } } )
 617         {
 618             if ( -f $elem ) {
 619                 push @files, $elem;
 620             } elsif ( $elem =~ /\*/ ) {
 621                 push @files, glob( $elem );
 622             }
 623         }
 624
 625         if ( scalar @files == 0 ) {
 626             Maasha::Common::error( qq(Argument to --$arg->{ 'long' } must be a valid file or fileglob expression - not $options->{ $arg->{ 'long' } }) );
 627         }
 628
 629         $options->{ $arg->{ 'long' } } = [ @files ];
 630     }
 631 }
 632
 633
 634 sub check_allowed
 635 {
 636     # Martin A. Hansen, May 2009.
 637
 638     # Check if all values to all arguement are allowed and raise an
 639     # error if not.
 640
 641     my ( $arg,      # hashref
 642          $options,  # options hash
 643        ) = @_;
 644
 645     # Returns nothing.
 646
 647     my ( $elem );
 648
 649     if ( defined $arg->{ 'allowed' } and defined $options->{ $arg->{ 'long' } } )
 650     {
 651         map { $val_hash{ $_ } = 1 } split /,/, $arg->{ 'allowed' };
 652
 653         if ( $arg->{ 'type' } =~ /^(list|files|files!)$/ )
 654         {
 655             foreach $elem ( @{ $options->{ $arg->{ 'long' } } } )
 656             {
 657                 if ( not exists $val_hash{ $elem } ) {
 658                     Maasha::Common::error( qq(Argument to --$arg->{ 'long' } $elem is not allowed) );
 659                 }
 660             }
 661         }
 662         else
 663         {
 664             if ( not exists $val_hash{ $options->{ $arg->{ 'long' } } } ) {
 665                 Maasha::Common::error( qq(Argument to --$arg->{ 'long' } $options->{ $arg->{ 'long' } } is not allowed) );
 666             }
 667         }
 668     }
 669 }
 670
 671
 672 sub check_disallowed
 673 {
 674     # Martin A. Hansen, May 2009.
 675
 676     # Check if any values to all arguemnts are disallowed and raise an error if so.
 677
 678     my ( $arg,      # hashref
 679          $options,  # options hash
 680        ) = @_;
 681
 682     # Returns nothing.
 683
 684     my ( $val, %val_hash );
 685
 686     if ( defined $arg->{ 'disallowed' } and defined $options->{ $arg->{ 'long' } } )
 687     {
 688         foreach $val ( split /,/, $arg->{ 'disallowed' } )
 689         {
 690             if ( $options->{ $arg->{ 'long' } } eq $val ) {
 691                 Maasha::Common::error( qq(Argument to --$arg->{ 'long' } $val is disallowed) );
 692             }
 693         }
 694     }
 695 }
 696
 697
 698 # marked for deletion - obsolete?
 699 #sub getopt_files
 700 #{
 701 #    # Martin A. Hansen, November 2007.
 702 #
 703 #    # Extracts files from an explicit GetOpt::Long argument
 704 #    # allowing for the use of glob. E.g.
 705 #    # --data_in=test.fna
 706 #    # --data_in=test.fna,test2.fna
 707 #    # --data_in=*.fna
 708 #    # --data_in=test.fna,/dir/*.fna
 709 #
 710 #    my ( $option,   # option from GetOpt::Long
 711 #       ) = @_;
 712 #
 713 #    # Returns a list.
 714 #
 715 #    my ( $elem, @files );
 716 #
 717 #    foreach $elem ( split ",", $option )
 718 #    {
 719 #        if ( -f $elem ) {
 720 #            push @files, $elem;
 721 #        } elsif ( $elem =~ /\*/ ) {
 722 #            push @files, glob( $elem );
 723 #        }
 724 #    }
 725 #
 726 #    return wantarray ? @files : \@files;
 727 #}
 728
 729
 730 sub sig_handler
 731 {
 732     # Martin A. Hansen, April 2008.
 733
 734     # Removes temporary directory and exits gracefully.
 735     # This subroutine is meant to be run always as the last
 736     # thing even if a script is dies or is interrupted
 737     # or killed.
 738
 739     my ( $sig,   # signal from the %SIG
 740        ) = @_;
 741
 742     # print STDERR "signal->$sig<-\n";
 743
 744     my $script = Maasha::Common::get_scriptname();
 745
 746     chomp $sig;
 747
 748     sleep 1;
 749
 750     if ( $sig =~ /MAASHA_ERROR/ )
 751     {
 752         print STDERR "\nProgram '$script' had an error"                     . "  -  Please wait for temporary data to be removed\n";
 753         status_log( "ERROR" );
 754     }
 755     elsif ( $sig eq "INT" )
 756     {
 757         print STDERR "\nProgram '$script' interrupted (ctrl-c was pressed)" . "  -  Please wait for temporary data to be removed\n";
 758         status_log( "INTERRUPTED" );
 759     }
 760     elsif ( $sig eq "TERM" )
 761     {
 762         print STDERR "\nProgram '$script' terminated (someone used kill?)"  . "  -  Please wait for temporary data to be removed\n";
 763         status_log( "TERMINATED" );
 764     }
 765     else
 766     {
 767         print STDERR "\nProgram '$script' died->$sig"                       . "  -  Please wait for temporary data to be removed\n";
 768         status_log( "DIED" );
 769     }
 770
 771     clean_tmp();
 772
 773     exit( 0 );
 774 }
 775
 776
 777 sub clean_tmp
 778 {
 779     # Martin A. Hansen, July 2008.
 780
 781     # Cleans out any unused temporary files and directories in BP_TMP.
 782
 783     # Returns nothing.
 784
 785     my ( $tmpdir, @dirs, $curr_pid, $dir, $user, $sid, $pid );
 786
 787     $tmpdir = bp_tmp();
 788
 789     $curr_pid = Maasha::Common::get_processid();
 790
 791     @dirs = Maasha::Filesys::ls_dirs( $tmpdir );
 792
 793     foreach $dir ( @dirs )
 794     {
 795         if ( $dir =~ /^$tmpdir\/(.+)_(\d+)_(\d+)_bp_tmp$/ )
 796         {
 797             $user = $1;
 798             $sid  = $2;
 799             $pid  = $3;
 800
 801 #            next if $user eq "maasha"; # DEBUG
 802
 803             if ( $user eq Maasha::Common::get_user() )
 804             {
 805                 if ( not Maasha::Common::process_running( $pid ) )
 806                 {
 807                     # print STDERR "Removing stale dir: $dir\n";
 808                     Maasha::Filesys::dir_remove( $dir );
 809                 }
 810                 elsif ( $pid == $curr_pid )
 811                 {
 812                     # print STDERR "Removing current dir: $dir\n";
 813                     Maasha::Filesys::dir_remove( $dir );
 814                 }
 815             }
 816         }
 817     }
 818 }
 819
 820
 821 sub get_tmpdir
 822 {
 823     # Martin A. Hansen, April 2008.
 824
 825     # Create a temporary directory based on
 826     # $ENV{ 'BP_TMP' } and sessionid. The directory
 827     # name is written to the status file.
 828
 829     # Returns a path.
 830
 831     my ( $user, $sid, $pid, $script, $path, $file, $fh, $line );
 832
 833     $user   = Maasha::Common::get_user();
 834     $sid    = Maasha::Common::get_sessionid();
 835     $pid    = Maasha::Common::get_processid();
 836     $script = Maasha::Common::get_scriptname();
 837
 838     $path = bp_tmp() . "/" . join( "_", $user, $sid, $pid, "bp_tmp" );
 839     $file = bp_tmp() . "/" . join( ".", $user, $script, $pid ) . ".status";
 840
 841     $fh   = Maasha::Filesys::file_read_open( $file );
 842     flock($fh, 1);
 843     $line = <$fh>;
 844     chomp $line;
 845     close $fh;
 846
 847     $fh   = Maasha::Filesys::file_write_open( $file );
 848     flock($fh, 2);
 849     print $fh "$line;$path\n";
 850     close $fh;
 851
 852     Maasha::Filesys::dir_create( $path );
 853
 854     return $path;
 855 }
 856
 857
 858 sub biopiecesrc
 859 {
 860     # Martin A. Hansen, July 2009.
 861
 862     # Read Biopiece configuration info from .biopiecesrc.
 863     # and returns the value of a given key.
 864
 865     my ( $key,   # configuration key
 866        ) = @_;
 867
 868     # Returns a string.
 869
 870     my ( $file, $fh, $record );
 871
 872     $file = "$ENV{ 'HOME' }/.biopiecesrc";
 873
 874     return undef if not -f $file;
 875
 876     $fh     = Maasha::Filesys::file_read_open( $file );
 877     flock($fh, 1);
 878     $record = get_record( $fh );
 879     close $fh;
 880
 881     if ( exists $record->{ $key } ) {
 882         return $record->{ $key };
 883     } else {
 884         return undef;
 885     }
 886 }
 887
 888 sub bp_tmp
 889 {
 890     # Martin A. Hansen, March 2013.
 891
 892     # Returns the BP_TMP path.
 893     # Errs if no BP_TMP in ENV and
 894     # creates BP_TMP if it doesn't exists.
 895
 896     my ( $path );
 897
 898     Maasha::Common::error( qq(no BP_TMP set in %ENV) ) if not -d $ENV{ 'BP_TMP' };
 899
 900     $path = $ENV{ 'BP_TMP' };
 901
 902     unless ( -d $path ) { # No BP_TMP so we create it
 903         mkdir $path or die qq(failed to create dir "$path": $!);
 904     }
 905
 906     return $path;
 907 }
 908
 909 END
 910 {
 911     clean_tmp();
 912 }
 913
 914
 915 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 916
 917
 918 1;
 919
 920 __END__