File Coverage

blib/lib/Regexp/Tr.pm

Criterion	Covered	Total	%
statement	31	36	86.1
branch	8	18	44.4
condition	3	11	27.2
subroutine	7	8	87.5
pod	4	4	100.0
total	53	77	68.8

package Regexp::Tr;

### IMPORTS
# Boilerplate package beginning
use 5.008;
use strict;
use warnings;
use Carp;

### PACKAGE VARIABLES

# UNIVERSAL package variables
our $VERSION = "0.05";

# The following hash contains caller package names
# as keys and arrayrefs as values.  These arrayrefs
# begin with the parameters passed, and end with the
# object (therefore, $last{pkg}[-1] is the last object
# created for the namespace "pkg".
my %last;

# This is a scratch opening in the symbol table and
# IS NOT GUARANTEED TO BE ANYTHING AT ALL.
our @_called;

# This method creates a new instance of the object
sub new {
    # Get parameters and suppress warnings
    my($class,$from,$to,$mods) = @_;
    $from = "" unless(defined($from));
    $to   = "" unless(defined($to));
    $mods = "" unless(defined($mods));

    # Name (or make) the anonymous array in the
    # %last hash for the caller's package.
    # (The typeglob assignment saves a hash
    # access each time @_called is...well, called.)
    *_called = ($last{caller()} ||= []);

    # Work the efficiency for loops
    unless(scalar(@_called) and
	   ($from eq $_called[0]) and
	   ($to   eq $_called[1]) and
	   ($mods eq $_called[2]) )
    {
	my $subref = eval '
	sub(\$) {
	    my $ref = shift;
	    return ${$ref} =~ tr/'.$from.'/'.$to.'/'.$mods.';
	};';
	carp 'Bad tr///:'.$@ if $@;
	@_called = ($from,$to,$mods,bless($subref,$class));
    }
    return $_called[-1];
}

# Performs the actual tr/// operation set up by the object.
sub bind {
    my $self = shift;

    # Verify reference passed
    (my $ref = shift)
	or carp "No reference passed";
    my $reftype = ref($ref);
    if(!$reftype) {
	carp "Parameter is not a reference.\n"
	    ."You might have forgotten to backslash the scalar";
    } elsif($reftype ne "SCALAR") {
	carp "Parameter not a scalar reference";
    }

    # Perform the operation
    return &{$self}($ref);
}

# Performs the tr/// operation on a scalar passed to the object.
sub trans {
    my($self,$val) = @_;
    my $cnt = $self->bind(\$val);
    return wantarray ? ($val, $cnt) : $val;
}

# Flushes the efficiency storage
sub flush {
    %last = ();
    @_called = ();
    return;
}

return 1;
__END__