################################################################################
#
# $Project: /Tk-DataTree $
# $Author: mhx $
# $Date: 2008/01/11 00:18:49 +0100 $
# $Revision: 7 $
# $Snapshot: /Tk-DataTree/0.06 $
# $Source: /t/102_stress.t $
#
################################################################################
#
# Copyright (c) 2004-2008 Marcus Holland-Moritz. All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
################################################################################
use Test;
BEGIN { plan tests => 100 }
use Tk;
use Tk::DataTree;
eval {
require Scalar::Util;
*dualvar = \&Scalar::Util::dualvar;
};
if ($@) {
print "# Scalar::Util not installed\n";
*dualvar = sub { "$_[1] ($_[0])" };
}
my $sleep = $ENV{DATATREE_TEST_SLEEP} || 0;
my $mw = new MainWindow;
$mw->geometry("800x600");
my @dt = map {
getwidget()->pack(-fill => 'both', -expand => 1, -side => 'left')
} 1 .. 4;
srand 0;
my $string = 'aaaaa';
$mw->idletasks;
for (1 .. 100) {
s/#.*//;
/\S/ or next;
for my $dt (@dt) {
if (rand() < 0.1) {
$dt->packForget;
$dt->destroy;
$dt = getwidget()->pack(-fill => 'both', -expand => 1, -side => 'left');
}
my $r = getrand();
if (rand() < 0.5) {
$dt->data($r);
}
else {
$dt->configure(-data => $r);
}
$dt->autosetmode;
$dt->configure(-undefcolor => getcolor());
my $w = $dt->Subwidget('scrolled') || $dt;
$w->Subwidget('normalstyle')
->configure(-fg => getcolor(), -background => getcolor());
$w->Subwidget('nodestyle')
->configure(-fg => getcolor(), -background => getcolor());
$w->Subwidget('activestyle')
->configure(-fg => getcolor(), -background => getcolor());
}
$mw->idletasks;
ok($@,'');
select undef, undef, undef, $sleep;
}
sub getwidget
{
my $r = rand 3;
if ($r < 1) {
return $mw->Scrolled('DataTree', -activecolor => getcolor(),
-scrollbars => 'sw');
}
elsif ($r < 2) {
return $mw->DataTree(-activecolor => getcolor());
}
else {
return $mw->Scrolled('DataTree', -activecolor => getcolor(),
-scrollbars => 'e');
}
}
sub getcolor
{
my @hex = ('0'..'9', 'A'..'F');
join '', '#', map { $hex[rand @hex] } 1 .. 6;
}
sub getrand
{
my $l = shift || 0;
my $c = rand( $l > 4 ? 5 : 7 );
if ($c < 1) {
return int rand 100000;
}
elsif ($c < 2) {
return $string++;
}
elsif ($c < 3) {
return dualvar(int rand 100000, $string++);
}
elsif ($c < 4) {
return sub { log rand shift };
}
elsif ($c < 5) {
return undef;
}
elsif ($c < 6) {
return [ map { getrand($l+1) } 0 .. rand 10 ];
}
elsif ($c < 7) {
return { map { ($string++ => getrand($l+1)) } 0 .. rand 10 };
}
}