home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / lib / perl5 / Gtk2 / TestHelper.pm < prev   
Encoding:
Perl POD Document  |  2006-07-27  |  5.2 KB  |  230 lines
  1. #
  2. # $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/pm/TestHelper.pm,v 1.12 2006/07/27 20:13:27 kaffeetisch Exp $
  3. #
  4.  
  5. package Gtk2::TestHelper;
  6. use strict;
  7. use warnings;
  8. use Test::More;
  9. use Carp;
  10.  
  11. our $VERSION = '0.02';
  12.  
  13. sub import
  14. {
  15.     shift;
  16.     my %opts = (@_);
  17.  
  18.     plan skip_all => $opts{skip_all} if ($opts{skip_all});
  19.  
  20.     croak "tests must be provided at import" unless (exists ($opts{tests}));
  21.  
  22.     if ($opts{nowin32} && $^O eq 'MSWin32')
  23.     {
  24.         plan skip_all => "not appliciable on win32";
  25.     }
  26.  
  27.     if ($opts{at_least_version})
  28.     {
  29.         my ($rmajor, $rminor, $rmicro, $text) = 
  30.                         @{$opts{at_least_version}};
  31.         unless (Gtk2->CHECK_VERSION ($rmajor, $rminor, $rmicro))
  32.         {
  33.             plan skip_all => $text;
  34.         }
  35.     }
  36.  
  37.     # gtk+ 2.0.x can use X fonts, and requires a connection to the
  38.     # display at all times; so, ignore noinit for those versions.
  39.     delete $opts{noinit} unless Gtk2->CHECK_VERSION (2, 2, 0);
  40.  
  41.     if( $opts{noinit} || Gtk2->init_check )
  42.     {
  43.         plan tests => $opts{tests};
  44.     }    
  45.     else
  46.     {    
  47.         plan skip_all => 'Gtk2->init_check failed, probably '
  48.                 .'unable to open DISPLAY';
  49.     }
  50.  
  51.     # ignore keyboard
  52.     Gtk2->key_snooper_install (sub { 1; });
  53.  
  54.     # turn on strict and warnings in caller
  55.     $^W = 1;
  56.     @_ = ();
  57.     goto &strict::import;
  58. }
  59.  
  60. package main;
  61.  
  62. # go ahead and use Gtk2 for them.
  63. use Gtk2;
  64. # and obviously they'll need Test::More
  65. use Test::More;
  66.  
  67. # encourage use of these constants in tests
  68. use Glib qw(TRUE FALSE);
  69.  
  70.  
  71. # useful wrappers
  72. sub run_main (;&) {
  73.     my $callback = shift;
  74.     Glib::Idle->add (sub {
  75.         if ($callback) {
  76.             #print "# Entering run_main shutdown callback\n";
  77.             $callback->();
  78.             #print "# Leaving run_main shutdown callback\n";
  79.         }
  80.         Gtk2->main_quit;
  81.         FALSE;
  82.     });
  83.     #print "# Entering main loop (run_main)\n";
  84.     Gtk2->main;
  85.     #print "# Leaving main loop (run_main)\n";
  86. }
  87. sub ok_idle ($;$) {
  88.     my ($testsub, $test_name) = @_;
  89.     run_main {
  90.         # 0 Test::More::ok
  91.         # 1 this block's ok() call
  92.         # 2 idle callback in run_main
  93.         # 3 Gtk2::main call in run_main
  94.         # 4 Gtk2::main call in run_main (again)
  95.         # 5 ok_idle
  96.         # 6 the caller we want to print
  97.         local $Test::Builder::Level = 6;
  98.         ok ($testsub->(), $test_name);
  99.     }
  100. }
  101. sub is_idle ($$;$) {
  102.     my ($asub, $b, $test_name) = @_;
  103.     run_main {
  104.         local $Test::Builder::Level = 6; # see ok_idle()
  105.         is ($asub->(), $b, $test_name);
  106.     }
  107. }
  108.  
  109.  
  110. sub ginterfaces_ok {
  111.     my ($object_or_package) = @_;
  112.     my $type = ref $object_or_package || $object_or_package;
  113.     my $i = 0;
  114.     my @ifaces = Glib::Type->list_interfaces ($type);
  115.     foreach my $iface (@ifaces) {
  116.         if ($object_or_package->isa ($iface)) {
  117.             $i++;
  118.         } else {
  119.             warn "GType $type is supposed to implement $iface, "
  120.                . "but \@type\::ISA doesn't contain $iface!\n";
  121.         }
  122.     }
  123.     is ($i, scalar(@ifaces), "GInterface versus \@ISA for $type");
  124. }
  125.  
  126.  
  127. 1;
  128. __END__
  129.  
  130. =head1 NAME
  131.  
  132. Gtk2::TestHelper - Code to make testing Gtk2 and friends simpler.
  133.  
  134. =head1 SYNOPSIS
  135.  
  136.   use Gtk2::TestHelper tests => 10;
  137.  
  138. =head1 DESCRIPTION
  139.  
  140. A simplistic module that brings together code that would otherwise have to be
  141. copied into each and every test. The magic happens during the importing process
  142. and therefore all options are passed to the use call. The module also use's
  143. strict, warnings, Gtk2, and Test::More so that the individual tests will not
  144. have to. The only required option is the number of tests. The module installs a
  145. key snooper that causes all keyboard input to be ignored.
  146.  
  147. =head1 OPTIONS
  148.  
  149. =over
  150.  
  151. =item tests
  152.  
  153. The number of tests to be completed.
  154.  
  155. =item noinit
  156.  
  157. Do not call Gtk2->init_check, assume that it is not necessary.
  158.  
  159. =item nowin32
  160.  
  161. Set to true if all tests are to be skipped on the win32 platform.
  162.  
  163. =item at_least_version
  164.  
  165. A reference to a list that is checked with Gtk2->CHECK_VERSION.
  166.  
  167. =item skip_all
  168.  
  169. Simply skip all tests with the reason provided.
  170.  
  171. =back
  172.  
  173. =head1 "EXPORTED" FUNCTIONS
  174.  
  175. This module also defines a few utility functions for use in tests; since
  176. we already override import and pull the dirty trick of calling use in
  177. the package main, these are defined in the package main rather than exported
  178. by Exporter.
  179.  
  180. =over
  181.  
  182. =item run_main
  183.  
  184. =item run_main (CODEREF)
  185.  
  186. =item run_main BLOCK
  187.  
  188. Run a main loop, and stop when all pending events are handled.  This is
  189. useful if you have a test that needs a main loop to run properly, because
  190. it allows your program to remain noninteractive.  Important for a test
  191. suite.
  192.  
  193. If the optional I<CODEREF> is supplied, it will be run right before killing
  194. the mainloop.  The function is prototyped to allow two styles of invocation:
  195.  
  196.   run_main (\&some_sub);    # explicit code reference
  197.   run_main { print "hi" };  # callback as a block
  198.  
  199. =item ok_idle (TEST_SUB [, TEST_NAME])
  200.  
  201. Run Test::Simple's ok() on the return value of I<TEST_SUB> after handling
  202. pending events.  Implemented with C<run_main> and other special trickery.
  203.  
  204. =item is_idle (THIS_SUB, THAT [, NAME])
  205.  
  206. Like ok_idle(), but compares the return value of I<THIS_SUB> with I<THAT>
  207. using Test::More's is().
  208.  
  209. =item ginterfaces_ok (GOBJECT_OR_PACKAGE)
  210.  
  211. Verify that the GObject subclass I<GOBJECT_OR_PACKAGE>'s @ISA is set up properly
  212. with all of the GInterfaces that the type system claims it supports.  Something
  213. like an isa_ok() in steroids.
  214.  
  215. =back
  216.  
  217. =head1 SEE ALSO
  218.  
  219. L<perl>(1), L<Gtk2>(3pm).
  220.  
  221. =head1 AUTHORS
  222.  
  223. The Gtk2-Perl Team.
  224.  
  225. =head1 COPYRIGHT AND LICENSE
  226.  
  227. Copyright 2003-2005 by the gtk2-perl team.
  228.  
  229. LGPL, See LICENSE file for more information.
  230.