# Copyright © 2007 Rob Vossen http://puff.uvt.nl/
#
# Tremble is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License, as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.  This program is distributed WITHOUT ANY WARRANTY..  You should have
# received a copy of the GNU General Public License along with draai.  If not,
# see <http://www.gnu.org/licenses/>.

package Clone;       #transparent

use strict;
use Symbol; 

sub fromplaintext
{
  my $text       = shift;

  my ($top_element_key,$type2token) = eval($text);

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^V:/)
    {
      $type2token->{$type}=$type2token->{$type};
    }
  }

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^(S:|R:)/)
    {
      $type2token->{$type}=\$type2token->{$type2token->{$type}};
    }
    elsif ($type =~ /^G:/)
    {
      my $glob  = Symbol::gensym;
      ${*$glob} = $type2token->{$type2token->{$type}};
      $type2token->{$type}=$glob;
    }
  }

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^A:/)
    {
      foreach my $elt (@{$type2token->{$type}})
      {
        $elt=$type2token->{$elt};
      }
    }
    elsif ($type =~ /^H:/)
    {
      foreach my $key (keys %{$type2token->{$type}})
      {
        my $value=$type2token->{$type}->{$key};
	delete $type2token->{$type}->{$key};
	$type2token->{$type}->{$type2token->{$key}}=$type2token->{$value};
      }
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      my $package=$1;

      if (ref($type2token->{$type}) eq 'HASH')
      { 
        bless $type2token->{$type},$package;
        foreach my $key (keys %{$type2token->{$type}})
        {
          my $value=$type2token->{$type}->{$key};
	  delete $type2token->{$type}->{$key};
          $type2token->{$type}->{$type2token->{$key}}=$type2token->{$value};
        }
      }
      elsif (ref($type2token->{$type}) eq 'ARRAY')
      {
        bless $type2token->{$type},$package;
        foreach my $elt (@{$type2token->{$type}})
        {  
          $elt=$type2token->{$elt};
        }
      }
    }
  }
  return($type2token->{$top_element_key}->{'C'.'lone'});
}

sub linear
{
  my $token      = shift;
  my $token2type = shift;
  my $type2token = shift;
  my $typenr     = shift;

  my $type       = ref $token;

  if ($type =~ /^(CODE|IO::Handle)$/)
  {
    warn "type: $type is illegal, and cannot be copied from text";
    return();
  }

  unless ($type)
  {
    unless (defined($token))
    {
      $type = $token = 'UNDEF';
    }
    else
    {
      $type = 'VALUE';
    }
  }

  unless (exists($token2type->{$token}))
  {
    if ($type =~ /^(ARRAY|HASH|REF|SCALAR|VALUE|LVALUE|GLOB|UNDEF)$/)
    {
      $type=substr($type,0,1);
    }
    else
    {
      $type= 'P:'.$type;
    }

    $typenr->{$type}++;
    $type.=':'.$typenr->{$type};

    $type2token->{$type}=$token;
    $token2type->{$token}=$type;

    if ($type =~ /^A:/)
    {
      foreach my $elt (@$token)
      {
        &linear($elt,$token2type,$type2token,$typenr);
      }
    }
    elsif ($type =~ /^H:/)
    {
      foreach my $elt (values %$token)
      {
        &linear($elt,$token2type,$type2token,$typenr);
      }
    }
    elsif ($type =~ /^(V:|U:|L:)/)
    {
    }
    elsif ($type =~ /^(S:|R:)/)
    {
      &linear($$token,$token2type,$type2token,$typenr);
    }
    elsif ($type =~ /^(G:)/)
    {
      &linear(${*$token},$token2type,$type2token,$typenr);
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      if ($token =~ /HASH/)
      {
        foreach my $elt (values %$token)
        {
          &linear($elt,$token2type,$type2token,$typenr);
        }
      }
      elsif ($token =~ /ARRAY/)
      {
        foreach my $elt (@$token)
        {
          &linear($elt,$token2type,$type2token,$typenr);
        }
      }
      else
      {
        &linear($token,$token2type,$type2token,$typenr);       
      }
    }
  }
}

sub copy
{
  my $self      = shift;
  my $thing     = shift;
  my $mem       = {};
  my $refs      = {};
  my $keys      = {};
  my $intersect = {};

  &refkeys($thing,$keys,$refs);

  foreach my $key (keys %$refs)
  {
    $intersect->{$key}=1 if (exists($keys->{$key}));
  }

  my $copy = &u_copy($thing,$mem);
  &thorelli($copy,$intersect,$mem);

  return($copy);
}

sub refkeys
{
  my $thing     = shift;
  my $keys      = shift;
  my $refs      = shift;

  my $type   = ref $thing;


  if ($type  && $thing !~ /SCALAR|CODE|LVALUE|GLOB|IO::Handle/)
  {
    no warnings 'uninitialized';
    $refs->{$thing}=1;

    if ($type =~ /REF/)
    {
      &refkeys($$thing,$keys,$refs) unless $refs->{$$thing};
    }
    elsif ($thing =~ /ARRAY/)
    {
      foreach my $elt (@$thing)
      {
        &refkeys($elt,$keys,$refs) unless $refs->{$elt};
      }
    }
    else
    {
      foreach my $key (keys %$thing)
      {
        $keys->{$key}=1;
        &refkeys($thing->{$key},$keys,$refs) unless $refs->{$thing->{$key}};
      }
    }
  }
}

sub unhexbytes
{
  pack sprintf("H%d",length($_[0])),$_[0];
}

sub plaintext
{
  my $type2token = shift;
  my $text = '{';

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^A/)
    {
      $text.= "\n'$type'=>[";

      foreach my $elt (@{$type2token->{$type}})
      {
        if (defined($elt))
        {
	  $text .= "'$elt',";
        }
        else
        {
          $text .= "'',";
        }
      }
      $text =~ s/,$//;
      $text.="],";
    }
    elsif ($type =~ /^H/)
    {
      $text.= "\n'$type'=>{";

      no warnings 'uninitialized';
      foreach my $key (keys %{$type2token->{$type}})
      {
	$text .= "\n'$key'=>'$type2token->{$type}->{$key}',";
      }
      $text =~ s/,$//;
      $text.='},';
    }
    elsif ($type =~ /^V/)
    {
      $text.= "\n'$type'=>'".$type2token->{$type}."',";
    }
    elsif ($type =~ /^(S|R|G)/)
    {
      $text.= "\n'$type'=>'$type2token->{$type}',";
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      if ($type2token->{$type} =~ /HASH/)
      {
        $text.="\n'$type'=>{";

        foreach my $key (keys %{$type2token->{$type}})
        {
	  $text .= "\n'$key'=>'$type2token->{$type}->{$key}',";
        }

        $text =~ s/,$//;
        $text.='},';
      }
      else
      {
        $text.= "\n'$type'=>[";

        foreach my $elt (@{$type2token->{$type}})
        {
          if (defined($elt))
          {
	    $text .= "'$elt',";
          }
          else
          {
            $text .= "'',";
          }
        }

        $text =~ s/,$//;
        $text.="],";
      }
    }
  }

  $text =~ s/,$/}/;
  return($text);
}

sub ar_copy
{
  my $type;
  my $object = {};
  my $array  = [];
  my $mem    = shift;

  foreach my $elt (@_)
  {
    $type = ref $elt;

    unless ($type && ($type !~ /LVALUE/))
    {
      push (@$array,$elt);
    }
    else
    {
      if ($elt =~ /ARRAY/)
      {
        unless (defined($mem->{$elt}))
        {
	  $mem->{$elt} = [];
          bless $mem->{$elt}, $type unless ($type =~ /ARRAY/);
          @{$mem->{$elt}}=&ar_copy($mem,@$elt);
        }
      }
      elsif ($type =~ /HASH/)
      {
        unless (defined($mem->{$elt}))
        {
	  $mem->{$elt} = {};
          %{$mem->{$elt}}=&ha_copy($mem,$elt);
        }
      }
      elsif ($type =~ /SCALAR|REF/)
      {

        unless (defined($mem->{$elt}))
        {
	  $mem->{$elt}='';
          $mem->{$elt}=&sr_copy($mem,$$elt);
        }

      }
      elsif ($type =~ /CODE/)
      {
        push (@$array,$elt);
      }
      elsif ($type =~ /GLOB/)
      {
        $mem->{$elt} = Symbol::gensym;
        ${*{$mem->{$elt}}} = ${*{$elt}};
      }
      else
      {
        unless (defined($mem->{$elt}))
        {
	  $mem->{$elt} = {};
          bless $mem->{$elt}, $type;
          %{$mem->{$elt}} = &ha_copy($mem,$elt);
        }
      }
      push (@$array,$mem->{$elt});
    }
  }

  return(@$array);
}

sub clone
{
  my $self      = shift;
  my $mem       = {};
  my $refs      = {};
  my $keys      = {};
  my $intersect = {};
  my $thorelli  = {};

  &refkeys($self,$keys,$refs);

  foreach my $key (keys %$refs)
  {
    $intersect->{$key}=1 if (exists($keys->{$key}));
  }

  my $copy = &u_copy($self,$mem);

  &thorelli($copy,$intersect,$mem,$thorelli);

  return($copy);
}

sub text
{
  my $type2token = shift;
  my $text = '{';

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^A/)
    {
      $text.= "\n'$type'=>[";

      foreach my $elt (@{$type2token->{$type}})
      {
        if (defined($elt))
        {
	  $text .= "'$elt',";
        }
        else
        {
          $text .= "'',";
        }
      }
      $text =~ s/,$//;
      $text.="],";
    }
    elsif ($type =~ /^H/)
    {
      $text.= "\n'$type'=>{";

      no warnings 'uninitialized';
      foreach my $key (keys %{$type2token->{$type}})
      {
	$text .= "\n'$key'=>'$type2token->{$type}->{$key}',";
      }
      $text =~ s/,$//;
      $text.='},';
    }
    elsif ($type =~ /^V/)
    {
      $text.= "\n'$type'=>'".&hexbytes($type2token->{$type})."',";
    }
    elsif ($type =~ /^(S|R|G)/)
    {
      $text.= "\n'$type'=>'$type2token->{$type}',";
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      if ($type2token->{$type} =~ /HASH/)
      {
        $text.="\n'$type'=>{";

        foreach my $key (keys %{$type2token->{$type}})
        {
	  $text .= "\n'$key'=>'$type2token->{$type}->{$key}',";
        }

        $text =~ s/,$//;
        $text.='},';
      }
      elsif ($type2token->{$type} =~ /ARRAY/)
      {
        $text.= "\n'$type'=>[";

        foreach my $elt (@{$type2token->{$type}})
        {
          if (defined($elt))
          {
	    $text .= "'$elt',";
          }
          else
          {
            $text .= "'',";
          }
        }

        $text =~ s/,$//;
        $text.="],";
      }
      else
      {
        $text.= "\n'$type'=>'".&hexbytes($type2token->{$type})."',";
      }
    }
  }

  $text =~ s/,$/}/;
  return($text);
}

sub new
{
  my $pkg  = shift;
  my $self = {};
  bless $self,$pkg;
  return($self);
}

sub fromtext
{
  my $text       = &checktext(shift);
  return(undef) unless ($text);

  my ($top_element_key,$type2token) = eval($text);

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^V:/)
    {
      $type2token->{$type}=&unhexbytes($type2token->{$type});
    }
  }

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^(S:|R:)/)
    {
      $type2token->{$type}=\$type2token->{$type2token->{$type}};
    }
    elsif ($type =~ /^G:/)
    {
      my $glob  = Symbol::gensym;
      ${*$glob} = $type2token->{$type2token->{$type}};
      $type2token->{$type}=$glob;
    }
  }

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^A:/)
    {
      foreach my $elt (@{$type2token->{$type}})
      {
        $elt=$type2token->{$elt};
      }
    }
    elsif ($type =~ /^H:/)
    {
      foreach my $key (keys %{$type2token->{$type}})
      {
        my $value=$type2token->{$type}->{$key};
	delete $type2token->{$type}->{$key};
	$type2token->{$type}->{$type2token->{$key}}=$type2token->{$value};
      }
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      my $package=$1;

      if (ref($type2token->{$type}) eq 'HASH')
      { 
        bless $type2token->{$type},$package;
        foreach my $key (keys %{$type2token->{$type}})
        {
          my $value=$type2token->{$type}->{$key};
	  delete $type2token->{$type}->{$key};
          $type2token->{$type}->{$type2token->{$key}}=$type2token->{$value};
        }
      }
      elsif (ref($type2token->{$type}) eq 'ARRAY')
      {
        bless $type2token->{$type},$package;
        foreach my $elt (@{$type2token->{$type}})
        {  
          $elt=$type2token->{$elt};
        }
      }
    }
  }
  return($type2token->{$top_element_key}->{'C'.'lone'});
}

sub copy2text
{
  my $token      = {'C'.'lone' => &clone(shift)};
  my $token2type = {};
  my $type2token = {};
  my $typenr     = {};

  &linear($token,$token2type,$type2token,$typenr);

  return('('.&outnumber($token,$token2type,$type2token,$typenr).",\n".&text($type2token).")\n");
}

sub plain2text
{
  my $token      = {'C'.'lone' => &clone(shift)};
  my $token2type = {};
  my $type2token = {};
  my $typenr     = {};

  &linear($token,$token2type,$type2token,$typenr);

  return('('.&outnumber($token,$token2type,$type2token,$typenr).",\n".&plaintext($type2token).")\n");
}

sub thorelli
{
  my $copy      = shift;
  my $intersect = shift;
  my $mem       = shift;
  my $thorelli  = shift;

  my $type   = ref $copy;

  no warnings 'uninitialized';
  $thorelli->{$copy}=1;

  if ($type  && $type !~ /SCALAR|CODE|LVALUE|IO::Handle/)
  {
    if ($type =~ /REF/)
    {
      &thorelli($$copy,$intersect,$mem,$thorelli) unless ($thorelli->{$$copy});
    }
    elsif ($copy =~ /ARRAY/)
    {
      foreach my $elt (@$copy)
      {
        &thorelli($elt,$intersect,$mem,$thorelli) unless ($thorelli->{$elt});
      }
    }
    elsif ($type =~ /GLOB/)
    {
      &thorelli(${*$copy},$intersect,$mem,$thorelli) unless ($thorelli->{${*$copy}});
    }
    else
    {
      foreach my $key (keys %$copy)
      {
        if (defined($intersect->{$key}))
        {
          $copy->{$mem->{$key}}=$copy->{$key};
          &thorelli($copy->{$mem->{$key}},$intersect,$mem,$thorelli) unless ($thorelli->{$copy->{$key}});
          delete $copy->{$key};
        }
        else
        {
          &thorelli($copy->{$key},$intersect,$mem,$thorelli) unless ($thorelli->{$copy->{$key}});
        }
      }
    }
  }
}

sub hexbytes
{
  unpack sprintf("H%d",2*length($_[0])),$_[0];
}

sub ha_copy
{
  my $type;
  my $array = {};
  my $mem   = shift;
  my $hash  = shift;

  foreach my $key (keys %$hash)
  {
    $type = ref $hash->{$key};

    unless ($type && ($type !~ /LVALUE/))
    {
      $array->{$key}=$hash->{$key};
    }
    else
    {
      if ($hash->{$key} =~ /ARRAY/)
      {
        unless (defined($mem->{$hash->{$key}}))
        {
	  $mem->{$hash->{$key}}= [];
          bless $mem->{$hash->{$key}}, $type unless ($type =~ /ARRAY/);
          @{$mem->{$hash->{$key}}}=&ar_copy($mem,@{$hash->{$key}})
        }
      }
      elsif ($type =~ /HASH/)
      {
       unless (defined($mem->{$hash->{$key}}))
        {
	  $mem->{$hash->{$key}}= {};
	  %{$mem->{$hash->{$key}}}=&ha_copy($mem,$hash->{$key});
        }

      }
      elsif ($type =~ /SCALAR|REF/)
      {
        unless (defined($mem->{$hash->{$key}}))
	{
          $mem->{$hash->{$key}}='';
          $mem->{$hash->{$key}}=&sr_copy($mem,${$hash->{$key}});
        }
      }
      elsif ($type =~ /CODE/)
      {
        $mem->{$hash->{$key}}=$hash->{$key};
      }
      elsif ($type =~ /GLOB/)
      {
        $mem->{$hash->{$key}} = Symbol::gensym;
        ${*{$mem->{$hash->{$key}}}} = ${*{$hash->{$key}}};
      }
      else
      {
        if ($hash->{$key} =~ /HASH/)
        {
	  unless (defined($mem->{$hash->{$key}}))
          {
            $mem->{$hash->{$key}}={};
            bless $mem->{$hash->{$key}}, $type;
            %{$mem->{$hash->{$key}}}=&ha_copy($mem,$hash->{$key});
          }

        }

      }
      $array->{$key}=$mem->{$hash->{$key}};
    }
  }

  return(%$array);
}

sub u_copy
{
  my $object = {};
  my $elt    = shift;
  my $mem    = shift;

  my $type   = ref $elt;

  unless ($type && ($type !~ /LVALUE/))
  {
    return($elt);
  }
  else
  {
    if ($elt =~ /ARRAY/)
    {
      $mem->{$elt}=[];
      bless $mem->{$elt}, $type unless ($type =~ /ARRAY/);
      @{$mem->{$elt}}=&ar_copy($mem,@$elt);
    }
    elsif ($type =~ /HASH/)
    {
      $mem->{$elt}={};
      %{$mem->{$elt}}=&ha_copy($mem,$elt);
    }
    elsif ($type =~ /SCALAR|REF/)
    {
      $mem->{$elt}='';
      $mem->{$elt}=&sr_copy($mem,$$elt);
    }
    elsif ($type =~ /CODE/)
    {
      return($elt);
    }
    elsif ($type =~ /GLOB/)
    {
      $mem->{$elt} = Symbol::gensym;
      ${*{$mem->{$elt}}} = ${*{$elt}};
    }
    else
    {
      $mem->{$elt}={};
      bless $mem->{$elt}, $type;
      %{$mem->{$elt}} = &ha_copy($mem,$elt);
    }

    return($mem->{$elt});
  }
}

sub outnumber
{
  my $token      = shift;
  my $token2type = shift;
  my $type2token = shift;
  my $typenr     = shift;

  foreach my $type (keys %$type2token)
  {
    if ($type =~ /^A/)
    {
      foreach my $elt (@{$type2token->{$type}})
      {
        $elt=$token2type->{$elt} if defined($elt);
      }
    }
    elsif ($type =~ /^H/)
    {

      foreach my $key (keys %{$type2token->{$type}})
      {
        unless (exists($token2type->{$key}))
        {
          $typenr->{'V'}++;
          $token2type->{$key}='V:'.$typenr->{'V'};
          $type2token->{'V:'.$typenr->{'V'}}=$key;
        }
        my $value=$type2token->{$type}->{$key};

	delete $type2token->{$type}->{$key};

        no warnings 'uninitialized';
	$type2token->{$type}->{$token2type->{$key}}=$token2type->{$value};
      }

    }
    elsif ($type =~ /^V/)
    {
    }
    elsif ($type =~ /^(S|R)/)
    {
      $type2token->{$type}=$token2type->{${$type2token->{$type}}};
    }
    elsif ($type =~ /^G/)
    {
      $type2token->{$type}=$token2type->{${*{$type2token->{$type}}}};      
    }
    elsif ($type=~/^P:([^:]+):/)
    {
      if ($type2token->{$type} =~ /HASH/)
      {
        foreach my $key (keys %{$type2token->{$type}})
        {
          unless (exists($token2type->{$key}))
          {
            $typenr->{'V'}++;
            $token2type->{$key}='V:'.$typenr->{'V'};
            $type2token->{'V:'.$typenr->{'V'}}=$key;
          }
          my $value=$type2token->{$type}->{$key};

	  delete $type2token->{$type}->{$key};
	  $type2token->{$type}->{$token2type->{$key}}=$token2type->{$value};
        }
      }
      elsif ($type2token->{$type} =~ /ARRAY/)
      {
        foreach my $elt (@{$type2token->{$type}})
        {
          $elt=$token2type->{$elt} if defined($elt);
        }
      }
      else
      {
      }
    }
  }

  my $type = ref($token);
  $type = 'VALUE' unless $type;

  if ($type =~ /^(ARRAY|HASH|REF|SCALAR|VALUE)$/)
  {
    $type=substr($type,0,1);
  }
  else
  {
    $type= 'P:'.$type;
  }

  return("'$type:1'");
}

sub sr_copy
{
  my $mem  = shift;
  my $sr   = shift;
  my $object;

  return (\$sr) unless (ref $sr);
  $mem->{$sr} = &u_copy($sr,$mem)
  unless (defined($mem->{$sr}));

  $object = $mem->{$sr};

  return(\$object);
}

sub checktext
{
  my $text=shift;
  my $t=$text;

  $t =~ s/\n//gs;
  $t =~ s/'(A|H|P:[\w:]+|R|S|V|L):\d+'//g;
  $t =~ s/'[0-9a-f]*'//g;
  $t =~ s/\[,*\]//g;
  $t =~ s/\{(=>,?)*\}//g;
  $t =~ s/=>(,=>)*//g;
  $t =~ s/\(,\s*(\{\})?\)\s*//s;

  if ($t)
  {
    warn "Datafile is corrupted: $text => $t\n";
    return(undef);
  }
  return($text);
}

sub convert2text
{
  my $token      = {'C'.'lone' => shift};
  my $token2type = {};
  my $type2token = {};
  my $typenr     = {};

  &linear($token,$token2type,$type2token,$typenr);

  $token='('.&outnumber($token,$token2type,$type2token,$typenr).",\n".&text($type2token).")\n";

  return($token)
}
'end Clone';       #transparent