#! /usr/bin/perl -w
# $Id$
## Most parts are ripped from Template::Test and thus (c) Andy Wardley
# This is an utility script to extract Test cases (from the DATA secion)
# from the TT test suite # in order to reuse them in Jemplate.
#
# Limitation : it's not currently possible to automatically generate
# Test.Data compatible suite because TT test suite also relies on
# Perl manipulation. (context, post-processing, My::Object)
use strict;
use warnings;
use Template;
use IO::All;
use File::Spec;
use Getopt::Long;
use Pod::Usage;
my $context = '';
my $ctx_file = '';
my $mode = "perl";
my $help = 0;
GetOptions('help|?' => \$help, "context=s" => \$ctx_file, "mode=s", \$mode)
or pod2usage(2);
pod2usage(1) if $help;
our $tt = Template->new;
if (-e $ctx_file) {
my $content = io($ctx_file)->slurp;
if ($mode eq 'perl') {
require JSON;
my $json = JSON->new(); #pretty => 1, delimiter => 1);
$context = $json->objToJson(eval $content );
} else {
#assume it's raw context
$context = $content;
}
}
my @data = io('-')->separator('__DATA__')->slurp;
my $data = pop @data;
my $tests = extract($data);
create_jemplates($tests);
generate_testfile($tests, $context);
# Create the Test.Data test file
sub generate_testfile {
my ($tests, $context) = @_;
# reuse tt itself ;)
$tt->process('test-data.tmpl.tt',
{ tests => $tests, context => $context, name => 'newtest' })
or die $tt->error;
}
# create jemplates on disk based on the 'input' of the tests
sub create_jemplates {
my $tests = shift;
for my $t (@$tests) {
my $name = $t->{name} || "";
my $filename = File::Spec->catfile('jemplates', dirify($name).'.html');
my $content = delete $t->{input};
$content > io($filename);
$t->{filename} = $filename;
}
}
# Generate a cleaner filename from the test name
sub dirify {
my $name = shift;
$name =~ s/ /-/g;
$name =~ s/[^\w\.-]/_/g;
return $name;
}
sub extract {
my ($src) = @_;
my $input;
eval {
local $/ = undef;
$input = ref $src ? <$src> : $src;
};
if ($@) {
warn "Cannot read input text from $src\n";
return undef;
}
# remove any comment lines
$input =~ s/^#.*?\n//gm;
# remove anything before '-- start --' and/or after '-- stop --'
$input = $' if $input =~ /\s*--\s*start\s*--\s*/;
$input = $` if $input =~ /\s*--\s*stop\s*--\s*/;
my @tests = split(/^\s*--\s*test\s*--\s*\n/im, $input);
# if the first line of the file was '--test--' (optional) then the
# first test will be empty and can be discarded
shift(@tests) if $tests[0] =~ /^\s*$/;
my @suite = ();
my $count = 0;
# the remaining tests are defined in @tests...
foreach my $input (@tests) {
$count++;
my $name = '';
if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) {
$name = $1;
} else {
$name = "test $count";
}
# split input by a line like "-- expect --"
my $expect;
($input, $expect) =
split(/^\s*--\s*expect\s*--\s*\n/im, $input);
$expect = ''
unless defined $expect;
# input text may be prefixed with "-- use name --" to indicate a
# Template object in the $ttproc hash which we should use
if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) {
warn "ignored 'use' thing";
next;
}
# another hack: if the '-- expect --' section starts with
# '-- process --' then we process the expected output
# before comparing it with the generated output. This is
# slightly twisted but it makes it possible to run tests
# where the expected output isn't static. See t/date.t for
# an example.
if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) {
warn "ignored the 'process' hack";
next;
};
push @suite, { input => $input, expect => $expect, name => $name };
}
return \@suite;
}
__END__
=head1 NAME
find a name if this script is useful
=head1 SYNOPSIS
mangle.pl [--context file] [--mode perl|other] < input
Options:
--help this help message
--context= context file to use
--mode= of the context
=head1 DESCRIPTION
stub. to write.
=cut