samples/hash2array.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Fatal qw<open close>;
   7 use Text::Balanced qw<extract_bracketed>;
   8
   9 open my $hash_t,       '<', 't/20-hash.t';
  10 open my $array_t,      '>', 't/30-array.t';
  11 open my $array_fast_t, '>', 't/31-array-fast.t';
  12
  13 sub num {
  14  my ($char) = $_[0] =~ /['"]?([a-z])['"]?/;
  15  return ord($char) - ord('a')
  16 }
  17
  18 sub hash2array {
  19  my ($h) = @_;
  20  return $h unless $h and ref $h eq 'HASH';
  21  my @array;
  22  for (keys %$h) {
  23   $array[num($_)] = hash2array($h->{$_});
  24  }
  25  return \@array;
  26 }
  27
  28 sub dump_array {
  29  my ($a) = @_;
  30
  31  return 'undef' unless defined $a;
  32
  33  if (ref $a) {
  34   die "Invalid argument" unless ref $a eq 'ARRAY';
  35   return '[ ' . join(', ', map dump_array($_), @$a) . ' ]';
  36  } else {
  37   $a = "'\Q$a\E'" if $a !~ /^\s*\d/;
  38   return $a;
  39  }
  40 }
  41
  42 sub extract ($$) {
  43  extract_bracketed $_[0], $_[1],  qr/.*?(?<![\\@%])(?:\\\\)*(?=$_[1])/
  44 }
  45
  46 sub convert_testcase ($$) {
  47  local $_ = $_[0];
  48  my $fast = $_[1];
  49
  50  s!(\ba\b)?(\s*)HASH\b!($1 ? 'an': '') . "$2ARRAY"!eg;
  51  s{
  52   [\{\[]\s*(['"]?[a-z]['"]?(?:\s*,\s*['"]?[a-z]['"]?)*)\s*[\}\]]
  53  }{
  54   '[' . join(', ', map { my $n = num($_); $fast ? $n : "\$N[$n]" }
  55                     split /\s*,\s*/, $1) . ']'
  56  }gex;
  57  s!%(\{?)\$!\@$1\$!g;
  58
  59  my $buf;
  60  my $suffix = $_;
  61  my ($bracket, $prefix);
  62  while (do { ($bracket, $suffix, $prefix) = extract($suffix, '{'); $bracket }) {
  63   my $array = dump_array(hash2array(eval $bracket));
  64   $buf .= $prefix . $array;
  65  }
  66  $buf .= $suffix;
  67  $buf =~ s/\s+/ /g;
  68  $buf =~ s/\s+$//;
  69
  70  return "$buf\n";
  71 }
  72
  73 my $in_data;
  74 while (<$hash_t>) {
  75  if (/^__DATA__$/) {
  76   $in_data = 1;
  77   print $array_t      $_;
  78   print $array_fast_t $_;
  79  } elsif (!$in_data) {
  80   s{'%'}{'\@'};
  81   print $array_t      $_;
  82   print $array_fast_t $_;
  83  } else {
  84   print $array_t      convert_testcase($_, 0);
  85   print $array_fast_t convert_testcase($_, 1);
  86  }
  87 }
  88
  89 close $hash_t;
  90 close $array_t;
  91 close $array_fast_t;
  92
  93 open my $hash_kv_t,  '<', 't/22-hash-kv.t';
  94 open my $array_kv_t, '>', 't/32-array-kv.t';
  95
  96 $in_data = 0;
  97 while (<$hash_kv_t>) {
  98  if (/^__DATA__$/) {
  99   $in_data = 1;
 100  } elsif (!$in_data) {
 101   s{'%'}{'\@'};
 102   if (/\bplan\s*[\s\(]\s*tests\b/) {
 103    s/\s*;?\s*$//;
 104    s/^(\s*)//;
 105    $_ = qq($1if ("\$]" >= 5.011) { $_ } else { plan skip_all => 'perl 5.11 required for keys/values \@array' }\n);
 106   }
 107  } else {
 108   $_ = convert_testcase($_, 1);
 109  }
 110  print $array_kv_t $_;
 111 }