view release on metacpan or  search on metacpan

Util/Util.pm  view on Meta::CPAN

#!/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__

=head1 NAME

LaBrea::Tarpit::Util

=head1 SYNOPSIS

  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

=head1 DESCRIPTION - LaBrea::Tarpit::Util

A collection of utility programs used by other modules and applications of
LaBrea::Tarpit

=over 2

=item $rv=cache_is_valid(*HANDLE,\%look_n_feel,$short);

  input:	HANDLE
		\look_n_feel
		flag, true  = check short cache
		      false = standard

  returns:	size of file, HANDLE open
		if cache valid
		false, cache requires update

  dispose:	close HANDLE;

=cut
  
# 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;
}

=item $rv = update_cache(\%look_n_feel,\$html,\$short);

  Write new cache file with contents of 
  optional $html and/or $short

  The filename for the short cache is taken from 
  $look_n_feel{html_cache_file} . '.short'

  returns:	true on success
		false if failed

=cut

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

=item $rv=upd_cache($filename,$pagename,$html,$short);

This is the way B<update_cache> should have worked the first time, sigh....

Update a cache for a page and short report.

  Write new cache file with contents of 
  optional $html and/or $short

  The filename for the short cache is taken from 
  $filename . '.short'

  The page file name is taken from the $filename stub
  $filename.$pagename

  i.e.	$filename = mycache
	$pagename = page2

  eq => mycache.page2

  returns:	true on success
		false if failed

=cut

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'