File Coverage

blib/lib/Tie/Coupler.pm

Criterion	Covered	Total	%
statement	15	121	12.4
branch	0	32	0.0
condition	0	15	0.0
subroutine	5	18	27.7
pod	4	4	100.0
total	24	190	12.6

# ----------------------------------------------------------------------------#
# Tie::Coupler                                                                #
#                                                                             #
# Copyright (c) 2001-02 Arun Kumar U .                 #
# 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__;