package Data::Stringer;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw(uneval);

our $VERSION = '0.01';

require overload;

my %stab;

## $stab{'@x0x123456'} = \@thevalue
## $stab{'%x0x123456'} = \%thevalue
## $stab{'$x0x123456'} = [\$thevalue]
## $stab{'$x0x123456'} = [\$thevalue, $aggregate, $index] # for elements

BEGIN {

  my @queue;

  sub uneval {
    %stab = @queue = ();
    my $label = pass_1_item(\@_);       # prime the pump
    pass_1_item(shift @queue) while @queue; # drain the pump
    return pass_2($label);                # dump the result
  }

  sub pass_1_item {
    my $ref = shift;

    my $label = ref_to_label($ref);
    return $label if $stab{$label}; # already seen

    if ($label =~ /^\$/) {      # scalar
      $stab{$label}[0] = $ref;
      push @queue, $$ref if ref $$ref;
    } elsif ($label =~ /^\@/) { # array
      $stab{$label} = $ref;
      for my $index (0..$#$ref) {
        for ($ref->[$index]) {  # carefully creating alias, not copy
          my $thislabel = ref_to_label(\$_);
          $stab{$thislabel} = [\$_, $label, $index];
          push @queue, $_ if ref $_;
        }
      }
    } elsif ($label =~ /^%/) {  # hash
      $stab{$label} = $ref;
      for my $key (keys %$ref) {
        for ($ref->{$key}) {    # carefully creating alias, not copy
          my $thislabel = ref_to_label(\$_);
          $stab{$thislabel} = [\$_, $label, $key];
          push @queue, $_ if ref $_;
        }
      }
    } else {
      die "Cannot process $label yet";
    }

    return $label;
  }
}

BEGIN {

  my @deferred;

  sub pass_2 {
    my $result_label = shift;

    @deferred = ();
    return join("",
                pass_2_declarations(),
                pass_2_initializations(),
                map("$_\n", @deferred),
                pass_2_blessings(),
                "$result_label;\n",
               );
  }

  sub pass_2_value {
    my $value = shift;
    my $set_place = shift;
    my $set_index = shift;

    if (ref $value) {
      my $label = ref_to_label($value);
      if ($label =~ /^\$/) { # it is a scalar, so it might be an element
        (my ($value, $place, $index) = @{$stab{$label}}) >= 1 or die;
        if ($place) {
          if ($place =~ /^[@%]/) {
            push(@deferred,
                 element_of($set_place, $set_index) . " = \\" .
                 element_of($place, $index) . ";");
            return "00";        # placeholder for a deferred action
          } else {
            die "dunno place $place";
          }
        } else {
          return "\\$label";    # no place in particular
        }
      } else {
        return "\\$label";
      }
    } else {
      return quote_scalar($value);
    }
  }

}

sub pass_2_declarations {
  return join("",
              "my (",
              join(", ",
                   grep {
                     /^[\@%]/ or /^\$/ and not $stab{$_}[1]
                   } keys %stab),
              ");\n");
}

sub pass_2_initializations {
  return join("",
              map(pass_2_initialization($_, $stab{$_}),
                  sort keys %stab),
             );
}

sub pass_2_blessings {
  return join("",
              map(pass_2_blessing($_, $stab{$_}),
                  sort keys %stab),
             );
}

sub pass_2_initialization {
  my $label = shift;
  my $value = shift;

  if ($label =~ /^\$/) {        # scalar
    if (@$value > 1) {          # it's an element:
      return "";
    } else {
      return "$label = ".pass_2_value(${$value->[0]}).";\n";
    }
  } elsif ($label =~ /^\@/) {   # array
    return "$label = (".join(", ",
                             map {
                               pass_2_value($value->[$_], $label, $_);
                             } 0..$#$value,
                            ).");\n";
  } elsif ($label =~ /^%/) {    # hash
    return "$label = (".join(", ",
                             map {
                               pass_2_value($_) .
                                 " => " .
                                   pass_2_value($value->{$_}, $label, $_);
                             } keys %$value,
                            ).");\n";
  } else {
    die "Cannot process $label yet";
  }

}


sub pass_2_blessing {
  my $label = shift;
  my $value = shift;

  ## get to the proper location of an element for scalars
  if ($label =~ /^\$/) {
    $label = element_of($value->[1], $value->[2]) if @$value > 1;
    $value = $value->[0];
  }
  my ($package) = overload::StrVal($value) =~ /^(.*)=/;
  if (defined $package) {       # it's blessed
    return "bless \\$label, ".quote_scalar($package), ";\n";
  } else {
    return "";
  }
}

sub element_of {
  my $label = shift;
  my $index = shift;
  if ($label =~ s/^\@/\$/) {
    return "$label\[".quote_scalar($index)."\]";
  } elsif ($label =~ s/^%/\$/) {
    return "$label\{".quote_scalar($index)."\}";
  } else {
    die "Cannot take element_of($label, $index)";
  }
}

sub ref_to_label {
  my $ref = shift;

  ## eventually do something with $realpack
  my ($realpack, $realtype, $id) =
    (overload::StrVal($ref) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/) or die;
  s/^0x/X/ or s/^/X/ for $id;
  if ($realtype eq "SCALAR" or $realtype eq "REF") {
    return "\$$id";
  } elsif ($realtype eq "ARRAY") {
    return "\@$id";
  } elsif ($realtype eq "HASH") {
    return "%$id";
  } else {
    die "dunno $ref => $realpack $realtype $id";
  }
}

sub quote_scalar {
  local $_ = shift;
  if (!defined($_)) {
    return "undef";
  }
  {
    no warnings;
    if ($_ + 0 eq $_) {         # safe as a number...
      return $_;
    }
    if ("$_" == $_) {           # safe as a string...
      s/([\\\'])/\\$1/g;
      return '\'' . $_ .  '\'';
    }
  }
  die "$_ is not safe as either a number or a string";
}

1;