use strict;
use warnings;

package Data::Morph;
use Scalar::Util;
use Carp;

my $CLASS = __PACKAGE__;

use base 'Exporter';
our @EXPORT_OK = qw(makeRule);

my $MSG_BAD_SLICE
  = "Parameter list <%s> contains a bad array index: <%s>";


#==================================================================
# FUNCTIONS, I
#==================================================================

sub unblessCopy {
  my $xData = shift;

  return $xData unless Scalar::Util::blessed($xData);
  my $sDataRef = Scalar::Util::reftype($xData);

  if ($sDataRef eq 'ARRAY') {
    return [ @$xData ];
  } elsif ($sDataRef eq 'HASH') {
    return { %$xData };
  } elsif ($sDataRef eq 'SCALAR') {
    my $sTmp = $$xData;
    return \$sTmp;
  } elsif ($sDataRef eq 'REF') {
    my $sTmp = $$xData;
    return \$sTmp;
  } elsif ($sDataRef eq 'CODE') {
    # borrowed from Acme::Curse (author Moritz Lenz)
    return sub { goto &$xData };
  } else {
    return $xData;
  }
}

#==================================================================
# HELPER CLASSES
#==================================================================

my $RULE_CLASS = 'Data::Morph::Rule';
{
  package Data::Morph::Rule;

  sub new {
    my ($sClass, $xLoad, $xDump, $xPrep
        , $sDefaultParamName) = @_;

    if (! defined($xDump)) {
      $xDump = \&Data::Morph::unblessCopy;
    } elsif ($xDump eq '') {
      $xDump = undef;
    }

    my $hRule = { load => $xLoad
                , dump => $xDump
                , prep => $xPrep
                , paramName => $sDefaultParamName};
    return bless($hRule, $sClass);
  }

  sub getDefaultParamName { return shift->{paramName} }
  sub getDump     { return shift->{dump} }
  sub getLoad     { return shift->{load} }
  sub getPrepRule { return shift->{prep} }

  sub dump {
    my ($self, $xData, $hReplace, $aPath) = @_;
    my $xDump = $self->getDump();
    return $xData unless defined($xDump);

    return &$xDump($xData, 0, $hReplace, $aPath)
      if (ref($xDump) eq 'CODE');

    #dump is the name of a method
    #print STDERR "Data::Morph::Rule::dump: <$xDump>\n";
    my $sEval = "\$xData->$xDump(\$hReplace, \$aPath)";
    my $sRetVal = eval($sEval);
    #print STDERR "eval<$sEval> retval=<" 
    #  . (defined($sRetVal) ? $sRetVal : 'undef') . ">\n";
    return scalar eval($sEval);
  }

  sub load {
    my ($self, $xData, $hReplace, $aPath) = @_;
    my $xLoad = $self->getLoad();
    return $xData unless defined($xLoad);

    return &$xLoad($xData, 1, $hReplace, $aPath)
      if (ref($xLoad) eq 'CODE');

    my $xParams = $xData;
    if (ref($xData) eq '') {
      my $sDefault = $self->getDefaultParamName();
      $xParams = { $sDefault => $xData } if defined($sDefault);
    }
    return Data::Morph::_applyStringRule($xParams, $xLoad, 1);
  }
}

#==================================================================
# FUNCTIONS, II
#==================================================================

sub makeRule {
  return $RULE_CLASS->new(@_);
}

#==================================================================
# CLASS METHODS
#==================================================================

sub newCustom {
  my ($sClass, $crDump, $crLoad) = @_;
  my $self = { loader => $crLoad, dumper => $crDump };
  return bless($self, $sClass);
}

sub newSerializer {
  my $sClass = shift @_;
  eval("require Data::Serializer; return 1")
    or do { return undef; };

  my $oSerializer = Data::Serializer->new(@_);
  my $crDump = sub {
    my $xData = shift;
    return $oSerializer->serialize($xData);
  };
  my $crLoad = sub {
    my $xData = shift;
    return $oSerializer->deserialize($xData);
  };
  return $sClass->newCustom($crDump, $crLoad);
}

sub new {
  my ($sClass, $sSerializer, $sDump, $sLoad) = @_;
  $sDump = 'Dump' unless defined($sDump);
  $sLoad = 'Load' unless defined($sLoad);

  #print STDERR "<$sDump> <$sLoad>\n";

  my ($crLoad, $crDump);
  if (defined($sSerializer)) {
    # don't import Dump - otherwise we would
    # redefine Data::Morph::dump and
    # set it to Data::Dumper::Dump
    eval("require $sSerializer;"
         . "\$crDump=\\&${sSerializer}::$sDump if \$sDump;"
         . "\$crLoad=\\&${sSerializer}::$sLoad if \$sLoad;"
         . "return 1;") or do { return undef; };
  }
  #print STDERR "<$crLoad> <$crDump>\n";
  return $sClass->newCustom($crDump, $crLoad);
}

#==================================================================
# PUBLIC OBJECT METHODS
#==================================================================

#synonyms

BEGIN {
  *freezeInner      = *dumpInner;
  *serializeInner   = *dumpInner;
  *freezeOuter      = *dumpOuter;
  *serializeOuter   = *dumpOuter;
  *freeze           = *dump;
  *serialize        = *dump;

  *thawInner        = *loadInner;
  *deserializeInner = *loadInner;
  *thawOuter        = *loadOuter;
  *deserializeOuter = *loadOuter;
  *thaw             = *load;
  *deserialize      = *load;
}

sub getDumper() {
  return shift->{dumper};
}

sub getLoader() {
  return shift->{loader};
}

# serialize, freeze

sub dump {
  my ($self, $xInner, $xRule) = @_;
  #print STDERR "dump: <$xInner>\n";
  return $self->dumpOuter($self->dumpInner($xInner, $xRule));
}

sub dumpInner {
  my ($self, $xInner, $xRule) = @_;
  #print STDERR "dumpInner: <$xInner>\n";

  my $hReplace = {};
  my $xDump = _applyRule($xInner, $xRule, 0, $hReplace, []);
  return _fixReferences($xDump, $hReplace, []);
}

sub dumpOuter {
  my ($self, $xOuter) = @_;
  my $crDump = $self->getDumper();
  #print STDERR "dumpOuter: <$xOuter> <$crDump>\n";
  return $crDump ? &$crDump($xOuter) : $xOuter;
}

# deserialize, thaw

sub load {
  my ($self, $sData, $xRule) = @_;
  return $self->loadInner($self->loadOuter($sData), $xRule);
}

sub loadInner {
  my ($self, $xOuter, $xRule) = @_;
  my $hReplace = {};
  my $xLoad = _applyRule($xOuter, $xRule, 1, $hReplace, []);
  return _fixReferences($xLoad, $hReplace, []);
}

sub loadOuter {
  my ($self, $sData) = @_;
  my $crLoad = $self->getLoader();
  return $crLoad ? &$crLoad($sData) : $sData;
}

#==================================================================
# PRIVATE OBJECT METHODS
#==================================================================

#==================================================================
# PRIVATE FUNCTIONS
#==================================================================

sub _applyArrayRule {
  my ($xData, $xRule, $bLoad, $hReplace, $aPath) = @_;

  #modify copy of array, not original array
  #but do so in a way that preserves references
  my $idData = Scalar::Util::refaddr($xData);
  my $aData = $hReplace->{$idData};
  unless (defined($aData)) {
    $hReplace->{$idData} = $aData = [ @$xData ];
  }
  #print STDERR "_applyArrayRule: <$xData> <$idData> <$aData>\n";

  my $iRuleCount = $#$xRule;
  for(my $i=0; $i<=$#$xData; $i++) {
    my $xValueRule = $i < $iRuleCount
      ? $xRule->[$i] : $xRule->[-1];
    $aData->[$i] = _applyRule($xData->[$i], $xValueRule, $bLoad
                              , $hReplace, $aPath);

  }
  #print STDERR "_applyArrayRule: <@$aData>\n";
  return $aData;
}

sub _applyHashRule {
  my ($xData, $xRule, $bLoad, $hReplace, $aPath) = @_;

  # scan to see if any keys apply to $xData
  my ($k,$v);
  my $bModified=0;
  while (($k,$v) = each(%$xData)) {
    next unless exists($xRule->{$k});
    $bModified=1;
    last;
  }
  return $xData unless $bModified; #internal cursor already reset
  while (each(%$xData)) {};        #reset internal cursor


  # copy data so that changes to hash key values don't affect the
  # original
  my $idData = Scalar::Util::refaddr($xData);
  my $hData = $hReplace->{$idData};
  unless (defined($hData)) {
    $hReplace->{$idData} = $hData = { %$xData };
  }
  #print STDERR "_applyHashRule: <$xData> <$idData> <$hData>\n";

  while (($k,$v) = each(%$xData)) {
    if (exists($xRule->{$k})) {
      my $xValueRule = $xRule->{$k};
      #print STDERR "_applyHashRule: <$k> <$bLoad>\n";

      #print STDERR "_applyHashRule: valueRule=<"
      #  . (defined($xValueRule) ? $xValueRule : 'undef')
      #  . ">\n";

      $hData->{$k} = _applyRule($v, $xValueRule, $bLoad
                                , $hReplace, $aPath);

      #print STDERR "_applyHashRule: data=<"
      #  . (defined($hData->{$k}) ? $hData->{$k} : 'undef')
      #  . ">\n";
    } else {
      $hData->{$k} = $v;
    }
  }
  return $hData;
}

sub _applyRule {
  my ($xData, $xRule, $bLoad, $hReplace, $aPath, $bNewRule) = @_;
  return $xData unless defined($xRule);

  #if we've replaced the rule for processing the data, then we
  #needn't worry about circles.

  if (!$bNewRule && ref($xData)) {
    #stop traversal at circularities
    foreach (@$aPath) { return $xData if ($xData eq $_); }
    $aPath = [ @$aPath, $xData ];
  }

  my $sRuleRef = ref($xRule);
  #print STDERR "_applyRule: <$sRuleRef>\n";
  if ($sRuleRef eq 'CODE') {
    #apply a function to load and unload the data
    return &$xRule($xData, $bLoad, $aPath, $hReplace);
  } elsif ($sRuleRef eq '') {
    #rule = bless/unbless data
    return _applyStringRule($xData, $xRule, $bLoad);

  } elsif ($sRuleRef eq 'ARRAY') {
    if (ref($xData) eq 'ARRAY') {
      return _applyArrayRule($xData, $xRule, $bLoad
                             , $hReplace, $aPath);
    }
  } elsif ($sRuleRef eq 'HASH') {
    if (ref($xData) eq 'HASH') {
      return _applyHashRule($xData, $xRule, $bLoad
                            , $hReplace, $aPath);
    }
  } elsif (Scalar::Util::blessed($xRule)) {
    #apply a custom rule after loading the data
    my $xValueRule = $xRule->getPrepRule();

    #print STDERR "_applyRule: load=<$bLoad> prepData=<"
    #    . (defined($xValueRule) ? $xValueRule : 'undef') . ">\n";
    #print STDERR "_applyRule: before <"
    #  . (defined($xData) ? "$xData|@{[%$xData]}" : 'undef') . ">\n";


    if ($bLoad) {
      if (defined($xValueRule)) {
        $xData = _applyRule($xData, $xValueRule, $bLoad
                            , $hReplace, $aPath, 1);
      }
      #print STDERR "_applyRule: after load <"
      #  . (defined($xData) ? "$xData|@{[%$xData]}" : 'undef')
      #  . ">\n";

      return $xRule->load($xData, $hReplace, $aPath);
    } else {
      $xData = $xRule->dump($xData, $hReplace, $aPath);
      #print STDERR "_applyRule: after dump <"
      #  . (defined($xData) ? $xData : 'undef') . ">\n";

      return defined($xValueRule)
        ? _applyRule($xData, $xValueRule, $bLoad
                     , $hReplace, $aPath)
        : $xData;
    }
  }
  return $xData;
}

sub _applyStringRule {
  my ($xData, $sRule, $bLoad) = @_;

  #print STDERR "_applyStringRule: <$bLoad> <$sRule>\n";

  if ($bLoad) {
    # remove whitespace so we don't have to fix parameter names
    # with leading or trailing whitespace
    my ($sClass, $sMethod, $sParams) = _splitStringRule($sRule);

    if ($sMethod) {
      my $aParams = _buildParams($sParams, $xData);
      #print STDERR "class=<$sClass> method=<$sMethod> "
      #  ."params=<@$aParams>\n";

      # if there is a bug in the evaluated code and the
      # bug occurs in array context, then () will be returned
      # rather than a scalar.  Since callers to this method
      # always expect a scalar result, we force the scalar
      # context using scalar - thanks PerlMonk [Anno]
      # for the suggestion.
      return scalar eval("$sClass->$sMethod(\@\$aParams)");
    }

    return $xData unless ref($xData);
    return bless($xData, $sClass);
  }
  return unblessCopy($xData);
}

sub _buildParams {
  my ($sParams, $xData) = @_;
  my $sDataRef = ref($xData);

  my @aParams;
  if (defined($sParams)) {
    my @aParamNames = split(/,/, $sParams);
    if ($sDataRef eq 'HASH') {
      foreach (@aParamNames) {
        #print STDERR "param=<$_>\n";
        push @aParams, $xData->{$_};
      }
    } elsif ($sDataRef eq 'ARRAY') {
      foreach my $sName (@aParamNames) {
        if ($sName =~ /^(\d+)\.\.$/) {
          $sName ="$1..$#$xData";
        } elsif ($sName !~ /^\d+(?:\.\.\d+)?$/) {
          #bad data - skip it
          carp(sprintf($MSG_BAD_SLICE, $sParams, $sName));
          next;
        }
        push @aParams, eval "\@\$xData[$sName]";
      }
    } else {
      push @aParams, $xData;
    }
  } else {
    push @aParams, $xData;
  }
  return \@aParams;
}

sub _fixReferences {
  my ($xData, $hReplace, $aPath) = @_;
  # note: it is very important that pure scalar data be
  # returned immediately.  Past versions had problems with
  # Storable because their data got stringified when it
  # was used as a hash key. This changed internal flags on
  # the data and caused both Storable and JSON to dump the
  # data as a string even though its internal memory representation
  # was as an integer.

  my $sRef = Scalar::Util::reftype($xData);
  return $xData unless $sRef;

  #stop traversal at circularities
  foreach (@$aPath) { return $xData if ($xData eq $_); }
  $aPath = [ @$aPath, $xData ];

  #check to see if the reference has already been replaced
  my $idData = Scalar::Util::refaddr($xData);
  my $xReplace = $hReplace->{$idData};
  return $xReplace if defined($xReplace);
  #print STDERR "_fixReferences: <$idData> <$xData>\n";

  if ($sRef eq 'HASH') {
    while (my ($k,$v) = each(%$xData)) {
      $xData->{$k} = _fixReferences($v,$hReplace,$aPath);
    }
  } elsif ($sRef eq 'ARRAY') {
    for(my $i=0; $i<=$#$xData; $i++) {
      $xData->[$i]= _fixReferences($xData->[$i], $hReplace, $aPath);
    }
  }
  return $xData;
}

sub _splitStringRule {
  my ($sRule) = @_;
  $sRule =~ s/\s//g;
  return ($sRule =~ /^((?:\w+::)*\w+)(?:->(\w+)(?:\(([^\)]*)\))?)?$/);
}


#==================================================================
# MODULE INITIALIZATION
#==================================================================

1;