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