samples/hash2array.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Fatal qw/open/;
   7 use Text::Balanced qw/extract_bracketed/;
   8
   9 open my $hash_t,  '<', 't/20-hash.t';
  10 open my $array_t, '>', 't/21-array.t';
  11
  12 sub num { ord($_[0]) - ord('a') }
  13
  14 sub hash2array {
  15  my ($h) = @_;
  16  return $h unless $h and ref $h eq 'HASH';
  17  my @array;
  18  for (keys %$h) {
  19   $array[num($_)] = hash2array($h->{$_});
  20  }
  21  return \@array;
  22 }
  23
  24 sub dump_array {
  25  my ($a) = @_;
  26  return 'undef' unless defined $a;
  27  return $a      unless ref $a;
  28  die "Invalid argument" unless ref $a eq 'ARRAY';
  29  return '[ ' . join(', ', map dump_array($_), @$a) . ' ]';
  30 }
  31
  32 sub extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
  33
  34 my $in_data;
  35 while (<$hash_t>) {
  36  if (/^__DATA__$/) {
  37   $in_data = 1;
  38   print $array_t $_;
  39  } elsif (!$in_data) {
  40   s{s/\^\$/%/}{s/^\$/@/};
  41   print $array_t $_;
  42  } else {
  43   s!->{([a-z])}!'->[' . num($1) . ']'!eg;
  44   my $buf;
  45   my $suffix = $_;
  46   my ($bracket, $prefix);
  47   while (do { ($bracket, $suffix, $prefix) = extract($suffix); $bracket }) {
  48    $buf .= $prefix . dump_array(hash2array(eval $bracket));
  49   }
  50   $buf .= $suffix;
  51   $buf =~ s/\s+/ /g;
  52   print $array_t "$buf\n";
  53  }
  54 }