Tie::Coupler - Tie based implementation of coupled scalars

 use Tie::Coupler;

 my $options = { fconvert => \&double,
                 rconvert => \&half,
                 init     => 1,
               };

 my $impl = new Tie::Coupler($var, $coupled, $options);

 $var = 2;
 print "$var, $coupled\n";   ## Would print: 2, 4

 $coupled = 6;
 print "$var, $coupled\n";   ## Would print: 3, 6

 $impl->fconvert(\&triple);
 $var = 5;
 print "$var, $coupled\n";   ## Would print: 5, 15

 $impl->decouple();          ## The two scalars are now independent
                             ## of each other now

 sub double { my ($val) = @_; $val * 2; }
 sub triple { my ($val) = @_; $val * 3; }
 sub half   { my ($val) = @_; int($val / 2); }

# ----------------------------------------------------------------------------#
# Tie::Coupler                                                                #
#                                                                             #
# Copyright (c) 2001-02 Arun Kumar U <u_arunkumar@yahoo.com>.                 #
# All rights reserved.                                                        #
#                                                                             #
# This program is free software; you can redistribute it and/or               #
# modify it under the same terms as Perl itself.                              #
# ----------------------------------------------------------------------------#

package Tie::Coupler;

use strict;
use vars qw($VERSION);

use Carp;

$VERSION = '0.01';

sub new
{
  my ($class) = shift;
  my ($args)  = $_[2];
  my (%sargs, %cargs);
  
  if (defined($args) && ref($args) ne 'HASH') {
    warn("Invalid options: Should be a hash reference\n");
    croak('Usage: ' . __PACKAGE__ . '->new($scalar1, $scalar2, $opthash)');
  }
  
  $args = {} if (!defined($args));
  %sargs = %cargs = %{$args};
  $sargs{'convert'} = $sargs{'fconvert'};
  $sargs{'this'} = \$_[0]; $sargs{'couple'} = \$_[1];

  $cargs{'convert'} = $cargs{'rconvert'};
  $cargs{'this'} = \$_[1]; $cargs{'couple'} = \$_[0];

  my $simpl = tie($_[0], 'Tie::Coupling', \%sargs);
  my $cimpl = tie($_[1], 'Tie::Coupling', \%cargs);
  
  my $self = {};
  $self->{'_simpl'}  = $simpl;
  $self->{'_cimpl'}  = $cimpl;
  $self->{'_source'} = \$_[0];
  $self->{'_couple'} = \$_[1];

  bless $self, $class;
  return $self;
}

sub decouple
{
  my $var = $_[0]->{'_source'};
  my $couple = $_[0]->{'_couple'};

  ## Ugly hack to prevent -w from spitting the warning message 
  ## "untie attempted while 1 inner references still exist" 

  undef($_[0]);

  untie(${$var});
  untie(${$couple});
}

sub fconvert
{
  my ($self) = shift;
  $self->{'_simpl'}->convert(@_);
}

sub rconvert
{
  my ($self) = shift;
  $self->{'_cimpl'}->convert(@_);
}

1;

package Tie::Coupling;

use strict;
use Carp;

my @options = qw(this couple convert init);
my @attribs = qw(couple value this init);

sub TIESCALAR
{
  my ($proto, $args) = @_;
  my ($self, $class);

  $self = {};
  $class = ref($proto) || $proto;
  bless $self, $class;
  
  map { $self->{"_" . $_} = $args->{$_}; } @options;
  $self->_checkOptions();
  $self->_value($self->_this());

  if ($self->{'_init'}) { $self->STORE($self->_value()); }

  return $self;
}

sub FETCH
{
  my ($self) = @_;
  return $self->_value();
}

sub STORE
{
  my ($self, $value) = @_;
  
  my $convert = $self->convert();
  my $pattern = qr{(?i)retain};

  if (!defined($convert)) {
    $self->_value($value); 
    $self->_couple($value);
  }
  elsif ($convert =~ $pattern) { $self->_value($value); }
  elsif (defined($convert)) {
    my $nvalue = $self->_transform($value); 
    $self->_value($value); 
    $self->_couple($nvalue); 
  }
  else { confess("Should have never got this far !!"); }
  return $self->_value();
}

sub convert
{
  my ($self) = shift;
  
  $self->{'_convert'} = $_[0] if (@_);
  return $self->{'_convert'};
}

sub _checkOptions
{
  my ($self) = @_;
  
  my $convert = $self->convert();  
  my $ref = ref($convert);
  my $pattern = qr{(?i)retain};

  if (defined($convert) && $convert !~ $pattern) {
    if (!($ref eq 'CODE' || $ref eq 'ARRAY')) {
      carp("Conversion callback should be either a code reference or an array reference\n");
      croak("Usage: tie \$s, \'" . __PACKAGE__  . 
            "\', { couple => \\\$var, convert => \\&coderef }");
    }
  }
}

sub _value
{
  my ($self) = shift;
  
  $self->{'_value'} = $_[0] if (@_);
  return $self->{'_value'};
}

sub _couple
{
  my ($self) = shift;
  
  ${$self->{'_couple'}} = $_[0] if (@_);
  return ${$self->{'_couple'}};
}

sub _this
{
  my ($self) = shift;
  
  ${$self->{'_this'}} = $_[0] if (@_);
  return ${$self->{'_this'}};
}

sub _transform
{
  my ($self, $value) = @_;
  my ($convert, $ref);

  $convert = $self->convert();
  $ref = ref($convert);
  
  return $value if (!defined($convert));  

  if (!($ref eq 'CODE' || $ref eq 'ARRAY')) {
    croak("Conversion callback should be either a CODE reference or an ARRAY reference\n");
  }

  if ($ref eq 'CODE') { return $convert->($value); }
  else {
    if (ref($convert->[0]) eq 'CODE') {
      my $function = $convert->[0];
      my @params = (@{$convert})[1 .. $#{$convert}];
      
      return $function->($value, @params);    
    }
    else {
      my $pack   = $convert->[0];
      my $method = $convert->[1];
      my @params = (@{$convert})[2 .. $#{$convert}];
      
      return $pack->$method($value, @params);    
    }
  }
}

1;

__END__;