######################################################################
#
# $Id: KvpRoutines.pm,v 1.34 2012/01/07 07:56:13 mavrik Exp $
#
######################################################################
#
# Copyright 2004-2012 The WebJob Project, All Rights Reserved.
#
######################################################################
#
# Purpose: Key/Value Pair routines
#
######################################################################

package WebJob::KvpRoutines;

require Exporter;

use 5.008;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use Fcntl qw(:DEFAULT :flock);
use FileHandle;
use File::Basename;
use File::Temp;
use WebJob::FdaRoutines 1.012;
use WebJob::ValidationRoutines;

@EXPORT = qw(KvpGetKvps KvpLockFile KvpSetKvps KvpUnlockFile);

@EXPORT_OK = ();
@ISA = qw(Exporter);
$VERSION = do { my @r = (q$Revision: 1.34 $ =~ /(\d+)/g); sprintf("%d."."%03d" x $#r, @r); };

######################################################################
#
# KvpGetKvps
#
######################################################################

sub KvpGetKvps
{
  my ($phPArgs) = @_;

  ####################################################################
  #
  # Make sure that required inputs are defined.
  #
  ####################################################################

  my %hLArgs =
  (
    'Hash' => $phPArgs,
    'Keys' =>
    [
#     'AcceptMultipleValues', # Optional
#     'AutoLock',             # Optional
#     'Delimiter',            # Optional
#     'Error',                # Optional output (scalar)
      'File',
#     'FileFormat',           # Optional input (scalar)
#     'MatchKeyCase',         # Optional
      'Properties',
#     'RecursionKey',         # Optional
#     'RecursionLevel',       # Optional (not intended for external use)
#     'RecursionLimit',       # Optional
#     'Rejects',              # Required output (array reference)
#     'RequiredKeys',         # Optional
#     'RequireAllKeys',       # Optional
#     'RequireKnownKeys',     # Optional
      'Template',
#     'UnquoteValues',        # Optional
#     'VerifyValues',         # Optional
    ],
  );
  if (!defined(VerifyHashKeys(\%hLArgs)))
  {
    $$phPArgs{'Error'} = $hLArgs{'Error'} if (defined($phPArgs));
    return undef;
  }

  ####################################################################
  #
  # Assign default values where necessary.
  #
  ####################################################################

  my ($sAcceptMultipleValues, $sAutoLock, $sDelimiter, $sFileFormat, $sKeyCaseRegex, $sRequireKnownKeys, $sUnquoteValues, $sVerifyValues);

  $sAcceptMultipleValues = $$phPArgs{'AcceptMultipleValues'} || 0;

  $sAutoLock = $$phPArgs{'AutoLock'} || 0;

  $sDelimiter = $$phPArgs{'Delimiter'} || "=";

  $sFileFormat = $$phPArgs{'FileFormat'} || "kvp";

  $sKeyCaseRegex = ($$phPArgs{'MatchKeyCase'}) ? "" : "(?i)";

  $sRequireKnownKeys = $$phPArgs{'RequireKnownKeys'} || 0;

  $sUnquoteValues = $$phPArgs{'UnquoteValues'} || 0;

  $sVerifyValues = $$phPArgs{'VerifyValues'} || 0;

  $$phPArgs{'RecursionLevel'} = 0 unless (defined($$phPArgs{'RecursionLevel'}) && $$phPArgs{'RecursionLevel'} =~ /^\d+$/);

  $$phPArgs{'RecursionLimit'} = 3 unless (defined($$phPArgs{'RecursionLimit'}) && $$phPArgs{'RecursionLimit'} =~ /^\d+$/);

  $$phPArgs{'Rejects'} = [];

  ####################################################################
  #
  # Don't go beyond the recursion limit.
  #
  ####################################################################

  if ($$phPArgs{'RecursionLevel'} >= $$phPArgs{'RecursionLimit'})
  {
    $$phPArgs{'Error'} = "Recursion limit ($$phPArgs{'RecursionLimit'}) reached. Processing stopped at file \"$$phPArgs{'File'}\".";
    return undef;
  }

  ####################################################################
  #
  # Only the top-level properties file must exist.
  #
  ####################################################################

  if (!-f $$phPArgs{'File'})
  {
    if ($$phPArgs{'RecursionLevel'} < 1)
    {
      if ($$phPArgs{'File'} ne "-")
      {
        $$phPArgs{'Error'} = "File ($$phPArgs{'File'}) does not exist or is not regular.";
        return undef;
      }
    }
    else
    {
      return 1;
    }
  }

  ####################################################################
  #
  # Take note of the top-level filename in case it's needed later.
  #
  ####################################################################

  if ($$phPArgs{'RecursionLevel'} == 0)
  {
    $$phPArgs{'TopLevelFile'} = $$phPArgs{'File'};
  }

  ####################################################################
  #
  # Conditionally create a lock file. This is a shared lock.
  #
  ####################################################################

  my %hLockArgs;

  if ($sAutoLock && $$phPArgs{'File'} ne "-")
  {
    %hLockArgs =
    (
      'LockFile'   => $$phPArgs{'File'} . ".lock",
      'LockFlags'  => LOCK_SH,
      'LockRemove' => 1,
    );
    if (!KvpLockFile(\%hLockArgs))
    {
      $$phPArgs{'Error'} = $hLockArgs{'Error'};
      return undef;
    }
  }

  ####################################################################
  #
  # Open the properties file for read access.
  #
  ####################################################################

  my $oFileHandle = new FileHandle;
  if (!defined($oFileHandle))
  {
    $$phPArgs{'Error'} = "Unable to obtain a file handle.";
    return undef;
  }

  my $sOpenMode = "<";

  if ($$phPArgs{'File'} eq "-")
  {
    if (!$oFileHandle->fdopen(fileno(STDIN), "r"))
    {
      $$phPArgs{'Error'} = "File (STDIN) could not be opened ($!).";
      return undef;
    }
  }
  else
  {
    if (!$oFileHandle->open("$sOpenMode $$phPArgs{'File'}"))
    {
      $$phPArgs{'Error'} = "File ($$phPArgs{'File'}) could not be opened ($!).";
      return undef;
    }
  }

  ####################################################################
  #
  # Read the properties file. Reject lines that don't adhere to the
  # specified file format. Conditionally ignore case when evaluating
  # keys. If the Template sub-hash is empty, then no key/value pairs
  # will be returned. If strict mode is enabled, every value must
  # pass a regular expression check.
  #
  # Notes for regular expression keys: If the actual key and the
  # corresponding template key don't match when compared as lowercase
  # strings, assume that the template key was specified as a regular
  # expression, and use the actual key (as spelled) to populate the
  # properties hash. This is useful for creating compact templates
  # where the keys vary and generally won't be known ahead of time.
  # This feature, however, may not work as expected if the caller has
  # set the RequireAllKeys option because there is no way to predict
  # which or how many keys will be in the config file. Also, the
  # MatchKeyCase option should be set so that the regular expression
  # can handle case matching on its own.
  #
  ####################################################################

  my $sLineRegex = ($sFileFormat =~ /^singleton$/io) ? qr(^(.+)()$) : qr(^([^$sDelimiter]+)$sDelimiter(.*)$);

  for (my $sLineNumber = 1; my $sLine = $oFileHandle->getline(); $sLineNumber++)
  {
    $sLine =~ s/[\r\n]+$//; # Remove CRs and LFs.
    $sLine =~ s/(^|[^\\])#.*$/$1/; # Remove comments, but only if they aren't escaped.
    $sLine =~ s/[\\](#)/$1/g; # Remove the escapes that were protecting the comments.
    if (my ($sKey, $sValue) = ($sLine =~ /$sLineRegex/))
    {
      $sKey =~ s/^\s+//; # Remove leading whitespace.
      $sKey =~ s/\s+$//; # Remove trailing whitespace.
      $sValue = $sKey if ($sFileFormat =~ /^singleton$/io);
      $sValue =~ s/^\s+//; # Remove leading whitespace.
      $sValue =~ s/\s+$//; # Remove trailing whitespace.
      if ($sUnquoteValues && $sValue =~ /^(["'])(.*)\1$/)
      {
        my $sQuoteSymbol = $1;
        $sValue = $2;
        $sValue =~ s/[\\]($sQuoteSymbol)/$1/g; # Remove the escapes that were protecting embedded quotes of the same kind.
      }
      if (defined($sKey) && length($sKey))
      {
        my $sKeyIsKnown = 0;
        foreach my $sTemplateKey (keys(%{$$phPArgs{'Template'}}))
        {
          if ($sKey =~ /^$sKeyCaseRegex$sTemplateKey$/)
          {
            $sKeyIsKnown = 1;
            if ($sVerifyValues && $sValue !~ /^$$phPArgs{'Template'}{$sTemplateKey}$/)
            {
              $$phPArgs{'Error'} = "The value for the \"$sKey\" property on line $sLineNumber of \"$$phPArgs{'File'}\" does not pass muster.";
              $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");
              return undef;
            }
            if (defined($$phPArgs{'RecursionKey'}) && lc($sKey) eq lc($$phPArgs{'RecursionKey'}))
            {
              my $sNewFile = $sValue;
              my $sOldFile = $$phPArgs{'File'};
              $$phPArgs{'File'} = $sNewFile;
              $$phPArgs{'RecursionLevel'}++;
              my $sAbort = (!KvpGetKvps($phPArgs)) ? 1 : 0;
              $$phPArgs{'RecursionLevel'}--;
              $$phPArgs{'File'} = $sOldFile;
              return undef if ($sAbort);
            }
            else
            {
              my $sOfficialKey = (lc($sKey) eq lc($sTemplateKey)) ? $sTemplateKey : $sKey;
              if ($sAcceptMultipleValues)
              {
                push(@{$$phPArgs{'Properties'}{$sOfficialKey}}, $sValue);
              }
              else
              {
                $$phPArgs{'Properties'}{$sOfficialKey} = $sValue;
              }
            }
            last;
          }
        }
        if (!$sKeyIsKnown)
        {
          if ($sRequireKnownKeys)
          {
            $$phPArgs{'Error'} = "The \"$sKey\" property on line $sLineNumber of \"$$phPArgs{'File'}\" is not known/supported.";
            $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");
            return undef;
          }
          else
          {
            push(@{$$phPArgs{'Rejects'}}, $sLineNumber);
          }
        }
      }
    }
    else
    {
      push(@{$$phPArgs{'Rejects'}}, $sLineNumber) unless ($sLine =~ /^\s*$/o);
    }
  }

  ####################################################################
  #
  # Close the properties file.
  #
  ####################################################################

  $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");

  ####################################################################
  #
  # Conditionally unlock the lock file.
  #
  ####################################################################

  if ($sAutoLock && $$phPArgs{'File'} ne "-")
  {
    KvpUnlockFile(\%hLockArgs);
  }

  ####################################################################
  #
  # Conditionally verify that all keys in the template are present.
  #
  ####################################################################

  my @aKeys = ();
  my @aRequiredKeys = ();
  my $sRequireAllKeys = $$phPArgs{'RequireAllKeys'} || 0;

  if ($sRequireAllKeys)
  {
    @aRequiredKeys = keys(%{$$phPArgs{'Template'}});
  }
  else
  {
    @aRequiredKeys = @{$$phPArgs{'RequiredKeys'}} if (exists($$phPArgs{'RequiredKeys'}));
  }
  foreach my $sTemplateKey (@aRequiredKeys)
  {
    if (!exists($$phPArgs{'Properties'}{$sTemplateKey}) || !defined($$phPArgs{'Properties'}{$sTemplateKey}))
    {
      push(@aKeys, $sTemplateKey);
    }
  }
  if (scalar(@aKeys) > 0)
  {
    my $sKeys = join(",", @aKeys);
    $$phPArgs{'Error'} = "One or more required properties ($sKeys) in \"$$phPArgs{'TopLevelFile'}\" are missing or undefined.";
    return undef;
  }

  1;
}


######################################################################
#
# KvpLockFile
#
######################################################################

sub KvpLockFile
{
  return FdaLockFile($_[0]);
}


######################################################################
#
# KvpSetKvps
#
######################################################################

sub KvpSetKvps
{
  my ($phPArgs) = @_;

  ####################################################################
  #
  # Make sure that required inputs are defined.
  #
  ####################################################################

  my %hLArgs =
  (
    'Hash' => $phPArgs,
    'Keys' =>
    [
#     'AppendToFile',  # Optional
#     'AutoLock',      # Optional
      'File',
#     'Delimiter',     # Optional
#     'MatchKeyCase',  # Optional
#     'Newline',       # Optional
      'Properties',
#     'QuoteSymbol',   # Optional
#     'QuoteValues',   # Optional
#     'Template',      # Optional
#     'VerifyValues',  # Optional
    ],
  );
  if (!defined(VerifyHashKeys(\%hLArgs)))
  {
    $$phPArgs{'Error'} = $hLArgs{'Error'} if (defined($phPArgs));
    return undef;
  }

  ####################################################################
  #
  # Assign default values where necessary.
  #
  ####################################################################

  my ($sAutoLock, $sDelimiter, $sKeyCaseRegex, $sNewline, $sQuoteSymbol, $sQuoteValues, $sVerifyValues);

  $sAutoLock = $$phPArgs{'AutoLock'} || 0;

  $sDelimiter = $$phPArgs{'Delimiter'} || "=";

  $sKeyCaseRegex = ($$phPArgs{'MatchKeyCase'}) ? "" : "(?i)";

  $sNewline = $$phPArgs{'Newline'} || "$/";

  $sQuoteSymbol = (defined($$phPArgs{'QuoteSymbol'}) && $$phPArgs{'QuoteSymbol'} =~ /^(["'])$/) ? $1 : '"';

  $sQuoteValues = $$phPArgs{'QuoteValues'} || 0;

  $sVerifyValues = $$phPArgs{'VerifyValues'} || 0;

  ####################################################################
  #
  # Conditionally create a lock file. This is an exclusive lock.
  #
  ####################################################################

  my %hLockArgs;

  if ($sAutoLock && $$phPArgs{'File'} ne "-")
  {
    %hLockArgs =
    (
      'LockFile'   => $$phPArgs{'File'} . ".lock",
      'LockRemove' => 1,
    );
    if (!KvpLockFile(\%hLockArgs))
    {
      $$phPArgs{'Error'} = $hLockArgs{'Error'};
      return undef;
    }
  }

  ####################################################################
  #
  # Open the properties file for write access. However, do not use a
  # temporary file if the filename is "-" or the append flag is set.
  #
  ####################################################################

  my ($oFileHandle, $oTempHandle);

  if ($$phPArgs{'File'} eq "-")
  {
    $oFileHandle = new FileHandle;
    if (!defined($oFileHandle))
    {
      $$phPArgs{'Error'} = "Unable to obtain a file handle.";
      return undef;
    }
    if (!$oFileHandle->fdopen(fileno(STDOUT), "w"))
    {
      $$phPArgs{'Error'} = "File (STDOUT) could not be opened ($!).";
      return undef;
    }
  }
  else
  {
    if ($$phPArgs{'AppendToFile'})
    {
      $oFileHandle = new FileHandle;
      if (!defined($oFileHandle))
      {
        $$phPArgs{'Error'} = "Unable to obtain a file handle.";
        return undef;
      }
      if (!$oFileHandle->open(">> $$phPArgs{'File'}"))
      {
        $$phPArgs{'Error'} = "File ($$phPArgs{'File'}) could not be opened ($!).";
        return undef;
      }
    }
    else
    {
      my $sDirectory = dirname($$phPArgs{'File'});
      my ($sMode, $sUid, $sGid);
      if (-f $$phPArgs{'File'})
      {
        if (!stat($$phPArgs{'File'}))
        {
          $$phPArgs{'Error'} = "Unable to get attributes for $$phPArgs{'File'} ($!).";
          return undef;
        }
        ($sMode, $sUid, $sGid) = (stat(_))[2,4,5];
      }
      eval { $oTempHandle = new File::Temp(DIR => $sDirectory, TEMPLATE => ".XXXXXXXXXX"); };
      if ($@)
      {
        my $sMessage = $@; $sMessage =~ s/[\r\n]+/ /g; $sMessage =~ s/\s+/ /g; $sMessage =~ s/\s+$//;
        $$phPArgs{'Error'} = "Unable to create/open a temporary file ($sMessage).";
        return undef;
      }
      $oFileHandle = $oTempHandle;
      if (defined($sMode) && !chmod($sMode, $oFileHandle))
      {
        $$phPArgs{'Error'} = "Unable to set permissions (" . sprintf("%04o", $sMode) . ") for temporary file ($!).";
        $oFileHandle->close();
        return undef;
      }
      if (defined($sUid) && defined($sGid) && !chown($sUid, $sGid, $oFileHandle))
      {
        $$phPArgs{'Error'} = "Unable to set owner/group ($sUid/$sGid) for temporary file ($!).";
        $oFileHandle->close();
        return undef;
      }
    }
  }

  ####################################################################
  #
  # Generate the contents of the Properties hash. If the Template
  # hash exists, only output properties that are common to both
  # hashes. If the VerifyValues option is enabled, test each value to
  # ensure that it's valid according to the specified expression.
  #
  ####################################################################

  my ($sLQuote, $sRQuote);

  $sLQuote = ($sQuoteValues) ? $sQuoteSymbol : "";
  $sRQuote = ($sQuoteValues) ? $sQuoteSymbol : "";
  foreach my $sKey (sort(keys(%{$$phPArgs{'Properties'}})))
  {
    my $sValue = $$phPArgs{'Properties'}{$sKey};
    if (exists($$phPArgs{'Template'}))
    {
      my $sHaveKvp = 0;
      foreach my $sTemplateKey (keys(%{$$phPArgs{'Template'}}))
      {
        if ($sKey =~ /^$sKeyCaseRegex$sTemplateKey$/)
        {
          if ($sVerifyValues && $sValue !~ /^$$phPArgs{'Template'}{$sTemplateKey}$/)
          {
            $$phPArgs{'Error'} = "The value for the \"$sKey\" property does not pass muster.";
            $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");
            return undef;
          }
          $sKey = $sTemplateKey if (lc($sKey) eq lc($sTemplateKey));
          $sHaveKvp = 1;
          last;
        }
      }
      next unless ($sHaveKvp);
    }
    $sValue =~ s/(#)/\\$1/g; # Insert escapes to protect embedded '#'s.
    $sValue =~ s/($sQuoteSymbol)/\\$1/g if ($sQuoteValues); # Insert escapes to protect embedded quotes.
    if (!$oFileHandle->print($sKey, $sDelimiter, $sLQuote, $sValue, $sRQuote, $sNewline))
    {
      $$phPArgs{'Error'} = "Unable to write the key/value pair for the \"$sKey\" property to $$phPArgs{'File'} ($!).";
      $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");
      return undef;
    }
  }

  ####################################################################
  #
  # Close the properties file.
  #
  ####################################################################

  $oFileHandle->close() unless ($$phPArgs{'File'} eq "-");

  ####################################################################
  #
  # Move the properties file into place.
  #
  ####################################################################

  if ($oTempHandle)
  {
    if (!rename($oFileHandle->filename(), $$phPArgs{'File'}))
    {
      $$phPArgs{'Error'} = "Unable to move $$phPArgs{'File'} into place ($!).";
      return undef;
    }
    $oFileHandle->unlink_on_destroy(0);
  }

  ####################################################################
  #
  # Conditionally unlock the lock file.
  #
  ####################################################################

  if ($sAutoLock && $$phPArgs{'File'} ne "-")
  {
    KvpUnlockFile(\%hLockArgs);
  }

  1;
}


######################################################################
#
# KvpUnlockFile
#
######################################################################

sub KvpUnlockFile
{
  return FdaUnlockFile($_[0]);
}

1;

__END__

=pod

=head1 NAME

WebJob::KvpRoutines - Key/Value Pair routines

=head1 SYNOPSIS

    use WebJob::KvpRoutines 1.029;

=head1 DESCRIPTION

This module is a collection of key/value pair routines designed to
support various WebJob server-side utilities. As such, minimal effort
was put into supporting this code for general consumption. In other
words, use at your own risk and don't expect the interface to remain
the same or backwards compatible from release to release. This module
does not provide an OO interface, nor will it do so anytime soon.

Note: Revisions of this script prior to 1.026 should not be used in
heavy load and/or high frequency situations because the implementation
of KvpSetKvps() was susceptible to a race condition.

=head1 AUTHOR

Klayton Monroe

=head1 LICENSE

All documentation and code are distributed under same terms and
conditions as B<WebJob>.

=cut
