#!/usr/bin/perl -w
# -*- perl -*-
#
# Author: Slaven Rezic
#
use strict;
use Cwd qw(cwd);
use FindBin;
use File::Basename qw(basename);
use File::Spec;
use Getopt::Long;
use lib $FindBin::RealBin;
use TkTest qw(display_test);
BEGIN {
display_test();
}
BEGIN {
if (!eval q{
use Test::More;
use POSIX ":sys_wait_h";
use File::Temp qw(tempfile tempdir);
1;
}) {
print "1..0 # skip no Test::More and/or POSIX module\n";
CORE::exit(0);
}
if ($^O eq 'MSWin32') {
print "1..0 # skip not on Windows\n"; # XXX but why?
CORE::exit(0);
}
}
my $DEBUG = 0;
my $blib = File::Spec->rel2abs("$FindBin::RealBin/../blib");
my $script = "$blib/script/tkpod";
my $tkmore_script = "$blib/script/tkmore";
my $batch_mode = defined $ENV{BATCH} ? $ENV{BATCH} : 1;
my $cwd = cwd;
# http://rt.cpan.org/Ticket/Display.html?id=41320 (have to chdir out
# of temp directory before File::Temp cleans directories)
END { chdir $cwd if defined $cwd }
GetOptions("d|debug" => \$DEBUG,
"batch!" => \$batch_mode)
or die "usage: $0 [-debug] [-nobatch]";
# Create test directories/files:
my $testdir = tempdir("tkpod_XXXXXXXX", TMPDIR => 1, CLEANUP => 1);
die "Can't create temporary directory: $!" if !$testdir;
my $cpandir = "$testdir/CPAN";
mkdir $cpandir, 0777 or die "Cannot create temporary directory: $!";
my $cpanfile = "$testdir/CPAN.pm";
{
open FH, "> $cpanfile"
or die "Cannot create $cpanfile: $!";
print FH "=pod\n\nTest\n\n=cut\n";
close FH
or die "While closing: $!";
}
my $obscurepod = "ThisFileReallyShouldNotExistInAPerlDistroXYZfooBAR";
my $obscurefile = "$testdir/$obscurepod.pod";
{
open FH, "> $obscurefile"
or die "Cannot create $obscurefile: $!";
print FH "=pod\n\nThis is: $obscurepod\n\n=cut\n";
close FH
or die "While closing: $!";
}
my @opt = (
['-tk'],
['-tree','-geometry','+0+0'],
['-notree'],
['-Mblib'],
#['-Iblib/lib'],
['-d'],
['-server'],
['-xrm', '*font: {nimbus sans l} 24',
'-xrm', '*serifFont: {nimbus roman no9 l}',
'-xrm', '*sansSerifFont: {nimbus sans l}',
'-xrm', '*monospaceFont: {nimbus mono l}',
],
[$script], # the pod of tkpod itself
# Environment settings
['-tree', '__ENV__', TKPODCACHE => "$testdir/pods_%v_%o_%u"],
['__ENV__', TKPODDEBUG => 1],
['__ENV__', TKPODEDITOR => 'ptked'],
[$obscurepod.".pod", '__ENV__', TKPODDIRS => $testdir],
# tkmore
['__SCRIPT__', $tkmore_script, $0],
['__SCRIPT__', $tkmore_script, "-xrm", "*fixedFont:{monospace 10}", $0],
['__SCRIPT__', $tkmore_script, "-font", "monospace 10", $0],
['__SCRIPT__', $tkmore_script, "$FindBin::RealBin/testdata/latin1.txt"],
['__SCRIPT__', $tkmore_script, -encoding => "utf-8", "$FindBin::RealBin/testdata/utf8.txt"],
['__SCRIPT__', $tkmore_script, -encoding => "utf-8", "$FindBin::RealBin/testdata/utf8.txt.gz"],
# This should be near end...
['__ACTION__', chdir => $testdir ],
["CPAN"],
# Cleanup (jump out of $testdir, so File::Temp cleanup does not fail)
['__ACTION__', chdir => $FindBin::RealBin ],
);
plan tests => scalar @opt;
OPT:
for my $opt (@opt) {
if ($opt->[0] eq '__ACTION__') {
my $action = $opt->[1];
if ($action eq 'chdir') {
chdir $opt->[2] or die $!;
} else {
die "Unknown action $action";
}
pass "Just setting an action...";
next;
}
local %ENV = %ENV;
delete $ENV{$_} for qw(TKPODCACHE TKPODDEBUG TKPODDIRS TKPODEDITOR);
my $this_script = $script;
my @this_opts;
my @this_env;
for(my $i = 0; $i<=$#$opt; $i++) {
if ($opt->[$i] eq '__ENV__') {
$ENV{$opt->[$i+1]} = $opt->[$i+2];
push @this_env, $opt->[$i+1]."=".$opt->[$i+2];
$i+=2;
} elsif ($opt->[$i] eq '__SCRIPT__') {
$this_script = $opt->[$i+1];
$i+=1;
} else {
push @this_opts, $opt->[$i];
}
}
my $testname = "Trying " . basename($this_script) . " with @this_opts";
if (@this_env) {
$testname .= ", environment " . join(", ", @this_env);
}
if ($batch_mode) {
my $pid = fork;
if ($pid == 0) {
run_tkpod($this_script, \@this_opts);
}
for (1..10) {
select(undef,undef,undef,0.05);
my $kid = waitpid($pid, WNOHANG);
if ($kid) {
is($?, 0, $testname);
next OPT;
}
}
kill TERM => $pid;
for (1..10) {
select(undef,undef,undef,0.05);
if (!kill 0 => $pid) {
pass($testname);
next OPT;
}
}
kill KILL => $pid;
pass($testname);
} else {
run_tkpod($this_script, \@this_opts);
pass($testname);
}
}
sub run_tkpod {
my($script, $this_opts_ref) = @_;
my @cmd = ($^X, "-Mblib=$blib", $script, "-geometry", "+10+10", @$this_opts_ref);
warn "@cmd\n" if $DEBUG;
if ($batch_mode) {
open(STDERR, ">" . File::Spec->devnull) unless $DEBUG;
exec @cmd;
die $!;
} else {
system @cmd;
if ($? == 2) {
die "Aborted by user...\n";
}
if ($? != 0) {
warn "<@cmd> failed with status code <$?>";
}
}
}
__END__