LaBrea::Tarpit::Util - LaBrea::Tarpit::Util documentation

  use LaBrea::Tarpit::Util qw( .... );

  $rv = cache_is_valid(*HANDLE,\%look_n_feel,$short);
  $rv = update_cache(\%look_n_feel,\$html,\$short);  
  ($modtime,$update)=daemon2_cache($cache,$src,$age);
  $modtime = page_is_current($cache_time,$page);
  $rv = share_open(*LOCK,*FILE,$filename,$nblock,$umask);   
  $rv = ex_open(*LOCK,*FILE,$filename,$func,$nblock,$umask);
  $rv = close_file(*LOCK,*FILE)
  $time_string = http_date(time);
  $name = script_name($depth);
  $alive = reap_kids(\%kids);  deprecated in this module

        cache_is_valid 
	daemon2_cache
        close_file
        ex_open
        http_date
	labrea_whoami
	page_is_current
	script_name
        share_open
        update_cache
	upd_cache
	reap_kids

#!/usr/bin/perl
package LaBrea::Tarpit::Util;
#
# 5-17-02, michael@bizsystems.com
#
use strict;
#use diagnostics;
use vars qw($VERSION @ISA @EXPORT_OK);
use AutoLoader 'AUTOLOAD';
use Fcntl qw(:DEFAULT :flock);

$VERSION = do { my @r = (q$Revision: 0.06 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

require Exporter;

@ISA = qw(Exporter);
@EXPORT_OK = qw (
	cache_is_valid
	update_cache
	upd_cache
	daemon2_cache
	page_is_current
	share_open
	ex_open
	close_file
	http_date
	script_name
	reap_kids
	labrea_whoami
);

# autoload declarations

sub cache_is_valid;
sub update_cache;
sub upd_cache;
sub daemon2_cache;
sub share_open;
sub ex_open;
sub close_file;
sub http_date;
sub script_name;
sub page_is_current;
sub reap_kids;
sub labrea_whoami;
sub DESTROY {};  

1;
__END__

  
# returns true if cache ready, otherwise false
# cache is not locked, it is updated atomicaly
#
# input:	*HANDLE,\%look_n_feel, short_flag
# returns:	size of file, HANDLE open, if cache valid
#		false, cache requires update
#
sub cache_is_valid {
  my ($FH,$lnf,$f) = @_;
  return undef unless
	exists $lnf->{html_cache_file} &&
	exists $lnf->{html_expire} &&
	$lnf->{html_expire} > 0 &&
	($f = ($f) ? $lnf->{html_cache_file}.'.short' : $lnf->{html_cache_file}) &&
	-e $f &&
	-r $f;
  my ($size,$mtime) = (stat($f))[7,9];
  return undef unless
	$mtime + $lnf->{html_expire}  > time &&
	open($FH,$f);
  return $size;
}

sub update_cache {
  my ($lnf,$htm,$sht) = @_;
  return undef unless exists $lnf->{html_cache_file};
  @_ = ($lnf->{html_cache_file},'',$htm,$sht);
  goto &upd_cache;
}

sub upd_cache {
  my($f,$pn,$htm,$sht) = @_;
  return undef unless $htm || $sht;	# must want to do something
  $pn = ($pn) ? '.'.$pn : '';		# insert dot or make null
  local (*LOCK,*FH,*SH);
  return undef unless
	$f.$pn &&
# open new file non-blocking with exclusive lock
	ex_open(*LOCK,*FH,$f.$pn.'.tmp',-1,1);

  if ( $htm ) {		# html present
    print FH $$htm;
    if ($sht &&		# short report present too
	open(SH,'>'.$f.$pn.'.short.tmp' )) {
      $_ = select SH;
      $| = 1;
      select $_;
      print SH $$sht;
      close SH;
      rename 		# atomic update
	$f.$pn.'.short.tmp',
	$f.'.short';
    }
    close_file(*LOCK,*FH);
# atomic update, return true on success
      rename 		# atomic update
	$f.$pn.'.tmp',
	$f.$pn;
  } elsif ( $sht ) {	# unconditional 'else'
    print FH $$sht;
    close_file(*LOCK,*FH);
    rename		# atomic update
      $f.$pn.'.tmp',
      $f.'.short';
  } else {
    close_file(*LOCK,*FH);	# should not get here
    return undef;
  }
  1;
}

# $debug is the alarm time of the eval

sub daemon2_cache {
  my ($cf,$sf,$age,$debug) = @_;
  require LaBrea::NetIO;
  import LaBrea::NetIO qw (daemon_handler);
  $age = 0 unless $age;
  local(*LOCK,*IN,*OUT);
  my $update = 0;
  my $time = time;
  my @return;
  my $timeout = (ref $sf eq 'HASH' && !exists $sf->{file} && $sf->{d_timeout})
	? $sf->{d_timeout} : 180;
  $timeout = $debug if $debug;
  local $SIG{ALRM} = sub { die "remote connect timeout"; };
  eval {
  die 'missing output cache file' unless $cf;
  alarm $timeout;
  while (1) {
    my $cmt = (-e $cf) ? (stat($cf))[9] : 0;	# cache last modified time
    unless ($cmt + $age < $time) {
      @return = ($cmt,$update);
      last;
    }
    my $nblock = ! $debug; 			# will block if debug
    if ( ex_open(*LOCK,*OUT,$cf.'.tmp',-1,$nblock) ) {	# attempt non blocking open
      my $subref;
      unless ($subref = daemon_handler(*IN,$sf)) {
	@return = ();
	close_file(*LOCK,*OUT);
	last;
      }
      print IN "standard\n" 
	if ref $sf eq 'HASH' && !exists $sf->{file};
      while ($_ = &$subref) {
	print OUT $_;
      }
      close OUT;
      close IN;
      rename $cf.'.tmp', $cf;	# atomic update
      close LOCK;
      $update = 1;
    } else {
      sleep 1;			# another process is updating, wait
    }
  } # end while
  alarm 0;
  }; # end eval
  @return = () if $@;		# oops
  return (wantarray) ? @return : $return[0];
}

sub page_is_current {
  my ($ct,$page) = @_;
  my $mtime;
  return (-e $page && $ct <= ($mtime =(stat($page))[9])) ? $mtime : 0;
}

sub share_open {
  my ($LOCK, $fh, $fn, $nblock, $umask) = @_;
  $nblock = ($nblock) ? LOCK_NB : 0;
  $umask = 0117 unless $umask;
  umask $umask;
  return undef unless sysopen $LOCK, $fn . '.flock', O_RDWR|O_CREAT|O_TRUNC;
#	die(&me . ': could not open file shared ' . $fn . '.flock');
  unless (flock($LOCK,LOCK_SH|$nblock)) {
    close $LOCK; 
    return undef;
  }
  return 1 if sysopen $fh, $fn, O_RDONLY|O_CREAT;
#	die(&me . ': could not open file shared ' . $fn);
  close $LOCK;
  return undef;
}

sub ex_open {
  my ($LOCK, $fh, $fn, $func, $nblock, $umask) = @_;
  $nblock = ($nblock) ? LOCK_NB : 0;
  $umask = 0117 unless $umask;
  umask $umask;
  return undef unless sysopen $LOCK, $fn . '.flock', O_RDWR|O_CREAT|O_TRUNC;
#	die(&me . ': could not open file exclusive ' . $fn . '.flock');
  unless (flock($LOCK,LOCK_EX|$nblock)) {
    close $LOCK; 
    return undef;
  }
  if ( $func ) {
    if ( $func =~ /[^\d]/ || $func < 0 ) {
#print STDERR "open NEW $fn\n";
      $func = O_RDWR|O_CREAT|O_TRUNC;
    } else {
#print STDERR "open APPEND $fn\n";
      $func = O_RDWR|O_APPEND|O_CREAT;
    }
  } else {
# use sysopen FILEHANDLE,FILENAME,MODE,PERMS
#print STDERR "open RDRW $fn\n";
    $func = O_RDWR|O_CREAT;
  }
  unless (sysopen $fh, $fn, $func) {
    close $LOCK;
    return undef;
  }
  my $tmp = select $fh;
  $| = 1;
  select $tmp;
  return 1;
}

sub close_file {
  my ($fl, $fh) = @_;
  close $fh;
  close $fl;	# returns true on success
}

sub http_date {
  my($time) = @_;
  my($sec,$min,$hr,$mday,$mon,$yr,$wday) = gmtime($time);
  return
    (qw(Sun Mon Tue Wed Thu Fri Sat))[$wday] . ', ' .			# "%a, "
    sprintf("%02d ",$mday) .						# "%d "
    (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon] . ' ' .	# "%b "
    ($yr + 1900) . ' ' .							# "%Y "
    sprintf("%02d:%02d:%02d ",$hr,$min,$sec) .				# "%T "
    'GMT';								# "%Z"
}

sub script_name {
  my $depth = $_[0] || 0;
(caller($depth))[1] =~ m|([^/]+)$|; return $1;}

sub labrea_whoami {
  @_ = sort grep ( /^LaBrea/ && /\.pm$/ && ($_ = $`),keys %INC);
  my $whoami = '';
  foreach (@_) {
    $_ =~ s#/#::#g;
    $_ =~ /([^:]+)$/;
    $_ = '$'.$_.'::VERSION';
    $whoami .= $1 . ' ' . (eval "$_") . ' ';
  }
  chop $whoami;
  return $whoami;
}

sub reap_kids {
  require LaBrea::NetIO;
  goto &LaBrea::NetIO::reap_kids;
}

1;