######################################################################
#
# $Id: EadRoutines.pm,v 1.10 2012/01/07 07:56:13 mavrik Exp $
#
######################################################################
#
# Copyright 2010-2012 The WebJob Project, All Rights Reserved.
#
######################################################################
#
# Purpose: Home for various encoder and decoder routines.
#
######################################################################

package WebJob::EadRoutines;

require Exporter;

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

use File::Basename;
use WebJob::ValidationRoutines;

@EXPORT = qw(EadUuDecode EadUuEncode);

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

######################################################################
#
# EadUuCloseSrcContext
#
######################################################################

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

  if (exists($$phPArgs{'SrcContext'}{'FileHandle'}))
  {
    my $sHandle = $$phPArgs{'SrcContext'}{'FileHandle'};
    close($sHandle);
  }

  1;
}


######################################################################
#
# EadUuDecode
#
######################################################################

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

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

  my %hLArgs =
  (
    'Hash' => $phPArgs,
    'Keys' =>
    [
#     'AbortOnError',    # Optional
      'DataSrc',
#     'ExcludeMembers',  # Optional
#     'ForceWrite',      # Optional
#     'IncludeMembers',  # Optional
#     'MemberMap'        # Optional
#     'OutputDirectory', # Optional
    ],
  );
  if (!defined(VerifyHashKeys(\%hLArgs)))
  {
    $$phPArgs{'Error'} = $hLArgs{'Error'} if (defined($phPArgs));
    return undef;
  }

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

  my $sAbortOnError = (defined($$phPArgs{'AbortOnError'}) && $$phPArgs{'AbortOnError'} =~ /^0$/) ? 0 : 1;

  my $sForceWrite = (defined($$phPArgs{'ForceWrite'}) && $$phPArgs{'ForceWrite'} =~ /^1$/) ? 1 : 0;

  my $sOutputDirectory = (defined($$phPArgs{'OutputDirectory'})) ? $$phPArgs{'OutputDirectory'} : ".";

  $$phPArgs{'SkipCount'} = 0;
 
  ####################################################################
  #
  # Make sure output directory exists.
  #
  ####################################################################

  if (!-d $sOutputDirectory)
  {
    $$phPArgs{'Error'} = "Output directory ($sOutputDirectory) does not exist.";
    return undef;
  }

  ####################################################################
  #
  # Determine and prepare data source.
  #
  ####################################################################

  if (!EadUuPrepareDataSrc($phPArgs))
  {
    return undef;
  }

  ####################################################################
  #
  # Let's decode it.
  #
  ####################################################################

  my ($sBadDecode, $sBadFormat, $sEofFound, $sLine);

  EadUuStartSrcContext($phPArgs);

  while (defined($sLine = EadUuGetLine($phPArgs)))
  {
    if ($sLine =~ /^begin ([0-7]{3}) ([\w.-]+)$/) # Note: Full paths are not allowed.
    {
      my $sMode = oct($1);
      my $sName = $2;
      if
      (
           (exists($$phPArgs{'ExcludeMembers'}) &&  EadUuMatchMember($$phPArgs{'ExcludeMembers'}, $sName))
        || (exists($$phPArgs{'IncludeMembers'}) && !EadUuMatchMember($$phPArgs{'IncludeMembers'}, $sName))
      )
      {
        $$phPArgs{'SkipCount'}++;
        next;
      }
      my $sFile = $sOutputDirectory . "/" . EadUuMapName($$phPArgs{'MemberMap'}, $sName);
      if (-f $sFile && !$sForceWrite)
      {
        my $sError = "File ($sFile) already exists.";
        push(@{$$phPArgs{'MemberTuples'}}, ["fail", $sFile, $sError]);
        if ($sAbortOnError)
        {
          $$phPArgs{'Error'} = $sError;
          EadUuCloseSrcContext($phPArgs);
          return undef;
        }
        next;
      }
      if (!open(EAD_DST_FH, "> $sFile"))
      {
        my $sError = "File ($sFile) could not be created ($!).";
        push(@{$$phPArgs{'MemberTuples'}}, ["fail", $sFile, $sError]);
        if ($sAbortOnError)
        {
          $$phPArgs{'Error'} = $sError;
          EadUuCloseSrcContext($phPArgs);
          return undef;
        }
        next;
      }
      binmode(EAD_DST_FH);
      $sBadDecode = $sBadFormat = $sEofFound = 0;
      while (defined($sLine = EadUuGetLine($phPArgs)))
      {
        if ($sLine =~ /^end$/)
        {
          $sEofFound = 1;
          last;
        }
        else
        {
          my $sDeclaredLength = (ord(substr($sLine, 0, 1)) - 0x20) & 0x3f;
          my $sNFill = ($sDeclaredLength % 3) ? 3 - ($sDeclaredLength % 3) : 0;
          my $sComputedLength = (((length($sLine) - 1) * 3) / 4) - $sNFill; # Subtract 1 to remove the lead byte.
          if ($sComputedLength != $sDeclaredLength || $sLine !~ /^([ -`]+)$/)
          {
            $sBadFormat = 1;
            last;
          }
          if ($sDeclaredLength)
          {
            my $sUnpackedData = unpack("u", $sLine);
            if (!defined($sUnpackedData))
            {
              $sBadDecode = 1;
              last;
            }
            print EAD_DST_FH $sUnpackedData;
          }
        }
      }
      close(EAD_DST_FH);
      if ($^O !~ /MSWin(32|64)/i)
      {
        chmod($sMode, $sFile);
      }
      if ($sBadFormat || $sBadDecode)
      {
        my $sLineNumber = $$phPArgs{'SrcContext'}{'LineNumber'};
        my $sError = "Error on line $sLineNumber (line does not pass muster or fails to decode). File ($sFile) may be incomplete.";
        push(@{$$phPArgs{'MemberTuples'}}, ["fail", $sFile, $sError]);
        if ($sAbortOnError)
        {
          $$phPArgs{'Error'} = $sError;
          EadUuCloseSrcContext($phPArgs);
          return undef;
        }
      }
      elsif (!$sEofFound)
      {
        push(@{$$phPArgs{'MemberTuples'}}, ["warn", $sFile, "EOF marker not found. File ($sFile) may be incomplete."]);
      }
      else
      {
        push(@{$$phPArgs{'MemberTuples'}}, ["pass", $sFile, undef]); # Success
      }
    }
  }

  EadUuCloseSrcContext($phPArgs);

  1;
}


######################################################################
#
# EadUuEncode
#
######################################################################

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

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

  my %hLArgs =
  (
    'Hash' => $phPArgs,
    'Keys' =>
    [
      'DataDst',
      'DataSrc',
#     'Mode',    # Optional
      'Name',
    ],
  );
  if (!defined(VerifyHashKeys(\%hLArgs)))
  {
    $$phPArgs{'Error'} = $hLArgs{'Error'} if (defined($phPArgs));
    return undef;
  }

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

  my $sName = basename($$phPArgs{'Name'}); # Note: Full paths are not allowed.
  if ($sName !~ /^[\w.-]+$/)
  {
    $$phPArgs{'Error'} = "Name ($sName) contains characters not in the allowed character set ([0-9A-Za-z_.-]).";
    return undef;
  }

  my $sMode = (defined($$phPArgs{'Mode'}) && $$phPArgs{'Mode'} =~ /^[0-7]{3}$/) ? $$phPArgs{'Mode'} : "600";

  ####################################################################
  #
  # Determine and prepare data source.
  #
  ####################################################################

  if (!EadUuPrepareDataSrc($phPArgs))
  {
    return undef;
  }

  ####################################################################
  #
  # Determine and prepare data destination.
  #
  ####################################################################

  if (!EadUuPrepareDataDst($phPArgs))
  {
    return undef;
  }

  ####################################################################
  #
  # Let's encode it.
  #
  ####################################################################

  my $sNToRead = 45;

  if ($$phPArgs{'DstIsFile'})
  {
    my $sDstFileHandle = $$phPArgs{'DstFileHandle'};
    print $sDstFileHandle "begin $sMode $sName\n";
    if ($$phPArgs{'SrcIsFile'})
    {
      my $sLine;
      my $sSrcFileHandle = $$phPArgs{'SrcFileHandle'};
      while (read($sSrcFileHandle, $sLine, $sNToRead))
      {
        print $sDstFileHandle (pack("u", $sLine) || "");
      }
      close($sSrcFileHandle);
    }
    else
    {
      for (my $sIndex = 0; $sIndex < length(${$$phPArgs{'DataSrc'}}); $sIndex += $sNToRead)
      {
        my $sData = substr(${$$phPArgs{'DataSrc'}}, $sIndex, $sNToRead);
        print $sDstFileHandle (pack("u", $sData) || "");
      }
    }
    print $sDstFileHandle "`\nend\n";
  }
  else
  {
    ${$$phPArgs{'DataDst'}} .= "begin $sMode $sName\n"; # Use '.=' here since the caller may already have data in this variable.
    if ($$phPArgs{'SrcIsFile'})
    {
      my $sLine;
      my $sSrcFileHandle = $$phPArgs{'SrcFileHandle'};
      while (read($sSrcFileHandle, $sLine, $sNToRead))
      {
        ${$$phPArgs{'DataDst'}} .= (pack("u", $sLine) || "");
      }
      close($sSrcFileHandle);
    }
    else
    {
      for (my $sIndex = 0; $sIndex < length(${$$phPArgs{'DataSrc'}}); $sIndex += $sNToRead)
      {
        my $sData = substr(${$$phPArgs{'DataSrc'}}, $sIndex, $sNToRead);
        ${$$phPArgs{'DataDst'}} .= (pack("u", $sData) || "");
      }
    }
    ${$$phPArgs{'DataDst'}} .= "`\nend\n";
  }

  1;
}


######################################################################
#
# EadUuGetLine
#
######################################################################

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

  my $sLine;

  if (exists($$phPArgs{'SrcContext'}{'FileHandle'}))
  {
    my $sHandle = $$phPArgs{'SrcContext'}{'FileHandle'};
    $sLine = <$sHandle>;
  }
  else
  {
    if ($$phPArgs{'SrcContext'}{'Index'} < $$phPArgs{'SrcContext'}{'Count'})
    {
      $sLine = ${$$phPArgs{'SrcContext'}{'Lines'}}[$$phPArgs{'SrcContext'}{'Index'}++];
    }
  }
  $sLine =~ s/[\r\n]+$// if defined($sLine);

  $$phPArgs{'SrcContext'}{'LineNumber'}++;

  return $sLine;
}


######################################################################
#
# EadUuMapName
#
######################################################################

sub EadUuMapName
{
  my ($phMemberMap, $sName) = @_;

  if (exists($$phMemberMap{$sName}) && defined($$phMemberMap{$sName}) && length($$phMemberMap{$sName}))
  {
    return $$phMemberMap{$sName};
  }

  return $sName;
}


######################################################################
#
# EadUuMatchMember
#
######################################################################

sub EadUuMatchMember
{
  my ($paMembers, $sName) = @_;

  foreach my $sMember (@$paMembers)
  {
    return 1 if ($sName eq $sMember);
  }

  return 0;
}


######################################################################
#
# EadUuPrepareDataDst
#
######################################################################

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

  my $sDstFileHandle;

  if (ref($$phPArgs{'DataDst'}) =~ /^(ARRAY|HASH|CODE|REF|LVALUE|FORMAT|IO|Regexp)$/)
  {
    $$phPArgs{'Error'} = "Invalid data type ($1) for 'DataDst' argument.";
    return undef;
  }
  elsif (ref($$phPArgs{'DataDst'}) eq "GLOB")
  {
    $sDstFileHandle = $$phPArgs{'DataDst'};
  }
  elsif (ref($$phPArgs{'DataDst'}) eq "SCALAR")
  {
    $$phPArgs{'DstIsFile'} = 0;
  }
  else
  {
    if ($$phPArgs{'DataDst'} eq "-")
    {
      $sDstFileHandle = \*STDOUT;
    }
    else
    {
      if (!open(EAD_DST_FH, "> $$phPArgs{'DataDst'}"))
      {
        $$phPArgs{'Error'} = "File ($$phPArgs{'DataDst'}) could not be created ($!).";
        return undef;
      }
      $sDstFileHandle = \*EAD_DST_FH;
    }
  }

  if (defined($sDstFileHandle))
  {
    binmode($sDstFileHandle);
    $$phPArgs{'DstFileHandle'} = $sDstFileHandle;
    $$phPArgs{'DstIsFile'} = 1;
  }

  1;
}


######################################################################
#
# EadUuPrepareDataSrc
#
######################################################################

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

  my $sSrcFileHandle;

  if (ref($$phPArgs{'DataSrc'}) =~ /^(ARRAY|HASH|CODE|REF|LVALUE)$/)
  {
    $$phPArgs{'Error'} = "Invalid data type ($1) for 'DataSrc' argument.";
    return undef;
  }
  elsif (ref($$phPArgs{'DataSrc'}) eq "GLOB")
  {
    $sSrcFileHandle = $$phPArgs{'DataSrc'};
  }
  elsif (ref($$phPArgs{'DataSrc'}) eq "SCALAR")
  {
    $$phPArgs{'SrcIsFile'} = 0;
  }
  else
  {
    if ($$phPArgs{'DataSrc'} eq "-")
    {
      $sSrcFileHandle = \*STDIN;
    }
    else
    {
      if (!open(EAD_SRC_FH, "< $$phPArgs{'DataSrc'}"))
      {
        $$phPArgs{'Error'} = "File ($$phPArgs{'DataSrc'}) could not be opened ($!).";
        return undef;
      }
      $sSrcFileHandle = \*EAD_SRC_FH;
    }
  }

  if (defined($sSrcFileHandle))
  {
    binmode($sSrcFileHandle);
    $$phPArgs{'SrcFileHandle'} = $sSrcFileHandle;
    $$phPArgs{'SrcIsFile'} = 1;
  }

  1;
}


######################################################################
#
# EadUuStartSrcContext
#
######################################################################

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

  $$phPArgs{'SrcContext'}{'LineNumber'} = 0;

  if ($$phPArgs{'SrcIsFile'})
  {
    $$phPArgs{'SrcContext'}{'FileHandle'} = $$phPArgs{'SrcFileHandle'};
  }
  else
  {
    push(@{$$phPArgs{'SrcContext'}{'Lines'}}, split(/[\r\n]+/, ${$$phPArgs{'DataSrc'}}));
    $$phPArgs{'SrcContext'}{'Index'} = 0;
    $$phPArgs{'SrcContext'}{'Count'} = scalar(@{$$phPArgs{'SrcContext'}{'Lines'}});
  }

  1;
}

1;

__END__

=pod

=head1 NAME

WebJob::EadRoutines - Home for various encoder and decoder routines

=head1 SYNOPSIS

    use WebJob::EadRoutines;

=head1 DESCRIPTION

This module is a collection of various encoder and decoder routines
designed to support various WebJob 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.

=head1 AUTHOR

Klayton Monroe

=head1 LICENSE

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

=cut
