File Coverage

blib/lib/Template/Magic.pm

Criterion	Covered	Total	%
statement	273	295	92.5
branch	85	112	75.8
condition	48	79	60.7
subroutine	61	67	91.0
pod	19	28	67.8
total	486	581	83.6

package Template::Magic ;
$VERSION = 1.40 ;
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__