Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Re: Dualvar via table

by AnomalousMonk (Bishop)
on Jan 17, 2020 at 20:26 UTC ( #11111548=note: print w/replies, xml ) Need Help??


in reply to Dualvar via table

I share the concerns of others about mixing too much Perl majick together: the result may blow up in your (or your maintainer's) face in very unexpected ways. But as to some tangential questions...

Is there an efficient way to check whether the values of a hash are unique?
c:\@Work\Perl\monks>perl -wMstrict -le "my %h = qw(a 1 b 2 c 3 d 1); ;; my %r = reverse %h; keys %r == keys %h or die qq{hash @{[ %h ]} not unique}; " hash c 3 a 1 b 2 d 1 not unique at -e line 1.
... a solution to return several values if the hash is not unique ...
The general approach to maintaining several values for a hash key is an anonymous array. Maybe something like:
c:\@Work\Perl\monks>perl -wMstrict -le "use Data::Dump qw(dd); ;; my %h = ( a => [ 1 ], b => [ 2, 99, 88 ], c => [ 3 ], d => [ 1, 99 ] ); ;; my %r; for my $hk (keys %h) { push @{ $r{$_} }, $hk for @{ $h{$hk} }; } dd \%r; " { 1 => ["a", "d"], 2 => ["b"], 3 => ["c"], 88 => ["b"], 99 => ["b", "d +"] }
Update: Note that this inversion approach for multi-value hashes is not round-tripable unless you consider the arrays of values to be unordered lists:
c:\@Work\Perl\monks>perl -wMstrict -le "use Test::More 'no_plan'; use Test::NoWarnings; ;; use Data::Dump qw(dd); ;; my %h = ( a => [ 1 ], b => [ 2, 99, 88 ], c => [ 3 ], d => [ 1, 99 ] ); ;; my %r = invert(%h); dd \%r; ;; my %rr = invert(%r); dd \%rr; ;; is_deeply \%rr, \%h, 'round trip'; ;; done_testing; ;; exit; ;; sub invert { my %h = @_; my %r; for my $hk (keys %h) { push @{ $r{$_} }, $hk for @{ $h{$hk} }; } return %r; } " { 1 => ["a", "d"], 2 => ["b"], 3 => ["c"], 88 => ["b"], 99 => ["b", "d +"] } { a => [1], b => [99, 88, 2], c => [3], d => [99, 1] } not ok 1 - round trip # Failed test 'round trip' # at -e line 1. # Structures begin differing at: # $got->{b}[0] = '99' # $expected->{b}[0] = '2' 1..1 ok 2 - no warnings 1..2 # Looks like you failed 1 test of 2.


Give a man a fish:  <%-{-{-{-<

Replies are listed 'Best First'.
Re^2: Dualvar via table
by Dirk80 (Pilgrim) on Jan 19, 2020 at 12:45 UTC

    Thank you all so much. I never used the tie-functionality before. So I thought this could be a thing to use it. The same applies for dualvar. But now I see that this could be dangerous and too much magic.

    So I was thinking a lot about all your answers. And now I took into account that the table is given only once (at compile time) to the class and not for each variable. I'm rejecting multi dimensionsal hashes. And I see that the tie functionality can be well replaced by the overload functionality via use overload '""' => \&str, '0+' => \&num, fallback => 1;.

    Here my new suggestion, which seems to work fine:

    Main program:

    #!/usr/bin/perl use strict; use warnings; use FindBin qw($Bin); use Cwd qw(abs_path); BEGIN{ unshift(@INC, abs_path("$Bin")) } my %table; BEGIN { %table = ( 1 => 'NORTH', 2 => 'SOUTH', 3 => 'EAST', 4 => 'WEST'); } use My::GenDualVar "Direction", %table; my $direction = Direction->new(2); $direction->set('WEST'); print $direction->num() . "\n"; print $direction->str() . "\n"; print $direction->hex() . "\n"; # should work if overloading is active #print $direction . "\n"; #print $direction+0 . "\n";

    Package My::GenDualVar:

    package My::GenDualVar; use strict; use warnings; use Carp; use Scalar::Util qw( looks_like_number ); no strict "refs"; sub import { croak "Parameters are missing. " . "Parameters have to be the name of the to be generated class a +nd " . "an unique one dimensional table (hash) with numbers as keys a +nd strings as values" unless @_ >= 3; my $class = shift; my $new_class = shift; my %num_table = @_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; croak "Given table is empty" if keys %num_table == 0; my %str_table = reverse %num_table; keys %str_table == keys %num_table or croak qq{Given table @{[ %nu +m_table ]} is not unique}; while (my ($num, $str) = each %num_table) { croak "Key $num of given table is not a number" unless looks_l +ike_number($num); croak "Value $str of given table is not a string" if ref($str) +; } eval qq{package $new_class;\n} . q{use overload '""' => \&str, '0+' => \&num, fallback => 1;}; My::GenDualVar->generate_new_for($new_class, \%num_table, \%str_ta +ble); My::GenDualVar->generate_set_for($new_class, \%num_table, \%str_ta +ble); My::GenDualVar->generate_num_for($new_class); My::GenDualVar->generate_str_for($new_class); My::GenDualVar->generate_hex_for($new_class); } sub generate_new_for { my ($class, $new_class, $ref_num_table, $ref_str_table) = @_; *{"${new_class}::new"} = sub { my ($class, $val) = @_; my $self = bless { '_num_table' => $ref_num_table, '_str_table +' => $ref_str_table }, $class; $self->set($val); return $self; } } sub generate_set_for { my ($class, $new_class, $ref_num_table, $ref_str_table) = @_; *{"${new_class}::set"} = sub { my ($self, $val) = @_; if( looks_like_number($val) ) { croak "Invalid number $val in set method of class " . ref( +$self) . ". " . "Valid numbers are " . join(", ", sort{$a <=> $b} keys + %{$self->{'_num_table'}}) unless exists $self->{'_num_table'}->{$val}; $self->{'_num'} = $val; $self->{'_str'} = $self->{'_num_table'}->{$val}; } else { croak "Invalid string $val in set method of class " . ref( +$self) . ". " . "Valid strings are " . join(", ", sort keys %{$self->{ +'_str_table'}}) unless exists $self->{'_str_table'}->{$val}; $self->{'_num'} = $self->{'_str_table'}->{$val}; $self->{'_str'} = $val; } } } sub generate_num_for { my ($class, $new_class) = @_; *{"${new_class}::num"} = sub { my ($self) = @_; return $self->{'_num'}; } } sub generate_str_for { my ($class, $new_class) = @_; *{"${new_class}::str"} = sub { my ($self) = @_; return $self->{'_str'}; } } sub generate_hex_for { my ($class, $new_class) = @_; *{"${new_class}::hex"} = sub { my ($self) = @_; return sprintf("%#x", $self->{'_num'}); } } 1;

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (4)
As of 2020-04-01 05:58 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    To "Disagree to disagree" means to:









    Results (186 votes). Check out past polls.

    Notices?