Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

update required for subroutine

by satzbu (Acolyte)
on Apr 21, 2010 at 04:07 UTC ( #835943=perlquestion: print w/replies, xml ) Need Help??

satzbu has asked for the wisdom of the Perl Monks concerning the following question:

Hi monks please help me to update this code this is used to replace a hash key with another hash value when i change grouping the input hash keys means it cant work please help me to debug this code

#!/usr/bin/perl use warnings; use strict; use Data::Dumper; my %xhash = ('a' => { 'b' => { 'e' => 'E', 'c' => 'C', 'content' => 'B ' }, 'content' => 'A ', 'd' => 'D' }); my %c_hash=('a' => { 'addval' => { 'b' => { 'addval' => { 'e' => { 'addv +al' => {}, 'repv +al' => '5' }, 'c' => { 'addv +al' => {}, 'repv +al' => '3' } }, 'repval' => '2' }, 'd' => { 'addval' => {}, 'repval' => '4' } }, 'repval' => '1' }); sub traverse { my ($hash, $callback, $mode) = @_; return unless ref($hash) eq "HASH"; for my $key (keys %$hash) { my $val = $hash->{$key}; if (ref($val) eq "HASH") { traverse($val, $callback, $mode); if ($mode eq "collect") { if (exists $val->{repval}) { $callback->($key, $val->{repval}); } } } if ($mode eq "replace") { $callback->($key, $val, $hash); } } } my %repl; # lookup table: a => 1, etc. traverse(\%c_hash, sub { my ($key, $val) = @_; $repl{$key} = $val; }, "collect" ); # print Dumper \%repl; # debug traverse(\%xhash, sub { my ($key, $val, $href) = @_; if (exists $repl{$key}) { my $newkey = $repl{$key}; $href->{$newkey} = $val; delete $href->{$key}; } }, "replace" ); print Dumper \%xhash; __END__ $VAR1 = { '1' => { '4' => 'D', 'content' => 'A ', '2' => { '3' => 'C', 'content' => 'B ', '5' => 'E' } } }; _WANT TO CHANGE THE INPUT AS_ my %xhash = ('a' => [{ 'b' => [{ 'e' => ['E'], 'c' => ['C'], 'content' => ['B'] }], 'content' =>['A'], 'd' => ['D'] }]); _OUTPUT FOR THIS INPUT_ my %xhash = (['a' => [{ 'b' => [{ 'e' => ['E'], 'c' => ['C'], 'content' => ['B'] }], 'content' => ['A'], 'd' => ['D'] }]); _REQUIRED OUTPUT_ $VAR1 = { '1' => [{ '4' => ['D'], 'content' => ['A'], '2' => [{ '3' => ['C'], 'content' => ['B'], '5' => ['E'] }] }] };

please help me its very urgent

Replies are listed 'Best First'.
Re: update required for subroutine
by almut (Canon) on Apr 21, 2010 at 09:36 UTC

    Isn't this pretty much exactly what we've already had in Hash handling error?

    The only difference I can spot is that the value associated with 'e' / 5 in that node had been ['E','V'] instead of ['E'].  The solution I suggested should equally be applicable.

    Update: complete code (as I understand your task) — just in case:

    #!/usr/bin/perl use warnings; use strict; use Data::Dumper; my %xhash = ('a' => [{ 'b' => [{ 'e' => ['E'], 'c' => ['C'], 'content' => ['B'] }], 'content' =>['A'], 'd' => ['D'] }]); my %c_hash=('a' => { 'addval' => { 'b' => { 'addval' => { 'e' => { 'addv +al' => {}, 'repv +al' => '5' }, 'c' => { 'addv +al' => {}, 'repv +al' => '3' } }, 'repval' => '2' }, 'd' => { 'addval' => {}, 'repval' => '4' } }, 'repval' => '1' }); sub traverse { my ($hash, $callback, $mode) = @_; traverse($hash->[0], $callback, $mode) if ref($hash) eq "ARRAY"; return unless ref($hash) eq "HASH"; for my $key (keys %$hash) { my $val = $hash->{$key}; if (ref($val)) { traverse($val, $callback, $mode); if ($mode eq "collect") { if (exists $val->{repval}) { $callback->($key, $val->{repval}); } } } if ($mode eq "replace") { $callback->($key, $val, $hash); } } } my %repl; # lookup table: a => 1, etc. traverse(\%c_hash, sub { my ($key, $val) = @_; $repl{$key} = $val; }, "collect" ); # print Dumper \%repl; # debug traverse(\%xhash, sub { my ($key, $val, $href) = @_; if (exists $repl{$key}) { my $newkey = $repl{$key}; $href->{$newkey} = $val; delete $href->{$key}; } }, "replace" ); print Dumper \%xhash; __END__ $VAR1 = { '1' => [ { '4' => [ 'D' ], 'content' => [ 'A' ], '2' => [ { '3' => [ 'C' ], 'content' => [ 'B' ], '5' => [ 'E' ] } ] } ] };

      mam this output only i have from your code see the error inner keys are not replaced

      _OUTPUT_ $VAR1 = { '1' => [ { 'b' => [ { 'e' => [ 'E', 'G' ], 'c' => [ 'C' ], 'content' => 'B ' } ], 'content' => 'A ', 'd' => [ { 'content' => 'D ', 'x' => [ 'C' ], 'z' => [ 'E', 'G' ] } ] } ] }; _INPUT_ my %xhash=('a' => [ { 'b' => [ { 'e' => [ 'E', 'G' ], 'c' => [ 'C' ], 'content' => 'B ' } ], 'content' => 'A ', 'd' => [ { 'content' => 'D ', 'x' => [ 'C' ], 'z' => [ 'E', 'G' ] } ] } ]); my %c_hash=('a' => { 'addval' => { 'b' => { 'addval' => { 'e' => { 'addv +al' => {}, 'repv +al' => '5' }, 'c' => { 'addv +al' => {}, 'repv +al' => '3' } }, 'repval' => '2' }, 'd' => { 'addval' => { 'x' => { 'addv +al' => {}, 'repv +al' => '10' }, 'z' => { 'addv +al' => {}, 'repv +al' => '11' } }, 'repval' => '4' } }, 'repval' => '1' });

        You must be using code different from the one I posted.  When I use your input %xhash and %c_hash in the exact above code, I get

        $VAR1 = { '1' => [ { '4' => [ { '11' => [ 'E', 'G' ], 'content' => 'D ', '10' => [ 'C' ] } ], 'content' => 'A ', '2' => [ { '3' => [ 'C' ], 'content' => 'B ', '5' => [ 'E', 'G' ] } ] } ] };
    A reply falls below the community's threshold of quality. You may see it by logging in.
Re: update required for subroutine
by GrandFather (Saint) on Apr 21, 2010 at 08:21 UTC

    As far as I can tell the only difference between the current output of your code and the output you indicate that you want is the hash references are nested in array references. That being the case the following version of the call back sub does the trick:

    sub { my ($key, $val, $href) = @_; if (exists $repl{$key}) { my $newkey = $repl{$key}; $val = [$val] if ref ($val) eq "HASH"; $href->{$newkey} = $val; delete $href->{$key}; }

    Note the $val = [$val] ... line.

    True laziness is hard work
Re: update required for subroutine
by arc_of_descent (Hermit) on Apr 21, 2010 at 06:47 UTC

    I would recommend you read up on how Perl's array and hash structures work and on how to populate as well as iterate over them. Check here for a good start - perldsc

    It also helps to initially draw your data structures on paper.

Re: update required for subroutine
by Anonymous Monk on Apr 21, 2010 at 06:39 UTC
    Your "required output" is nonsense (syntax error, and impossible data structure). I would say try again, but this is like the 5th iteration. Good luck.
Re: update required for subroutine
by pemungkah (Priest) on Apr 21, 2010 at 20:02 UTC
    I realize you're in a hurry, but you're really going about this all wrong.

    You're running code, getting an answer, posting it here, and asking for help.

    This is not, as they say, a sustainable development model.

    Do you have tests? Are you using a source code management tool? I know - you don't have time. But consider: your development cycle is now at the mercy of folks deciding to help. You need to do more to help yourself.

    Take one example of your input and expected output, and write a test. Use Test::Deep to check the differences between the data structure you're getting and the one you want. Start using the debugger to step through the manipulations of the data structure to check that each step is doing what you want, or to find where it's not.

    You don't have to use something complicated to start doing source control. Use RCS. You don't have to set up a repository, and there are very few commands. Learn SVN or Mercurial or git some other time.

    The only person who can really invest in this code is you, and you need to treat yourself right and give yourself the tools you need to fix this. I realize that you're probably under pressure to get this done, but your current working method will not do it.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://835943]
Approved by biohisham
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (6)
As of 2021-05-12 18:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Perl 7 will be out ...





    Results (132 votes). Check out past polls.

    Notices?