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