1# Copyright (C) 2003,2006,2007 Slaven Rezic. All rights reserved. 2# This program is free software; you can redistribute it and/or 3# modify it under the same terms as Perl itself. 4 5# Parts taken from TkTest.pm from Perl/Tk 6 7package TkTest; 8 9use strict; 10use vars qw(@EXPORT); 11 12use base qw(Exporter); 13@EXPORT = qw(check_display_test_harness display_test); 14 15use ExtUtils::Command::MM qw(test_harness); 16 17sub check_display_test_harness { 18 my(@test_harness_args) = @_; 19 20 # In case of cygwin, use'ing Tk before forking (which is done by 21 # Test::Harness) may lead to "remap" errors, which are normally 22 # solved by the rebase or rebaseall utilities. 23 # 24 # Here, I just skip the DISPLAY check on cygwin to not force users 25 # to run rebase. 26 # 27 if (!($^O eq 'cygwin' || $^O eq 'MSWin32')) { 28 29 eval q{ 30 use blib; 31 use Tk; 32 }; 33 die "Strange: could not load Tk library: $@" if $@; 34 35 # empty the argument list for the following test_harness 36 @ARGV = () if !_can_MainWindow(); 37 } 38 39 test_harness(@test_harness_args); 40} 41 42# Avoid this function. Tk 804.xxx may die if multiple MainWindows are 43# created within one process (seen e.g. on FreeBSD systems). By using 44# this function a test MainWindow will be created, so the next "real" 45# $mw creation may fail. 46# 47# display_test() is only safe if subsequent creation of MainWindows is 48# done in separate processes (i.e. if using system(...)) 49sub display_test { 50 if (!_can_MainWindow()) { 51 print "1..0 # skip Cannot create MainWindow\n"; 52 CORE::exit(0); 53 } 54} 55 56sub _can_MainWindow { 57 require Tk; 58 if (defined $Tk::platform && $Tk::platform eq 'unix') { 59 my $mw = eval { MainWindow->new() }; 60 if (!Tk::Exists($mw)) { 61 warn "Cannot create MainWindow (maybe no X11 server is running or DISPLAY is not set?)\n$@\n"; 62 return 0; 63 } else { 64 $mw->destroy; 65 return 1; 66 } 67 } else { 68 return 1; 69 } 70} 71 721; 73 74__END__ 75