Re^2: Dualvar via table

[Dirk80]

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;