]> git.vpit.fr Git - perl/modules/autovivification.git/blob - samples/hash2array.pl
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/autovivification.git] / 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 }