package Tk::EasyGUI;

=head1 NAME

	Tk::EasyGUI.pm

=head1 VERSION

0.14

=head1 SYNOPSIS

	use Tk::EasyGUI qw(
		column_of_entries
		row_of_buttons
		entries_accept
		entries_rollback
		entries_to_string
	);

	my $mw = Tk::EasyGUI::init('Some Title', \&some_error_msg_sub);

=head1 DESCRIPTION

What you have here is a method of banging out quick and dirty Perl/Tk GUIs
for use with almost any Perl code that you might have in early development, or
for which you may have only temporary need. It does two things for you. Firstly,
you can use it to build a simple GUI most quickly. Secondly, the GUI you build
will have built-in input-error checking.

A complete, fully POD-ified example of how to employ this module may be found
online under the URL below...

F<http://starling.us/tet/gus_perl/gus_easy_gui_pl/gus_example_easy_gui.txt>

...look also for this screenshot...

F<http://starling.us/tet/gus_perl/gus_easy_gui_pl/gus_example_easy_gui.Win32.png>

=head1 EXPORTED SUBROUTINES

=cut

use strict;
use warnings;
use Tk;
use Tk::Pane;
use Tk::Balloon;

use base qw(Exporter);
use vars qw($VERSION @EXPORT_OK);
our @EXPORT_OK = qw(
	column_of_entries
	row_of_buttons
	entries_accept
	entries_rollback
	entries_to_string
);
our %EXPORT_TAGS = (all => \@EXPORT_OK,);

# Scoping problem for below when package in same file as main. Why?
$VERSION = '$Revision: 0.13 $' =~ m{ \$Revision: \s+ (\S+) }xm;

my $err_cref; # Let calling pkg decide how to report errors, if desired.

my %mw_defs; # A place to put main window defs so $mw won't be in every @_.

# Returns ref to file Tk browsing command so that script can later
# just do $mw_defs{'cmd_open_browse'} to build browse buttons.
sub get_open_browse {
	my $mw = shift;
    return sub { $mw->getOpenFile() };
}

# Returns ref to file Tk browsing command so that script can later
# just do $mw_defs{'cmd_save_browse'} to build browse buttons.
sub get_save_browse {
	my $mw = shift;
	return sub { $mw->getSaveFile() };
}

# Initiate a window.
sub init {
	my $title = shift;
	$err_cref = shift;
	my $mw = MainWindow->new( -title => " $title" );
	$mw_defs{'cmd_open_browse'} = get_open_browse($mw);
	$mw_defs{'cmd_save_browse'} = get_save_browse($mw);
	return $mw;
}

# Dispatch table of hints for balloon pop-ups to hover over entry widgets..
# Replaces huge if-elsif-else block as per 'Higher Order Perl' textbook.
my %balloon_msgs;
BEGIN {
	%balloon_msgs = (
		'p'   => q{Path: 'c:\foo\bar.txt' or '/foo/bar.txt' (sans quotes)},
		'po'  => q{Path Open: 'c:\foo\bar.txt' or '/foo/bar.txt' (sans quotes)},
		'ps'  => q{Path Save: 'c:\foo\bar.txt' or '/foo/bar.txt' (sans quotes)},
		's'   => q{String: 'Any ASCII chars.' (sans quotes)},
		'i'   => q{Integer: 1 only.},
		'i,i' => q{Integer List: -1, 0, 1, 2 ...},
		'r'   => q{Real Number: 1 only.},
		'r,r' => q{Real List: -99.9, 0.0, 18.5 ...},
		'fbk' => q{Look here for error messges and other program feedback.},
	);
}

# Define some (user-overridable) built-in widget attributes.
my %wgt_attribs;
BEGIN {
	%wgt_attribs = (
		'entries_label_width'  => 10, # Label width inside of entries frame.
		'entries_entry_width'  => 40, # Entry width inside of entries frame.
		'entries_frame_relief' => 'sunken', # Relief of entries frame.
		'entries_frame_pack_side' => 'top',
		'entries_frame_expand' => 1,
		'entries_frame_fill' => 'both',
		'entries_font' => 'courier',

		'buttons_label_width'  => 10, # Label width inside of buttons frame.
		'buttons_frame_relief' => 'flat',   # Relief of buttons frame.
		'buttons_frame_pack_side' => 'top',
		'buttons_frame_expand' => 0,
		'buttons_frame_fill' => 'both',

		'show_feedback' => 1,  # Display a feedback entry widget.
		'all_or_none'   => 0,  # Pass none if any widget fails its test.
		'auto_rollback' => 0,  # Roll back all if any widget fails its test.
	);
}

# Override built-in widget attributes with user-supplied hash values.
sub load_wgt_attribs {
	my ($prefix, $href) = @_; # Prefix = 'entries' or 'buttons'.
	while ( my ($key, $val) = each %$href ) {
		$wgt_attribs{$prefix . '_' . $key} = $val;
	}
}

# Define one label-entry widget.
sub label_entry {
	my ($wgt, $balloon, $lbl, $type, $cont, $min, $max, $res) = @_;
	my $ptr;
	if ( ref $cont ) {                 # Assume start-up values all good.
		$wgt->{'to'}->{$lbl} = $cont;  # Tested-acceptable throughput
		$wgt->{'fm'}->{$lbl} = $$cont; # Untested user input.
	} else {
		$wgt->{'to'}->{$lbl} =         # Tested-acceptable throughput
		$wgt->{'fm'}->{$lbl} = $cont;  # Untested user input.
	}
	$wgt->{'to'}->{"$lbl Type"} = $type;
	$wgt->{'to'}->{"$lbl Min"} = $min if defined $min;  # Min for int and real.
	$wgt->{'to'}->{"$lbl Max"} = $max if defined $max;  # Max for int and real.
	$wgt->{'to'}->{"$lbl Res"} = $res if defined $res;  # Resolution for real.
	entries_frame($wgt, $lbl); # Nest each in own frame.
	entries_label($wgt, $lbl); # Give each a label.
	entries_entry($wgt, $lbl); # Entry widget itself.
	entries_button_path($wgt, $lbl, $cont, $type)
		if $wgt->{'to'}->{"$lbl Type"} =~ /p(o|s)?/; # Paths get brows button.
  	$balloon->attach(
		$wgt->{"Entry $lbl"},
		-balloonmsg => $balloon_msgs{"$type"},
	);
}

# Called internally by &label_entry sub.
sub entries_frame {
	my ($wgt, $lbl) = @_;
	$wgt->{"Frame $lbl"} = $wgt->{'Pane'}->Frame(
		-relief      => 'flat',
		-borderwidth => 0, )->pack(
			-side        => 'top',
			-expand      => 1,
			-fill        => 'x' );
}

# Called internally by &label_entry sub.
sub entries_label {
	my ($wgt, $lbl) = @_;
	$wgt->{"Label $lbl"} = $wgt->{"Frame $lbl"}->Label(
		-anchor     => 'e',
		-width      => $wgt_attribs{'entries_label_width'},
		-text       => "$lbl:", )->pack(
			-side       => 'left',
			-expand     => 0,
			-fill       => 'x');
}

# Called internally by &label_entry sub.
sub entries_entry {
	my ($wgt, $lbl) = @_;
	$wgt->{"Entry $lbl"} = $wgt->{"Frame $lbl"}->Entry(
		-textvariable => \$wgt->{'fm'}->{$lbl}, # Untested user input.
		-width      => $wgt_attribs{'entries_entry_width'},
		-background => 'white',
		-foreground => 'blue',
		-relief     => 'sunken',
		-font       => $wgt_attribs{'entries_font'}	)->pack(
			-side       => 'left',
			-expand     => 1,
			-fill       => 'x' );
}

# Test whether mystery reference is an hashref.
sub isa_href {
	my $mystery_ref = shift;
	return eval { my $x; $x = $mystery_ref->{''}; 1};
}

=head2  Building Columns of Label-Entry Widgets

	my $path     = '/ram/bar.csv';    # Example path.
	my $real     = '5.0';             # Example real number.
	my $capitals = 'CAPITAL LETTERS'; # Example string.

	my $int_list = '0, 1, 2, 3, 4';
	my $real_list = '0.9, 1.8, 2.7, 3.6, 4.5';

	my @tk_ent = (
		{ show_feedback   => 1,
		  label_width     => 10,
		  entry_width     => 40,
		  frame_relief    => 'sunken',
		  frame_pack_side => 'top',
		  all_or_none     => 0,         # Do not require all entries must pass.
		  auto_rollback   => 0,         # Do not roll back if an entry fails.
		}, # Your attribs. Empty hash or none is okay.
		['Log File',   'ps',   '/ram/foo.log'],              # Data is a string.
		['Data File',  'po',   \$path],                      # Data via sref.
		['Capitals',   's',    \$capitals, '^[A-Z| ]+$'],    # Data via sref.
		['Integer',    'i',    5, 0, 10],                    # Data is an integer.
		['Int List',   'i,i',  \$int_list,  -2, 9],          # Data via sref.
		['Real',       'r',    \$real, -10.0, 10.0, 3],      # Data via sref.
		['Real List',  'r,r',  "$real_list", -3.3, 11.9, 2], # Data via sref.
	);

	my $wgt_1 = column_of_entries($parent, $lbl, $aref, int);    # int is starting height in pixels

=cut

# Define a column of label-entry widgets.
sub column_of_entries {
	my ($parent, $lbl, $aref, $height) = @_;
	my $wgt = {};
	if ( isa_href($aref->[0]) ) { # Test for user-supplied hash.
		$wgt = shift @$aref ;
		load_wgt_attribs('entries', $wgt);
	}
	$wgt->{'fm'} = {};
	$wgt->{'to'} = {};
	group_frame($wgt, $parent, $lbl, 'entries' ); # Columnate together.
	group_pane($wgt, $height);  # Give it scrollbars.
	my $balloon = group_balloon($wgt);  # Give it scrollbars.
	foreach ( @$aref ) { # Create each separate label-entry set.
		label_entry($wgt, $balloon, @$_ );
	}
	label_entry( # Optional label-entry to show errors for THIS FRAME ONLY.
		$wgt,
		$balloon,
		'Feedback',	'fbk', 'Read error messages for this frame here.' )
		if $wgt_attribs{'show_feedback'};
	return ($wgt);
}

=head2  Building Rows of Buttons

	my @tk_btn = (
		{ label_width     => 10,
		  frame_relief    => 'flat',
		  frame_pack_side => 'top' }, # Optional attribs. Empty hash okay.
		[ 'Start',  sub { print "Start\n" }, # Un-toggled label and toggle-on action.
		  'gray', 'green',                   # Un-toggled and toggled colors.
		  'Stop',   sub { print "Stop\n" }   # Toggled label and toggle-off action.
		],
		[ 'Run',    sub { print "Run\n" },   # Un-toggled label and toggle-on action.
		  'Pause',  sub { print "Pause\n" }  # Toggled label and toggle-off action.
		],
		[ 'Submit', sub { submit_entries($wgt_1) },  # Label and action.
		  'gray', 'yellow'                           # In-active and active colors.
		],
		[ 'Exit',   sub { exit MainLoop },   # Label and action. Default colors.
		],
	);

	my $wgt_2 = row_of_buttons( $mw, 'Actions', \@tk_btn );

=cut

# Define a labeled row of buttons.
sub row_of_buttons {
	my ($parent, $lbl, $btn_arefs) = @_;
	my $wgt = {};
	if ( isa_href($btn_arefs->[0]) ) { # Test for user-supplied hash.
		$wgt = shift @$btn_arefs ;
		load_wgt_attribs('entries', $wgt);
	}
	group_frame($wgt, $parent, $lbl, 'buttons' ); # Columnate together.
	group_label($wgt, $lbl, 'buttons' ); # Label together.
	foreach (@$btn_arefs ) {
		button($wgt, $lbl, @$_);
	}
	return ($wgt);
}

# Define one button.
sub button {
	my $wgt = shift; my $lbl = shift;
	my $txt_1 = shift; 	my $cref_1 = shift;
	my ($hue_1, $hue_2, $txt_2, $cref_2);
	if ( scalar @_ == 4) { # User gave all possible args, four are left.
		($hue_1, $hue_2, $txt_2, $cref_2) = @_;
	} elsif ( ref $_[-1] ) { # User specified a toggle button.
		($txt_2, $cref_2) = @_;
	} else { # Only colors remain to be defined.
		($hue_1, $hue_2) = @_;
	}
	$hue_1 = 'gray' unless defined $hue_1; # Default color.
	$hue_2 = 'red' unless defined $hue_2;  # Default color.
	$txt_2 = $txt_1 unless defined $txt_2;
	$cref_2 = $cref_1 unless defined $cref_2;
	my $pack_expansion = $txt_1 eq '*.*' ? 0 : 1; 
	$wgt->{"Button $lbl $txt_1 $txt_2"} = $wgt->{"Frame $lbl"}->Button(
		-text             => " $txt_1 ",
		-command          => sub {
			toggle(
				$wgt,   $lbl,
				$txt_1, $cref_1,
				$txt_2, $cref_2,
				$hue_1, $hue_2 )
			},
		-background       => $hue_1,
		-activebackground => $hue_2,
		-relief           => 'raised',
	)->pack(
		-side   => 'left',
		-expand => $pack_expansion,
		-fill   => 'x'
	);
}

# So toggle buttons can have ? and * as text.
sub regex_escape_string {
	my @chars = split //, $_[0];
		foreach (@chars) { $_ = "\\" . $_ if $_ =~ m/[\.|\*|\?]/ }
	return join '', @chars;
}

# How a button can be made to toggle.
sub toggle {
	my ($wgt, $lbl, $txt_1, $cref_1, $txt_2, $cref_2, $hue_1, $hue_2) = @_;
	my $regex_txt = regex_escape_string($txt_1);
	my $regex_hue = regex_escape_string($hue_2);
	if	(
			$wgt->{"Button $lbl $txt_1 $txt_2"}->cget(-text) =~ m/$regex_txt/
			&&
			$wgt->{"Button $lbl $txt_1 $txt_2"}->cget(-activebackground) =~ m/$regex_hue/
		) {
		&$cref_1;
		$wgt->{"Button $lbl $txt_1 $txt_2"}->configure(-text => $txt_2);
		$wgt->{"Button $lbl $txt_1 $txt_2"}->configure(
			-background => $hue_2,
			-activebackground => $hue_1)
			if $txt_1 ne $txt_2;
	} else {
		&$cref_2;
		$wgt->{"Button $lbl $txt_1 $txt_2"}->configure(
			-text => $txt_1,
			-background => $hue_1,
			-activebackground => $hue_2,
		);
	}
}

# Used in grouping rows and columns.
sub group_frame {
	my ($wgt, $parent, $lbl, $prefix) = @_;
	my $frame_id = 'Frame'; # Columns nest deeper in frames than rows.
	$frame_id .= " $lbl" if $prefix =~ m/buttons/; # In a row not a column?
	$wgt->{"$frame_id"} = $parent->Frame(
		-relief      => $wgt_attribs{$prefix . '_frame_relief'},
		-borderwidth => 5, )->pack(
			-side        => $wgt_attribs{$prefix . '_frame_pack_side'},
			-expand      => $wgt_attribs{$prefix . '_frame_expand'},
			-fill        => $wgt_attribs{$prefix . '_frame_fill'} 
);
	$wgt->{'Frame'}->configure( -label => $lbl, ) if $prefix eq 'entries';
}

# Used in grouping rows and columns.
sub group_pane {
	my ($wgt, $height) = @_;
	$wgt->{'Pane'} = $wgt->{'Frame'}->Scrolled(
		'Pane',
		-height     => $height,
		-scrollbars => 'e',
		-sticky     => 'we' )->pack(
			-side   => 'top',
			-expand => 1,
			-fill   => 'both' );
}

# Used in grouping rows and columns.
sub group_label {
	my ($wgt, $lbl, $prefix) = @_;
	my $frame_id = 'Frame'; # Columns nest deeper in frames than rows.
	$frame_id .= " $lbl" if $prefix =~ m/buttons/; # In a row not a column?
	$wgt->{'Label'} = $wgt->{"$frame_id"}->Label(
		-anchor     => 'e',
		-width      => $wgt_attribs{$prefix . '_label_width'},
		-text       => "$lbl:", )->pack(
			-side       => 'left',
			-expand     => 0,
			-fill       => 'x');
}

# Used in grouping rows and columns.
sub group_balloon {
	my ($wgt) = @_;
	return $wgt->{'Pane'}->Balloon(
		-state           => 'balloon',
		-balloonposition => 'mouse',
		-background      => 'darkseagreen',
		-foreground      => 'black',
	);
}

# Dispatch table of validity check subroutine names.
# Replaces huge if-elsif-else block as per 'Higher Order Perl' textbook.
my %entry_tests;
BEGIN {
	%entry_tests = (
		's'   => q{ string_test($wgt, $fm, $to, $lbl)},
		'p'   => q{ path_test($wgt, $fm, $lbl) }, # Pre version 0.12 compat.
		'po'  => q{ path_test($wgt, $fm, $lbl) },
		'ps'  => q{ path_test($wgt, $fm, $lbl) },
		'i'   => q{ int_test($wgt, $fm, $to, $lbl) },
		'r'   => q{ real_test($wgt, $fm, $to, $lbl) },
		'i,i' => q{ num_list_test($wgt, $fm, $to, $lbl, 0) },
		'r,r' => q{ num_list_test($wgt, $fm, $to, $lbl, 1) },
		'_DEFAULT_' => q{  },
	);
}

# Build a browse button for Entry widget when it contains a path.
sub entries_button_path {
	my ($wgt, $lbl, $path, $type) = @_;
	$path = $$path if ref $path;
	if ($type =~ /^po?$/) {                         # Assume 'po' unless...
		button($wgt, $lbl, '*.*',
			sub { $wgt->{'fm'}->{"$lbl"} = &{$mw_defs{'cmd_open_browse'}} },
			'gray', 'blue');
	} elsif ($type eq 'ps') {                     # ...it is 'ps' instead.
		button($wgt, $lbl, '*.*',
			sub { $wgt->{'fm'}->{"$lbl"} = &{$mw_defs{'cmd_save_browse'}} },
			'gray', 'blue');
	}
}

=head2 Accepting Entries

	entries_accept($wgt);

=cut

# Test and accept throughput from a column of label entry widgets.
sub entries_accept {
	my ($wgt) = @_;
	my $fm = $wgt->{'fm'};
	my $to = $wgt->{'to'};
	my $report = '';
	my $bad_wgts = 0;
	my @action_srefs;
	my @report;

	# Clear last error if has to do with GUI widgets.
	$fm->{'Feedback'} = '' if $fm->{'Feedback'} =~ m/Entry .* (not|too) /
		and $wgt_attribs{'show_feedback'};
	foreach my $lbl ( keys %$fm ) {

		next if $lbl eq 'Feedback'; # So subs can append to feedback sans log entries.

		# Is widget's value equivalent to last throughput?
		my $flag_equiv = equiv_test($wgt, $fm, $to, $lbl);
        my $flag_bad_wgt;
		unless ( $flag_equiv ) { # User has overtyped previous value.
			if ( exists $entry_tests{$to->{"$lbl Type"}} ) {
				my $test = eval qq[ sub { $entry_tests{$to->{"$lbl Type"}} } ];
				$flag_bad_wgt = &$test;
				$bad_wgts += $flag_bad_wgt
			} else {
				print qq[Oops! '$lbl' is of unanticipated type '$to->{"$lbl Type"}'.\n];
			}
			unless ( $flag_bad_wgt ) { # If widget okay, accumulate this change.
				if ( ref $to->{$lbl} ) {
					push @report, qq[\n\t$lbl: ${$to->{$lbl}} -> $fm->{$lbl}; ];
					push @action_srefs, sub { ${$to->{$lbl}} = $fm->{$lbl} };
				} else {
					push @report, qq[\n\t$lbl: $to->{$lbl} -> $fm->{$lbl}; ];
					push @action_srefs, sub { $to->{$lbl} = $fm->{$lbl} };
				}
			}
		} else {
			$wgt->{"Entry $lbl"}->configure(-background => 'white');
		}
    }

    my $changes;
	if ( $bad_wgts && $wgt->{'all_or_none'} ) {
		entries_rollback($wgt, $to, $fm) if $wgt->{'auto_rollback'};
	} else {
		$changes = join '', @report;
		foreach ( @action_srefs ) { &$_ }
	}

	if ( $changes ) { rpt_error( "User edits via GUI: $changes" ) }
}

# Test equivalency of strings whether they represent scalars or lists.
# Needful because list representation may hold spaces which only seem
# unequavilent while not being so as a list.
sub equiv_test {
	my ($wgt, $fm, $to, $lbl) = @_;
	my $to_value = $to->{$lbl}; # Might be a ref.
	$to_value = $$to_value if ref $to_value;          # Get value if a ref.
	my $flag = 0;
	if ( $to->{"$lbl Type"} =~ m/(i.i|r.r)/) {        # It is a list.
		my @to_list = eval ( qq[ $to_value   ] );     # Evaluate as list.
		my @fm_list = eval ( qq[ $fm->{$lbl} ] );     # Evaluate as list.
		my $limit = $#fm_list > $#to_list ? $#fm_list : $#to_list; # Get larger.
		for (0 .. $limit) {

			# Avoid undef warning.
			if ( defined $fm_list[$_] && defined $to_list[$_] ) {
				++$flag if $to_list[$_] != $fm_list[$_];  # Count non-equivs.
			} else {
				++$flag;                  # Undef list fails too.
			}
		}
	} else {                                          # Not a list.
		++$flag if  $to_value ne $fm->{$lbl};     # Inc if non-equivalent.
	}
	return $flag == 0; # True if equivalent.
}

=head2 Rolling Back Entry Widgets

You can roll back (or up, depending on viewpoint) the entry widgets of a given
entry widget set. If you don't specify a color, the Entry widgets will be turn
yellow, since rollback is ordinarily presumed an error.

	entries_rollback($wgt_1, $wgt_1->{to}, $wgt_1->{fm}, 'white');

=cut

# Called to undo last user inputs. To copy back from output to input
# so that entry widget displays prior throughput.
# May also be called to use widgets as mere display rather than inputs.
sub entries_rollback {
	my ($wgt, $to, $fm, $bg_clr) = @_;
	$bg_clr = 'yellow' unless defined $bg_clr;
	foreach my $lbl ( keys %$fm ) {

		if ($lbl =~ m/Feedback/) {
			$fm->{$lbl} .= " Entries rolled back." unless $bg_clr eq 'white';
			$fm->{$lbl} =~ s/^\s+//;
			next;
		}

		# Colorized rolled back wigets.
		$wgt->{"Entry $lbl"}->configure(-background => $bg_clr)
			unless $wgt->{"Entry $lbl"}->cget('-background') eq 'red' ;

		my $to_value = $to->{$lbl};                   # Might be a ref.
		$to_value = $$to_value if ref $to_value;      # Get value if a ref
		$fm->{$lbl} = $to_value;                      # Roll back value.
	}
}

=head2 Stringifying Entry Widgets

You can get a string of Labels and Entries to be used, for instance, in writing
to a log file. The last arg is optional, a regex for those Labels to be
excluded.

	entries_to_string($wgt_1, $wgt_1->{to}, 'Log File');

=cut

# Give back entries joined into a string.
sub entries_to_string {
	my ($wgt, $to, $exclude_re) = @_;
	my $joined = '';
	foreach my $lbl ( sort keys %$to ) {
		next if $lbl =~ /Feedback|( Max| Min| Res| Type)$/;
		next if defined $exclude_re && $lbl =~ /$exclude_re/;
		my $to_value = $to->{$lbl};                   # Might be a ref.
		$to_value = $$to_value if ref $to_value;      # Get value if a ref
		$joined .= "$lbl = $to_value; ";              # Roll back value.
	}
	return $joined;
}

# Test an entry widget's contents for suitablitly as a path.
sub path_test {
	my ($wgt, $fm, $lbl) = @_;
	$fm->{$lbl} =~ s{\\}{/}g; # All paths Unix-like for Perl.
	$fm->{$lbl} =~ s{(^"|"$)}{}g; # Lose quotes.
	$fm->{$lbl} = qq{"$fm->{$lbl}"} if $fm->{$lbl} =~ m/ /; # Quote if has spaces.
	if ($fm->{$lbl} !~ m/^"??([a-z]:)??\/[a-z|0-9| |_|\-|\/|\.]+"??$/i ) {
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops! Entry '$lbl' not valid path.}
			if $wgt_attribs{'show_feedback'};
		return 1; }
	$wgt->{"Entry $lbl"}->configure(-background => 'white');
	return 0;
}

# Test an entry widget's contents for suitablitly as a number: int or real.
sub num_list_test {
	my ($wgt, $fm, $to, $lbl, $flag) = @_;
	my ($re_match, $id, $format);
	if ( $flag == 0 ) {  # Zero flags int. One flags real.
		$id = 'integer';
		$re_match = '^(-|\+)??[0-9]+$';
	} elsif ($flag == 1) {
		$id = 'real-number' ;
		$re_match = '^(-|\+)??[0-9]+\.?[0-9]*$';
		$format = 2;
		$format = $to->{"$lbl Res"} if defined $to->{"$lbl Res"};
		$format = '%.' . $format . 'f';
	} else {
		die "Oops! Flag must be 0 or 1, not $flag for &num_list_test."
	}
	my @nums = split /\s*[,|:|;]\s*/, $fm->{$lbl}; # Separate out integers.
	my $i = my $err_typ = my $err_rng = 0 ; # Init counters.
	foreach (@nums) { # Should be int or real.
		++$err_typ unless $_ =~ m/$re_match/; # Is it really?
		++$err_rng
			if $err_typ == 0
			and range_test($wgt, $fm, $to, $lbl, $_); # In range if so?
		$nums[$i] = sprintf($format, $_)
			if $err_typ + $err_rng == 0
			and defined $format; # Set res on real-nums if all else okay.
		++$i;
	}
	if ( $err_typ + $err_rng == 0 ) {
		$wgt->{"Entry $lbl"}->configure(-background => 'white');
		$fm->{$lbl} = join ', ', @nums;
		return 0; } # Type and range good for all.
	$wgt->{"Entry $lbl"}->configure(-background => 'yellow'); # Something wrong.
	$fm->{'Feedback'} =
		qq{Oops! Entry '$lbl' not a proper $id list. Errors = $err_typ.}
		if $err_typ > 0
		and $wgt_attribs{'show_feedback'};
	return 1;
}


# Test an entry widget's contents for regex match.
sub string_test {
	my ($wgt, $fm, $to, $lbl) = @_;
	my $regex = $to->{"$lbl Min"}; # Key name shared with &range_test.
	$regex = '.*' unless defined $regex;
	if ( $fm->{$lbl} ne '' ) { # Test only if not blank
		if ( $fm->{$lbl} !~ m/$regex/ ) { 
			$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
			$fm->{'Feedback'} =
				qq{Oops! Entry '$lbl' not a RegEx match for '$regex'.}
				if $wgt_attribs{'show_feedback'};
			return 1; 
		} 
		$wgt->{"Entry $lbl"}->configure(-background => 'white');
		return 0;
	} else {
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops? Entry '$lbl' is blank.}
			if $wgt_attribs{'show_feedback'};
		return 1; 
	}
}

# Test an entry widget's contents for suitablitly as an integer.
sub int_test {
	my ($wgt, $fm, $to, $lbl) = @_;
	if ( $fm->{$lbl} ne '' ) { # Test only if not blank
		if ($fm->{$lbl} !~ m/^(-|\+)?[0-9]+$/) {
			return range_test($wgt, $fm, $to, $lbl); 
			$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
			$fm->{'Feedback'} = qq{Oops! Entry '$lbl' not an integer.}
				if $wgt_attribs{'show_feedback'};
			return 1;
		}
		$wgt->{"Entry $lbl"}->configure(-background => 'white');
		return 0;
	} else {
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops? Entry '$lbl' is blank.}
			if $wgt_attribs{'show_feedback'};
		return 1;
	}
}

# Test an entry widget's contents for suitablitly as a real number.
sub real_test {
	my ($wgt, $fm, $to, $lbl) = @_;
	if ( $fm->{$lbl} ne '' ) { # Test only if not blank.
		if ($fm->{$lbl} =~ m/^(-|\+)?[0-9]+\.?[0-9]*$/) {
			my $format = 2; # Default
			$format = $to->{"$lbl Res"} if defined $to->{"$lbl Res"};
			$format = '%.' . $format . 'f';
			$fm->{$lbl} = sprintf($format, $fm->{$lbl});
			return range_test($wgt, $fm, $to, $lbl); 
		}
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops! Entry '$lbl' not a real number.}
			if $wgt_attribs{'show_feedback'};
		return 1;
	} else {
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops? Entry '$lbl' is blank.}
			if $wgt_attribs{'show_feedback'};
		return 1;
	}
}

# Test an entry widget's contents for suitablitly as a range-limited real number.
sub range_test {
	my ($wgt, $fm, $to, $lbl, $val) = @_;
	$val = $fm->{$lbl} unless defined $val;
	return 0 unless
		defined $to->{"$lbl Min"}
		&&
		defined $to->{"$lbl Max"};
	if ( $val ne '' ) { # Test only if not blank
		if ( $val > $to->{"$lbl Max"}  ) {
			$fm->{'Feedback'} =
				qq{Oops! Entry '$lbl' too high. Max = $to->{"$lbl Max"}.}
				if $wgt_attribs{'show_feedback'};
			$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
			return 1; 
		}
		if ( $val < $to->{"$lbl Min"}  ) {
			$fm->{'Feedback'} =
				qq{Oops! Entry '$lbl' too low. Min = $to->{"$lbl Min"}.}
				if $wgt_attribs{'show_feedback'};
			$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
			return 1; 
		}
	} else {
		$wgt->{"Entry $lbl"}->configure(-background => 'yellow');
		$fm->{'Feedback'} = qq{Oops? Entry '$lbl' is blank.}
			if $wgt_attribs{'show_feedback'};
		return 1;
	}

    	$wgt->{"Entry $lbl"}->configure(-background => 'white');
	return 0;
}

# What to do with errors from entry widget testing, etc.
sub rpt_error {
	my $msg = shift;
	if (defined $err_cref) { &{$err_cref}($msg) }
	else { warn $msg }
}

=head1 TO DO

Add more widget types.

=head1 BUGS AND LIMITATIONS

Only creates columns of label-entry and rows of button widgets at present.

=head1 AUTHOR

Gan Uesli Starling <F<gan@starling.us>>

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2007 - 2017 by Gan Uesli Starling.
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;

__END__