Hi again, Some more thoughts: 1) If there are any functions eg in src/Gtk2.c update_ui that could be recursive perhaps the names should be made different by prefixing them with an '_' underscore (rather than what I did by adding a suffix of '1') so that Gtk2.pm has sub update_ui that calls _update_ui in the src.Gtk2.c file. 2) The old perl way of connecting signals allowed for multiple items of data to be passed as args after the callback arg. I don't know how it works but the effect is that the args to the callback can be got by: my ($widget, @data) = @_; If the callback is for an event, the event structurea is added at the end so a signal handler could get the args eg: my ($class, $data1, $data2, $data3, $event) = @_; depending on how the signal was connected. I am not sure what the best answer is - I remember some threads on the gtk-perl list ages ago. I guess that it might be simplest to insist that all data is passed in an anonymous array/hash so that only a ref is passed - which is what happens already I guess :) 3) I have written (and attached) a Gtk2::Test module and a script that will generate test scripts for each widget mentioned in the gtk2 docs. These scripts can be extended as methods are added. I guess that if you want to use them it would be best to add them to the t/ directory after the widgets are added. I have also attached two minimal versions that I have edited to run. You will see that a script can easily test several widgets and it might be better to concatenate the tests when the widgets become stable. I guess that the test scripts could be written (if missing) by the compile-widgets script so that they magically appear when the widgets are added to the Gtk2/ directory but they would lose the sequence prefix that ensures that they are run in a sensible order. Regards, Dermot
#!/usr/bin/perl
#==============================================================================
#=== This is common code for test scripts
#==============================================================================
require 5.000; use strict 'vars', 'refs', 'subs';
BEGIN {
use Test;
use Data::Dumper;
use UNIVERSAL qw(can isa);
use POSIX qw(isdigit);
use Exporter qw ();
=pod
=head1 NAME
Gtk2::Test - Utility methods for testing Gtk2-Perl
=head1 SYNOPSIS
BEGIN {
use Gtk2::Test;
@test_plan = (
[$USE, 'Gtk2'],
["init()"],
["timeout_add(2000, 'handler', 'data')"],
["timeout_remove(\$ret)", '== 1'],
["update_ui"],
);
plan tests => scalar @test_plan;
}
$DEBUG = $ARGV[0] || 0;
&do_tests;
=head1 DESCRIPTION
Gtk2::Test provides some utility methods that are used to test Gtk2-Perl
directly or during 'make test'. There are several exported variables that
can be used to work with - such as the current class, value returned,
error string and current object.
The methods carry out the tests and report all actions requested.
The methods can be called directly or indirectly but the simplest way is
to specify a test_plan and run it automatically.
=head1 C<@test_plan>
This is the real user interface. All the tests are defined in an array that
is exported from Gtk2::Test.
The array holds all the tests in the order that they should be run.
Each test is defined as an anonymous array of up to 4 elements and
there are several possible test specifications:
=over 4
=item C<[$USE, 'Classname']>
This will try to 'use Classname;' and report any failures.
BYPRODUCT - C<$class> is set to 'Classname'
=item C<['new()']>
This will construct an object $o with the args supplied (none in this case)
The actual call will be C<$o = new Classname()>
BYPRODUCT - C<$o> is set to the object returned from the method call
=item C<['method()']>
This will call this method with the args supplied (none in this case)
The actual call will be C<$o->init()>
BYPRODUCT - C<$ret> is set to the value returned from the method call
=item C<["method('arg1', 'arg2')", '== 1']>
This will call this method with the args supplied and check that the
returned value (stored in C<$ret>) is numerically equal to 1
BYPRODUCT - C<$ret> is set to the value returned from the method call
=item C<[$GET_SET, 'method', "'Expected'", "'New value'"]>
This will call C<get_method()> and check that it returns 'Expected'
Then it calls C<set_method('New value')>
Finally calls C<get_method()> again and checks that it returns 'New value'
The comparison depends on the first expected value - if it is digits the
checks are C<($ret == $expected)> otherwise C<($ret eq $expected)>
=back
=head2 Checks
The returned value (stored in C<$ret>) is compared as specified in the
second arg. Any code supplied is C<eval()>ed and failures passed back.
=head1 VARIABLES
=over 4
=item C<$o>
This is the widget instance that was constructed and is used for all
subsequent tests.
=item C<$save>
This where you can save widget instances for use later - ie $o->add($save);
=item C<$err>
The error string returned by the latest test.
=item C<$ret>
The value that was returned by the latest method call
=item C<$DEBUG>
Setting $DEBUG to a number > 0 will cause debugging messages to be printed
Level Output
1 Method calls that will be tested
2 Failed check on expected value
3 new() calls
4 All checks made on expected value
5 A Data::Dumper print of $o on failure
=back
=cut
=head1 CONSTANTS
=over 4
=item C<$USE>
This is a request to use() a class
=item C<$GET_SET>
This is a request to get/set/get a widget property
=item Values to use in C<@test_plan>
These values can be used in the testplan to avoid escaping strings and to
make sure that the values get through to the test evals
C<$NULL> Null string ('')
C<$ZERO> Zero (0)
C<$TRUE>
C<$FALSE>
=item Placeholder args
C<$NOARGS>
C<$NOCHECK>
=item C<$FAIL>
Returned in the event of failure.
=item C<$OK>
Returned if test succeeded
=back
=cut
use vars qw(
@ISA @EXPORT
@test_plan
$DEBUG
$USE
$GET_SET
$OK
$FAIL
$NOARGS
$NOCHECK
$NULL $ZERO $TRUE $FALSE
$class
$err
$ret
$o $save
);
$DEBUG = 0;
$FAIL = '__FAIL';
$OK = '__OK';
# $NOARGS = '__NOARGS';
$NOCHECK = undef;
$USE = '__USE';
$GET_SET = '__GET_SET';
$NULL = '';
$ZERO = "'0'";
$TRUE = 1;
$FALSE = $ZERO;
@ISA = qw(Test);
# These symbols (globals and functions) are always exported
@EXPORT = qw(
$DEBUG
$FAIL $OK $NOARGS
$USE
$class $err $o $save $ret @test_plan
);
print "This might take a while if widgets have not yet been compiled\n";
}
=head1 TESTING METHODS
The class methods provide ways to test methods automatically or manually.
Do remember to add 1 to the C<plan tests> line in C<BEGIN>
for each manual test that you add to your test script.
=over 4
=cut
=item C<&do_tests()>
Run all the tests in the test_plan
e.g. C<&do_tests;>
=cut
sub do_tests {
my ($t, $method, $args, $call);
foreach $t (@test_plan) {
$call = $t->[0];
if (" $USE use " =~ / $call /) {
ok(&try_use($t->[1]), $OK, $err);
} else {
$call =~ /\(/ or $call .= "()";
$call =~ /\)/ or $call .= ")";
$call =~ /(.+)\((.*)\)$/;
$method = $1; $args = $2;
if ($method =~ '^new') {
ok(&try_new($method, $args), $OK, $err);
} elsif (" $GET_SET get_set " =~ / $method /) {
ok(&try_get_set($t->[1], $t->[2], $t->[3]), $OK, $err);
} else {
ok(&try_method($method, $args, $t->[1]), $OK, $err);
}
}
}
}
=item C<&try_method($method, $args, $expect)>
Run the method in the current class with the supplied arg string and check
that C<$expect> is returned if specified.
e.g. C<ok(&try_method('get_border_width', '== 2'), $OK, $err);>
=cut
sub try_method {
my ($method, $args, $expect) = @_;
$args ||= '';
my $res;
$err = '';
unless ($o->can($method)) {
$err = "$class\->$method - no such method";
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
my $expr = "\$ret = \$o->$method($args)";
print "$expr - " if $DEBUG > 0;
eval $expr;
if ($@) {
$err = "Failed to call $class\->$method($args): ".$@;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
if (defined $expect) {
# print "$ret $expect"."\n";
$expr = "\$res = '$ret' $expect";
print "Checking if '$ret' $expect - " if $DEBUG > 3;
eval $expr;
unless ($res) {
$err = "Value returned by $class\->$method($args) ".
"was '$ret' which does NOT $expect";
print "$err\n" if $DEBUG > 1;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
}
$err = '';
return $OK;
}
=item C<&try_get_set($method, $old, $new)>
Run the C<get_method()> in the current class and check it equals C<$old>
Then run C<set_method($new)> and finally run C<get_method> again to check
that C<$new> is returned.
e.g. C<ok(&try_get_set('resizable', $TRUE, $FALSE), $OK, $err);>
=cut
sub try_get_set {
my ($method, $old, $new) = @_;
if (isdigit($old)) {
(&try_method("get_$method", $NOARGS, "== $old") eq $OK) or return $FAIL;
(&try_method("set_$method", $new) eq $OK) or return $FAIL;
(&try_method("get_$method", $NOARGS, "== $new") eq $OK) or return $FAIL;
} else {
(&try_method("get_$method", $NOARGS, "eq $old") eq $OK) or return $FAIL;
(&try_method("set_$method", $new) eq $OK) or return $FAIL;
(&try_method("get_$method", $NOARGS, "eq $new") eq $OK) or return $FAIL;
}
return $OK;
}
=item C<&try_use($class)>
Tries to C<use $class;>.
e.g. C<ok(&try_use('Classname'), $OK, $err);>
=cut
sub try_use {
$class = shift;
$o = $class;
my $expr = "use $class";
print "---------------------------\n".
"$expr - " if $DEBUG > 2;
eval $expr;
if ($@) {
$err = "Could not use $class";
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
return $OK;
}
=item C<&try_new($method, $args)>
Tries to call C<$o = $class->$method($args);>.
e.g. C<ok(&try_new('new_with_label', 'Label text'), $OK, $err);>
=cut
sub try_new {
my ($call, $args) = @_;
my $expr = "\$o = $call ${class}($args)";
print "$expr - " if $DEBUG > 2;
eval $expr;
if ($@) {
$err = "$class\->$call($args) FAILED: ". $@;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
print Dumper($o) if $DEBUG > 4;
if ($o->isa($class)) {
return $OK;
} else {
$err = "Widget is not a $class";
print Dumper($o) if $DEBUG > 4;
return $FAIL;
}
}
=item C<&test_string($class)>
Returns a skeleton test script for specified widget
e.g. C<print(&test_string("Gtk2::Gdk::Pixmap"));>
=cut
sub test_string {
my ($class) = @_;
return
"#!/usr/bin/perl
#==============================================================================
#=== This is a script to test $class
#==============================================================================
require 5.000; use strict 'vars', 'refs', 'subs';
BEGIN {
use Gtk2::Test;
\ test_plan = (
[\$USE, 'Gtk2'],
[\"init()\"],
[\$USE, '$class'],
[\"new()\"],
[\"method('args')\", \"eq 'Expected'\"],
[\$GET_SET, 'method', \"'Expected'\", \"'New value'\"],
);
plan tests => scalar \ test_plan;
}
\$DEBUG = \$ARGV[0] || 0;
\&do_tests;
";
}
=back
=cut
1;
Attachment:
write_test_scripts.pl
Description: Perl program
Attachment:
010_Gtk2_main.t
Description: Troff document
Attachment:
041_Gtk2_Window.t
Description: Troff document