package RDA::Lock;

# $Id: Lock.pm,v 1.23 2009/01/13 16:46:12 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Lock.pm,v 1.23 2009/01/13 16:46:12 mschenke Exp $
#
# Change History
# 20090113  MSC  Change the copyright notice.

=head1 NAME

RDA::Lock - Package Used to Manage Locks.

=head1 SYNOPSIS

require RDA::Lock;

=head1 DESCRIPTION

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use Fcntl ':flock';
  use IO::File;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.23 $ =~ /(\d+)\.(\d+)/);

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<RDA::Lock::lock($agt,$nam[,$flg])>

This method takes an exclusive lock. You can use the environment variable
C<RDA_LOCK> to specify the directory in which lock files are regrouped. When
the directory is not specified, it creates the lock file in the directory
containing the setup file. On VMS, it uses an alternative mechanism, based on
the file presence. When the flag is set, it does not wait until the lock is
available. It returns true for success or false for failure.

=head2 S<RDA::Lock::mlock($agt,$nam[,$flg])>

This method is similar to the C<lock> method. When forking is emulated, it uses
an alternative mechanism, based on file presence. In that context, the lock
file cannot be located on a network file system.

=head2 S<RDA::Lock::slock($agt,$nam[,$flg])>

This method is similar to the C<lock> method but it only takes a shared lock.
Shared locks are not always effective on VMS or in contexts where forking is
emulated.

=cut

sub lock
{ my ($agt, $nam, $flg) = @_;

  $agt->can_flock
    ? _lock($agt, $nam, $flg ? LOCK_EX | LOCK_NB : LOCK_EX)
    : _file($agt, $nam, $flg);
}

sub mlock
{ my ($agt, $nam, $flg) = @_;

  ($agt->can_flock > 0)
    ? _lock($agt, $nam, $flg ? LOCK_EX | LOCK_NB : LOCK_EX)
    : _file($agt, $nam, $flg);
}

sub slock
{ my ($agt, $nam, $flg) = @_;

  ($agt->can_flock > 0)
    ? _lock($agt, $nam, $flg ? LOCK_SH | LOCK_NB : LOCK_SH)
    : 0;
}

# Use a file as locking mechanism
sub _file
{ my ($agt, $nam, $flg) = @_;
  my ($fil, $lck, $tbl);

  $tbl = $agt->get_info('lfn');
  unless (exists($tbl->{$nam}))
  { $fil = File::Spec->catfile(
      (exists($ENV{'RDA_LOCK'}) ? $ENV{'RDA_LOCK'} : $agt->get_info('ctl')),
      "$nam.lck");
    $lck = IO::File->new;
    while (!$lck->open($fil, O_CREAT | O_EXCL))
    { die "RDA-00119: Cannot create the lock file for '$nam':\n $!\n"
        unless $! =~ m/File exists/i;
      return 0 if $flg;
      sleep(3);
    }
    $lck->close;
    $tbl->{$nam} = $fil;
  }
  return 1;
}

# Use an operating system lock
sub _lock
{ my ($agt, $nam, $flg) = @_;
  my ($fil, $lck, $tbl);

  # Determine the lock file path
  return 0 unless $nam;
  $tbl = $agt->get_info('lfn');
  if (exists($tbl->{$nam}))
  { $lck = $tbl->{$nam};
  }
  else
  { $fil = File::Spec->catfile(
      (exists($ENV{'RDA_LOCK'}) ? $ENV{'RDA_LOCK'} : $agt->get_info('ctl')),
      "$nam.lck");
    $lck = IO::File->new;
    open($lck, ">>$fil") ||
      die "RDA-00119: Cannot create the lock file for '$nam':\n $!\n";
    $tbl->{$nam} = $lck;
  }

  # Take the lock
  flock($lck, $flg);
}

=head2 S<RDA::Lock::unlock($agt,$nam)>

This method releases a lock. It returns true for success or false for failure.

=cut

sub unlock
{ my ($agt, $nam) = @_;
  my ($lck, $ret, $tbl);

  $tbl = $agt->get_info('lfn');
  return 0 unless exists($tbl->{$nam});
  $lck = $tbl->{$nam};
  return flock($lck, LOCK_UN) if ref($lck);
  ++$ret while unlink($lck);
  delete($tbl->{$nam});
  $ret;
}

=head1 JOB AND THREAD LOCK METHODS

=head2 S<RDA::Lock::end($agt)>

This method removes the files that were created to indicate a lock by their
presence.

=cut

sub end
{ my ($agt) = @_;
  my ($fil, $tbl);

  $tbl = $agt->get_info('lfn');
  foreach my $nam (keys(%$tbl))
  { next if ref($fil = $tbl->{$nam});
    1 while unlink($fil);
  }
}

=head2 S<RDA::Lock::init($agt,$flg)>

This method prepares the lock context for a new job or thread. When the flag
is set, it also takes a shared lock to indicate that a thread is running. The
method derives the lock name from the name of the setup file. It is prefixed
with C<-T->.

=cut

sub init
{ my ($agt, $flg) = @_;

  $agt->set_info('lfn', {});
  _lock($agt, '-T-'.$agt->get_info('nam'), LOCK_SH | LOCK_NB)
    if $flg && $agt->can_fork > 0;
}

=head2 S<RDA::Lock::wait_thread($agt)>

This method takes an exclusive lock that can only be obtained if no threads
are running. The lock is released immediately.

=cut

sub wait_thread
{ my ($agt) = @_;
  my $nam = '-T-'.$agt->get_info('nam');

  _lock($agt, $nam, LOCK_EX);
  unlock($agt, $nam);
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Daemon|RDA::Daemon>, L<RDA::Discover|RDA::Discover>,
L<RDA::Extra|RDA::Extra>, L<RDA::Filter|RDA::Filter>,
L<RDA::Log|RDA::Log>, L<RDA::Module|RDA::Module>,
L<RDA::Output|RDA::Output>, L<RDA::Pod|RDA::Pod>,
L<RDA::Profile|RDA::Profile>, L<RDA::Remote|RDA::Remote>,
L<RDA::Render|RDA::Render>, L<RDA::Setting|RDA::Setting>,
L<RDA::Upgrade|RDA::Upgrade>, L<RDA::Value|RDA::Value>,
L<RDA::Web|RDA::Web>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2009, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut