#!/usr/bin/perl
# ----------------------------------------------------------------------------
# This software is Copyright (C) 2007, All Rights Reserved
# ----------------------------------------------------------------------------
# This program is protected by local and international copyright laws. Any
# use of this program is subject to the the terms of the license agreement
# included as part of this distribution archive. Any other uses are strictly
# prohibited without the written permission of the Vendor and all
# other rights are reserved.
# -----------------------------------------------------------------------------
# Warning : Modifying this program violates your license agreement!
# -----------------------------------------------------------------------------

package IT::FreezeThaw;

use strict;

use IT::Globals qw($CGIDIR $DATADIR $SETTINGS);

# library globals
use vars qw($FREEZETHAW_SORT_KEYS);
$FREEZETHAW_SORT_KEYS = 1;     # sort keys when thawing so testplan code comparisons work (slightly slower)

# ------------------------------------------------------------------------
# Function    : loadStructFromFile
# Description : load a structure from a file (YOU MUST FILELOCK MANUALLY!)
# Usage       : my $struct = &IT::FreezeThaw::loadStructFromFile($filepath, ['ALLOW_PERL_EVAL']);
# ------------------------------------------------------------------------

sub loadStructFromFile {
  my $filepath        = shift;
  my $allow_perl_eval = shift;

  # error checking
  &IT::Error::dieOnValidationErrors(
    ["\$filepath",        $filepath,        "fileMustExist"],
    ["\$allow_perl_eval", $allow_perl_eval, "oneOf(,ALLOW_PERL_EVAL)"],
  );

  ### Load the string from a file
  my $string = &IT::File::readFile($filepath, 'WITHOUT_FILELOCKING'); # without filelocking is ok since it will retry or die if file is changed during read
  if ($string eq '') { return undef; }

  ### Remove perl datafile safety headers (optional)
  $string =~ s/^.*?__END__[\r\n]+//s;

  ### Thaw structure
  my $struct = &structThaw($string, $allow_perl_eval);

  return $struct;
}

# ------------------------------------------------------------------------
# Function    : saveStructToFile
# Description : save a structure to a file (YOU MUST FILELOCK MANUALLY!)
# Usage       : &IT::FreezeThaw::saveStructToFile($filepath, $struct, [$freezeAs]);
# ------------------------------------------------------------------------

sub saveStructToFile {
  my $filepath = shift;
  my $struct   = shift;
  my $freezeAs = shift || "perl";

  # error checking
  &IT::Error::dieOnValidationErrors(
    ["\$filepath", $filepath, "notRelativePath"],
    ["\$freezeAs", $freezeAs, "oneOf(,perl,hexPerl)"],
  );

  ### Add perl datafile safety headers
  my $string = qq|#!$^X\nprint "Content-type: text/html\\n\\n<html></html>"\n__END__\n|;  #-- skip syntax check --#

  ### Freeze structure
  $string .= &structFreeze($struct, $freezeAs);

  ### Write the string to a file
  &IT::FileLock::getLock('exclusive');
  &IT::File::writeFile("$filepath.temp.dat.cgi", $string);
  rename("$filepath.temp.dat.cgi", $filepath) || die "Couldn't rename file! $!";
  &IT::FileLock::releaseLock();
}


# ------------------------------------------------------------------------
# Function    : structFreeze
# Description : serialize a deep structure
# Usage       : my $string = &structFreeze($struct, $freezeAs);
# Args        : $freezeAs must be perl or hexPerl
# ------------------------------------------------------------------------

sub structFreeze {
  my $struct   = shift;
  my $freezeAs = shift;

  # error checking
  &IT::Error::dieOnValidationErrors(
    ["\$struct",   $struct,   ""],
    ["\$freezeAs", $freezeAs, "oneOf(perl,hexPerl)"],
  );

  # freeze (serialize) perl data structure
  my $perlCode = &_structFreeze_perl($struct);

  if ($freezeAs eq 'perl') {
    my $perlCodeWithHeader = "#perl=" . $perlCode;
    return $perlCodeWithHeader;
  }
  elsif ($freezeAs eq 'hexPerl') {
    my $hexEncodedPerlCodeWithHeader = "#hexperl=" . unpack('H*',$perlCode);
    return $hexEncodedPerlCodeWithHeader;
  }
  else { die "unknown freezeAs method '$freezeAs'!"; }

}

# ------------------------------------------------------------------------
# Function    : structThaw
# Description : re-animate a frozen structure
# Usage       : my $struct = &structThaw($frozen_string, $allow_perl_eval);
# ------------------------------------------------------------------------

sub structThaw {
  my $frozenStruct    = shift;
  my $allow_perl_eval = shift;

  # error checking
  &IT::Error::dieOnValidationErrors(
    ["\$frozenStruct",    $frozenStruct,    "notRef"],
    ["\$allow_perl_eval", $allow_perl_eval, "oneOf(,ALLOW_PERL_EVAL)"],
  );

  ### thaw frozen data structure
  unless (length $frozenStruct) { return undef; }

  # get perl code from frozen struct
  my $perlCode;
  if    ($frozenStruct =~ s/^#hexperl=//) { $perlCode = pack('H*', $frozenStruct); }
  elsif ($frozenStruct =~ s/^#perl=//)    { $perlCode = $frozenStruct; }
  else {
    die "unknown struct format, doesn't start with #hexperl= or #perl=!";
  }

  # evaluate perl code
  my $struct;
  if ($allow_perl_eval) {
    $struct = eval $perlCode;
    if ($@) { die("structThaw: eval error: $@"); }
  }
  else {
    ($struct) = &_structThaw_perl_safely($perlCode);
  }

  # return data structure
  return $struct;
}

# ------------------------------------------------------------------------
# Function    : structCopy
# Description : copy a data structure by freezing and thawing it again
# Usage       : my $structCopy = &structCopy($originalStruct);
# ------------------------------------------------------------------------

sub structCopy {
  my $originalStruct = shift;

  my $frozenStruct   = &structFreeze($originalStruct, 'perl');
  my $structCopy     = &structThaw($frozenStruct, 'ALLOW_PERL_EVAL');

  return $structCopy;
}

# ------------------------------------------------------------------------
# Function    : _structFreeze_perl
# Description : freeze structure into indented, readable perl
# Usage       : &_structFreeze_perl($struct);
# ------------------------------------------------------------------------

sub _structFreeze_perl {
  my $ref            = shift;
  my $depth          = int shift; # defined when function calls itself recursively
  my $remove_padding = shift;     # defined when function calls itself recursively

  my $refType        = ref($ref);
  my $perlcode       = '';
  my $indentation    = '     ';

  ### VALUE
  if ($refType eq '') {
    my $scalar = $ref;  # it's not a ref at this point
    if (defined $scalar)         { $perlcode .= &_quoteString($scalar); }
    else                         { $perlcode .= 'undef'; };
  }

  ### REF
  elsif ($refType eq 'REF') {
    $perlcode .= '\\';
    $perlcode .= &_structFreeze_perl($$ref, 0);
  }

  ### SCALAR
  elsif ($refType eq 'SCALAR') {
    $perlcode .= $indentation x $depth;
    $perlcode .= "\\" . &_quoteString($$ref);
  }

  ### ARRAY
  elsif ($refType eq 'ARRAY') {
    my $item;
    my $count;
    my $arrayContainsRefs = grep { ref $_ } @$ref;

    $perlcode .= "[";
    $perlcode .= "\n" if $arrayContainsRefs;

    foreach $item (@$ref) {
      if ($count++ > 0) {
        $perlcode .= ", ";
        $perlcode .= "\n" if $arrayContainsRefs;
      }
      $perlcode .= &_structFreeze_perl($item, $depth+1);
    }
    $perlcode .= "\n" if $arrayContainsRefs;
    $perlcode .= $indentation x $depth if $arrayContainsRefs;  ;
    $perlcode .= "]";
  }


  ### HASH
  elsif ($refType eq 'HASH') {
    my $key;
    my $count;

    my $maxQuotedKeyLength = 0;
    foreach (keys %$ref) {
      my $keyLength = length &_quoteString($_);
      if ($maxQuotedKeyLength < $keyLength) { $maxQuotedKeyLength = $keyLength; }
    }

    $perlcode .= $indentation x $depth;
    $perlcode .= "{\n";
    my @keys = $FREEZETHAW_SORT_KEYS ? sort keys %$ref : keys %$ref; # sorting is slower so it can be disabled (but must be on for testplans)
    foreach $key(@keys) {
      if ($count++ > 0) { $perlcode .= ",\n"; }
      $perlcode .= $indentation x $depth;
      $perlcode .= sprintf "%-${maxQuotedKeyLength}s => ", &_quoteString($key);
      $perlcode .= &_structFreeze_perl($ref->{$key}, $depth+1, 'remove_padding');
    }
    $perlcode .= "\n";
    $perlcode .= $indentation x $depth;
    $perlcode .= "}";
  }

  ### UNKNOWN
  else {
    die "unknown ref type '$refType'";
  }

  # remove leading padding
  if ($remove_padding) { $perlcode =~ s/^\s*//s; }

  return $perlcode;

}

# ------------------------------------------------------------------------
# Function    : _structThaw_perl_safely
# Description : decode perlcode into a data structure using regexps instead
#               of eval.  This is slower than eval but SAFE since even if
#               someone was able to insert arbitrary perl code it wouldn't run.
#
#               This function works by parsing the first token (\, {, [, or string) and returning
#               it, then calling itself recursively to deal with nested structures.
#
#               See m// under 'perldoc perlop' for details on \G and /c
#
# Usage       : my $struct = &_structThaw_perl_safely($perlcode);
# ------------------------------------------------------------------------

sub _structThaw_perl_safely {
  my $perlcode = shift;
  my $lastPosition = shift;
  my $struct;

  # set match start position (passed when function calls itself recursively);
  if ($lastPosition) { pos($perlcode) = $lastPosition; }

  # skip leading whitespace
  $perlcode =~ /\G\s+/gcs;

  ### no code passed
  if (not defined $perlcode) {
    $struct = undef;
  }

  # undefined (string 'undef' in perl code)
  elsif ($perlcode =~ /\Gundef/gcsi) {
    $struct = undef;
  }

  # single-quoted strings
  elsif ($perlcode =~ /\G'/gcsi) {
    my $string = '';
    while (1) {
      if    ($perlcode =~ /\G([^'\\]+)/gcsi) { $string .= $1; }    # ' and \ need special handling
      elsif ($perlcode =~ /\G(\\\\)/gcsi)    { $string .= '\\'; }  # '\\' is a valid string
      elsif ($perlcode =~ /\G(\\')/gcsi)     { $string .= "'"; }   # '\'' is a valid string
      elsif ($perlcode =~ /\G'/gcsi)         { last; }
      else { die "unrecognized chars in string: '$perlcode' "; }
    }
    $struct = $string;
  }

  # scalar refs
  elsif ($perlcode =~ /\G\\/gcsi) {
    my($value, $newPosition) = &_structThaw_perl_safely($perlcode, pos($perlcode));
    pos($perlcode)           = $newPosition;
    $struct = \$value;
  }

  # array refs
  elsif ($perlcode =~ /\G\[/gcsi) {   # match til end of array or end of code
    my @array;
    while ($perlcode !~ /\G\s*]/gcsi && $perlcode !~ /\G\z/gcsi) {

      # load next value
      my($value, $newPosition) = &_structThaw_perl_safely($perlcode, pos($perlcode));
      pos($perlcode)           = $newPosition;

      # skip over comma (if there is one)
      $perlcode =~ /\G\s*,\s*/gcsi;

      # add value to array
      push @array, $value;
    }
    $struct = \@array;
  }

  # hash refs
  elsif ($perlcode =~ /\G\{/gcsi) {
    my %hash;
    while ($perlcode !~ /\G\s*}/gcsi && $perlcode !~ /\G\z/gcsi) {  # match til end of hash or end of code

      # get key name
      my($keyName, $keyValue, $position);
      ($keyName, $position) = &_structThaw_perl_safely($perlcode, pos($perlcode));
      pos($perlcode) = $position;

      # skip over => or ,
      $perlcode =~ /\G\s*(,|=>)\s*/gcsi;

      # get key value
      ($keyValue, $position) = &_structThaw_perl_safely($perlcode, pos($perlcode));
      pos($perlcode) = $position;

      # skip over comma (if there is one)
      $perlcode =~ /\G\s*,\s*/gcsi;

      # add name/value to hash
      $hash{$keyName} = $keyValue;
    }
    $struct = \%hash;
  }

  # make sure we reached end of code (only check on original function call, not recursive calls)
  my $isRecursivelyCalled = defined $lastPosition;
  my $parsedToEndOfCode   = length $perlcode == pos $perlcode;
  if (!$isRecursivelyCalled && !$parsedToEndOfCode) {
    my $remainingCode = $1 if $perlcode =~ /\G(.+)/gcs;
    die "couldn't parse perl code starting at: '$remainingCode'\n";
  }

  # return structure (and last position)
  $lastPosition = pos($perlcode);
  return wantarray ? ($struct, $lastPosition) : $struct;
}

# ----------------------------------------------------------------------------
# Function    : _quoteString
# Description :
# Usage       :
# ----------------------------------------------------------------------------

sub _quoteString {
  my $str = shift;
  $str =~ s/([\\\'])/\\$1/g;
  return "'$str'";
};

# ----------------------------------------------------------------------------
# end of file
1;

