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