# Lock.pm: Class Used for Managing Locks

package RDA::Object::Lock;

# $Id: Lock.pm,v 1.9 2015/06/06 18:59:53 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Lock.pm,v 1.9 2015/06/06 18:59:53 RDA Exp $
#
# Change History
# 20150606  MSC  Improve the unlock method.

=head1 NAME

RDA::Object::Lock - Class Used for Managing Locks

=head1 SYNOPSIS

 require RDA::Object::Lock;

=head1 DESCRIPTION

The objects of the C<RDA::Object::lock> class are used to manage locks. It
is a subclass of L<RDA::Object|RDA::Object>.

You can use the C<RDA_LOCK> environment variable to specify the directory in
which lock files are regrouped. When the directory is not specified or does not
exist, it creates the lock files in the lock subdirectory.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use Fcntl qw(:flock);
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Rda qw($FIL_PERMS);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
@DUMP    = (
  obj => {
    'RDA::Agent' => 1,
    },
  );
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'lock'   => ['${CUR.O_LOCK}', 'lock'],
    'mlock'  => ['${CUR.O_LOCK}', 'mlock'],
    'slock'  => ['${CUR.O_LOCK}', 'slock'],
    'unlock' => ['${CUR.O_LOCK}', 'unlock'],
    },
  inc => [qw(RDA::Object)],
  met => {
    'get_info' => {ret => 0},
    'lock'     => {ret => 0},
    'mlock'    => {ret => 0},
    'set_info' => {ret => 0},
    'slock'    => {ret => 0},
    'unlock'   => {ret => 0},
    'wait'     => {ret => 0},
    },
  );

# Define the global private constants

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Object::Lock-E<gt>new($agt,$dir)>

The lock control object constructor. It takes the agent reference and the lock
file directory as arguments.

It is represented by a blessed hash reference. The following special keys are
used:

=over 12

=item S<    B<'agt' > > Reference to the agent object

=item S<    B<'cfg' > > Reference to the RDA software configuration

=item S<    B<'dir' > > Lock file directory

=item S<    B<'fil' > > Alternative prefix for locking by file presence

=item S<    B<'oid' > > Object identifier

=item S<    B<'_bkp'> > Lock cache backup

=item S<    B<'_hnd'> > Lock file handle cache

=item S<    B<'_job'> > Job/thread log name

=item S<    B<'_lck'> > Lock file name cache

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $agt, $dir) = @_;

  # Create the lock control object and return the object reference
  return bless {
    agt  => $agt,
    cfg  => $agt->get_config,
    dir  => $dir,
    fil  => 'TMP',
    oid  => 'LCK',
    _hnd => {},
    _job => $agt->get_oid.'_job',
    _lck => {},
    }, ref($cls) || $cls;
}

=head2 S<$h-E<gt>get_file($nam)>

This method returns the path of the lock file when defined. Otherwise, it
returns an undefined value.

=cut

sub get_file
{ my ($slf, $nam) = @_;

  return exists($slf->{'_lck'}->{$nam}) ? $slf->{'_lck'}->{$nam} : undef;
}

=head2 S<$h-E<gt>lock($nam[,$flg])>

This method takes an exclusive lock. For 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<$h-E<gt>mlock($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<$h-E<gt>slock($nam[,$flg])>

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

=cut

sub lock  ## no critic (Builtin)
{ my ($slf, $nam, $flg) = @_;

  return $slf->{'cfg'}->can_flock
    ? _lock($slf, $nam, $flg ? LOCK_EX | LOCK_NB : LOCK_EX)  ## no critic (Bit)
    : _file($slf, $nam, $flg);
}

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

  return ($slf->{'cfg'}->can_flock > 0)
    ? _lock($slf, $nam, $flg ? LOCK_EX | LOCK_NB : LOCK_EX)  ## no critic (Bit)
    : _file($slf, $nam, $flg);
}

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

  return ($slf->{'cfg'}->can_flock > 0)
    ? _lock($slf, $nam, $flg ? LOCK_SH | LOCK_NB : LOCK_SH)  ## no critic (Bit)
    : 0;
}

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

  unless (exists($slf->{'_lck'}->{$nam}))
  { $fil = RDA::Object::Rda->cat_file($slf->{'dir'}, "$nam.lck");
    $lck = IO::File->new;
    while (!$lck->open($fil, O_CREAT | O_EXCL, $FIL_PERMS))  ## no critic (Bit)
    { die get_string('ERR_CREATE', $fil, $!) unless $! =~ m/File exists/i;
      return 0 if $flg;
      sleep(3);
    }
    $lck->close;
    $slf->{'_lck'}->{$nam} = $fil;
  }
  return 1;
}

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

  # Determine the lock file path
  return 0 unless $nam;
  if (exists($slf->{'_hnd'}->{$nam}))
  { $lck = $slf->{'_hnd'}->{$nam};
  }
  else
  { $fil = RDA::Object::Rda->cat_file($slf->{'dir'}, "$nam.lck");
    $lck = IO::File->new;
    $lck->open($fil, O_CREAT | O_APPEND | O_RDWR, ## no critic (Bit)
               $FIL_PERMS)
      or die get_string('ERR_CREATE', $fil, $!);
    $slf->{'_hnd'}->{$nam} = $lck;
    $slf->{'_lck'}->{$nam} = $fil;
  }

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

=head2 S<$h-E<gt>unlock($nam[,$flg])>

This method releases a lock. When the flag is true, it removes the lock file
for all lock mechanisms. It returns true for success or false for failure.

=cut

sub unlock
{ my ($slf, $nam, $flg) = @_;
  my ($lck, $ret);

  return 0 unless exists($slf->{'_lck'}->{$nam});
  if (!exists($slf->{'_hnd'}->{$nam}))
  { $lck = delete($slf->{'_lck'}->{$nam});
    ++$ret while unlink($lck);
  }
  else
  { $lck = $slf->{'_hnd'}->{$nam};
    if (($ret = flock($lck, LOCK_UN)) && $flg)
    { $lck->close;
      delete($slf->{'_hnd'}->{$nam});
      $lck = delete($slf->{'_lck'}->{$nam});
      1 while unlink($lck);
    }
  }
  return $ret;
}

=head1 JOB AND THREAD LOCK METHODS

=head2 S<$h-E<gt>end($flg)>

This method removes the files that were created to indicate a lock by their
presence. Unless the flag is set, it performs explicit unlocks.

=cut

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

  $tbl = $slf->{'_lck'};
  foreach my $nam (keys(%{$tbl}))
  { if (exists($slf->{'_hnd'}->{$nam}))
    { flock($slf->{'_hnd'}->{$nam}, LOCK_UN) unless $flg;
    }
    else
    { 1 while unlink($tbl->{$nam});
    }
  }
  if ($tbl = delete($slf->{'_bkp'}))
  { $slf->{'_hnd'} = $tbl->{'_hnd'};
    $slf->{'_lck'} = $tbl->{'_lck'};
  }
  else
  { $slf->{'_hnd'} = {};
    $slf->{'_lck'} = {};
  }
  return;
}

=head2 S<$h-E<gt>init($flg)>

This method prepares the lock context for a new job or thread. When the flag
is set, it takes a shared lock to indicate that a thread is running. The method
derives the lock name from the result set name.

=cut

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

  $slf->{'_bkp'} = {_hnd => $slf->{'_hnd'},
                    _lck => $slf->{'_lck'}};
  $slf->{'_hnd'} = {};
  $slf->{'_lck'} = {};
  _lock($slf, $slf->{'_job'}, LOCK_SH | LOCK_NB)  ## no critic (Bit)
    if $flg && $slf->{'cfg'}->can_fork > 0;
  return;
}

=head2 S<$h-E<gt>wait>

This method takes an exclusive lock that can only be obtained if no threads
are running. It releases the lock immediately.

=cut

sub wait  ## no critic (Builtin)
{ my ($slf) = @_;

  _lock($slf, $slf->{'_job'}, LOCK_EX);
  unlock($slf, $slf->{'_job'});
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Output|RDA::Object::Output>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut