lib/CXGN/Tools/Script.pm

   1 package CXGN::Tools::Script;
   2 use strict;
   3 use warnings;
   4 use English;
   5 use Carp;
   6 use FindBin;
   7
   8 =head1 NAME
   9
  10 CXGN::Tools::Script - useful little functions for writing command-line
  11 scripts
  12
  13 =head1 SYNOPSIS
  14
  15 coming soon
  16
  17 =head1 DESCRIPTION
  18
  19 coming soon
  20
  21 =head1 FUNCTIONS
  22
  23 All functions below are EXPORT_OK.
  24
  25 =cut
  26
  27 use base qw/Exporter/;
  28
  29 BEGIN {
  30   our @EXPORT_OK = qw(
  31                       out_fh
  32                       in_fh
  33                       lock_script
  34                       unlock_script
  35                       dprint
  36                       debugging
  37                      );
  38 }
  39 our @EXPORT_OK;
  40
  41
  42 =head2 out_fh
  43
  44   Usage: my $out_fh = out_fh($opt{o});
  45   Desc : get an output filehandle.
  46   Ret  : \*STDOUT if passed '-', '', or undef,
  47          or if given a filehandle, attempts to open it
  48          like ">$filename", dies on failure
  49   Args : optional filename to open
  50   Side Effects: might open a file for writing
  51
  52 =cut
  53
  54 sub out_fh {
  55   my ($filename) = @_;
  56
  57   if(!$filename || $filename eq '-') {
  58     return \*STDOUT;
  59   } else {
  60     open my $f,">$filename"
  61       or croak "Cannot open '$filename' for writing: $!";
  62     return $f;
  63   }
  64 }
  65
  66
  67 =head2 in_fh
  68
  69   Usage: my $in_fh = in_fh($opt{o});
  70   Desc : get an input filehandle.
  71   Ret  : \*STDIN if passed '-', '', or undef,
  72          or if given a filehandle, attempts to open it,
  73          dies on failure
  74   Args : optional filename to open
  75   Side Effects: might open a file for reading
  76
  77 =cut
  78
  79 sub in_fh {
  80   my ($filename) = @_;
  81
  82   if(!$filename || $filename eq '-') {
  83     return \*STDIN;
  84   } else {
  85     open my $f,$filename
  86       or croak "Cannot open '$filename' for reading: $!";
  87     return $f;
  88   }
  89 }
  90
  91
  92 our $lockfile_name = File::Spec->catfile( File::Spec->tmpdir,
  93                                           "$FindBin::Script.pid");
  94
  95 =head2 lock_script
  96
  97   Usage: lock_script();
  98   Desc : attempt to acquire a system-wide lock, unique to whatever
  99          script you're running this from.  Use this and its companion
 100          unlock_script() when you have a script that needs to only
 101          have one instance running on a given host at one time.
 102   Args : quiet => 0, #if passed, don't warn if script is already running
 103   Ret  : 1 if successful at aquiring lock, 0 if not successful
 104   Side Effects: creates a lockfile in the temp directory specified by
 105                 File::Spec->tmpdir
 106   Example:
 107
 108      use CXGN::Tools::Script qw/lock_script unlock_script/;
 109      lock_script() or die "only run one instance";
 110
 111      #do some stuff
 112
 113      unlock_script();
 114
 115 =cut
 116
 117 sub lock_script {
 118   my %opts = @_;
 119   #check for a lockfile
 120   if( -s $lockfile_name ) {
 121     #if found, check if that PID is still running
 122     my $pid = _read_lockfile();
 123     -d '/proc' or confess "The way we do lockfiles depends on there being a /proc dir.  sorry.";
 124
 125     if( $pid && -d "/proc/$pid" ) {
 126       warn "Script still running with pid $pid.\n"
 127         unless $opts{quiet};
 128       return 0;
 129     } else {
 130       unlink $lockfile_name
 131         or croak "Could not unlink stale lock file '$lockfile_name': $!";
 132     }
 133   }
 134
 135   open( my $lock_fh, ">$lockfile_name" )
 136     or croak "Could not open '$lockfile_name' for writing";
 137   print $lock_fh "$PROCESS_ID\n";
 138   close $lock_fh;
 139
 140   -f $lockfile_name or croak "Could not lock script with pidfile '$lockfile_name'\n";
 141   return 1;
 142 }
 143 sub _read_lockfile {
 144   open( my $lock_fh, $lockfile_name )
 145     or return;
 146   my $pid = <$lock_fh>;
 147   chomp $pid;
 148   $pid =~ /^\d+$/ or return 0;
 149   return $pid;
 150 }
 151
 152 =head2 unlock_script
 153
 154   Usage: unlock_script();
 155   Desc : release the system-wide lock on this script
 156   Args : none
 157   Ret : 0 on failure, 1 on successful release, 2 if the lock file did
 158         not belong to this script and thus was not deleted
 159   Side Effects:
 160   Example:
 161
 162 =cut
 163
 164 sub unlock_script {
 165   #delete our lockfile
 166   my $pid = _read_lockfile();
 167   return 2 unless $pid && $pid == $PROCESS_ID;
 168   unlink( $lockfile_name );
 169   if( -f $lockfile_name ) {
 170     warn "Could not delete lockfile '$lockfile_name': $!";
 171     return 0;
 172   }
 173   return 1;
 174 }
 175 # try to clear any locks when the program ends
 176 END {
 177   unlock_script();
 178   1;
 179 }
 180
 181
 182
 183 BEGIN {  #figure out a name for this script's debugging environment variable
 184   our $debugenv_name = $FindBin::Script;
 185   $debugenv_name =~ s/\.pl$//;
 186   $debugenv_name =~ s/[^a-zA-Z\d]//g;
 187   $debugenv_name = uc($debugenv_name).'DEBUG';
 188 }
 189 use constant DEBUG => ($ENV{our $debugenv_name} ? 1 : 0);
 190
 191 =head2 dprint
 192
 193   Usage: dprint "foo! foofoofoo!\n";
 194   Desc : if this script's debugging environment variable is set, print
 195          the message to STDERR.  The name of the script's debugging
 196          environment variable is constructed from the script's name,
 197          plus DEBUG.  For example, the script do_some_weird_stuff.pl
 198          would have a debugging environment variable named
 199          DOSOMEWEIRDSTUFFDEBUG
 200   Args : same args as print()
 201   Ret  : same as print()
 202   Side Effects: might print things to STDERR
 203   Example:
 204
 205     rob@toblerone:~$ DOSOMEWEIRDSTUFFDEBUG=1 ./do_some_weird_stuff.pl
 206     foo!  foofoofoo!
 207     rob@toblerone:~$ ./do_some_weird_stuff.pl
 208     rob@toblerone:~$
 209
 210 =cut
 211
 212 sub dprint(@) { if(DEBUG) { local $|=1; print STDERR @_; } }
 213
 214 =head2 debugging
 215
 216   Usage: do_something() if debugging;
 217   Desc : same as dprint, except just returns 1 if the debug env is
 218          set, undef if not
 219   Args : none
 220   Ret  : 1 if debugging, 0 otherwise
 221   Side Effects: none
 222
 223 =cut
 224
 225 sub debugging {
 226   DEBUG ? 1 : 0;
 227 }
 228
 229 =head1 AUTHOR(S)
 230
 231 Robert Buels
 232
 233 =cut
 234
 235 ###
 236 1;#do not remove
 237 ###