lecture in color

Perl Abstractions

while you might think that we're functioning "at a high level of abstraction", so far everything we have written has corresponded directly with what actually happens.
There are true abstractions in Perl: situations in which what you write corresponds only loosely with what happens.

Three abstractions

pseudo-hashes: seem to work like hashes, but keys are scoped so that using an improper key causes a runtime error.
ties: associate arrays, hashes, and scalars with other structures in memory or on disk.
objects: have automatically called methods to accomplish many tasks.
overloading: allows definition of what it means to add, subtract, increment class instances, etc.

Pseudo-hashes

Hash tables make poor implementations of C++ structures with static elements.
Too much memory use if keys don't change.
Answer (or simple hack): pseudo-hashes.
Pseudo-hashes are references to array in which the first element is a hash that describes the offsets of the other elements. E.g.,
```
 $a = [ { 'name'=>1, 'weight'=>2, 'age'=>3 }, 'Homer Simpson', 250, 50 ] ; 
```
The "magic" of pseudo-hashes is that
- $a->[1] is also known as $a->{name}
- $a->[2] is also known as $a->{weight}
- $a->[3] is also known as $a->{age}
This is a really simple mapping and can easily be spoiled.
- one must declare the offset of a reference via, e.g.,
```
 $a->[0]->{'phone'}=4; 
```
  before referring to an element.
- one can't splice a pseudo-hash, because the offsets of members will remain the same in the spliced array.
The advantage is that there's one simple hash that maps names to indices that can be shared by multiple pseudo-hashes.

Ties

generalization of the pseudo-hash concept.
map operations on hashes, arrays, scalars, or filehandles to anything whatever.
Perl calls this magic, which is a technical term for anything that disguises a complex external process in a simple syntax.

Tying a scalar

define special methods TIESCALAR, FETCH, and STORE.
TIESCALAR: called when scalar is tied.
FETCH: called when user reads the value.
STORE: called when user writes the value.
place them in a class.
tie class to a specific variable.

Example of scalar tying:

Consider the code (from PP chapter 14)

contents of perl_abs/centsible...
#! /var/local/couch/bin/perl 

package Centsible; 
sub TIESCALAR { bless \my $self, shift } 
sub STORE { 
   $Centsible::realvalue=${$_[0]}; 
   ${ $_[0] } = $_[1] 
} 
sub FETCH { 
   $Centsible::realvalue=${$_[0]}; 
   sprintf "%.02f", ${ my $self = shift } 
} 

package main; 

sub foo { 
    print "tie=${$_[0]}\n"; 
    ${$_[0]} = 60; 
    print "tie=${$_[0]}\n"; 
} 
tie $bucks, "Centsible"; 
$bucks = 45.0089382; 
$foo = tied $bucks; 
print "FETCH of foo =" . $foo->FETCH . "\n"; 
# print "FETCH of bucks = " . $bucks->FETCH . "\n"; # doesn't work
foo(\$bucks); 
print "realvalue = $Centsible::realvalue\n"; 
$bucks += 0; 
print "realvalue = $Centsible::realvalue\n"; 
$bucks *= 1.0715; # tax
print "realvalue = $Centsible::realvalue\n"; 
$bucks *= 1.0715; # tax on tax 
print "realvalue = $Centsible::realvalue\n"; 
print "That will be $bucks, please!\n"; 
...end of perl_abs/centsible

This produces

contents of perl_abs/centsible.out...
realvalue = 
realvalue = 45.0089382
realvalue = 45.01
realvalue = 48.228215
That will be 51.68, please!
...end of perl_abs/centsible.out

Advanced example: persistent file-storage of string

Consider the code (from PP chapter 14)

contents of perl_abs/ScalarFile.pm...
#! /var/local/couch/bin/perl 

package ScalarFile; 

use strict; 

sub TIESCALAR { 
    my $class = shift; 
    my $filename = shift; 
    # create filename if doesn't exist. 
    my $fh; # placeholder for unique filehandle
    if (open $fh, "<", $filename 
     or open $fh, ">", $filename) { 
	close $fh; 
	$ScalarFile::count++; 	# one more of these 
	return bless \$filename, $class; 
    } else { 
	return undef; 	# failure
    } 
} 

sub FETCH { 
    my $self = shift; 
    return unless open my $fh, $$self; 
    read($fh, my $value, -s $fh) ; 
    return $value; 
} 

sub STORE { 
    my ($self,$value) = @_; 
    open my $fh, ">", $$self or die "can't write to  $$self: $!"; 
    syswrite($fh, $value) == length $value
	or die "can't syswrite: $!"; 
    close $fh; 
    return $value; 
} 

sub DESTROY { 
    my $self = shift; 
    $ScalarFile::count--; 
} 

sub count { $ScalarFile::count } 

1; 
...end of perl_abs/ScalarFile.pm

And use this via

contents of perl_abs/ScalarFile.pl...
#! /var/local/couch/bin/perl 

use ScalarFile; 

tie ($string, "ScalarFile", "ScalarFile.data"); 
print "string=$string\n"; 
print "Enter a new string: "; my $newstring = <STDIN>; 
$string = $newstring; 
...end of perl_abs/ScalarFile.pl

This prints

contents of perl_abs/ScalarFile.pl.out...
lin09{couch}86: ScalarFile.pl
string=
Enter a new string: yo
lin09{couch}87: ScalarFile.pl
string=yo

Enter a new string: merry spring break
lin09{couch}88: ScalarFile.pl
string=merry spring break

Enter a new string: alas, poor yorick
lin09{couch}89: 
...end of perl_abs/ScalarFile.pl.out

What constitutes a scalar:

TIESCALAR: ability to initialize
FETCH: ability to read a value
STORE: ability to update a value
DESTROY: ability to clean up after use

What constitutes an array:

TIEARRAY: create one.
FETCH: fetch a value.
STORE: store a value.
DESTROY: clean up afterward.
FETCHSIZE: return number of elements.
STORESIZE: set number of elements.
EXTEND: increase size to given number of elements.
EXISTS: whether an array element exists or not.
DELETE: delete an element (make it not exist).
CLEAR: make the array contain no data.
PUSH: push data into array at top.
POP: pop data off top.
SHIFT: remove data from bottom of array.
UNSHIFT: add data at bottom of array.
SPLICE: array splicing.

Array tying:

decide how you want behavior to differ from that of a regular array.
implement any methods in which you want differing behavior.
inherit all other methods from Tie::StdArray (the default array behavior).

Example: an array of numbers with default value

Consider:

contents of perl_abs/DefArray.pm...
#! /var/local/couch/bin/perl 

package DefArray; 

# this package implements a hash whose elements are never empty. 
# Any elements that don't exist are assigned a given default value. 

use Tie::Array; 

our @ISA = qw(Tie::StdArray); 
our $DEF = 0x7fffffff; 

sub TIEARRAY { 
    my $class = shift; 
    return bless [], $class; 
} 

sub EXISTS { 
    my $self = shift; 
    my $index = shift; 
    return undef if $index >= @$self; 
    return 1 if exists($self->[$index]); 
    return undef; 
} 

sub FETCH { 
    my $self = shift; 
    my $index = shift; 
    return $DEF if ! exists $self->[$index]; 
    return $self->[$index]; 
} 

1; 
...end of perl_abs/DefArray.pm

And call it with:

contents of perl_abs/DefArray.pl...
#! /var/local/couch/bin/perl 
use DefArray; 
tie @array, 'DefArray';
$array[5] = 0;
print "array[5]=$array[5]\n"; 
print "array[2]=$array[2]\n"; 
foo(\@array); 
print "array[3]=$array[3]\n"; 

sub foo { 
    my $array = shift; 
    print "array[5]=$array->[5]\n"; 
    $array->[3]=16; 
} 
...end of perl_abs/DefArray.pl

This prints:

contents of perl_abs/DefArray.pl.out...
array[5]=0
array[2]=2147483647
...end of perl_abs/DefArray.pl.out

What constitutes a hash?

TIEHASH: create one.
FETCH: fetch a value.
STORE: store a value.
DELETE: delete a value.
CLEAR: make the array contain no data.
EXISTS: whether an array element exists or not.
FIRSTKEY: return the first key of a hash.
NEXTKEY: return the next key of a hash.
DESTROY: clean up afterward.

Strategy for tying a hash

decide upon deviant behavior
implement required methods.
inherit rest from Tie::StdHash.

What you've always wanted (for a2)

Here's the basis of an edge class where all unknown edges are infinite!

Consider:

contents of perl_abs/DefHash.pm...
#! /var/local/couch/bin/perl 

package DefHash; 

# this package implements a hash whose elements are never empty. 
# Any elements that don't exist are assigned a given default value. 

use Tie::Hash; 

our @ISA = qw(Tie::StdHash); 
our $DEF = 0x7fffffff; 

sub TIEHASH { 
    my $class = shift; 
    return bless {}, $class; 
} 

sub EXISTS { 
    my $self = shift; 
    my $key = shift; 
    return 1 if exists($self->{$key}); 
    return undef; 
} 

sub FETCH { 
    my $self = shift; 
    my $key = shift; 
    return $DEF if ! exists $self->{$key}; 
    return $self->{$key}; 
} 

1; 
...end of perl_abs/DefHash.pm

And call it with:

contents of perl_abs/DefHash.pl...
#! /var/local/couch/bin/perl 

use DefHash; 

tie %hash, 'DefHash';
$hash{'boston'} = 0;
print "hash{boston}=$hash{'boston'}\n"; 
print "hash{cleveland}=$hash{'cleveland'}\n"; 
...end of perl_abs/DefHash.pl

This prints:

contents of perl_abs/DefHash.pl.out...
hash{boston}=0
hash{cleveland}=2147483647
...end of perl_abs/DefHash.pl.out

Extreme power: a hash that remembers history

Consider the code:

contents of perl_abs/TimeHash.pm...
#! /var/local/couch/bin/perl 

package TimeHash; 

# this package implements a hash whose elements are never empty. 
# Any elements that don't exist are assigned a given default value. 

use Tie::Hash; 

our @ISA = qw(Tie::StdHash); 
our $DEF = 0x7fffffff; 

sub TIEHASH { 
    my $class = shift; 
    return bless {}, $class; 
} 

sub FETCH { 
    my $self = shift; 
    my $key = shift; 
    return undef if ! exists $self->{$key}; 
    return $self->{$key}->[0]; 
} 

sub STORE { 
    my $self = shift; 
    my $key = shift; 
    my $value = shift; 
    unshift(@{$self->{$key}},$value); 
} 

sub DELETE { 
    my $self = shift; 
    my $key = shift; 
    return if ! exists $self->{$key}; 
    shift @{$self->{$key}}; 
    delete $self->{$key} if @{$self->{$key}} == 0; 
} 

1; 
...end of perl_abs/TimeHash.pm

Call this with:

contents of perl_abs/TimeHash.pl...
#! /var/local/couch/bin/perl 

use TimeHash; 

tie %hash, 'TimeHash';
$hash{'boston'} = 275; 
print "hash{boston}=$hash{'boston'}\n"; 
$hash{'boston'} = 'cat'; 
print "hash{boston}=$hash{'boston'}\n"; 
delete $hash{'boston'}; 
print "hash{boston}=$hash{'boston'}\n"; 
delete $hash{'boston'}; 
print "hash{boston}=$hash{'boston'}\n"; 
...end of perl_abs/TimeHash.pl

and it prints:

contents of perl_abs/TimeHash.pl.out...
hash{boston}=275
hash{boston}=cat
hash{boston}=275
hash{boston}=
...end of perl_abs/TimeHash.pl.out

Old values are remembered and restored by delete.

What constitutes a filehandle?

TIEHANDLE: create one.
TELL: describe filehandle position.
SEEK: seek to a position.
PRINTF: call printf to a handle.
READ: do a read of data from the handle.
WRITE: do a write of data to the handle.
EOF: whether the file is at EOF.
BINMODE: whether to utilize raw mode or not.
FILENO: returns the file descriptor number of the handle.
DESTROY: how to destroy one when no longer needed.

Ties to databases

most powerful feature: tie a hash to a database.
FETCH does a query.
STORE does a change.
at all times, content is persistent.

A simple database tie

Call this:

contents of perl_abs/DBHash1.pl...
#! /var/local/couch/bin/perl 

use GDBM_File;
tie(%PREFS, 'GDBM_File', './DBHash.data', 1, 0);
$PREFS{'Couch'} = 'Cheese'; 
$PREFS{'Panetta'} = 'Chocolate'; 
untie(%PREFS);


...end of perl_abs/DBHash1.pl

and then call this:

contents of perl_abs/DBHash2.pl...
#! /var/local/couch/bin/perl 

use GDBM_File;
tie(%PREFS, 'GDBM_File', './DBHash.data', 1, 0);
print "Couch prefers $PREFS{'Couch'}\n"; 
print "Panetta prefers $PREFS{'Panetta'}\n"; 
untie(%PREFS);


...end of perl_abs/DBHash2.pl

to print:

contents of perl_abs/DBHash2.pl.out...
Couch prefers Cheese
Panetta prefers Chocolate
...end of perl_abs/DBHash2.pl.out

This works even though the writing and reading statements are in different processes!

Watch out!

Every tie operation has preconditions and postconditions.
Preconditions: how we must limit the use of a tie so that it works properly.
Postconditions: what privilege we will enjoy if we obey the preconditions.
In the defaulting ties above, content could potentially be anything.
In a database tie, content must be a string.

The point

In C++, objects came before abstractions.
In Perl, it was the other way around.
Ties came first.
Object-oriented programming followed the same pattern.

Objects

Nothing more than a generalization of the tie mechanism.
Several methods implicitly invoked.

Predefined classes:

The class UNIVERSAL.
- base class for all Perl objects
- methods:
  - isa("packagename"): whether this object inherits methods from the given package.
  - can("methodname"): whether there is a method with the given name.
Pseudo-class SUPER
- in a method, SUPER::thing refers to the thing in the first class listed in @ISA.

Methods with implicit invocation

DESTROY frees resources associated with an instance of a package. E.g., open filehandles.
AUTOLOAD tries to define undefined subroutines in a package, or bombs if it can't.

Autoloading accessors

Consider:

contents of perl_abs/Auto1.pm...
#! /var/local/couch/bin/perl 

package Auto1; 
use strict; 
our $AUTOLOAD; 
use Data::Dumper; 

sub new { shift; return bless {@_}; } 

sub AUTOLOAD { 
    print "autoloading $AUTOLOAD\n"; 
    print "parameters=". Dumper(\@_); 
    return if $AUTOLOAD=~/::DESTROY$/; 
    foreach my $field qw(name rank serial) { 
	return $_[0]->{$field} if $AUTOLOAD =~ /.*::$field$/; 
    } 
    return undef;
} 

1; 
...end of perl_abs/Auto1.pm

Call this with:

contents of perl_abs/Auto1.pl...
#! /var/local/couch/bin/perl 

use Auto1; 
my $t = new Auto1; 
$t->{'name'} = 'frank'; 
print "name is " . $t->name . "\n"; 
...end of perl_abs/Auto1.pl

This prints:

contents of perl_abs/Auto1.pl.out...
autoloading Auto1::name
parameters=$VAR1 = [
          bless( {
                   'name' => 'frank'
                 }, 'Auto1' )
        ];
name is frank
autoloading Auto1::DESTROY
parameters=$VAR1 = [
          bless( {
                   'name' => 'frank'
                 }, 'Auto1' )
        ];
...end of perl_abs/Auto1.pl.out

Another example:

Consider:

contents of perl_abs/Auto2.pm...
#! /var/local/couch/bin/perl 

package Auto2; 
use strict; 
no strict "refs"; 
our $AUTOLOAD; 
our %FIELDS = ( 'name'=>1, 'rank'=>1, 'serial'=>1 ); 
use Data::Dumper; 

sub new { shift; return bless {@_}; } 

sub AUTOLOAD { 
    print "autoloading $AUTOLOAD\n"; 
    print "arguments=" . Dumper(\@_); 
    return if $AUTOLOAD=~/::DESTROY$/; 
    my $autoload = $AUTOLOAD; $autoload =~ s/^.*:://; 
    if (! $FIELDS{$autoload}) { 
        print "invalid request for field '$autoload'\n"; 
	return; 
    } 
    eval "sub $autoload :lvalue { \$_[0]->{'$autoload'} }"; 
    goto &$autoload; 
} 

1; 
...end of perl_abs/Auto2.pm

Call this with:

contents of perl_abs/Auto2.pl...
#! /var/local/couch/bin/perl 

use Auto2; 
my $t = new Auto2; 
$t->{'name'} = 'frank'; 
print "name is " . $t->name . "\n"; 
...end of perl_abs/Auto2.pl

This prints:

contents of perl_abs/Auto2.pl.out...
autoloading Auto2::name
arguments=$VAR1 = [
          bless( {
                   'name' => 'frank'
                 }, 'Auto2' )
        ];
name is frank
autoloading Auto2::DESTROY
arguments=$VAR1 = [
          bless( {
                   'name' => 'frank'
                 }, 'Auto2' )
        ];
...end of perl_abs/Auto2.pl.out

As a finely tuned example,

Consider:

contents of perl_abs/Auto3.pm...
#! /var/local/couch/bin/perl 

package Auto3; 
use strict; 
no strict "refs"; 
our $AUTOLOAD; 
our %FIELDS = ( 'name'=>1, 'rank'=>1, 'serial'=>1 ); 
use Data::Dumper; 

sub new { shift; return bless {@_}; } 

sub AUTOLOAD :lvalue { 
    print "autoloading $AUTOLOAD\n"; 
    print "arguments=" . Dumper(\@_); 
    return if $AUTOLOAD=~/::DESTROY$/; 
    my $autoload = $AUTOLOAD; $autoload =~ s/^.*:://; 
    if (! $FIELDS{$autoload}) { 
        print "invalid request for field '$autoload'\n"; 
	return; 
    } 
    $_[0]->{$autoload}=$_[1] if defined $_[1]; 
    $_[0]->{$autoload}
} 

1; 
...end of perl_abs/Auto3.pm

Call this with:

contents of perl_abs/Auto3.pl...
#! /var/local/couch/bin/perl 

use Auto3; 
my $t = new Auto3(name=>'frank', 'serial'=>2, 'rank'=>'corporal'); 
print "name is " . $t->name . "\n"; 
print "runt is " . $t->runt . "\n"; 
$t->name = 'george'; 
print "name is " . $t->name . "\n"; 
$t->serial(15); 
print "serial is " . $t->serial . "\n"; 
...end of perl_abs/Auto3.pl

This prints:

contents of perl_abs/Auto3.pl.out...
autoloading Auto3::name
arguments=$VAR1 = [
          bless( {
                   'serial' => 2,
                   'name' => 'frank',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
name is frank
autoloading Auto3::runt
arguments=$VAR1 = [
          bless( {
                   'serial' => 2,
                   'name' => 'frank',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
invalid request for field 'runt'
runt is 
autoloading Auto3::name
arguments=$VAR1 = [
          bless( {
                   'serial' => 2,
                   'name' => 'frank',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
autoloading Auto3::name
arguments=$VAR1 = [
          bless( {
                   'serial' => 2,
                   'name' => 'george',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
name is george
autoloading Auto3::serial
arguments=$VAR1 = [
          bless( {
                   'serial' => 2,
                   'name' => 'george',
                   'rank' => 'corporal'
                 }, 'Auto3' ),
          15
        ];
autoloading Auto3::serial
arguments=$VAR1 = [
          bless( {
                   'serial' => 15,
                   'name' => 'george',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
serial is 15
autoloading Auto3::DESTROY
arguments=$VAR1 = [
          bless( {
                   'serial' => 15,
                   'name' => 'george',
                   'rank' => 'corporal'
                 }, 'Auto3' )
        ];
...end of perl_abs/Auto3.pl.out

Overloading

just like overloading in C++, Java, etc.
with a twist: parameter swapping.
Suppose you have a class instance c.
- In C++, 6+c cannot be overloaded, but c+6 can.
- In Perl, 6+c is called as a method of c, with parameters swapped.

Example of overloading:

Consider:

contents of perl_abs/Rat.pm...
#! /var/local/couch/bin/perl 

package Rat; # rational number

use overload '+'  => \&rat_add,    # overload addition 
             '-'  => \&rat_sub,    # overload subtraction
             '""' => \&rat_string; # convert from Rat to string

sub NUMER { 0 } sub numer { $_[0]->[&NUMER] } 
sub DENOM { 1 } sub denom { $_[0]->[&DENOM] } 

sub new { 
    my $pack  = shift; 
    my $numer; my $denom; 
    $numer = shift; $numer=0 if ! defined $numer; 
    if ($numer =~ /\//) { 
        ($numer,$denom)= split(/\//, $numer); 
    } else { 
	$denom = shift; $denom=1 if ! defined $denom; 
    } 
    bless [$numer, $denom] 
} 

sub rat_add { 
    print "...calling rat_add...\n"; 
    my $r1 = shift; $r1 = new Rat($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat($r2) if ref $r2 eq ''; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    my $result = new Rat(
	($r1->numer*$r2->denom+$r2->numer*$r1->denom)/$gcd, 
        $r1->denom*$r2->denom/$gcd
    ); 
    return bless $result; 
} 

sub rat_sub { 
    print "...calling rat_sub...\n"; 
    my $r1 = shift; $r1 = new Rat($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat($r2) if ref $r2 eq ''; 
    my $swapped = shift; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    if ($swapped) { 
        print "...swapping subtraction...\n"; 
	return new Rat(
	    ($r2->numer*$r1->denom-$r1->numer*$r2->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } else { 
	return new Rat(
	    ($r1->numer*$r2->denom-$r2->numer*$r1->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } 
} 

# convert a thing to a string 
sub rat_string { 
    print "...calling rat_string...\n"; 
    my $self = shift; 
    return $self->numer . '/' . $self->denom; 
} 

# reduce a fraction to lowest terms
sub reduce { 
    my $self = shift; 
    my $gcd = &gcd($self->[&NUMER], $self->[&DENOM]); 
    $self->[&NUMER] /= $gcd; 
    $self->[&DENOM] /= $gcd; 
    return $self; 
} 

# compute the greatest common divisor (Euclid's method) 
sub gcd { 
    my $a = shift; my $b = shift; 
    if ($a < $b) { my $t = $a; $a = $b; $b = $t; } 
    my $r; while (($r = $a % $b)) { $a = $b; $b = $r; } 
    return $b; 
} 

1; 
...end of perl_abs/Rat.pm

Call this with:

contents of perl_abs/Rat.pl...
#! /var/local/couch/bin/perl 
use Rat; 
my $number = new Rat(1,2); 
print "number is " . $number . "\n"; 
$number += 2;          # $number += new Rat(2); 
print "number is " . $number . "\n"; 
$number += "2/3";      # $number += new Rat("2/3") 
print "number is " . $number . "\n"; 
$number = 2 - $number; 
print "number is " . $number . "\n"; 

...end of perl_abs/Rat.pl

This prints:

contents of perl_abs/Rat.pl.out...
...calling rat_string...
number is 1/2
...calling rat_add...
...calling rat_string...
number is 5/2
...calling rat_add...
...calling rat_string...
number is 19/6
...calling rat_sub...
...swapping subtraction...
...calling rat_string...
number is -7/6
...end of perl_abs/Rat.pl.out

Overloading capabilities

Can overload numeric, trig functions.
Can't overload ||, &&, ?:

Auto-generation

If you declare some overloads, perl will try to auto-generate the others from rules of arithmetic.

Most of these are obvious:

 $a++ becomes $a=$a+1 
 $a+=5 becomes $a=$a+5

etc.

Special overloads

"": "stringification", called whenever one needs a string (use to define printed version of a thing).
0+: "numification", called whenever one needs a number, such as an array index.
bool: called whenever one needs a logical (boolean) value, such as inside an if.

Copy constructor (`=`)

Curious: you can't overload = (for real).
"Everything breaks" (can't assign references).
bizarre use of overloading =: preserving immutability of reference.
We know that when we concatenate strings, it is not possible to modify variables containing the strings by side-effects.
When the variable instead contains something we create, the default is to copy a pointer to the thing.
This causes problems when you mutate the value of the thing.

Example of what goes wrong:

Consider the code:

contents of perl_abs/Rat2.pm...
#! /var/local/couch/bin/perl 

package Rat2; # rational number

use overload '+'  => \&rat_add,    # overload addition 
             '++' => \&rat_plusplus, 
             '-'  => \&rat_sub,    # overload subtraction
             '""' => \&rat_string; # convert from Rat2 to string

sub NUMER { 0 } sub numer { $_[0]->[&NUMER] } 
sub DENOM { 1 } sub denom { $_[0]->[&DENOM] } 

sub new { 
    my $pack  = shift; 
    my $numer; my $denom; 
    $numer = shift; $numer=0 if ! defined $numer; 
    if ($numer =~ /\//) { 
        ($numer,$denom)= split(/\//, $numer); 
    } else { 
	$denom = shift; $denom=1 if ! defined $denom; 
    } 
    bless [$numer, $denom] 
} 

# add two rationals 
sub rat_add { 
    print "...calling rat_add...\n"; 
    my $r1 = shift; $r1 = new Rat2($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat2($r2) if ref $r2 eq ''; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    my $result = new Rat2(
	($r1->numer*$r2->denom+$r2->numer*$r1->denom)/$gcd, 
        $r1->denom*$r2->denom/$gcd
    ); 
    return bless $result; 
} 

# increment a rational 
sub rat_plusplus { 
    print "...calling rat_plusplus...\n"; 
    my $self = shift; 
    $self->[&NUMER] += $self->[&DENOM]; 
    $self; 
} 

# subtract two numbers 
sub rat_sub { 
    print "...calling rat_sub...\n"; 
    my $r1 = shift; $r1 = new Rat2($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat2($r2) if ref $r2 eq ''; 
    my $swapped = shift; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    if ($swapped) { 
	print "...computing swapped subtraction...\n"; 
	return new Rat2(
	    ($r2->numer*$r1->denom-$r1->numer*$r2->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } else { 
	return new Rat2(
	    ($r1->numer*$r2->denom-$r2->numer*$r1->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } 
} 

# convert a thing to a string 
sub rat_string { 
    print "...calling rat_string...\n"; 
    my $self = shift; 
    return $self->numer . '/' . $self->denom; 
} 

# reduce a fraction to lowest terms
sub reduce { 
    my $self = shift; 
    my $gcd = &gcd($self->[&NUMER], $self->[&DENOM]); 
    $self->[&NUMER] /= $gcd; 
    $self->[&DENOM] /= $gcd; 
    return $self; 
} 

# compute the greatest common divisor (Euclid's method) 
sub gcd { 
    my $a = shift; my $b = shift; 
    if ($a < $b) { my $t = $a; $a = $b; $b = $t; } 
    my $r; while (($r = $a % $b)) { $a = $b; $b = $r; } 
    return $b; 
} 

1; 
...end of perl_abs/Rat2.pm

Call this with:

contents of perl_abs/Rat2.pl...
#! /var/local/couch/bin/perl 
use Rat2; 
my $number = new Rat2(1,2); 
print "number is " . $number . "\n"; 
$number += 2;          # $number += new Rat2(2); 
print "number is " . $number . "\n"; 
$number += "2/3";      # $number += new Rat2("2/3") 
print "number is " . $number . "\n"; 
$second = $number; 
$second++; 
print "number is " . $number . "\n"; 
print "second is " . $second . "\n"; 

...end of perl_abs/Rat2.pl

This prints:

contents of perl_abs/Rat2.pl.out...
Operation `=': no method found, argument in overloaded package Rat2 at Rat2.pl line 10.
...calling rat_string...
number is 1/2
...calling rat_add...
...calling rat_string...
number is 5/2
...calling rat_add...
...calling rat_string...
number is 19/6
...end of perl_abs/Rat2.pl.out

This bombs, because we did a copy of a reference and then tried to mutate it without a copy constructor around.

How to fix this problem:

Consider the code:

contents of perl_abs/Rat3.pm...
#! /var/local/couch/bin/perl 

package Rat3; # rational number

use overload '+'  => \&rat_add,    # overload addition 
             '++' => \&rat_plusplus, 
             '-'  => \&rat_sub,    # overload subtraction
             '""' => \&rat_string, # convert from Rat3 to string
             '='  => \&rat_copy;   # copy constructor

sub NUMER { 0 } sub numer { $_[0]->[&NUMER] } 
sub DENOM { 1 } sub denom { $_[0]->[&DENOM] } 

sub new { 
    my $pack  = shift; 
    my $numer; my $denom; 
    $numer = shift; $numer=0 if ! defined $numer; 
    if ($numer =~ /\//) { 
        ($numer,$denom)= split(/\//, $numer); 
    } else { 
	$denom = shift; $denom=1 if ! defined $denom; 
    } 
    bless [$numer, $denom] 
} 

# add two rationals 
sub rat_add { 
    print "...calling rat_add...\n"; 
    my $r1 = shift; $r1 = new Rat3($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat3($r2) if ref $r2 eq ''; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    my $result = new Rat3(
	($r1->numer*$r2->denom+$r2->numer*$r1->denom)/$gcd, 
        $r1->denom*$r2->denom/$gcd
    ); 
    return bless $result; 
} 

# increment a rational 
sub rat_plusplus { 
    print "...calling rat_plusplus...\n"; 
    my $self = shift; 
    $self->[&NUMER] += $self->[&DENOM]; 
    $self; 
} 

# subtract two numbers 
sub rat_sub { 
    print "...calling rat_sub...\n"; 
    my $r1 = shift; $r1 = new Rat3($r1) if ref $r1 eq ''; 
    my $r2 = shift; $r2 = new Rat3($r2) if ref $r2 eq ''; 
    my $swapped = shift; 
    my $gcd = gcd($r1->denom, $r2->denom); 
    if ($swapped) { 
	print "...computing swapped subtraction...\n"; 
	return new Rat3(
	    ($r2->numer*$r1->denom-$r1->numer*$r2->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } else { 
	return new Rat3(
	    ($r1->numer*$r2->denom-$r2->numer*$r1->denom)/$gcd, 
	    $r1->denom*$r2->denom/$gcd
	); 
    } 
} 

# convert a thing to a string 
sub rat_string { 
    print "...calling rat_string...\n"; 
    my $self = shift; 
    return $self->numer . '/' . $self->denom; 
} 

# copy over a thing to preserve immutability of reference
sub rat_copy { 
    print "...calling rat_copy...\n"; 
    my $self = shift; 
    return bless [$self->numer, $self->denom]; 
} 

# reduce a fraction to lowest terms
sub reduce { 
    my $self = shift; 
    my $gcd = &gcd($self->[&NUMER], $self->[&DENOM]); 
    $self->[&NUMER] /= $gcd; 
    $self->[&DENOM] /= $gcd; 
    return $self; 
} 

# compute the greatest common divisor (Euclid's method) 
sub gcd { 
    my $a = shift; my $b = shift; 
    if ($a < $b) { my $t = $a; $a = $b; $b = $t; } 
    my $r; while (($r = $a % $b)) { $a = $b; $b = $r; } 
    return $b; 
} 

1; 
...end of perl_abs/Rat3.pm

Call this with:

contents of perl_abs/Rat3.pl...
#! /var/local/couch/bin/perl 
use Rat3; 
my $number = new Rat3(1,2); 
print "number is " . $number . "\n"; 
$number += 2;          # $number += new Rat3(2); 
print "number is " . $number . "\n"; 
$number += "2/3";      # $number += new Rat3("2/3") 
print "number is " . $number . "\n"; 
$second = $number; 
$second++; 
print "number is " . $number . "\n"; 
print "second is " . $second . "\n"; 

...end of perl_abs/Rat3.pl

This prints:

contents of perl_abs/Rat3.pl.out...
...calling rat_string...
number is 1/2
...calling rat_add...
...calling rat_string...
number is 5/2
...calling rat_add...
...calling rat_string...
number is 19/6
...calling rat_copy...
...calling rat_plusplus...
...calling rat_string...
number is 19/6
...calling rat_string...
second is 25/6
...end of perl_abs/Rat3.pl.out

Subtle: copy is only called when a mutator (e.g., ++ or --) is called. All other overloads are presumed to leave their arguments alone and produce a new value. Mutators are presumed to modify their values.

lecture in color

downloaded on Nov-23-2009 05:46:21 AM,
was last modified on Dec-31-1969 07:00:00 PM.
All lecture note content is copyright 2003 by
Alva L. Couch, Computer Science, Tufts University
(couch at cs dot tufts dot edu)

Perl Abstractions

Three abstractions

Pseudo-hashes

Ties

Tying a scalar

Example of scalar tying:

Advanced example: persistent file-storage of string

What constitutes a scalar:

What constitutes an array:

Array tying:

Example: an array of numbers with default value

What constitutes a hash?

Strategy for tying a hash

What you've always wanted (for a2)

Extreme power: a hash that remembers history

What constitutes a filehandle?

Ties to databases

A simple database tie

Watch out!

The point

Objects

Predefined classes:

Methods with implicit invocation

Autoloading accessors

Another example:

As a finely tuned example,

Overloading

Example of overloading:

Overloading capabilities

Auto-generation

Special overloads

Copy constructor (=)

Example of what goes wrong:

How to fix this problem:

Copy constructor (`=`)