Perl Medic: Transforming Legacy Code. Chapter 3. Pt. 2 | 3

Perl Medic: Transforming Legacy Code. Chapter 3. Pt. 2

We’re nearly done with the pickiness. There’s one final test we should apply. Have you guessed what it is? We should make sure that the user doesn’t enter a lower bound that’s higher than the upper one. Can you imagine what the implementation of bounded arrays would do if we didn’t check for this? I can’t, because I haven’t written it yet, but it might be ugly. Let’s head that off at the pass right now:

sub TIEARRAY
{
   my ($class, %arg) = @_;
   my ($upper, $lower) = delete @arg{qw(upper lower)};
   croak "Illegal arguments in tie" if %arg;
   $lower ||= 0;
   croak "No upper bound for array" unless $upper;
   /\D/ and croak "Array bound must be integer"
     for ($upper, $lower);
   croak "Upper bound < lower bound" if $upper < $lower;
         return bless { upper => $upper,
         lower => $lower, array => []
       }, $class;
}


and the new test goes at the end of 02tie.t (italicized):

Example 3.2 Final Version of 02tie.t

#!/usr/bin/perl use strict; use warnings;

use Test::More tests => 6; use Test::Exception;
use blib;
use Tie::Array::Bounded;

dies_ok { tie my @array, "Tie::Array::Bounded"
      "Croak with no bound specified";

my $obj;
lives_ok { $obj = tie my @array,
      "Tie::Array::Bounded", upper => 42 }
      "Tied array okay";

isa_ok($obj, "Tie::Array::Bounded");


      qr/must be integer/, "Non-integral bound fails";

      { tie my @array, "Tie::Array::Bounded", frogs => 10
throws_ok { tie my @array, "Tie::Array::Bounded", upper =>-1}
      qr/Illegal arguments/, "Illegal argument fails";

throws_ok { tie my @array, "Tie::Array::Bounded",
      lower => 2, upper => 1 }
      qr/Upper bound < lower/, "Wrong bound order fails";

Whoopee! We’re nearly there. Now we need to make the tied array behave properly, so let’s start a new test file for that, called 03use.t:

#!/usr/bin/perl
use strict;
use warnings;

use Test::More tests => 1; use Test::Exception; use blib;
use Tie::Array::Bounded;

my @array;
tie @array, "Tie::Array::Bounded", upper

lives_ok { $array[0] = 42 } "Store =>5;
works";

As before, let’s ensure that the test fails before we add the code to implement it:

% t/03use.t
1..1
Using /home/peter/perl_Medic/Tie/Array/Bounded/blib
not ok 1 - Store works
# Failed test (t/03use.t at line 13)
# died: Can't locate object method "STORE" via package
"Tie::Array::Bounded" (perhaps you forgot to load
"Tie::Array::Bounded"?) at t/03use.t line 13. # Looks
like you failed 1 tests of 1.

How about that. The test even told us what routine we need to write. perltie tells us what it should do. So let’s add to Bounded.pm:

sub STORE
{
  my ($self, $index, $value) = @_;
  $self->_bound_check($index);
  $self->{array}[$index] = $value;
}

     _bound_check

sub {
  my ($self, $index) = @_;
  my ($upper, $lower) = @{$self}{qw(upper lower)}; croak "Index $index out of   range [$lower, $upper]"
    if $index < $lower || $index > $upper;
}

We’ve abstracted the bounds checking into a method of its own in anticipation of needing it again. Now 03use.t passes, and we can add another test to make sure that the value we stored in the array can be retrieved:

is($array[0], 42, "Fetch works");

You might think this would fail for want of the FETCH method, but in fact:

ok 1 - Store works
Can't locate object method "FETCHSIZE" via package
"Tie::Array::Bounded" (perhaps you forgot to load
"Tie::Array::Bounded"?) at t/03use.t line 14. #
Looks like you planned 2 tests but only ran 1. #
Looks like your test died just after 1.

Back to perltie to find out what FETCHSIZE is supposed to do: return the size of the array. Easy enough:

sub FETCHSIZE
{
my $self = shift;
scalar @{$self->{array}};
}

Now the test does indeed fail for want of FETCH, so we’ll add that:

sub FETCH
{
  my ($self, $index) = @_;
  $self->_bound_check($index);
  $self->{array}[$index];
}

Created: March 27, 2003
Revised: March 24, 2004

URL: http://webreference.com/programming/awperl2/1