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