## Calculate a new field's values based on two others

        $t->calc($Sub)              ## Run $Sub for each row, with 
                                    ##  fields bound to local vars

        $t->calc($Sub,  $Sel)           ## Use these row nums
        $t->calc($Sub, undef, $Fields)  ## Use only these fields

        my $Col = $t->calc($Sub)    ## Gather return vals in vector

o o o
        ## Example 2: Create empty column; fill fields 1 by 1

        $t->col('PersonID');
        $t->calc(sub{no strict 'vars'; $PersonID = "$Last$First"});


##</code><code>##

sub calc
{
	## We operate in package main for this subroutine so the local
	## object and row number can be available to the caller's $Sub.

	## The following local vars will be available to $Sub
	## $_r ($main::_r) -- the row number in the entire table
	## $_s ($main::_s) -- the row number in selection or $Recs
	## $_t ($main::_t) -- the table object itself

	package main;			
	use vars qw($_r  $_s  $_t);
	local      ($_r, $_s, $_t);

	$_t							= shift;	
	my ($Sub, $Recs, $Fields)	= @_;

	## These optional params default to current field and current sel

	$Recs						||= $_t->selection();
	$Fields						||= $_t->fieldlist_all();
	
	## Local copy of symbol table.  Didn't seem to help.  Odd.
	## local %main::;	
	
	## We'll build a column of return values from $Sub if needed.
	my $WantVals				= defined(wantarray);
	my $Vals					= $_t->col_empty() if $WantVals;

	## Call col() on each field in list to make sure it exists.
	foreach (@$Fields) {$_t->col($_)};

	foreach $_s (0..$#$Recs)
	{
		$_r = $Recs->[$_s];

		## Bind $FieldName1, $FieldName2, (etc. for each field name in
		## $Fields) point to address of the current value for that
		## field in this record.

		no strict 'refs';
		foreach my $F (@$Fields) {*{$F} = \ $_t->{$F}->[$_r]};

		## Now $Sub may refer to $_r, $_s, $_t, and ${any field name}

		## Call $Sub and capture return values iff caller wants them
		($WantVals ? $Vals->[$_r] = &$Sub() : &$Sub());
	}

	## Return scalar column ref unless return context is undef
	return($WantVals ? $Vals : ());
}

##</code><code>##

## Don't overwrite fields in package main.
my @saveFields;
no strict 'refs'; package main;
foreach my $F (@$Fields) { push @saveFields, ${$F}; }

foreach $_s (0..$#$Recs)
{
    $_r = $Recs->[$_s];

    ## Bind $FieldName1, $FieldName2, (etc. for each field name in
    ## $Fields) point to address of the current value for that
    ## field in this record.

    no strict 'refs';
    foreach my $F (@$Fields) {*{$F} = \ $_t->{$F}->[$_r]};

    ## Now $Sub may refer to $_r, $_s, $_t, and ${any field name}

    ## Call $Sub and capture return values iff caller wants them
    ($WantVals ? $Vals->[$_r] = &$Sub() : &$Sub());
}

## Restore fields in main
no strict 'refs'; package main;
foreach my $F (@$Fields) { ${$F} = shift @saveFields; };

##</code><code>##

#!/usr/bin/perl

## Unit testing script for the Data::CTable module

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

use strict;

use Test;
BEGIN { plan tests => 30, todo => [] }

use Data::CTable;
use Data::CTable::Script;
use Data::CTable::Listing;
use Data::CTable::ProgressLogger;

## Suppress automatic built-in progress during testing in order to
## acheive nice unobscured testing output when all goes well. 

## (Will still test the progress() features directly with specific
## subclasses that gather the messages into memory instead of printing
## them out.)

Data::CTable->progress_class(0);

## Note whether we're on Unix...
my $OnUnix = ((-d "/") && (-d "/tmp"));

## Figure out some platform-specific path details...
my ($Sep, $Up, $Cur) = @{Data::CTable->path_info()}{qw(sep up cur)};

my $TestDir = "test$Sep"; ## "test/"


## First test is to read a file that we'll make use of in many of the
## other tests.

my $People1 = Data::CTable->new("${TestDir}people.tabs.txt") and ok(1) or die;


## Now for tests 2..onward, run unit-tests of specific feature
## groups...

ok(test_calc());        ## Calc method
ok(test_calc_restore_main_vars()); ## check that calc restores Main vars

1;


sub test_calc
{
    my $People2 = Data::CTable->new("${TestDir}people.tabs.txt") or die;
    
    package FooBar;

    no strict 'vars'; package main;
    $People2->calc(sub{$First = "\U$First\E/@{[$_t->length()]}/$_r/$_s"});

    return(0) unless ("@{$People2->col('First')}" eq 
                      "CHRIS/3/0/0 MARCO/3/1/1 PEARL/3/2/2");
    
    return(1);
}

sub test_calc_restore_main_vars
{
    my $People2 = Data::CTable->new("${TestDir}people.tabs.txt") or die;
    no strict 'vars'; package main;
    
    # make sure that calc doesn't overwrite fields in Main
    # especially important when calc is called repeatedly on tables with intersecting field names 
    $First = 'TEST';
    $People2->calc(sub{$Last});
    package main;
    return(0) if ( $First ne 'TEST' );
    return(1);  
}