Create deep hash mapping in perl - perl

Below is my Code with the Hash
#!/usr/bin/perl
use warnings;
use JSON::PP; # Just 'use JSON;' on most systems
my %name = (
'sl' => {
'fsd' => {
'conf' => {
'ul' => '/sl/fsd/conf/ul',
'si' => '/sl/fsd/conf/si',
'ho1' => '/sl/fsd/conf/ho1'
}
}
},
're' => {
'fsd' => {
'cron' => {
'README' => '/re/fsd/cron/README'
},
'bin' => {
'db' => {
'smart.p_add_tag' => '/re/fsd/bin/db/smart.p_add_tag',
'smart.p_tag_partition' => '/re/fsd/bin/db/smart.p_tag_partition',
'smart.p_add_tag_type' => '/re/fsd/bin/db/smart.p_add_tag_type'
}
},
'doc' => {
'SMART' => '/re/fsd/doc/SMART',
'README' => '/re/fsd/doc/README'
},
'data' => {
'README' => '/re/fsd/data/README'
},
'conf' => {
'al1' => '/re/fsd/conf/al1',
'file' => '/re/fsd/conf/file',
'ho' => '/re/fsd/conf/ho',
'al3' => '/re/fsd/conf/al3',
'hst' => '/re/fsd/conf/hst',
'us' => '/re/fsd/conf/us',
'README' => '/re/fsd/conf/README',
'al2' => '/re/fsd/conf/al2'
}
}
}
);
(my $root) = keys %name;
my %nodes = ();
my %tree = ();
my #queue = ($root);
list_children(\%name, \#queue, \%nodes) while #queue;
my $tree = build_tree($root, \%nodes);
my $json = JSON::PP->new->pretty; # prettify for human consumption
print $json->encode($tree);
sub list_children {
my $adjac = shift;
my $queue = shift;
my $nodes = shift;
my $node = shift #$queue;
my #children = keys %{$adjac->{$node}};
#children = grep { ! exists $nodes->{$_}} #children;
$nodes->{$node} = \#children;
push #$queue, #children;
}
sub build_tree {
my $root = shift;
my $nodes = shift;
my #children;
for my $child (#{$nodes->{$root}}) {
push #children, build_tree($child, $nodes);
}
my %h = ('text' => $root,
'children' => \#children);
return \%h;
}
I'm trying to output JSONified hash, but it is only traversing upto two levels. whereas i need it to traverse all upto the last child node of each parent. Can someone please help to achieve this.
Below is current output
{
"text" : "sl",
"children" : [
{
"text" : "fsd",
"children" : []
}
]
}

Normally, transforming the hash, and then json-ing is not the most efficient idea, because you're going to make one traversal to transform the hash and JSON's going to make one to json-ify it, and JSON is a type of transform of a hash.
However, JSON is usually done with XS, which means that the second traversal is faster, at least. That and JSON behavior is standardized.
use 5.016;
use strict;
use warnings;
use Data::Dumper ();
use JSON;
my $hash
= {
'Foods' => {
'fruits' => {
'orange' => '1',
'apple' => '2',
},
'Vegetables' => {
'tomato' => '3',
'carrot' => '1',
'cabbage' => '2',
}
}
};
sub descend {
my ( $structure, $block ) = #_;
my $res;
while ( my ( $k, $v ) = each %$structure ) {
$block->( $structure, $k, $v );
if ( ref( $v ) eq 'HASH' ) {
$res = descend( $v, $block );
}
}
return $res;
}
my $new = {};
my $curr = $new;
descend( $hash => sub {
my ( $lvl, $k, $v ) = #_;
my $node = { text => $k };
$curr->{children} //= [];
push $curr->{children}, $node;
if ( ref( $v ) eq 'HASH' ) {
$curr = $node;
}
else {
$node->{children} = { text => $v };
}
});
# allow for the root-level special case, and retrieve the first child.
$new = $new->{children}[0];
say Data::Dumper->Dump( [ $new ], [ '$new' ] );
say JSON->new->encode( $new );

Related

Perl how to access a value of nested hash without specific some middle keys (wildcard)

I trying to fetch the facebook mobile posts.
$VAR1 = {
"mf_story_key" => "225164133113094",
"page_id" => "102820022014173",
"page_insights" => {
"102820022014173" => {
"actor_id" => "102820022014173",
"page_id" => "102820022014173",
"page_id_type" => "page",
"post_context" => {
"publish_time" => "1641702174",
"story_name" => "EntStatusCreationStory"
},
"psn" => "EntStatusCreationStory",
"role" => 1,
}
},
"story_attachment_style" => "album",
};
$publish_time = $VAR1->{page_insights}{102820022014173}{post_context}{publish_time};
If 102820022014173 is a dynamic value, how do I access the publish_time value without specific it?
You need to get the keys to the page_insights hash and then iterate through them.
use strict;
use warnings;
use 5.010;
my $post = {
"mf_story_key" => "225164133113094",
"page_id" => "102820022014173",
"page_insights" => {
"102820022014173" => {
"actor_id" => "102820022014173",
"page_id" => "102820022014173",
"page_id_type" => "page",
"post_context" => {
"publish_time" => "1641702174",
"story_name" => "EntStatusCreationStory"
},
"psn" => "EntStatusCreationStory",
"role" => 1,
}
},
"story_attachment_style" => "album",
};
my $insights = $post->{page_insights};
my #insight_ids = keys %{$insights};
for my $id ( #insight_ids ) {
say "ID $id was published at ",
$insights->{$id}{post_context}{publish_time};
}
gives
ID 102820022014173 was published at 1641702174
for my $page_insight ( values( %{ $VAR1->{page_insights} } ) ) {
my $publish_time = $page_insight->{post_context}{publish_time};
...
}
If there's always going to exactly one element,
my $page_insight = ( values( %{ $VAR1->{page_insights} } )[0];
my $publish_time = $page_insight->{post_context}{publish_time};
...
(You can combine the two statements if you so desire.)

How to get the field name in Params::Validate in Perl

validate(
#_,
{
foo => {
callbacks => {
'smaller than a breadbox' => sub { shift() < $breadbox },
'green or blue' => sub {
return 1 if $_[0] eq 'green' || $_[0] eq 'blue';
&$failed(‘**fieldname** value is Invalid’);
}
bar => {
callbacks => {
'yellow or red' => sub {
return 1 if $_[0] eq 'yellow ' || $_[0] eq 'red';
&$failed(‘**fieldname** value is Invalid’);
}
}
}
}
);
Params::Validate - In the above code if my validation fails, I am calling the subroutine failed in which I am displaying the error message. I want to get field name from callbacks in params validate for which the validation has failed instead of directly passing the field name in the failed subroutine. Here foo and bar are fieldnames. How can I get the field name?
You could try something like this:
use strict;
use warnings;
use Params::Validate;
my %template =
(
bar => {
'color correct' => sub {
my ($fieldname, $value) = #_[0..1];
return 1 if $value eq 'green' || $value eq 'blue';
failed("'$fieldname': value '$value' is invalid");
}
},
foo => {
'smaller than a breadbox' => sub {
my ($fieldname, $value) = #_[0..1];
return 1 if $value < 20;
failed("'$fieldname' value '$value' is invalid");
}
}
);
func( bar => 'green', foo => 14 );
func( bar => 'yellow', foo => 17 );
sub func {
my %validate = map { $_ => { callbacks => get_callbacks( $_, $template{$_} ) } }
keys %template;
validate( #_, \%validate );
}
sub get_callbacks {
my ( $fname, $callbacks ) = #_;
my %cb;
for my $name (keys %$callbacks ) {
$cb{$name} = sub {
my $fieldname = $fname;
$callbacks->{$name}->( $fieldname, #_ )
};
}
return \%cb;
}
sub failed {
die $_[0];
}
Note: this uses closures to define a persistent fieldname variable. See perlsub for more information.

How do I extract the value from a nested hash with unknown level of nesting?

What is the best way to walk a nested hash structure to get the value when there can be an unknown number of nested levels?
For example the hash could be any of the following or any level of nesting.
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
my $hash = { 'known' => { 'a' => { 'b' => { 'c' => 'value' } } } };
my $hash = { 'known' => { 'a' => { 'b' => { 'c' => { 'd' => 'value' } } } } };
The keys a,b,c below could be any value.
I was thinking I could do it with a recursive function that extracts the key and value and the current level, checks to see if the value is a reference to
a hash and if so calls itself, otherwise I have the value?
An easy-to-read approach:
#!/usr/bin/env perl
use strict;
use warnings;
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
print get_deep_values($hash);
sub get_deep_values {
my $hash = shift;
if (ref($hash) eq 'HASH') {
get_deep_values( (values %$hash)[0] )
}
else {
return $hash;
}
}
Output:
value
Yes, recursion works,
use v5.16;
use warnings;
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
print sub { map { ref() ? __SUB__->(values %$_) : $_ } #_ }->($hash);
output
value
I assume none of the nested hashes have more than a single element?
A simple iteration is all that's necessary
use strict;
use warnings;
use 5.010;
my #hashes = (
{ 'known' => { 'a' => { 'b' => 'value1' } } },
{ 'known' => { 'a' => { 'b' => { 'c' => 'value2' } } } },
{ 'known' => { 'a' => { 'b' => { 'c' => { 'd' => 'value3' } } } } },
);
say get_value($_) for #hashes;
sub get_value {
my ($hash) = #_;
($hash) = values %$hash while ref $hash eq 'HASH';
$hash;
}
output
value1
value2
value3

How to merge HashRef in Moose attribute writer?

Having a simple example code
use Modern::Perl;
use Data::Dumper;
package My;
use Moose;
use Method::Signatures::Simple;
has 'result' => (
is => 'rw',
isa => 'HashRef',
default => sub{{}},
clearer => 'clear_result'
);
method run {
$self->clear_result; #clearing the result
$self->result( $self->run_part1 );
$self->do_something;
$self->result( $self->run_part3 ); #need merge
}
method do_something {
$self->result( $self->run_part2 ); #need merge
}
method run_part1 { return { aaa => 'aaa' } }
method run_part2 { return { bbb => 'bbb' } }
method run_part3 { return { ccc => 'ccc' } }
package main;
my $p = My->new;
say Dumper $p->run;
the result (ofcourse) is:
$VAR1 = {
'ccc' => 'ccc'
};
I want the result:
$VAR1 = {
'aaa' => 'aaa'
'bbb' => 'bbb'
'ccc' => 'ccc'
};
so, the question is - how to merge the $self->result HashRef when setting it?
Yes, i can add new method add_result like:
method add_result($hr) {
use Hash::Merge::Simple qw(merge);
$self->result( merge $self->result, $hr );
}
and change everywhere in my code the $self->result to $self->add_result but wonder if there is another solution...
has 'result' => (
acccessor => '_result',
isa => 'HashRef',
default => sub{{}},
clearer => 'clear_result'
);
sub result {
my $self = shift;
if (#_) {
my ($hr) = #_;
return $self->_result( ... merged hash ...);
} else {
return $self->_result();
}
}

How do Perl FIRSTKEY and NEXTKEY work

Tie::Hash has these:
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { each %{$_[0]} }
NEXTKEY takes two arguments, one of which is the last key but that arg is never referenced?
The various Tie docs don't shed any light on this other than this in perltie:
my $a = keys %{$self->{LIST}}; # reset each() iterator
looking at the doc for each doesn't add to this.
What's going on?
You only need to worry about the second argument to NEXTKEY if you care about which key was accessed last. By default, hashes don't care about the order, so it is not used.
As for the second part, the keys function in scalar context returns the number of items in the hash. Any call to keys resets the iterator used by keys and each because it exhausts the iterator.
A call to keys is really a call to FIRSTKEY and calls to NEXTKEY until there are no more items left in that haven't been returned.
A call to each is a call to FIRSTKEY (if FIRSTKEY hasn't been called yet) or a call to NEXTKEY (if FIRSTKEY has been called).
#!/usr/bin/perl
use strict;
use warnings;
my $i = 0;
tie my %h, "HASH::Sorted", map { $_ => $i++ } "a" .. "g";
for my $key (keys %h) {
print "$key => $h{$key}\n";
}
print "\n";
my $first = each %h;
print "first $first => $h{$first}\n";
my ($second_key, $second_value) = each %h;
print "second $second_key => $second_value\n";
print "\nall of them again:\n";
for my $key (keys %h) {
print "$key => $h{$key}\n";
}
package HASH::Sorted;
sub TIEHASH {
my $class = shift;
return bless { _hash => { #_ } }, $class;
}
sub FETCH {
my ($self, $key) = #_;
return $self->{_hash}{$key};
}
sub STORE {
my ($self, $key, $value) = #_;
return $self->{_hash}{$key} = $value;
}
sub DELETE {
my ($self, $key) = #_;
return delete $self->{_hash}{$key};
}
sub CLEAR {
my $self = shift;
%{$self->{_hash}} = ();
}
sub EXISTS {
my ($self, $key) = #_;
return exists $self->{_hash}{$key};
}
sub FIRSTKEY {
my $self = shift;
#build iterator
$self->{_list} = [ sort keys %{$self->{_hash}} ];
return $self->NEXTKEY;
}
sub NEXTKEY {
my $self = shift;
return shift #{$self->{_list}};
}
sub SCALAR {
my $self = shift;
return scalar %{$self->{_hash}};
}
This one uses a custom each method to allow you to iterate over the sorted hash more than one time. All of the standard rules about not being allowed to add or remove keys are still in effect though. It would be trivial to add a warning that iterators were still in use on a call to STORE or DELETE.
#!/usr/bin/perl
use strict;
use warnings;
my $i = 0;
tie my %h, "HASH::Sorted", map { $_ => $i++ } "a" .. "g";
for my $key (keys %h) {
print "$key => $h{$key}\n";
}
print "\n";
my $first = each %h;
print "first $first => $h{$first}\n";
my ($second_key, $second_value) = each %h;
print "second $second_key => $second_value\n";
print "\nall of them again:\n";
for my $key (keys %h) {
print "$key => $h{$key}\n";
}
print "\nmultiple iterators\n";
my $o = tied %h;
while (my ($k, $v) = $o->each("outer")) {
print "$k => $v\n";
while (my ($k, $v) = $o->each("inner")) {
print "\t$k => $v\n";
}
}
print "\nhybrid solution\n";
while (my ($k, $v) = each %h) {
print "$k => $v\n";
#the iter_name is an empty string
while (my ($k, $v) = $o->each) {
print "\t$k => $v\n";
}
}
package HASH::Sorted;
sub each {
my ($self, $iter_name) = (#_, "DEFAULT");
#each has not been called yet for this iter
unless (exists $self->{_iters}{$iter_name}) {
$self->{_iters}{$iter_name} = [ sort keys %{$self->{_hash}} ];
}
#end of list
unless (#{$self->{_iters}{$iter_name}}) {
delete $self->{_iters}{$iter_name};
return;
}
my $key = shift #{$self->{_iters}{$iter_name}};
if (wantarray) {
return $key, $self->{_hash}{$key};
}
return $key;
}
sub TIEHASH {
my $class = shift;
return bless {
_hash => { #_ },
_iters => {},
}, $class;
}
sub FETCH {
my ($self, $key) = #_;
return $self->{_hash}{$key};
}
sub STORE {
my ($self, $key, $value) = #_;
return $self->{_hash}{$key} = $value;
}
sub DELETE {
my ($self, $key) = #_;
return delete $self->{_hash}{$key};
}
sub CLEAR {
my $self = shift;
%{$self->{_hash}} = ();
}
sub EXISTS {
my ($self, $key) = #_;
return exists $self->{_hash}{$key};
}
sub FIRSTKEY {
my $self = shift;
#build iterator
$self->{_list} = [ sort keys %{$self->{_hash}} ];
return $self->NEXTKEY;
}
sub NEXTKEY {
my $self = shift;
return shift #{$self->{_list}};
}
sub SCALAR {
my $self = shift;
return scalar %{$self->{_hash}};
}