################################
# CLOSURES AS LIST OF COMMANDS #
################################
# Original and Untested Coding #
################################

# The key ability of closures is their ability to be 
# "function templates":  that is, closures provide
# an easy way to generate a multiplicity of similar
# functions without actually having to generate 
# (and maintain) extensive copy-pasted code or using
# all the heavy machinery and difficult syntax for
# objects.

sub doShiftValue($) {
    my $mag = int(shift);
    return sub($) {
    	return $mag + int(shift);	
    };
}

my @valueShifters;
push(@valueShifters, doShiftValue(-2));
push(@valueShifters, doShiftValue(5));
push(@valueShifters, doShiftValue(9));
push(@valueShifters, doShiftValue(-1));
push(@valueShifters, doShiftValue(15));
push(@valueShifters, doShiftValue(-6));

my $num = 1;
$num = $_->($num) foreach(@valueShifters);

###############################
# CLOSURES AS COMMAND HOLDERS #
###############################
# Original and Untested Coding#
###############################

# Closures can be chained together in order to provide
# a run-time generated piece of code flow.  This is
# very useful if you want to do a lot of conditional
# application, but you only want to test once: think of
# command line flags as a good example. 

# Method used to create the closures
sub doShiftValue($;$) {
    my $mag = int(shift);
    my $prevShift = shift;
    $prevShift = 
    	$prevShift or
    	sub($) { return shift; };
    return sub($) {
    	return $prevShift->($mag + int(shift));	
    }
}

# Create the chained closures
my $valueShifter = doShiftValue(-2);
$valueShifter = doShiftValue(5, $valueShifter);
$valueShifter = doShiftValue(9, $valueShifter);
$valueShifter = doShiftValue(-1, $valueShifter);
$valueShifter = doShiftValue(15, $valueShifter);
$valueShifter = doShiftValue(-6, $valueShifter);

# Apply the chained closures
my $num = $valueShifter->(1);

#############################
# CLOSURES AS DO-IT OBJECTS #
#############################
# From Regexp::Tr           #
#############################

# Closures work very nicely with objects, particularly
# if you have a "do-it" object: an object whose primary
# purpose is to accomplish a function application, like
# performing a regular expression, retrieving something
# from the database, etc.  Closures are also extremely 
# powerful when combined with run-time eval strings, as
# this example from my Regexp::Tr package shows.

# 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));

    my $subref = eval '
    sub(\$) {
    	my $ref = shift;
    	return ${$ref} =~ tr/'.$from.'/'.$to.'/'.$mods.';
    };';
    carp 'Bad tr///:'.$@ if $@;
    return bless($subref,$class);
}

# 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);
}


########################################
# CLOSURES AS ITERATOR IMPLEMENTATIONS #
########################################
# Examples from a project              #
########################################

# First-level functions, and particularly closures, can be
# used to powerful effect by passing them as arguments.  These
# first-level functions can then be applied themselves or combined
# with Perl's built-in functional functions (eg: map{}LIST and 
# grep{}LIST) to do very fast and very flexible list manipulation.

# Applies an arbitrary data filter
# Takes a subroutine reference.  Each record is fed through the subroutine; if the subroutine returns
# true, the record is kept.  If the subroutine returns false, the record is dropped.  Returns the
# number of records remaining.
sub applyDetailFilter {
	my $self = shift or carp "Method called as a subroutine";
	my $sub = shift or carp "No subroutine parameter provided";
	carp "Parameter is not a subroutine reference" unless(ref($sub) eq "CODE");
	carp "Too many parameters passed" if(scalar(@_));
	my $records = ${$self}[DATADEX];
	@$records = grep { $sub->($_) } @$records;
	return scalar(@$records);
}

# Applies an effective window.
# Takes a date in ccyymmdd form.  Any records having an effective date further in the future than
# the date provided are removed from the data array.  Returns the number of records remaining. 
sub applyEffectiveFilter {
	my $self = shift or carp "Method called as a subroutine";
	my $date = shift or carp "No date parameter provided";
	carp "Too many parameters passed" if(scalar(@_));
	return $self->applyDetailFilter(sub { "20".substr(shift,215,6) le $date });
}


# Applies an arbitrary data transformation
# Takes a subroutine reference.  Each record is fed through the subroutine; the result of the 
# subroutine is stored in place of that element.  Returns the number of records in the data set.
sub applyDetailTransform {
	my $self = shift or carp "Method called as a subroutine";
	my $sub = shift or carp "No subroutine parameter provided";
	carp "Parameter is not a subroutine reference" unless(ref($sub) eq "CODE");
	carp "Too many parameters passed" if(scalar(@_));
	my $records = ${$self}[DATADEX];
	@$records = map { $sub->($_) } @$records;
	return scalar(@$records);
}

# Applies a go live date
# Takes a date in ccyymmdd form.  For each record, if the termination date is less than the given 
# date, the termination date is set to the given date.  Also, for reach record, if the effective
# date is less than the given date, the effective date is set to the given date.
sub applyGoLiveTransform {
	my $self = shift or carp "Method called as a subroutine";
	my $date = shift or carp "No date parameter provided";
	carp "Too many parameters passed" if(scalar(@_));
	return $self->applyDetailTransform(sub {
		my $record = shift;
		foreach my $pos (215,221) {
			if($date gt "20".substr($record, $pos, 6)) {
				substr($record, $pos, 6) = substr($date, 2, 6);
			} 
		}
		return $record;
	});
}

###############################
# CLOSURES AS CODE GENERATORS #
###############################
# From Text::Shift            #
###############################

# Also consider using closures with typeglob assignments in
# order to turn the closures into normalish functions/methods. 
# This technique keeps compiled code small and takes out 
# copy/paste maintenance nightmares.

=head3 Accessors

    CLASS->uppercase()
    CLASS->lowercase()
    CLASS->numbers()

Returns a list consisting of the uppercase alphabet currently in use,
the lowercase alphabet currently in use, and the numbers currenty in
use.  Note that because the accessors are named the same thing as the
modifiers, it is important to use the parentheses here.

=head3 Modifiers

    CLASS->uppercase(LIST)
    CLASS->lowercase(LIST)
    CLASS->numbers(LIST)

Sets the uppercase, lowercase, or numbers alphabet in use for this
package.  Each package has a distinct "alphabetspace" which cannot be
modified by anyone else.  If you would like to change the default
alphabets in use, please see the source code comments.
=cut

# Create the alphabet control methods
our %_abs;  # Hash of callers' package names pointing to arrays
            # The array is made up of UPPERCASE, LOWERCASE, NUMBERS
BEGIN {
    my $funcref = sub( $ ) {
	my $index = shift;
	return sub($$) {
	    (undef, my $caller) = (shift, caller);
	    if(scalar(@_)) {
		# Modifier return
		$_abs{$caller} = [] unless($_abs{$caller});
		return $_abs{$caller}->[$index] = join("",@_);
	    } else {
		# Accessor return
		return $_abs{$caller}->[$index];
	    }
	};
    };
    
    *uppercase = $funcref->(0);
    *lowercase = $funcref->(1);
    *numbers   = $funcref->(2);
}