Chapter 17. The Magic of Tied Variables

In my Tie::Cycle example, everything after the variable name that I’m tying (that is, the class name and the remaining arguments) ends up as the arguments to TIESCALAR. Other than the method name, this looks like a normal constructor. Perl handles all the tying for me, so I don’t have to do that myself:

tie $class, 'Tie::Cycle', [ qw( first second third ) ];

That’s almost the same as calling TIESCALAR myself:

my $object = Tie::Cycle->TIESCALAR( [ qw( first second third ) ] );

However, since I didn’t use tie, all I get is the object, and Perl doesn’t know anything about the special interface. It’s just a normal object.

In Tie::Cycle (available on CPAN), the start of the module is quite simple. I have to declare the package name, set up the usual module bits, and define my TIESCALAR. I chose to set up the interface to take two arguments: the class name and an anonymous array. There isn’t anything special in that choice. TIESCALAR is going to get all of the arguments from tie and it’s up to me to figure out how to deal with them, including how to enforce the interface.

In this example, I’m simple-minded: I ensure that I have an array reference and that it has more than one argument. Like any other constructor, I return a blessed reference. Even though I’m tying a scalar, I use an anonymous array as my object. Perl doesn’t care what I do as long as I’m consistent. I call the internal STORE method from TIESCALAR so I only have that logic in one place:

package Tie::Cycle;
use strict;

our $VERSION = '1.19';

use Carp qw(carp);

use constant CURSOR_COL => 0;
use constant COUNT_COL  => 1;
use constant ITEM_COL   => 2;

sub _cursor  { $_[0]->[CURSOR_COL] }
sub _count   { $_[0]->[COUNT_COL] }
sub _item    { $_[0]->[ITEM_COL][ $_[1] // $_[0]->_cursor ] }

sub TIESCALAR {
    my( $class, $list_ref ) = @_;
    my $self = bless [], $class;

    unless( $self->STORE( $list_ref ) ) {
        carp "The argument to Tie::Cycle must be an array reference";
        return;
        }

    return $self;
    }

Once I have my tied variable, I use it just like I would any other variable of that type. I use my tied scalar just like any other scalar. I already stored an anonymous array in the object, but if I wanted to change that, I simply assign to the scalar. In this case, I have to assign an anonymous array:

$colors = [ qw(FF0000 00FF00 0000FF) ];

Behind the curtain, Perl calls my STORE method when I assign to the variable. Again, I don’t get to choose this method name, and I have to handle everything myself:

sub STORE {
    my( $self, $list_ref ) = @_;
    return unless ref $list_ref eq ref [];
    my @shallow_copy = map { $_ } @$list_ref;

    $self->[CURSOR_COL] = 0;
    $self->[COUNT_COL]  = scalar @shallow_copy;
    $self->[ITEM_COL]   = \@shallow_copy;
    }

Every time I try to get the value of the scalar, Perl calls FETCH. As before, I have to do all of the work to figure out how to return a value. I can do anything that I like as long as I return a value. In Tie::Cycle, I have to figure out which index I need to access, then return that value. I increment the index, figure out the index modulo the number of elements in the array, then return the right value:

sub FETCH {
    my( $self ) = @_;

    my $index = $self->[CURSOR_COL]++;
    $self->[CURSOR_COL] %= $self->_count;

    return $self->_item( $index );
    }

That’s all I have to do. I could create an UNTIE (or DESTROY) method, but I didn’t create any messes I have to clean up so I don’t do that for Tie::Cycle. There isn’t any additional magic for those. Everything that you already know about DESTROY works the same here.

If you look in the actual Tie::Cycle source, you’ll find additional methods. I can’t get to these through the tie interface, but with the object form I can. They aren’t part of the tie magic, but since it’s really just an object I can do object-oriented sorts of things, including adding methods. For example, the previous method gets me the previous value from the list without affecting the current index. I can peek without changing anything:

my $previous = tied( $colors )->previous;

The tied gets me the secret object and I immediately call a method on it instead of storing it in a variable. I can do the same thing, using next to peek at the next element:

my $next     = tied( $colors )->next;

And, as I showed earlier, I can reset the cycle:

tied( $colors )->reset;

I’ll create a tied scalar that sets an upper bound on the magnitude of the integer, meaning that there is some range around zero that I can store in the variable. To create the class to implement the tie, I do the same thing I had to do for Tie::Cycle: create TIESCALAR, STORE, and FETCH routines:

package Tie::BoundedInteger;
use strict;

use Carp qw(croak);

use vars qw( $VERSION );

$VERSION = 1.0;

sub TIESCALAR {
    my $class = shift;
    my $value = shift;
    my $max   = shift;

    my $self = bless [ 0, $max ], $class;

    $self->STORE( $value );

    return $self;
    }

sub FETCH { $_[0]->[0] }

sub STORE {
    my $self  = shift;
    my $value = shift;

    my $magnitude = abs $value;

    croak( "The [$value] exceeds the allowed limit [$self->[1]]" )
        if( int($value) != $value || $magnitude > $self->[1] );

    $self->[0] = $value;

    $value;
    }

1;

At the user level, I do the same thing I did before. I call tie with the variable name, the class that implements the behavior, and finally the arguments. In this program, I want to start off with the value 1, and set the magnitude limit to 3. Once I do that, I’ll try to assign $number each of the integer values between -5 and 5, then print what happened:

#!/usr/bin/perl

use Tie::BoundedInteger;

tie my $number, 'Tie::BoundedInteger', 1, 3;

foreach my $try ( -5 .. 5 ) {
    my $value =  eval { $number = $try };

    print "Tried to assign [$try], ";
    print "but it didn't work, " unless $number == $try;
    print "value is now [$number]\n";
    }

From the output I can see that I start off with the value 1 in $number, but when I try to assign -5 (a value with a magnitude greater than 3), it doesn’t work and the value is still 1. Normally my program would croak right there, but I used an eval to catch that error. The same thing happens for -4. When I try -3, it works.

Tried to assign [-5], but it didn't work, value is now [1]
Tried to assign [-4], but it didn't work, value is now [1]
Tried to assign [-3], value is now [-3]
Tried to assign [-2], value is now [-2]
Tried to assign [-1], value is now [-1]
Tried to assign [0], value is now [0]
Tried to assign [1], value is now [1]
Tried to assign [2], value is now [2]
Tried to assign [3], value is now [3]
Tried to assign [4], but it didn't work, value is now [3]
Tried to assign [5], but it didn't work, value is now [3]

My Tie::BoundedInteger example changed how I could store values by limiting their values. I can also change how I fetch the values. In this example, I’ll create Tie::Timely, which sets a lifetime on the value. After that lifetime expires, I’ll get undef when I access the value.

The STORE method is easy. I just store whatever value I get. I don’t care if it’s a simple scalar, a reference, an object, or anything else. Every time I store a value, though, I’ll record the current time too. That way every time I change the value I reset the countdown.

In the FETCH routine, I have two things I can return. If I’m within the lifetime of the value, I return the value. If I’m not, I return nothing at all:

package Tie::Timely;
use strict;

use Carp qw(croak);

use vars qw( $VERSION );

$VERSION = 1.0;

sub TIESCALAR {
    my $class      = shift;
    my $value      = shift;
    my $lifetime   = shift;

    my $self = bless [ undef, $lifetime, time ], $class;

    $self->STORE( $value );

    return $self;
    }

sub FETCH { time - $_[0]->[2] > $_[0]->[1] ? () : $_[0]->[0] }

sub STORE { @{ $_[0] }[0,2] = ( $_[1], time ) }

1;

When I talked about tying scalars, I showed my Tie::Cycle module, which treated an array like a scalar. To be fair, I should go the other way by treating a scalar as an array. Instead of storing several array elements, each of which incurs all of the overhead of a scalar variable, I’ll create one scalar and chop it up as necessary to get the array values. Essentially, my example trades memory space for speed. I’ll reuse my bounded integer example since I can make a number less than 256 fit into a single character. That’s convenient, isn’t it?

package Tie::StringArray;
use strict;

use Carp qw(croak);

use vars qw( $VERSION );

$VERSION = 1.0;

sub _null { "\x00" }
sub _last () { $_[0]->FETCHSIZE - 1 }

sub _normalize_index { $_[1] == abs $_[1] ? $_[1] : $_[0]->_last + 1 - abs $_[1] }

sub _store  { chr $_[1] }
sub _show   { ord $_[1] }
sub _string { ${ $_[0] } }

sub TIEARRAY {
    my( $class, @values ) = @_;

    my $string = '';
    my $self = bless \$string, $class;

    my $index = 0;

    $self->STORE( $index++, $_ ) foreach ( @values );

    $self;
    }

sub FETCH {
    my $index = $_[0]->_normalize_index( $_[1] );

    $index > $_[0]->_last ? () : $_[0]->_show(
        substr( $_[0]->_string, $index, 1 )
        );
    }

sub FETCHSIZE { length $_[0]->_string }

sub STORESIZE {
    my $self     = shift;
    my $new_size = shift;

    my $size = $self->FETCHSIZE;

    if( $size > $new_size ) { # truncate
        $$self = substr( $$self, 0, $size );
        }
    elsif( $size < $new_size ) { # extend
        $$self .= join '', ($self->_null) x ( $new_size - $size );
        }
    }

sub STORE {
    my $self  = shift;
    my $index = shift;
    my $value = shift;

    croak( "The magnitude of [$value] exceeds the allowed limit [255]" )
        if( int($value) != $value || $value > 255 );

    $self->_extend( $index ) if $index >= $self->_last;

    substr( $$self, $index, 1, chr $value );

    $value;
    }

sub _extend {
    my $self  = shift;
    my $index = shift;

    $self->STORE( 0, 1 + $self->_last )
        while( $self->_last >= $index );
    }

sub EXISTS  { $_[0]->_last >= $_[1] ? 1 : 0 }
sub CLEAR   { ${ $_[0] } = '' }

sub SHIFT   { $_[0]->_show( substr ${ $_[0] }, 0, 1, '' ) }
sub POP     { $_[0]->_show( chop   ${ $_[0] }           ) }

sub UNSHIFT {
    my $self = shift;

    foreach ( reverse @_ ) {
        substr ${ $self }, 0, 0, $self->_store( $_ )
        }
    }

sub PUSH {
    my $self = shift;

    $self->STORE( 1 + $self->_last, $_ ) foreach ( @_ )
    }

sub SPLICE
    {
    my $self      = shift;

    my $arg_count = @_;
    my( $offset, $length, @list ) = @_;

    if(    0 == $arg_count ) {
        ( 0, $self->_last )
        }
    elsif( 1 == $arg_count ) {
        ( $self->_normalize_index( $offset ), $self->_last )
        }
    elsif( 2 <= $arg_count ) { # offset and length only
        ( $self->_normalize_index( $offset ), do {
            if( $length < 0 ) { $self->_last - $length }
            else              { $start + $length - 1   }
            }
        )
        }

    #@removed = map { $self->POP } $start .. $end;


    if( wantarray ) {
        @removed;
        }
    else {
        defined $removed[-1] ? $removed[-1] : undef;
        }

    }

1;

To make this work, I’ll treat each position in my string as an array element. To store a value, In STORE the arguments are the index for the value and the value itself. I need to convert the value to a character and put that character in the right position in the string. If I try to store something other than a whole number between 1 and 255, I get an error.

To fetch a value I need to extract the character from the correct position in the string and convert it to a number. The argument to FETCH is the index of the element so I need to convert that to something I can use with substr.

Now, for the more complex array operations, I have to do a bit more work. To retrieve a splice, I have to grab several values, but splice is also an lvalue so I have to be ready to assign those positions more values. Not only that, a user might assign fewer or more values than the splice extracts, so I have to be ready to shrink or expand the string. That’s not scary, though, since I can already do all of that with a string by using substr.

Deleting an element is a bit trickier. In a normal array I can have an undefined element. How am I going to handle that in the middle of a string? Amazingly, my example left me a way to handle this: I can store a undef as a null byte. If I had to store numbers between 0 and 255, I would have been in trouble. Curious how that works out.

Perl also lets me extend a tied array. In a normal array, I can extend an array to let Perl know I want it to do the work to make a certain number of elements available (thus explicitly circumventing Perl’s built-in logic to make its best guess about the proper array length). In this example, I just need to extend the string.

I contrived that last example so I could show the whole process without doing anything too tricky. I might want to store an array of characters, and that example would work quite well for that. Now I want to adapt it to store a DNA sequence. My domain changes from 256 things to something much smaller, the set { T C G A }, which represents thymine, cytosine, guanine, and adenine. If I add in the possibility of a NULL (maybe my gene sequencer can’t tell what should be in a particular position), I have five possibilities. I don’t need an entire character for that. I can actually get by with three bits and have a little to spare.

Before I get too deeply into this, let me make a guess about how much memory this can save. A typical DNA sequence has several thousand base pairs. If I used an array for that, I’d have the scalar overhead for each one of those base pairs as a separate scalar. I’ll say that’s 10 bytes, just to be kind. For 10,000 base pairs, which is just a small sequence, that’s 100,000 bytes. That scalar overhead really starts to add up! Now, instead of that, I’ll store everything in a single scalar. I’ll incur the scalar overhead once. For 10,000 base pairs at three bits a pair, that’s 30,000 bits, or 3,750 bytes. I round that off to 4,000 bytes. That’s a factor of 25! Remember, this memory parsimony comes at the expense of speed. I’ll have to do a little bit more computational work.

With six bits I have eight distinct patterns. I need to assign some of those patterns meanings. Fortunately for me, Perl makes this really easy since I can type out binary strings directly as long as I’m using Perl 5.6 or later (see Chapter 16 for more on bit operations):

use constant N => 0b000;
use constant T => 0b001;
use constant C => 0b100;
use constant G => 0b110;
use constant A => 0b011;

use constant RESERVED1 => 0b111;
use constant RESERVED2 => 0b101;

Also, since I’m not using characters anymore, I can’t use substr. For vec, I’d have to partition the bits by powers of two, but I’d have to waste another bit for that (and I’m already wasting two). If I do that, I end up with 10 unused patterns. That might be nice if we eventually meet aliens with more complex hereditary encodings, but for now I’ll just stick with what we have.

Before you get scared off by this code, remember what I’m doing. It’s exactly the same problem as the last example where I stored digits as characters in a long string. This time I’m doing it at the bit level with a some more math. My specific example doesn’t matter as much as the concept that I can make anything, and I mean anything, look like an array if I’m willing to do all the work.

package Tie::Array::DNA;
use strict;
use parent qw(Tie::Array);

use Carp qw(croak carp);

use vars qw( $VERSION );
$VERSION = 1.0;

use constant BITS_PER_ELEMENT =>  3;
use constant BIT_PERIOD       => 24; # 24 bits
use constant BYTE_LENGTH      =>  8;
use constant BYTE_PERIOD      =>  3; # 24 bits

my %Patterns = (
    T => 0b001,
    A => 0b011,
    C => 0b100,
    G => 0b110,
    N => 0b000,
    );
my @Values   = ();
foreach my $key ( keys %Patterns ) {
    $Values[ $Patterns{$key} ] = $key
    }

sub _normalize { uc $_[1] }
sub _allowed   { length $_[1] eq 1 and $_[1] =~ tr/TCGAN// }

my %Last;

sub TIEARRAY {
    my( $class, @values ) = @_;

    my $string = \'';
    my $self = bless $string, $class;

    $$self = "\x00" x 10_000;
    $Last{ "foo" } = -1;

    my $index = 0;

    $self->STORE( $index++, $_ ) foreach ( @values );

    $self;
    }

sub _get_start_and_length {
    my( $self, $index ) = @_;

    my $bytes_to_start = int( $index * BITS_PER_ELEMENT / BYTE_LENGTH );

    my $byte_group = int( $bytes_to_start / BYTE_PERIOD );

    my $start  = $byte_group * BYTE_PERIOD;

    ( $start, BYTE_PERIOD )
    }

sub _get_bytes {
    my( $self, $index ) = @_;

    my( $start, $length ) = $self->_get_start_and_length( $index );

    my @chars = split //, substr( $$self, $start, $length );

    (ord( $chars[0] ) << 16) +
        (ord( $chars[1] ) << 8) +
            ord( $chars[2] );
    }

sub _save_bytes {
    my( $self, $index, $bytes ) = @_;

    my( $start, $length ) = $self->_get_start_and_length( $index );

    my $new_string = join '', map {
        chr(
            ( $bytes & ( 0xFF << $_ ) )
            >>
            $_
            )
        } qw( 16 8 0 );

    substr( $$self, $start, $length, $new_string );
    }

sub _get_shift
    {
    BIT_PERIOD - BITS_PER_ELEMENT - ($_[1] * BITS_PER_ELEMENT % BIT_PERIOD);
    }

sub _get_clearing_mask
    { ~ ( 0b111 << $_[0]->_get_shift( $_[1] ) ) }

sub _get_setting_mask
    { $_[0]->_get_pattern_by_value( $_[2] ) << $_[0]->_get_shift( $_[1] ) }

sub _get_selecting_mask
    { 0b111 << $_[0]->_get_shift( $_[1] ) }

sub _get_pattern_by_value {   $Patterns{ $_[1] }   }
sub _get_null_pattern     {   $Patterns{ 'N'   }   }

sub _get_value_by_pattern {   $Values  [ $_[1] ]   }

sub _string    { $_[0] }

sub _length { length ${$_[0]} }

sub _add_to_string { ${$_[0]} .= $_[1] }

sub STORE {
    my( $self, $index, $value )  = @_;

    $value = $self->_normalize( $value );

    carp( qq|Cannot store unallowed element "$value"| )
        unless $self->_allowed( $value );

    $self->_extend( $index ) if $index > $self->_last;

    # get the mask
    my $clear_mask  = $self->_get_clearing_mask( $index );
    my $set_mask    = $self->_get_setting_mask( $index, $value );

    # clear the area
    my $result = ( $self->_get_bytes( $index ) & $clear_mask ) | $set_mask;

    # save the string
    my( $start, $length ) = $self->_get_start_and_length( $index );

    my $new_string = join '', map {
        chr(
            ( $result & ( 0xFF << $_ ) )
            >>
            $_
            )
        } qw( 16 8 0 );

    substr( $$self, $start, $length, $new_string );

    $self->_set_last( $index ) if $index > $self->_last;

    $value
    }

sub FETCH {
    my( $self, $index ) = @_;

    # get the right substr
    my $bytes = $self->_get_bytes( $index );

    # get the mask
    my $select_mask  = $self->_get_selecting_mask( $index );
    my $shift        = $self->_get_shift( $index );

    # clear the area
    my $pattern = 0 + ( ( $bytes & $select_mask ) >> $shift );

    $self->_get_value_by_pattern( $pattern );
    }

sub FETCHSIZE { $_[0]->_last + 1 }
sub STORESIZE { $_[0]->_set_last( $_[1] ) }

sub EXTEND  { }
sub CLEAR   { ${ $_[0] } = '' }
sub EXISTS  { $_[1] < $Last{ "foo" }  }

sub DESTROY { }

__PACKAGE__;

This code gets a bit complicated because I have to implement my own array. Since I’m storing everything in a single string, and using the string as a long string of bits instead of characters, I have to come up with a way to get the information that I need.

I’m using three bits per element and characters come with eight bits. To make everything simpler, I decide to deal with everything in three-byte (24-bit) chunks because that’s the lowest common denominator between three-bit and eight-bit chunks of data. I do that in _get_bytes and _save_bytes, which figure out which three characters they need to grab. The _get_bytes method turns the three characters into a single number so I can later use bit operations on it, and the _save_bytes method goes the other way.

Once I have the number, I need to know how to pull out the three bits. There are eight elements in each group, so _get_selecting_mask figures out which of those elements I want and returns the right bit mask to select it. That bit mask is just 0b111 shifted up the right number of places. The _get_shift method handles that in general by using the constants BIT_PERIOD and BITS_PER_ELEMENT.

Once I got all of that in place, my FETCH method can use it to return an element. It gets the bit pattern then looks up that pattern with _get_value_by_pattern to turn the bits into the symbolic version (i.e. T, A, C, G ).

The STORE method does all that but the other way around. It turns the symbols into the bit pattern, shifts that up the right amount, and does the right bit operations to set the value. I ensure that I clear the target bits first using the mask, I get back from _get_clearing_mask. Once I clear the target bits I can use the bit mask from _get_setting_mask to finally store the element.

Whew! Did you make it this far? I haven’t even implemented all of the array features. How am I going to implement SHIFT, UNSHIFT, or SPLICE? Here’s a hint: remember that Perl has to do this for real arrays and strings. Instead of moving things over every time I affect the front of the data, it keeps track of where it should start, which might not be the beginning of the data. If I wanted to shift off a single element, I just have to add that offset of three bits to all of my computations. The first element would be at bits 3 to 5 instead of 0 to 2. I’ll leave that up to you, though.