gtk2-perl CVS 20021017

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 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
#=== This is common code for test scripts
require 5.000; use strict 'vars', 'refs', 'subs';

    use Test;
    use Data::Dumper;
    use UNIVERSAL qw(can isa);
    use POSIX qw(isdigit);
    use Exporter qw ();


=head1 NAME

Gtk2::Test - Utility methods for testing Gtk2-Perl


    use Gtk2::Test;
    @test_plan = (
        [$USE, 'Gtk2'],
            ["timeout_add(2000, 'handler', 'data')"],
            ["timeout_remove(\$ret)", '== 1'],
    plan tests => scalar @test_plan;

 $DEBUG = $ARGV[0] || 0;



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)>


=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.


=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




=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)

=item Placeholder args


=item C<$FAIL>

Returned in the event of failure.

=item C<$OK>

Returned if test succeeded



    use vars qw( 
        @ISA @EXPORT 



        $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(
        $FAIL $OK $NOARGS
        $class $err $o $save $ret @test_plan
    print "This might take a while if widgets have not yet been compiled\n";


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

=item C<&do_tests()>

Run all the tests in the test_plan

e.g. C<&do_tests;>

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);>

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);>

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);>

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);>

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"));>

sub test_string {
    my ($class) = @_;
#=== This is a script to test $class
require 5.000; use strict 'vars', 'refs', 'subs';

    use Gtk2::Test; 
    \ test_plan = (
        [\$USE, 'Gtk2'],
        [\$USE, '$class'],
            [\"method('args')\", \"eq 'Expected'\"],
            [\$GET_SET, 'method', \"'Expected'\", \"'New value'\"],
    plan tests => scalar \ test_plan;

\$DEBUG = \$ARGV[0] || 0;





Description: Perl program

Attachment: 010_Gtk2_main.t
Description: Troff document

Attachment: 041_Gtk2_Window.t
Description: Troff document

[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]