Re: gtk2-perl CVS 20021017
- From: Dermot Musgrove <dermot glade perl connectfree co uk>
- To: goran kirra net
- Cc: gtk-perl-list gnome org
- Subject: Re: gtk2-perl CVS 20021017
- Date: Sat, 19 Oct 2002 03:44:26 +0100
goran kirra net wrote:
[...]
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 :)
Good idea,
could you please add an "feature request" to the project page
so the idea is not lost.
As Guillaume Cottenceau wrote, I think that it might be more predictable
if handlers were called with just one data item/ref. Then each signal
handler could expect to receive ($widget, $data) or - for an event
($widget, $data, $event) as args and use a ref to a structure of hashes
and/or lists to pass data. AFAIR the variable number of data items was a
historical matter in Gtk-Perl - I guess that the only other way to do it
would be to pass ($widget, $event, @data) with an undef $event for
non-events and this would seem to be more wierd than using a data/ref.
I withdraw the request :)
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 didn't get the 041-script to run OK on my machine,
the "use Gtk2::Window" bit failed.
I added them to CVS anyway.
I am having problems compiling GObject and GSignal and this causes
all Gtk2 methods to fail - gtk2-perl-helpers.h missing?
I have also attached a new version of Gtk2::Test with better
documentation and changes suggested by Guillaume's email that it
should be acceptable to expect a known error as a successful test.
The new tests can be defined as eg:
["new()", $EXPECT_ERROR, "=~ /Usage:/"],
if the expected error has the string 'Usage:' in it somewhere. Gtk2::Test
prepends some explanatory text to the Gtk2 error so you can't test for
a known Gtk2 error at the start of the line. Instead of testing for:
'=~ /^FATAL: invalid GtkWindowType value topleel/'
you must test for:
'=~ /FATAL: invalid GtkWindowType value topleel/'
but check the returned error strings for more precise checks. Is this
OK Guillaume?
Regards, Dermot#!/usr/bin/perl
require 5.000; use strict 'vars', 'refs', 'subs';
# Copyright (c) 2002 Dermot Musgrove <dermot musgrove virgin net>
#
# This library is released under the same conditions as Perl, that
# is, either of the following:
#
# a) the GNU General Public License as published by the Free
# Software Foundation; either version 1, or (at your option) any
# later version.
#
# b) the Artistic License.
#
# If you use this library in a commercial enterprise, you are invited,
# but not required, to pay what you feel is a reasonable fee to perl.org
# to ensure that useful software is available now and in the future.
#
# (visit http://www.perl.org/ or email donors perlmongers org for details)
#==============================================================================
#=== This is common code for test scripts
#==============================================================================
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 by a
method, 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 THE TEST PLAN
=head2 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.
I<BYPRODUCT> - C<$class> is set to 'Classname'
=item C<['new()']>
This will construct an object $o in the current $class with the args
supplied (none in this case)
The actual call will be C<$o = new Classname()>
I<BYPRODUCT> - C<$o> is set to the object returned from the method call
and $save is set to the previously constructed object.
=item C<['method()']>
This will call this method with the args supplied (none in this case)
The actual call will be C<$o-E<gt>method()>
I<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
The actual call will be C<$o-E<gt>method('arg1', 'arg2')>
I<BYPRODUCT> - C<$ret> is set to the value returned from the method call
=item C<["method('arg1', 'arg2')", $EXPECT_ERROR, '=~ /error21/']>
This will call this method with the args supplied and expect failure.
Then it will check that the
error string (stored in C<$err>) contains the string 'error21'
The actual call will be C<$o-E<gt>method('arg1', 'arg2')>
I<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
BYPRODUCT - In all cases C<$err> is set to '' or the last error reported
=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.
=cut
use vars qw(
@ISA @EXPORT
@test_plan
$DEBUG
$USE
$GET_SET
$EXPECT_ERROR
$OK
$FAIL
$NOARGS
$NOCHECK
$NULL $ZERO $TRUE $FALSE
$class
$err
$ret
$o $save
$seq
);
$DEBUG = 0;
$FAIL = '__FAIL';
$OK = '__OK';
# $NOARGS = '__NOARGS';
$NOCHECK = undef;
$USE = '__USE';
$GET_SET = '__GET_SET';
$EXPECT_ERROR = '__EXPECT_ERROR';
$NULL = '';
$ZERO = "'0'";
$TRUE = 1;
$FALSE = $ZERO;
$seq = 0;
@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 METHODS
This is usually all you need to call to process your C<@test_plan>
=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) {
$seq++;
$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, $t->[1], $t->[2]), $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], $t->[2]), $OK, $err);
}
}
}
}
=back
There are several internal manual tests that you can use to extend your test
scripts but do remember to add 1 to the C<plan tests> line in C<BEGIN>
for each manual test that you add.
=over 4
=item C<&try_method($method, $args, $expect, $check)>
Run the method in the current class with the supplied arg string and check
that C<$expect> is returned if specified.
Returns either C<$OK> or C<$FAIL> (error details in C<$err>)
I<BYPRODUCT> - C<$ret> will hold the value returned by the method
e.g. C<ok(&try_method('get_border_width', '== 2'), $OK, $err);>
e.g. C<ok(&try_method('get_border_width', $EXPECT_ERROR, '=~ /error21/'), $OK, $err);>
=cut
sub try_method {
my ($method, $args, $expect, $check) = @_;
$args ||= '';
my $res;
$err = '';
#print Dumper(\ _);
print "Save ",Dumper($save) if $method eq 'add';
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 "$seq - $expr - " if $DEBUG > 0;
eval $expr;
if ($@) {
$err = "$class\->$method($args) FAILED: ".$@;
print Dumper($o) if $DEBUG > 2;
}
# Do checks
if (defined $expect && ($expect eq $EXPECT_ERROR)) {
$expr = "\$res = \$err $check";
# print "Checking if '$err' $check - " if $DEBUG > 0;
eval $expr;
unless ($res) {
$err = "Unexpected error returned by $class\->$method($args) ".
"was '$err' which does NOT $check";
# print "$err" if $DEBUG > 0;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
} else {
$err = "Expected error returned by $class\->$method($args): ".$@;
print $err if $DEBUG > 0;
return $OK;
# $err = "Expected error returned by $class\->$method($args) ";
# return $OK;
}
} elsif ($@) {
$err = "Failed to call $class\->$method($args): ".$@;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
} elsif (defined $expect) {
$expr = "\$res = '$ret' $expect";
print "Checking if '$ret' $expect - " if $DEBUG > 0;
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.
Returns either C<$OK> or C<$FAIL>
I<BYPRODUCT> - C<$ret> will hold the value returned by the last get_method
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;>.
Returns either C<$OK> or C<$FAIL>
I<BYPRODUCT> - C<$class> will hold the class name
e.g. C<ok(&try_use('Classname'), $OK, $err);>
=cut
sub try_use {
$class = shift;
$o = $class;
my $expr = "use $class";
print "\n--------------------------- $class\n" if $DEBUG > 1;
print "$seq - $expr - " if $DEBUG > 0;
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);>.
Returns either C<$OK> or C<$FAIL>
I<BYPRODUCT> - C<$o> will be a ref to the constructed object
e.g. C<ok(&try_new('new_with_label', 'Label text'), $OK, $err);>
=cut
sub try_new {
my ($method, $args, $expect, $check) = @_;
my $expr = "\$o = $method ${class}($args)";
my $res;
print "$seq - $expr - " if $DEBUG > 0;
#print "\n$seq - Save ",Dumper($save);
#print "$seq - \$o ",Dumper($o);
$save = $o;
eval $expr;
if ($@) {
$err = "$class\->$method($args) FAILED: ". $@;
print Dumper($o) if $DEBUG > 2;
# return $FAIL;
}
print Dumper($o) if $DEBUG > 4;
# Do checks
if (defined $expect && ($expect eq $EXPECT_ERROR)) {
$expr = "\$res = '$err' $check";
# print "Checking if '$err' $check - " if $DEBUG > 0;
eval $expr;
unless ($res) {
$err = "Unexpected error returned by $class\->$method($args) ".
"was '$err' which does NOT $check";
print "$err\n" if $DEBUG > 1;
print Dumper($o) if $DEBUG > 4;
return $FAIL;
} else {
$err = "Expected error returned by $class\->$method($args): ".$@;
print $err if $DEBUG > 0;
return $OK;
}
}
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
=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 C<$EXPECT_ERROR>
We are expecting this call to fail and will apply the check to C<$err>
instead of C<$ret>.
=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
$NULL Null string ('')
$ZERO Zero (0)
$TRUE
$FALSE
=item Placeholder args
$NOARGS
$NOCHECK
=item C<$FAIL>
Returned in the event of failure.
=item C<$OK>
Returned if test succeeded
=back
=cut
=head1 SEE ALSO
The Test(3) manpage
=head1 AUTHOR
Dermot Musgrove <dermot musgrove virgin net>
=head1 COPYRIGHT
Copyright (c) 2002. Dermot Musgrove. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
See http://www.perl.com/perl/misc/Artistic.html
=cut
1;
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
