1package HTML::Template::Pro; 2 3use 5.005; 4use strict; 5use integer; # no floating point math so far! 6use HTML::Template::Pro::WrapAssociate; 7use File::Spec; # generate paths that work on all platforms 8use Scalar::Util qw(tainted); 9use Carp; 10require DynaLoader; 11require Exporter; 12use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); 13@ISA = qw(DynaLoader Exporter); 14 15$VERSION = '0.9510'; 16 17@EXPORT_OK = qw/ASK_NAME_DEFAULT ASK_NAME_AS_IS ASK_NAME_LOWERCASE ASK_NAME_UPPERCASE ASK_NAME_MASK/; 18%EXPORT_TAGS = (const => [qw/ASK_NAME_DEFAULT ASK_NAME_AS_IS ASK_NAME_LOWERCASE ASK_NAME_UPPERCASE ASK_NAME_MASK/]); 19 20# constants for tmpl_var_case 21use constant { 22 ASK_NAME_DEFAULT => 0, 23 ASK_NAME_AS_IS => 1, 24 ASK_NAME_LOWERCASE => 2, 25 ASK_NAME_UPPERCASE => 4, 26}; 27use constant ASK_NAME_MASK => ASK_NAME_AS_IS | ASK_NAME_LOWERCASE | ASK_NAME_UPPERCASE; 28 29 30bootstrap HTML::Template::Pro $VERSION; 31 32## when HTML::Template is not loaded, 33## all calls to HTML::Template will be sent to HTML::Template::Pro, 34## otherwise native HTML::Template will be used 35push @HTML::Template::ISA, qw/HTML::Template::Pro/; 36push @HTML::Template::Expr::ISA, qw/HTML::Template::Pro/; 37 38# Preloaded methods go here. 39 40# internal C library init -- required 41_init(); 42# internal C library unload -- it is better to comment it: 43# when process terminates, memory is freed anyway 44# but END {} can be called between calls (as SpeedyCGI does) 45# END {_done()} 46 47# initialize preset function table 48use vars qw(%FUNC); 49%FUNC = 50 ( 51 # note that length,defined,sin,cos,log,tan,... are built-in 52 'sprintf' => sub { sprintf(shift, @_); }, 53 'substr' => sub { 54 return substr($_[0], $_[1]) if @_ == 2; 55 return substr($_[0], $_[1], $_[2]); 56 }, 57 'lc' => sub { lc($_[0]); }, 58 'lcfirst' => sub { lcfirst($_[0]); }, 59 'uc' => sub { uc($_[0]); }, 60 'ucfirst' => sub { ucfirst($_[0]); }, 61# 'length' => sub { length($_[0]); }, 62# 'defined' => sub { defined($_[0]); }, 63# 'abs' => sub { abs($_[0]); }, 64# 'hex' => sub { hex($_[0]); }, 65# 'oct' => sub { oct($_[0]); }, 66 'rand' => sub { rand($_[0]); }, 67 'srand' => sub { srand($_[0]); }, 68 ); 69 70sub new { 71 my $class=shift; 72 my %param; 73 my $options={param_map=>\%param, 74 functions => {}, 75 filter => [], 76 # ---- supported ------- 77 debug => 0, 78 max_includes => 10, 79 global_vars => 0, 80 no_includes => 0, 81 search_path_on_include => 0, 82 loop_context_vars => 0, 83 path => [], 84 associate => [], 85 case_sensitive => 0, 86 __strict_compatibility => 1, 87 force_untaint => 0, 88 # ---- unsupported distinct ------- 89 die_on_bad_params => 0, 90 strict => 0, 91 # ---- unsupported ------- 92# vanguard_compatibility_mode => 0, 93#============================================= 94# The following options are harmless caching-specific. 95# They are ignored silently because there is nothing to cache. 96#============================================= 97# stack_debug => 0, 98# timing => 0, 99# cache => 0, 100# blind_cache => 0, 101# file_cache => 0, 102# file_cache_dir => '', 103# file_cache_dir_mode => 0700, 104# cache_debug => 0, 105# shared_cache_debug => 0, 106# memory_debug => 0, 107# shared_cache => 0, 108# double_cache => 0, 109# double_file_cache => 0, 110# ipc_key => 'TMPL', 111# ipc_mode => 0666, 112# ipc_segment_size => 65536, 113# ipc_max_size => 0, 114#============================================ 115 @_}; 116 117 # make sure taint mode is on if force_untaint flag is set 118 if ($options->{force_untaint} && ! ${^TAINT}) { 119 croak("HTML::Template->new() : 'force_untaint' option set but perl does not run in taint mode!"); 120 } 121 122 # associate should be an array if it's not already 123 if (ref($options->{associate}) ne 'ARRAY') { 124 $options->{associate} = [ $options->{associate} ]; 125 } 126 # path should be an array if it's not already 127 if (ref($options->{path}) ne 'ARRAY') { 128 $options->{path} = [ $options->{path} ]; 129 } 130 # filter should be an array if it's not already 131 if (ref($options->{filter}) ne 'ARRAY') { 132 $options->{filter} = [ $options->{filter} ]; 133 } 134 135 my $case_sensitive = $options->{case_sensitive}; 136 my $__strict_compatibility = $options->{__strict_compatibility}; 137 # wrap associated objects into tied hash and 138 # make sure objects in associate are support param() 139 $options->{associate} = [ 140 map {HTML::Template::Pro::WrapAssociate->_wrap($_, $case_sensitive, $__strict_compatibility)} 141 @{$options->{associate}} 142 ]; 143 144 # check for syntax errors: 145 my $source_count = 0; 146 exists($options->{filename}) and $source_count++; 147 exists($options->{filehandle}) and $source_count++; 148 exists($options->{arrayref}) and $source_count++; 149 exists($options->{scalarref}) and $source_count++; 150 if ($source_count != 1) { 151 croak("HTML::Template->new called with multiple (or no) template sources specified! A valid call to new() has exactly one filename => 'file' OR exactly one scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR exactly one filehandle => \*FH"); 152 } 153 if ($options->{arrayref}) { 154 die "bad value of arrayref" unless UNIVERSAL::isa($_[0], 'ARRAY'); 155 my $template=join('',@{$options->{arrayref}}); 156 $options->{scalarref}=\$template; 157 } 158 if ($options->{filehandle}) { 159 local $/; # enable "slurp" mode 160 local *FH=$options->{filehandle}; 161 my $template=<FH>; 162 $options->{scalarref}=\$template; 163 } 164 165 # merging built_in funcs with user-defined funcs 166 $options->{expr_func}={%FUNC, %{$options->{functions}}}; 167 168 # hack to be fully compatible with HTML::Template; 169 # caused serious memory leak. it should be done on XS level, if needed. 170 # &safe_circular_reference($options,'options') ??? 171 #$options->{options}=$options; 172 bless $options,$class; 173 $options->_call_filters($options->{scalarref}) if $options->{scalarref} and @{$options->{filter}}; 174 175 return $options; # == $self 176} 177 178# a few shortcuts to new(), of possible use... 179sub new_file { 180 my $pkg = shift; return $pkg->new('filename', @_); 181} 182sub new_filehandle { 183 my $pkg = shift; return $pkg->new('filehandle', @_); 184} 185sub new_array_ref { 186 my $pkg = shift; return $pkg->new('arrayref', @_); 187} 188sub new_scalar_ref { 189 my $pkg = shift; return $pkg->new('scalarref', @_); 190} 191 192sub output { 193 my $self=shift; 194 my %oparam=(@_); 195 my $print_to = $oparam{print_to}; 196 197 if (defined wantarray && ! $print_to) { 198 return exec_tmpl_string($self); 199 } else { 200 exec_tmpl($self,$print_to); 201 } 202} 203 204sub clear_params { 205 my $self = shift; 206 %{$self->{param_map}}=(); 207} 208 209sub param { 210 my $self = shift; 211 #my $options = $self->{options}; 212 my $param_map = $self->{param_map}; 213 # compatibility with HTML::Template 214 # the one-parameter case - could be a parameter value request or a 215 # hash-ref. 216 if (scalar @_==0) { 217 return keys (%$param_map); 218 } elsif (scalar @_==1) { 219 if (ref($_[0]) and UNIVERSAL::isa($_[0], 'HASH')) { 220 # ref to hash of params --- simply dereference it 221 return $self->param(%{$_[0]}); 222 } else { 223 my $key=$self->{case_sensitive} ? $_[0] : lc($_[0]); 224 return $param_map->{$key} || $param_map->{$_[0]}; 225 } 226 } 227 # loop below is obvious but wrong for perl 228 # while (@_) {$param_map->{shift(@_)}=shift(@_);} 229 if ($self->{case_sensitive}) { 230 while (@_) { 231 my $key=shift; 232 my $val=shift; 233 $param_map->{$key}=$val; 234 } 235 } else { 236 while (@_) { 237 my $key=shift; 238 my $val=shift; 239 if (ref($val)) { 240 if (UNIVERSAL::isa($val, 'ARRAY')) { 241 $param_map->{lc($key)}=[map {_lowercase_keys($_)} @$val]; 242 } else { 243 $param_map->{lc($key)}=$val; 244 } 245 } else { 246 $param_map->{lc($key)}=$val; 247 } 248 } 249 } 250} 251 252sub register_function { 253 my($self, $name, $sub) = @_; 254 if ( ref($sub) eq 'CODE' ) { 255 if (ref $self) { 256 # per object call 257 $self->{expr_func}->{$name} = $sub; 258 $self->{expr_func_user_list}->{$name} = 1; 259 } else { 260 # per class call 261 $FUNC{$name} = $sub; 262 } 263 } elsif ( defined $sub ) { 264 croak("HTML::Template::Pro : last arg of register_function must be subroutine reference\n") 265 } else { 266 if (ref $self) { 267 if ( defined $name ) { 268 return $self->{expr_func}->{$name}; 269 } else { 270 return keys %{ $self->{expr_func_user_list} }; 271 } 272 } else { 273 return keys %FUNC; 274 } 275 } 276} 277 278sub _lowercase_keys { 279 my $orighash=shift; 280 my $newhash={}; 281 my ($key,$val); 282 unless (UNIVERSAL::isa($orighash, 'HASH')) { 283 Carp::carp "HTML::Template::Pro:_lowercase_keys:in param_tree: found strange parameter $orighash while hash was expected"; 284 return; 285 } 286 while (($key,$val)=each %$orighash) { 287 if (ref($val)) { 288 if (UNIVERSAL::isa($val, 'ARRAY')) { 289 $newhash->{lc($key)}=[map {_lowercase_keys($_)} @$val]; 290 } else { 291 $newhash->{lc($key)}=$val; 292 } 293 } else { 294 $newhash->{lc($key)}=$val; 295 } 296 } 297 return $newhash; 298} 299 300# sub _load_file { 301# my $filepath=shift; 302# open my $fh, $filepath or die $!; 303# local $/; # enable localized slurp mode 304# my $content = <$fh>; 305# close $fh; 306# return $content; 307# } 308 309## HTML::Template based 310 311#### callback function called from C library ############## 312# Note that this _get_filepath perl code is deprecated; ## 313# by default built-in find_file implementation is used. ## 314# use magic option __use_perl_find_file => 1 to re-enable it. 315########################################################### 316sub _get_filepath { 317 my ($self, $filename, $last_visited_file) = @_; 318 # look for the included file... 319 my $filepath; 320 if ((not defined $last_visited_file) or $self->{search_path_on_include}) { 321 $filepath = $self->_find_file($filename); 322 } else { 323 $filepath = $self->_find_file($filename, 324 [File::Spec->splitdir($last_visited_file)] 325 ); 326 } 327 carp "HTML::Template::Pro (using callback): template $filename not found!" unless $filepath; 328 return $filepath; 329} 330 331sub _find_file { 332 my ($options, $filename, $extra_path) = @_; 333 my $filepath; 334 335 # first check for a full path 336 return File::Spec->canonpath($filename) 337 if (File::Spec->file_name_is_absolute($filename) and (-e $filename)); 338 339 # try the extra_path if one was specified 340 if (defined($extra_path)) { 341 $extra_path->[$#{$extra_path}] = $filename; 342 $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path)); 343 return File::Spec->canonpath($filepath) if -e $filepath; 344 } 345 346 # try pre-prending HTML_Template_Root 347 if (defined($ENV{HTML_TEMPLATE_ROOT})) { 348 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename); 349 return File::Spec->canonpath($filepath) if -e $filepath; 350 } 351 352 # try "path" option list.. 353 foreach my $path (@{$options->{path}}) { 354 $filepath = File::Spec->catfile($path, $filename); 355 return File::Spec->canonpath($filepath) if -e $filepath; 356 } 357 358 # try even a relative path from the current directory... 359 return File::Spec->canonpath($filename) if -e $filename; 360 361 # try "path" option list with HTML_TEMPLATE_ROOT prepended... 362 if (defined($ENV{HTML_TEMPLATE_ROOT})) { 363 foreach my $path (@{$options->{path}}) { 364 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $path, $filename); 365 return File::Spec->canonpath($filepath) if -e $filepath; 366 } 367 } 368 369 return undef; 370} 371 372sub _load_template { 373 my $self = shift; 374 my $filepath=shift; 375 my $template = ""; 376 confess("HTML::Template->new() : Cannot open file $filepath : $!") 377 unless defined(open(TEMPLATE, $filepath)); 378 # read into scalar 379 while (read(TEMPLATE, $template, 10240, length($template))) {} 380 close(TEMPLATE); 381 $self->_call_filters(\$template) if @{$self->{filter}}; 382 return \$template; 383} 384 385# handle calling user defined filters 386sub _call_filters { 387 my $self = shift; 388 my $template_ref = shift; 389 my $options = $self;#->{options}; 390 391 my ($format, $sub); 392 foreach my $filter (@{$options->{filter}}) { 393 croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.") 394 unless ref $filter; 395 396 # translate into CODE->HASH 397 $filter = { 'format' => 'scalar', 'sub' => $filter } 398 if (ref $filter eq 'CODE'); 399 400 if (ref $filter eq 'HASH') { 401 $format = $filter->{'format'}; 402 $sub = $filter->{'sub'}; 403 404 # check types and values 405 croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.") 406 unless defined $format and defined $sub; 407 croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'") 408 unless $format eq 'array' or $format eq 'scalar'; 409 croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref") 410 unless ref $sub and ref $sub eq 'CODE'; 411 412 # catch errors 413 eval { 414 if ($format eq 'scalar') { 415 # call 416 $sub->($template_ref); 417 } else { 418 # modulate 419 my @array = map { $_."\n" } split("\n", $$template_ref); 420 # call 421 $sub->(\@array); 422 # demodulate 423 $$template_ref = join("", @array); 424 } 425 }; 426 croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@; 427 } else { 428 croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref"); 429 } 430 } 431 # all done 432 return $template_ref; 433} 434 4351; 436__END__ 437 438=head1 NAME 439 440HTML::Template::Pro - Perl/XS module to use HTML Templates from CGI scripts 441 442=head1 SYNOPSIS 443 444It is moved out and split. 445 446See L<HTML::Template::SYNTAX/SYNOPSIS> for introduction 447to HTML::Template and syntax of template files. 448 449See L<HTML::Template::PerlInterface/SYNOPSIS> for perl interface 450of HTML::Template, HTML::Template::Expr and HTML::Template::Pro. 451 452=head1 DESCRIPTION 453 454Original HTML::Template is written by Sam Tregar, sam@tregar.com 455with contributions of many people mentioned there. 456Their efforts caused HTML::Template to be mature html tempate engine 457which separate perl code and html design. 458Yet powerful, HTML::Template is slow, especially if mod_perl isn't 459available or in case of disk usage and memory limitations. 460 461HTML::Template::Pro is a fast lightweight C/Perl+XS reimplementation 462of HTML::Template (as of 2.9) and HTML::Template::Expr (as of 0.0.7). 463It is not intended to be a complete replacement, 464but to be a fast implementation of HTML::Template if you don't need 465querying, the extended facility of HTML::Template. 466Designed for heavy upload, resource limitations, abcence of mod_perl. 467 468HTML::Template::Pro has complete support of filters and HTML::Template::Expr's 469tag EXPR="<expression>", including user-defined functions and 470construction <TMPL_INCLUDE EXPR="...">. 471 472HTML::Template work cycle uses 2 steps. First, it loads and parse template. 473Then it accepts param() calls until you call output(). 474output() is its second phase where it produces a page from the parsed tree 475of template, obtained in the 1st step. 476 477HTML::Template::Pro loads, parse and outputs template on fly, 478when you call $tmpl->output(), in one pass. The corresponding code is 479written in C and glued to Perl using Perl+XS. As a result, 480comparing to HTML::Template in ordinary calls, it runs 48110-25 times faster. Comparing to HTML::Template with all caching enabled 482under mod_perl, it still 1-3 times faster. At that HTML::Template caching 483requires considerable amount of memory (per process, shareable, or on disk) 484to be permanently filled with parsed trees, whereas HTML::Template::Pro 485don't consumes memory for caches and use mmap() for reading templates on disk. 486 487Introduction to HTML::Template and syntax of template files is described 488in L<HTML::Template::SYNTAX>. 489Perl interface of HTML::Template and HTML::Template::Pro is described 490in L<HTML::Template::PerlInterface>. 491 492=head1 SEE ALSO 493 494L<HTML::Template::SYNTAX>, L<HTML::Template::PerlInterface>. 495 496Progect page is http://html-tmpl-pro.sourceforge.net 497 (and http://sourceforge.net/projects/html-tmpl-pro) 498 499Original modules are L<HTML::Template>, L<HTML::Template::Expr>. 500Their progect page is http://html-template.sourceforge.net 501 502=head1 BUGS 503 504See L<HTML::Template::PerlInterface/BUGS> 505 506=head1 AUTHOR 507 508I. Vlasenko, E<lt>viy@altlinux.orgE<gt> 509 510with contributions of 511Bruni Emiliano, E<lt>info at ebruni.itE<gt> 512Stanislav Yadykin, E<lt>tosick at altlinux.ruE<gt> 513Viacheslav Sheveliov E<lt>slavash at aha.ruE<gt> 514Shigeki Morimoto E<lt>shigeki.morimoto at mixi.co.jpE<gt> 515Kirill Rebenok E<lt>kirill at rebenok.plE<gt> 516 517=head1 COPYRIGHT AND LICENSE 518 519Copyright (C) 2005-2009 by I. Yu. Vlasenko. 520Pieces of code in Pro.pm and documentation of HTML::Template are 521copyright (C) 2000-2002 Sam Tregar (sam@tregar.com) 522 523The template syntax, interface conventions and a large piece of documentation 524of HTML::Template::Pro are based on CPAN module HTML::Template 525by Sam Tregar, sam@tregar.com. 526 527This library is free software; you can redistribute it and/or modify it under 528either the LGPL2+ or under the same terms as Perl itself, either Perl version 5295.8.4 or, at your option, any later version of Perl 5 you may have available. 530 531=cut 532