Group
Extension

Tk-DBI-LoginDialog/t/02sub.t

#!/usr/bin/perl
#########################
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl 02sub.t'
#
# 02sub.t - test harness for module Tk::DBI::LoginDialog
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 2 of the License,
# or any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#########################
use strict;
use warnings;

use Data::Dumper;
use Log::Log4perl qw/ :easy /;
use Tk;
use Test::More;

# ---- test harness ----
use lib 't';
use tester;

my $ot = tester->new('Tk::DBI::LoginDialog');
$ot->planned(308);


# ---- module ----
require_ok($ot->this);


# ---- globals ----
Log::Log4perl->easy_init($DEBUG);
my $log = get_logger(__FILE__);
my $top = $ot->top;


# ---- create ----
my %field = (dsn => "val_0", username => "val_1", password => "val_2");
my $ld0 = $top->LoginDialog(%field);
isa_ok($ld0, $ot->this, "new with parms");


# ---- destroy some subwidgets ----
$ot->queue_button($ld0, "Cancel");

for (keys %field, "error") {

	my $w = $ld0->Subwidget($_);

	$w->destroy;

	ok(Tk::Exists($w) == 0,	"destroy subwidget $_");

	$ld0->update;
}

my $ld1 = $top->LoginDialog;
isa_ok($ld1, $ot->this, "new no parms");


# ---- test properties of dialog ----
my %prop = (
  -title => 'foobar',
  -foreground => 'red',
  -background => 'blue',
);

while (my ($property, $value) = each %prop) {
	my $old_value = $ld1->cget($property);
	isnt($old_value, "",	"property $property default non-null");

	$ld1->configure($property => $value);
	isnt($ld1->cget($property), $old_value,	"property $property override");

	$prop{$property} = $old_value;
}
$ot->queue_button($ld1, "Cancel");

while (my ($property, $old_value) = each %prop) {

	$ld1->configure($property => $old_value);
	is($ld1->cget($property), $old_value,	"property $property reset");
}


# ---- test common properties of appropriate subwidgets ----
my %common;	# maintain a count of common properties
my $c_widget = 0;
my @subwidgets;

for my $w ($ld1->Subwidget) {

	next if ($w->class =~ /Frame|LoginDialog/);

	$c_widget++;
	my $properties = "";

	map {
		$properties .= sprintf "%s ", $_->[0];

		if (exists($common{$_->[0]})) {
			$common{$_->[0]}++;
		} else {
			$common{$_->[0]} = 1;
		}
	} $w->configure;

#	$log->debug(sprintf "subwidget [%s] class [%s] properties [%s]",
#		$w->name, $w->class, $properties);

	push @subwidgets, $w;
}

while (my ($property, $count) = each %common) {

	delete $common{$property} unless ($count == $c_widget);
	delete $common{$property} if ($property =~ /\-(takefocus|cursor|fg|bg)/);
}

#$log->debug(sprintf "c_widget [$c_widget] common [%s]", Dumper(\%common));

my %substitute = (
	'^[bB]lack$' => 'white',
	'^\d$' => '4',
	'^\d\d$' => '40',
	'^\#d9d9d9$' => 'red',
	'^[wW]hite$' => 'blue',
	'^raised$' => 'sunken',
	'^sunken$' => 'ridge',
);

for my $w (@subwidgets) {

	my $name = $w->name;

	while (my ($property, $value) = each %common) {
		my $value = $w->cget($property);
		$common{$property} = $value;

		isnt($value, "",	"widget $name property $property default non-null");

#		$log->debug("property [$property] value [$value]");
		while (my ($re, $swap) = each %substitute) {
			if ($value =~ /$re/) {
				$value = $swap;
#				$log->debug("swap [$swap]");
				last;
			}
		}
		
		$w->configure($property => $value);
		is($w->cget($property), $value,	"widget $name property $property apply");

	}
}

$ot->queue_button($ld1, "Cancel");



Powered by Groonga
Maintained by Kenichi Ishigaki <ishigaki@cpan.org>. If you find anything, submit it on GitHub.