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