package Template::Magic ; $VERSION = 1.39 ; use strict ; use 5.006_001 ; # This file uses the "Perlish" coding style # please read http://perl.4pro.net/perlish_coding_style.html ; use Carp ; $Carp::Internal{+__PACKAGE__}++ ; use warnings::register ; use Template::Magic::Zone ; use IO::Util ; use Class::Util ; use File::Spec ; sub NEXT_HANDLER () { 0 } ; sub LAST_HANDLER () { 1 } ; sub import { my ($pkg, $pragma) = @_ ; if ( $pragma && $pragma eq '-compile' ) { carp "The -compile pragma has no effect since version 1.39" if warnings::enabled } else { require Exporter ; our @ISA = 'Exporter' ; our @EXPORT_OK = qw| NEXT_HANDLER LAST_HANDLER | ; $pkg->export_to_level(1, @_) } } ; sub new { my ($c) = shift ; my ($s) = @_ ; $s = { @_ } # passing hash backward compatibility unless ref $s eq 'HASH' ; foreach ( keys %$s ) # passing -flag backward compatibility { $$s{$_} = delete $$s{-$_} if s/^-// } ; foreach ( values %$s ) # each value should be an ARRAY ref { $_ = [ $_ ] unless ref eq 'ARRAY' } ; bless $s, $c ; $$s{markers} ||= $s->DEFAULT_MARKERS ; $$s{output_handlers} ||= $s->DEFAULT_PRINT_HANDLERS ; $$s{text_handlers} ||= $s->DEFAULT_TEXT_HANDLERS || $$s{output_handlers} ; $$s{zone_handlers} ||= $s->DEFAULT_ZONE_HANDLERS ; $$s{value_handlers} ||= $s->DEFAULT_VALUE_HANDLERS ; $$s{post_handlers} ||= $s->DEFAULT_POST_HANDLERS ; $$s{lookups} ||= [ (caller)[0] ] ; $$s{options} ||= $s->DEFAULT_OPTIONS ; $$s{options} = { map { /^(no_)*(.+)$/ ; $2 => $1 ? 0 : 1 } @{$$s{options}} } ; foreach my $n qw| zone value text output post | { $$s{$n.'_handlers'} &&= [ $s->_Hload( $$s{$n.'_handlers'} , $n ) ] } ; $s } ; sub _Hload { my ($s, $arr, $n) = @_ ; map { if ( ref eq 'CODE' ) { $_ } elsif ( not ref ) { my $C = $s->can($_) || $s->can( join ( '_' , $_ , uc $n , 'HANDLERS' ) ) || croak qq(Unknown handler "$_") ; my $ref = $s->$C ; if ( ref $ref eq 'ARRAY' ) { $s->_Hload( $ref, $n ) } elsif ( ref $ref eq 'CODE' ) { $ref } } } @$arr } ; sub _re { my ($s) = @_ ; unless ( $$s{_re} ) # execute it just the first time AND if it has to parse { unless ( @{$$s{markers}} == 3 ) { no strict 'refs' ; my $m = $$s{markers}[0] ; my $M = $s->can($m) || $s->can($m.'_MARKERS') # backward compatibility || croak qq(Unknown markers "$m") ; $$s{markers} = $s->$M } ; $$s{markers} = [ map { qr/$_/s } ( @{$$s{markers}} , '(?:(?!' .$$s{markers}[2]. ').)*' , '\w+' ) ] ; my ($S, $I, $E, $A, $ID) = @{$$s{markers}} ; $$s{_re}{label} = qr/$S$I*$ID$A$E/s ; $$s{_re}{start_label} = qr/$S($ID)($A)$E/s ; $$s{_re}{end_label} = qr/$S$I($ID)$E/s ; $$s{_re}{include_label} = qr/$S\bINCLUDE_TEMPLATE\b($A)$E/s } ; wantarray ? @{$$s{markers}} : $$s{_re} } ; sub find_file { my ($s, $t) = @_ ; my $find = sub{(grep -s, @_)[0]} ; File::Spec->file_name_is_absolute($t) ? $find->($t) : ( $ENV{TEMPLATE_MAGIC_ROOT} && $find->( File::Spec->catfile( $ENV{TEMPLATE_MAGIC_ROOT} , $t ) ) || $find->( map File::Spec->catfile( $_ , $t ) , @{$$s{paths}} ) || $ENV{TEMPLATE_MAGIC_ROOT} && $find->( map File::Spec->catfile( $ENV{TEMPLATE_MAGIC_ROOT} , $_ , $t ) , @{$$s{paths}} ) || $find->($t) ) } ; sub output { my $s = shift ; my $args ; $$args{template} = shift ; $$args{lookups} = [ @_ ] if @_ ; IO::Util::capture { $s->_process( $args ) } } ; sub print { my $s = shift ; my $args ; $$args{template} = shift ; $$args{lookups} = [ @_ ] if @_ ; $s->_process( $args ) } ; sub noutput { my ($s, %args) = @_ ; $args{lookups} = [ $args{lookups} ] unless ref $args{lookups} eq 'ARRAY' ; IO::Util::capture { $s->_process( \%args ) } } ; sub nprint { my ($s, %args) = @_ ; $args{lookups} = [ $args{lookups} ] unless ref $args{lookups} eq 'ARRAY' ; $s->_process( \%args ) } ; sub _process { my ($s, $args) = @_ ; $$s{_temp_lookups} = $$args{lookups} if exists $$args{lookups} ; my $t ; if ( $t = $$args{container_template} || ${$$s{container_template}}[0] ) { $$s{_included_template} = $$args{template} } else { $t = $$args{template} } ; my $z = $s->load( $t ) ; $$z{tm} = $s ; $z->content_process ; delete $$z{tm} # to avoid tm object caching ; delete @$s{qw|_included_template _temp_lookups _NOT_lookup|} } ; sub load { my ($s, $t) = @_ ; my $main_zone ; if ( not ref $t ) { $t = $s->find_file($t) or croak qq(Template file "$t" empty or not found) ; if ( $$s{options}{cache} ) { $main_zone = IO::Util::_get_parsing_cache('magic_zone', $t) ; return $main_zone if $main_zone } } ; my $content = ref $t eq 'SCALAR' ? $t : IO::Util::slurp $t ; $main_zone = $s->_parse( $content ) ; $$s{options}{cache} &&! ref($t) # set cache && IO::Util::_set_parsing_cache 'magic_zone', $t, $main_zone ; $main_zone } ; sub purge_cache { $_[0] = 'magic_zone' ; goto &IO::Util::_purge_parsing_cache } ; sub _parse { my ($s, $content_ref) = @_ ; my $re = $s->_re ; my @temp = map { [ $_ , do { /$$re{end_label}/ && $1 || /$$re{include_label}/ && do{ (my $t = $1) =~ s/^\s+// ; $t ? $s->load($t) : 'CONTAINER_INCLUDE' } || /$$re{start_label}/ && { id => $1 , attributes => $2 } } ] } split /($$re{label})/ , $$content_ref ; for ( my $i = $#temp # find end ; $i >= 0 ; $i -- ) { my $id = $temp[$i][1] ; next if ( ref $id or not $id ) ; for ( ( my $ii = $i-1 # find THE start , my $l = 0 ) ; $ii >= 0 # condition ; ( $ii -- , $l ++ ) ) { my $the_start = $temp[$ii][1] ; next unless ref($the_start) eq 'HASH' # next if not start ; next unless $$the_start{id} eq $id # next if not THE start ; $$the_start{_s} = $ii + 1 ; $$the_start{_e} = $ii + $l ; last } } # allows to set protected props from outside class ; local $Class::props::force = 1 ; Template::Magic::Zone->new( _s => 0 , _e => $#temp , _t => \@temp , is_main => 1 ) } ############################# STANDARD HANDLERS ############################# # override these DEFAULT subs in subclasses to change defaults ; sub DEFAULT_ZONE_HANDLERS { } ; sub DEFAULT_POST_HANDLERS { } ; sub DEFAULT_TEXT_HANDLERS { } ; sub DEFAULT_VALUE_HANDLERS { my ($s, @args) = @_ ; [ $s->SCALAR , $s->REF , $s->CODE(@args) , $s->ARRAY , $s->HASH , $s->OBJECT ] } ; sub DEFAULT_PRINT_HANDLERS { [ sub { print $_[1] if defined $_[1] ; NEXT_HANDLER } ] } ; { no warnings 'once' ; *DEFAULT_OUTPUT_HANDLERS = \&DEFAULT_PRINT_HANDLER # deprecated } ; sub DEFAULT_OPTIONS { [ qw| cache | ] } ; sub DEFAULT_MARKERS { [ qw| { / } | ] } ; sub HTML_MARKERS { [ qw| | ] } ; sub CODE_MARKERS { [ qw| <- / -> | ] } ; sub HTML_VALUE_HANDLERS # value handler { my ($s, @args) = @_ ; [ $s->SCALAR , $s->REF , $s->CODE(@args) , $s->TableTiler , $s->ARRAY , $s->HASH , $s->FillInForm , $s->OBJECT ] } ; sub SCALAR # value handler { sub { my ($z) = @_ ; my $v = $z->value ; if ( not ref $v ) # if it's a plain string { $z->output($v) # set output ; $z->output_process( $v ) # process output (requires string) ; LAST_HANDLER } } } ; sub REF # value handler { sub { my ($z) = @_ ; my $v = $z->value ; if (ref($v) =~ /^(SCALAR|REF)$/) # if it's a reference { $z->value($$v) # dereference ; $z->value_process # process the new value ; LAST_HANDLER } } } ; sub ARRAY # value handler { sub { my ($z) = @_ ; if (ref $z->value eq 'ARRAY') # if it's an ARRAY { my ($i, $attr, $val_key, $ix_key, $named) = 0 ; if ( $attr = $z->attributes ) { $attr =~ s/^\s*(OF\s)*\s*//i ; ($val_key, $ix_key, $i) = split /\s+/, $attr ; $named = 1 } ; foreach my $item ( @{$z->value} ) # for each value in the array { $z->value( $named # set the value for the zone ? { $val_key => $item , $ix_key ? ($ix_key => $i ++) : () } : $item ) ; $z->value_process # process it } ; LAST_HANDLER } } } ; sub HASH # value handler { sub { my ($z) = @_ ; if (ref $z->value eq 'HASH') # if it's a HASH { $z->content_process # start again the process ; LAST_HANDLER } } } ; sub CODE # value handler { my ( undef, @args ) = @_ ; sub { my ($z) = @_ ; my $v = $z->value ; if ( ref $v eq 'CODE' ) { my $l = $z->location ; my $nv = Class::Util::blessed($l) ? do { no strict 'refs' ; $l->$v( ${ref($l).'::no_template_magic_zone'} ? () : $z , @args ) } : $v->( $z , @args ) ; if ( $v ne ($nv||'') ) # avoid infinite loop { $z->value($nv) ; $z->value_process } ; LAST_HANDLER } } } ; sub OBJECT { sub { my ($z) = @_ ; if ( Class::Util::blessed($z->value) ) { $z->content_process # process content ; LAST_HANDLER } } } ; sub ID_list { my ($s, $indent, $end) = @_ ; $indent ||= ' ' x 4 ; $end ||= '/' ; my $re = $s->_re ; $$s{text_handlers} = [ sub{} ] # does not print any text ; $$s{zone_handlers} = [ sub # takes control of the whole process { my ($z) = @_ ; $z->output_process( $indent x $z->level . $z->id . ":\n" ) ; $z->content_process ; my $cont = $z->content ; if ( $z->_e # if it is a block && $cont =~ /$$re{label}/ # and contains labels ) { $z->output_process( $indent x $z->level # print the end . $end . $z->id . ":\n" ) } ; LAST_HANDLER } ] } # START AutoLoaded handlers # 'sub' must be at start of line to be found by AutoSplit # no fancy coding here :-( sub _EVAL_ # zone handler { sub { my ($z) = @_; ; if ( $z->id eq '_EVAL_' ) { $z->value( eval $z->content ) } ; NEXT_HANDLER # lookup is skipped by the defined $z->value # value_process is entered by default } } sub _EVAL_ATTRIBUTES_ # zone handler { sub { my ($z) = @_ ; if ( $z->attributes ) { $z->param( eval $z->attributes ) } ; NEXT_HANDLER # $z->attributes should be a ref to a structure } } sub TRACE_DELETIONS # zone handler { sub { my ($z) = @_ # do lookup and value processes as usual ; $z->lookup_process ; $z->value_process # if they fail to find a true output trace the deletion ; if ( not defined $z->output ) { $z->output_process ( '<<' . $z->id . ' not found>>' ) unless ref $z->value eq 'HASH' } elsif ( not $z->output ) { $z->output_process ( '<<' . $z->id . ' found but empty>>' ) } ; LAST_HANDLER } } sub INCLUDE_TEXT # zone handler { sub { my ($z) = @_ ; if ( $z->id eq 'INCLUDE_TEXT' ) { my $file = $z->attributes ; open my $itxt, $file or croak qq(Error opening text file "$file": $^E) ; $z->text_process($_) while <$itxt> ; close $itxt ; LAST_HANDLER } } } ############### HTML HANDLERS ############## sub TableTiler # value handler { eval { local $SIG{__DIE__} ; require HTML::TableTiler ; return $HTML::TableTiler::VERSION >= 1.14 } ; if ( $@ ) { carp qq("HTML::TableTiler" is not installed on this system or it is not current\n) ; return sub {} # no action } else { sub # normal handler { my ($z) = @_ ; my $v = $z->value ; if ( ref($v) eq 'ARRAY' && HTML::TableTiler::is_matrix($v) # if matrix ) { $z->value ( do { my $cont = $z->content ; HTML::TableTiler::tile_table( $v , $cont && \$cont , $z->attributes , 1 ) } ) ; $z->value_process ; LAST_HANDLER } } } } sub FillInForm # value handler { eval { local $SIG{__DIE__} ; require HTML::FillInForm } ; if ( $@ ) { carp qq("HTML::FillInForm" is not installed on this system\n) ; sub {} } else { sub { my ($z) = @_ ; my $v = $z->value ; if ( ref($v) && defined UNIVERSAL::can( $v , 'param' ) ) { my $cont = IO::Util::capture { $z->content_process } ; my $attr = $z->attributes ; my ($list) = $attr =~ /ignore_fields\s*=>\s*\[(.*)\]/ ; my @if = map /(?:'|")(.+)(?:'|")/ #' , split /\s*,\s*/ , $list||'' ; $z->value( HTML::FillInForm ->new ->fill( scalarref => $cont , fobject => $v , ignore_fields => \@if ) ) ; $z->value_process ; LAST_HANDLER } } } } __END__ =pod =head1 NAME Template::Magic - Magic merger of runtime values with templates =head1 VERSION 1.39 Included in Template-Magic 1.39 distribution. The latest version changes are reported in the F file in this distribution. =head1 INSTALLATION =over =item Prerequisites Perl version >= 5.6.1 OOTools >= 2 IO::Util >= 1.46 File::Spec >= 0 =item CPAN If you want to install Template::Magic plus all related extensions (the prerequisites to use also L), all in one easy step: perl -MCPAN -e 'install Bundle::Template::Magic' =item Standard installation From the directory where this file is located, type: perl Makefile.PL make make test make install B: this installs just the main distribution and does not install the prerequisites of L. =item Distribution structure Bundle::Template::Magic a bundle to install everything in one step Template::Magic the main module Template::Magic::Zone defines the zone object Template::Magic::HTML handlers useful in HTML environment =back =head1 SYNOPSIS Just add these 2 magic lines to your code... use Template::Magic; Template::Magic->new->print( '/path/to/template' ); to have all your variable and subroutines merged with the F