1package HTML::Template::Pro::CommonTest;
2
3use strict;
4use warnings;
5use Carp;
6
7use Test;
8use File::Spec;
9use File::Path;
10use HTML::Template::Pro qw/:const/;
11#use Data::Dumper;
12use JSON;
13require Exporter;
14use vars qw/@ISA @EXPORT/;
15@ISA=qw/Exporter/;
16@EXPORT =qw/test_tmpl test_tmpl_std test_tmpl_expr dryrun/;
17
18use vars qw/$DumpDir $DumpDir_no_cs/;
19$DumpDir='json-cs';
20$DumpDir_no_cs='json';
21
22#$Data::Dumper::Terse=1;
23#$Data::Dumper::Indent=1;
24#$Data::Dumper::Useqq=1;
25#$Data::Dumper::Pair = ' : ';
26
27#########################
28
29my $DEBUG=$ENV{HTP_DEBUG};
30$DEBUG||=0;
31
32sub test_tmpl {
33    my $file=shift;
34    my $optref=shift;
35    my @param=@_;
36    my $tmpl;
37    print "\n--------------- Test: $file ---------------------\n";
38    chdir 'templates-Pro';
39    $tmpl=HTML::Template::Pro->new(filename=>$file.'.tmpl',debug=>$DEBUG, @$optref);
40    $tmpl->param(@param);
41    &dryrun($tmpl,$file);
42    $ENV{HTP_DUMP} && &dump_test ($file,{@$optref},{@param});
43    chdir '..';
44}
45
46sub test_tmpl_expr {
47    my $file=shift;
48    my $tmpl;
49    print "\n--------------- Test: $file ---------------------\n";
50    chdir 'templates-Pro';
51    $tmpl=HTML::Template::Pro->new(filename=>$file.'.tmpl', loop_context_vars=>1, case_sensitive=>1,tmpl_var_case=>ASK_NAME_UPPERCASE|ASK_NAME_AS_IS,debug=>$DEBUG, functions=>{'hello' => sub { return "hi, $_[0]!" }});
52    $tmpl->param(@_);
53    # per-object extension
54    $tmpl->register_function('per_object_call' => sub { return shift()."-arg"});
55    $tmpl->register_function('perobjectcall2' => sub { return shift()."-arg"});
56    &dryrun($tmpl,$file);
57    chdir '..';
58}
59
60my $case_ext = [
61    loop_context_vars=>1,
62    case_sensitive=>0,
63    ];
64my $case_int = [
65    loop_context_vars=>1,
66    case_sensitive=>1,
67    tmpl_var_case=>ASK_NAME_UPPERCASE,
68    ];
69
70sub test_tmpl_std {
71    my ($file,@args)=@_;
72    &test_tmpl($file, $case_ext, @args);
73    &test_tmpl($file, $case_int, @args);
74}
75
76sub dryrun {
77    my $tmpl=shift;
78    my $file=shift;
79    open (OUTFILE, ">$file.raw") || die "can't open $file.raw: $!";
80    binmode (OUTFILE);
81    $tmpl->output(print_to => *OUTFILE);
82    close (OUTFILE) || die "can't close $file.raw: $!";
83    my $fileout = &catfile("$file.out");
84    my $files_equal=&catfile("$file.raw") eq $fileout;
85    if ($files_equal) {
86	ok($files_equal) && unlink "$file.raw";
87    } else {
88	if (-x '/usr/bin/diff') {
89	    print STDERR `diff -u $file.out $file.raw`;
90	} else {
91	    print STDERR "# >>> ---$file.raw---\nTODO: diff here\n>>> ---end $file.raw---\n";
92	}
93    }
94    my $output=$tmpl->output();
95    ok (defined $output and $output eq $fileout);
96}
97
98sub catfile {
99    my $file=shift;
100    open (INFILE, $file) || die "can't open $file: $!";
101    binmode (INFILE);
102    local $/;
103    my $catfile=<INFILE>;
104    close (INFILE) || die "can't close $file: $!";
105    return $catfile;
106}
107
108my %filename_counter;
109$0=~/([\w_-]+)(?:\.t)$/;
110my $dump_prefix = $1 ? "$1-" : '';
111sub _dump_file_name {
112    my ($DumpDir,$file) = @_;
113    my $plain=$file;
114    $plain=~s![\\/:]!_!g;
115    return File::Spec->catfile($DumpDir,
116      $dump_prefix.$plain.'-'.sprintf("%.2d",++$filename_counter{$file}).'.json');
117}
118
119sub dump_test {
120    my ($file,$optref,$paramref) = @_;
121    mkpath ([$DumpDir,$DumpDir_no_cs]);
122    my $tojson = {
123	'file' => $file,
124	'options' => $optref,
125	'params' => $paramref,
126    };
127    &__dump_json(&_dump_file_name($DumpDir,$file), $tojson);
128    my $case_sensitive=$optref->{'case_sensitive'};
129    if (defined $case_sensitive) {
130	delete $optref->{'case_sensitive'};
131	$optref->{'tmpl_var_case'}=ASK_NAME_UPPERCASE unless $case_sensitive;
132    }
133    &__dump_json(&_dump_file_name($DumpDir_no_cs,$file), $tojson);
134}
135
136sub __dump_json {
137    my ($dump_file, $tojson) = @_;
138    open FH, '>', $dump_file or die "can't open ($!) ".$dump_file;
139    print FH to_json($tojson, {utf8 => 1, pretty => 1});
140    close (FH) or die "can't close ($!) ".$dump_file;
141}
142
143### Local Variables:
144### mode: perl
145### End:
146
147
1481;
149
150__END__
151
152#head1 NAME
153
154HTML::Template::Pro::CommonTest - internal common test library
155
156#head1 DESCRIPTION
157
158internal common test library
159
160#head1 AUTHOR
161
162I. Vlasenko, E<lt>viy@altlinux.orgE<gt>
163
164#head1 COPYRIGHT AND LICENSE
165
166Copyright (C) 2009 by I. Yu. Vlasenko.
167
168This library is free software; you can redistribute it and/or modify it under
169either the LGPL2+ or under the same terms as Perl itself, either Perl version 5.8.4
170or, at your option, any later version of Perl 5 you may have available.
171
172#cut
173