path: root/Perl/t/test-no-crash.pl

#!/usr/bin/perl -w
# $Id$
# This simple demo has been developped by C. Mertz <mertz@cena.fr>

use Tk;
use Tk::Zinc;
use Getopt::Long;

use strict;

# les variables positionnées en fonction des options de la ligne de commande
my $opt_log = 0;
my $opt_trace = "";
my $opt_render = 0;
my $opt_type = 0;

# on récupère les options
Getopt::Long::Configure('pass_through');
my $optstatus = GetOptions('log=i' => \$opt_log,
			   'trace=s' => \$opt_trace,
			   'render=i' => \$opt_render,
			   'type=s' => \$opt_type,
			   );


my $mw = MainWindow->new();

# The explanation displayed when running this demo
my $label=$mw->Label(-text => "This is a non-regression test, testing that
zinc is not core-dumping!",
		     -justify => 'left')->pack(-padx => 10, -pady => 10);


# Creating the zinc widget
my $zinc = $mw->Zinc(-width => 500, -height => 500,
		     -font => "10x20", # usually fonts are sets in resources
		                       # but for this example it is set in the code!
		     -borderwidth => 0, -relief => 'sunken',
		     -render => $opt_render,
		     )->pack;


my %itemtypes;
my @itemtypes = qw(arc tabular track waypoint
		   bezier curve rectangle triangles
		   group icon map reticle text window
		   );

if ($opt_type) { @itemtypes = ($opt_type); }



$zinc->add('group', 1);
$zinc->add('group', 1);
$zinc->add('icon', 1);
$zinc->add('map', 1);
$zinc->add('reticle', 1);
$zinc->add('text', 1,  -position => [300,120], -text => "hello world1");
$zinc->add('text', 1,  -position => [400,220], -text => "hello world2");
$zinc->add('text', 1,  -position => [400,220], -text => "hello world3");
$zinc->add('window', 1);
$zinc->add('track', 1, 5, -position => [100,20]);
$zinc->add('waypoint', 1, 5, -position => [100,20]);
$zinc->add('tabular', 1, 5, -position => [100,20]);
$zinc->add('tabular', 1, 5, -position => [100,20]);
$zinc->add('group', 1);
$zinc->add('group', 1);

#$zinc->itemconfigure ('tabular', -labelformat => "200x10");
#$zinc->update;



$zinc->add('arc', 1, [10,10 , 50,50]);
$zinc->add('bezier', 1, [10,10 , 50,50, 100,10, 10,200, 150,40]);
$zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]);
$zinc->add('rectangle', 1, [400,400 , 450,220]);
$zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
 	   -colors => ["blue:50", "red:20", "green:80"]);


my %options;
my %types;

foreach my $itemType (@itemtypes) {
    my $anItem = $zinc->find('withtype', $itemType);
    if (!defined $anItem) { print "no item $itemType\n"; next;};
    my @options = $zinc->itemconfigure($anItem);
    for my $elem (@options) {
	my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem;
	$options{$itemType}{$optionName} = [$optionType, $readOnly, $empty, $optionValue];
	$types{$optionType} = 1;
    }
}

foreach my $type (sort keys %types) {
#    print "$type\n";
}


$zinc->mapinfo('mapinfo1', 'create');
$zinc->mapinfo('mapinfo2', 'create');
$zinc->mapinfo('mapinfo3', 'create');

my %typesValues =
    ('justify' => ['left', 'right', 'center'],
     'alpha' => [0, 50, 100, 23],
     'anchor' => ['n', 's', 'e', 'w', 'nw', 'ne', 'sw', 'se', 'center'],
     'angle' => [0, 90, 180, 270, 360, 12, 93, 178, 272, 359],
     'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc',
			 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc',
			 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc',
			 '-',],
     'boolean' => [0..1],
#     'bitmap' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple7', 'AlphaStipple11', 'AlphaStipple14'], ####?!
     'pattern' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?!
     'patterns' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC
     'capstyle' => ['butt', 'projecting', 'round'],
#     'color' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], #TBC
     'gradient' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], ## TBC
     'gradients' => [['green'], ['LemonChiffon'], ['#c84'], ['#4488cc'], ['#888ccc444'],
		     ['red', 'green'], ['red', 'green', 'blue'],
		     ['red:50', 'green:50', 'blue:50'],
		     ['blue:0', 'green:50', 'red:90'],
		     ], ## TBC
     'dimension' => [0..5, 10, 50, 100, 0.0, 5.5, 100.5, 4.5],  ## and floats ?!
     'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations!
     'font' => ['10x20', '6x10', '6x12', '6x13'],
#     'gradientcolor' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444'], ## TBC
     'image' => [], ## TBC
     'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi?
     'item' => [],
     'joinstyle' => ['bevel', 'miter', 'round'],
     'labelformat' => [
		       "200x10", ## BUG BUG
#		       "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20"
		       ],
     'leaderanchors' => [], # [ "%10%30", "% 40 % 20", "% 67 % 21" ], ## TBC
     'lineend' => [ [10,10,10], [10,100,10], [100,10,10], [10,10,100], [100,10,100] ],
     'lineshape' => ['straight', 'rightlightning', 'leftlightning', 'rightcorner', 'leftcorner', 'doublerightcorner', 'doubleleftcorner'],
     'linestyle' => ['dotted', 'simple', 'dashed', 'mixed', 'dotted'],
     'mapinfo' => ['mapinfo1','mapinfo2','mapinfo3'], ## TBC
     'number' => [2.3, 1.0, 5.6, 2.1],
     'point' => [ [0,0] , [10,10], [20,20], [30,30], [20,20], [0,0] , [10,10] ],
     'priority' => [ 1, 10, 50, 1000, 10000 ],  # positif ou nul
     'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
		  'roundraised', 'roundsunken', 'roundgroove',
		  'roundridge', 'sunkenrule', 'raisedrule'],
     'text' => ['teststring', 'short', 'veryverylongstring'],
#     'taglist' => [], ## TBC
     'tags' => [ [1], [1..2], ['a','b'], ['tag1','tag2','tag3']],
     'unsignedint' => [ 0..5 , 10, 20, 30, 100 ],
     'window' => [], ## TBC
     );

# the following valid value associated to types should be all different from
# default value and from value initiated when creating items (see up...)
my %typesNonStandardValues = 
    ('justify' => 'right',
     'alpha' => 50,
     'anchor' => 'w',
     'angle' => 45,
     'autoalignment' => 'llc',
     'pattern' => 'AlphaStipple14',
     'patterns' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'],
     'capstyle' => 'butt',
     'gradient' => 'LemonChiffon',
     'gradients' => ['red:50', 'green:50', 'blue:50'],
     'dimension' => 45,
     'edgelist' => 'contour',
     'font' => '6x10',
     'image' => [], ## TBC
     'integer' => 7,
     'item' => [],
     'joinstyle' => 'miter',
     'labelformat' => "200x30", ## BUG BUG
     'leaderanchors' => "%10x60", ## BUG BUG
     'lineend' => [13,7,20],
     'lineshape' => 'rightlightning',
     'linestyle' => 'dotted',
     'mapinfo' => 'mapinfo2', ## TBC
     'number' => 7.6,
     'point' => [100,100],
     'priority' => 50,
     'relief' => 'groove',
     'text' => 'notsoshort',
     'tags' => ['tag1','tag11','tag111'],
     'unsignedint' => 22,
     'window' => undef, ## TBC
 );
    
my %typesFalseValues =
    ('alpha' => [0..100],
     'anchor' => ['n', 's', 'e', 'w'], ##TBC
     'angle' => [0..360],
     'boolean' => [0..1],
     'capstyle' => [],
     'dimension' => [0..100],
     'font' => ['10x20', '6x10', '6x12', '6x13'],
     'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
		  'roundraised', 'roundsunken', 'roundgroove',
		  'roundridge', 'sunkenrule', 'raisedrule'],
     );


$mw->Button(-text => "Test options",
	    -command => sub {&test_options},
	    )->pack(-pady => 4);   

$mw->Button(-text => "Test cloning",
	    -command => sub {&test_cloning},
	    )->pack(-pady => 4);   

    



sub test_attributes {
    foreach my $type (@itemtypes) {
	my @items = $zinc->find('withtype', $type);
	print "---------testing ", (1+$#items), " ",$type,"(s) ----------------\n";
	if ($#items == -1) { print "*** no such item: $type\n"; next;};
	my %theoptions = %{$options{$type}};
	foreach my $item (@items) {
	    ## il faudrait tester les options selon un ordre défini à l'avance
	    ## en passant par plusieurs occurences pour les options et en forçant
	    ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
	    my @boolean_attributes;
	    my %boolean_attributes;
	    foreach my $option (sort keys %theoptions) {
		my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
		if ($optionType eq 'boolean') {
		    next if $option eq -composerotation;
		    next if $option eq -composescale;
		    next if $option =~ /-\w+sensitive/ ;   # to get rid of many track options!
		    next if $option =~ /-filled\w+/ ;      # to get rid of many track options!
		    next if $option =~ /-speed\w+/ ;      # to get rid of many track options!
		    next if $option =~ /-\w+history/ ;      # to get rid of many track options!
		    push @boolean_attributes, $option;
		    $boolean_attributes{$option}=1;
		}
	    }
	    print $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n");
	    foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
		my $format = "%0" . ($#{boolean_attributes} +1) . "b";
		my $binary = sprintf ($format,$i);
		print $i, "/", (2**(1+$#boolean_attributes)), "  $binary\n";
		my @binary = split (//,$binary);
		foreach my $j (0 .. $#boolean_attributes) {
		    $zinc->itemconfigure( $item, $boolean_attributes[$j] => $binary[$j] );
		    print "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n";
		}
		foreach my $option (sort keys %theoptions) {
		    next if ($option eq -numfields);
		    next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested

		    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
		    my $typeValues = $typesValues{$optionType};
		    if (!defined $typeValues) {print "*** no values for type $optionType (option $option)\n";next;}
		    my @values = @{$typeValues};

		    if (!@values) {print "*** no values for type $optionType (option $option)\n";next;}
			

		    my $valueRef = ref ($values[0]);
		    my $previous_val;
		    my @previous_val;

		    if ($valueRef eq '') {
			$previous_val = $zinc->itemcget($item, $option);
		    }
		    else {
			@previous_val = $zinc->itemcget($item, $option);
		    }
		    print "\$zinc->itemconfigure($item ($type), $option => ",join (", ",@values),"\n"
			if ($opt_log == 1);
		    foreach my $value (@values) {
#			next unless $optionType eq "gradient";
			print "\$zinc->itemconfigure($item ($type), $option => $value)\n"
			    if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
			$zinc->itemconfigure($item, $option => $value);
			$zinc->update;
			$zinc->after(10);
		    }
		    
		    if ($valueRef eq '') {
			$zinc->itemconfigure($item, $option => $previous_val);
		    }
		    else {
			$zinc->itemconfigure($item, $option => \@previous_val);
		    }
		    
		}
#		print "end of sub_test_option\n";
	    }
	}
    }
    print "End of test_option\n";
}


# test2: configurer les fields des track / waypoint / tabular
#        jouer avec les labelformats

# test3: tester toutes les fonctions aléatoirement selon les signatures


# test4: tester qu'ne clonant ont obtient bien une copie de tous les attributs

sub test_cloning {
    foreach my $type (@itemtypes) {
	my $item = $zinc->find('withtype', $type);
	print "---------cloning and testing item ",$type,"(s) ----------------\n";
	if (!defined $item) { print "*** no such item: $type\n"; next;};
	my $clone = $zinc->clone($item);
	my %theoptions = %{$options{$type}};
	## il faudrait tester les options selon un ordre défini à l'avance
	## en passant par plusieurs occurences pour les options et en forçant
	## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
	foreach my $option (sort keys %theoptions) {
	    next if ($option eq -numfields);
	    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
	    my $value = $typesNonStandardValues{$optionType};
#	    if ($optionType ne 'boolean' && !defined $value) {print "*** no values for type $optionType (option $option)\n";next;}

	    my $valueRef = ref ($value);
	    my $previous_val;
	    my @previous_val;

	    # memoryzing previous value of the clone 
	    if ($valueRef eq '') {
		$previous_val = $zinc->itemcget($clone, $option);
	    }
	    else {
		@previous_val = $zinc->itemcget($clone, $option);
	    }

	    # in the case of boolean, we must always take the not value:
	    if ($optionType eq 'boolean') { $value = !$previous_val }

	    print "\$zinc->itemconfigure(clone $clone of $item ($type), $option => $value)\n"
		if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
	    $zinc->itemconfigure($clone, $option => $value);
	    $zinc->update;
#	    $zinc->after(10);
	    if ($valueRef eq '') {
		my $original_value = $zinc->itemcget($item, $option);
		my $clone_value = $zinc->itemcget($clone, $option);
#		print "original = $original_value\n";
#		print "clone    = $clone_value\n";
		if (defined $original_value && $original_value eq $clone_value) {
		    print "*** Cloned $type gets the same $option (type $optionType) ($original_value ?= $previous_val)\n";
		}
	    }
	    else {  # the value is a list
	    print "option $option is waiting a list $valueRef\n";		
	    }

	    # setting back the previous value
	    if ($valueRef eq '') { $zinc->itemconfigure($clone, $option => $previous_val) }
	    else { $zinc->itemconfigure($clone, $option => \@previous_val) }
	    
	}
    }
    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
    # tester le closest avec le centre de la bbox
    
    # faire la même chose que juste avant, mais en interchangeant clone et original
    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
    # tester le closest avec le centre de la bbox
    
    # supprimer l'item original

    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
    # tester le closest avec le centre de la bbox

    # modifier tous les attributs du clone
    # supprimer le clone

    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
    # tester le closest avec le centre de la bbox
     
    print "End of test_cloning\n";
}
    

# &test_mapitems; # should be done before really testing map items attributes
# &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes

&test_attributes; # on peut configurer toutes les attributs
&test_cloning; # le clonage fonctionne correctement !
MainLoop();