package SafeIO;
$VERSION = '1.1';
use strict;
use FileHandle;
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT=qw(ObtainLock ReleaseLock ReadFile WriteFile ErrorExit GetRemoteHost OpenFile CloseFile);

use FileCook;
# -- Bailout ---------------------------------------

my %files = ( );

sub CleanUp
{
  foreach my $file (keys %files)
  {
     my $record = $files{$file};
	 $record or next;

     if($record->{'lock'})
	 {
	    rmdir $file or print ("Could not release lock $file.<BR>");
	 }
	 elsif($record->{'handle'})
	 {
	    $record->{'handle'}->close() or print ("Could not close $file.<BR>");
	 }
  }
}

sub ErrorExit
{
  print "<HR><H2>Error</H2>\n<BR>\n";
  print $_[0];

  &CleanUp;

  print "<HR></body></html>";

  die(" *** SafeIO.pm " . $_[0]);
}

# -- Files and locks --------------------------------

sub TransformLock
{
  (my $lock) = @_;
  $lock =~ s/-/--/g;
  $lock =~ s/\//-/g;
  $lock =~ s/([^A-Za-z0-9_-])/'.'.ord($1).'.'/ge;
  $lock = '/tmp/_lock_' . $lock;
  return $lock;
}

sub ObtainLock
{
  (my $lock) = @_;
  $lock = TransformLock($lock);
  
  my $record = $files{$lock};

  if(!$record)
  {
	$files{$lock}={'lock'=>0};
	$record = $files{$lock};

	my $success = mkdir $lock;
    my $tries = 10;
    while ( !$success  && (--$tries))
    {
       sleep 1+int(rand(3));
       $success = mkdir $lock;
    }
    #$success or &ErrorExit("Could not obtain lock $lock. If the problem recurs, please contact <A HREF=\"http://www.toothycat.net/wiki/wiki.pl?MoonShadow\">MoonShadow</A>.<BR>\n");
    #default behaviour is now to assume lock was incorrectly stuck, and break it.
  }

  $record->{'lock'}++;
  return $record->{'lock'};
}

sub ReleaseLock
{
  (my $lock) = @_;
  $lock = TransformLock($lock);

  my $record = $files{$lock};
  $record->{'lock'} or &ErrorExit("Tried to release lock that had not been obtained: $lock.<BR>\n");
  $record->{'lock'}--;
  $record->{'lock'} and return; # something else still holds this lock

  rmdir $lock or &ErrorExit("Failed to release lock $lock.<BR>\n");
  $files{$lock} = 0;
}

# open file or die! if it returns it guarantees an open filehandle.
sub OpenFile
{
  my ($filename, $mode) = @_;

  $filename or &ErrorExit ("Trying to open file without supplying a name.<BR>\n");
  $mode or $mode = '<'; # default to read

  # we're creating a file or the file exists or we die
  (($mode ne '<') or (-e $filename)) or &ErrorExit ("File does not exist: $filename");

  if($files{$filename})
  {
    &ErrorExit ("Trying to open $filename, but it is already open.\n<BR>");
  }

  my $fh = new FileHandle;
  $fh->open($filename, $mode) or &ErrorExit("Could not open $filename: $!\n<BR>");
  binmode( $fh );

  $files{$filename} = { "handle" => $fh };
  $files{$fh} = { "name" => $filename };
  return $fh;
}

# files may be closed by name or handle.
sub CloseFile
{
  my ($id) = @_;
  $id or &ErrorExit("Script tried to close a file but didn't say which one to close.\n<BR>");

  my $fh;

  if($files{$id})
  {
    my $filename = $files{$id}->{"name"};
    $fh = $files{$id}->{"handle"};

	# $id is whichever one of filename and fh isn't defined yet.
	$filename or $filename = $id;
	$fh or $fh = $id;

    # destroy the records
    undef $files{$fh};
    undef $files{$filename};
  }
  
  if(!$fh)
  {
    &ErrorExit("Script tried to close a file ($id) but the file wasn't open.\n<BR>");
  }

  $fh->close();
}

# Locked read contents of a file containing a single cooked Perl struct.
# Takes filename and an optional second parameter. 
# If second parameter is set, it is returned if the file does not exist.
# Otherwise, ReadFile will die if the file does not exist.
sub ReadFile
{
  my ($filename, $default) = @_;
  if( -e $filename )
  {
    my $result;
    &ObtainLock( $filename );
	$result = ReadStruct( &OpenFile( $filename ) );
	&CloseFile( $filename );
	&ReleaseLock( $filename );
	$result or &ErrorExit( "Couldn't read $filename.\n<BR>" );
	return $result;
  }
  elsif( defined( $default ) )
  {
    return $default;
  }

  &ErrorExit ( "Tried to read $filename, but the file does not exist.\n<BR>" );
}

# Locked recursive write of a Perl structure to a file.
# Takes filename and pointer to structure.
sub WriteFile
{
  my ( $filename, $record ) = @_;
  my $filesize;

  &ObtainLock( $filename );
  $filesize = WriteStruct( &OpenFile( $filename, '>' ), $record );
  &CloseFile( $filename );
  &ReleaseLock( $filename );

  return $filesize;
}

# -- ID and user prefs ------------------------------

sub GetRemoteHost {
  my ($doMask) = @_;
  my ($rhost, $iaddr);

  $rhost = $ENV{REMOTE_HOST};
  $rhost or $rhost = '';

  if (defined($ENV{REMOTE_ADDR}) && $ENV{REMOTE_ADDR} =~ /^192.168.2/)
  {
  }
  else
  {
   if ($rhost eq "") {
    # Catch errors (including bad input) without aborting the script
    eval 'use Socket; defined($ENV{REMOTE_ADDR}) and $iaddr = inet_aton($ENV{REMOTE_ADDR}) and '
         . '$rhost = gethostbyaddr($iaddr, AF_INET);';
   }
  }
  if ((!defined($rhost)) || ($rhost eq "")) {
    $rhost = $ENV{REMOTE_ADDR};
	defined($rhost) or $rhost = "-";
    $rhost =~ s/\d+$/xxx/  if ($doMask);      # Be somewhat anonymous
  }
  return $rhost;
}

1;