File Coverage

blib/lib/Text/Template/Simple/Util.pm

Criterion	Covered	Total	%
statement	78	96	81.2
branch	20	46	43.4
condition	7	12	58.3
subroutine	18	20	90.0
pod	12	12	100.0
total	135	186	72.5

package Text::Template::Simple::Util;
use strict;
use warnings;
use base qw( Exporter );
use Carp qw( croak );
use Text::Template::Simple::Constants qw(
   :info
   DIGEST_MODS
   EMPTY_STRING
);

our $VERSION = '0.86';

BEGIN {
   # create a wrapper for binmode()
   if ( NEW_PERL ) {
      # older perl binmode() does not accept a second param
      *binary_mode = sub {
         my($fh, $layer) = @_;
         binmode $fh, q{:} . $layer;
      };
   }
   else {
      *binary_mode = sub { binmode $_[0] };
   }
   our %EXPORT_TAGS = (
      macro => [qw( isaref      ishref iscref                  )],
      util  => [qw( binary_mode DIGEST trim rtrim ltrim escape )],
      debug => [qw( fatal       DEBUG  LOG  L                  )],
   );
   our @EXPORT_OK    = map { @{ $EXPORT_TAGS{$_} } } keys %EXPORT_TAGS;
   $EXPORT_TAGS{all} = \@EXPORT_OK;
   our @EXPORT       =  @EXPORT_OK;
}

my $lang = {
   error => {
      q{tts.base.examine.notglob}                 => q{Unknown template parameter passed as %s reference! Supported types are GLOB, PATH and STRING.},
      q{tts.base.examine.notfh}                   => q{This GLOB is not a filehandle},
      q{tts.main.cdir}                            => q{Cache dir %s does not exist!},
      q{tts.main.bogus_args}                      => q{Malformed add_args parameter! 'add_args' must be an arrayref!},
      q{tts.main.bogus_delims}                    => q{Malformed delimiters parameter! 'delimiters' must be a two element arrayref!},
      q{tts.cache.opendir}                        => q{Can not open cache dir (%s) for reading: %s},
      q{tts.util.digest}                          => q{Can not load a digest module. Disable cache or install one of these (%s or %s). Last error was: %s},
      q{tts.cache.dumper}                         => q{Can not dump in-memory cache! Your version of Data::Dumper (%s) does not implement the Deparse() method. Please upgrade this module!},
      q{tts.cache.pformat}                        => q{Parameters must be in 'param => value' format},
      q{tts.cache.incache}                        => q{I need an 'id' or a 'data' parameter for cache check!},
      q{tts.main.dslen}                           => q{Start delimiter is smaller than 2 characters},
      q{tts.main.delen}                           => q{End delimiter is smaller than 2 characters},
      q{tts.main.dsws}                            => q{Start delimiter contains whitespace},
      q{tts.main.dews}                            => q{End delimiter contains whitespace},
      q{tts.main.import.invalid}                  => q{%s isn't a valid import parameter for %s},
      q{tts.main.import.undef}                    => q{%s is not defined in %s},
      q{tts.main.import.redefine}                 => q{%s is already defined in %s},
      q{tts.main.tts.args}                        => q{Nothing to compile!},
      q{tts.main.connector.args}                  => q{connector(): id is missing},
      q{tts.main.connector.invalid}               => q{connector(): invalid id: %s},
      q{tts.main.init.thandler}                   => q{user_thandler parameter must be a CODE reference},
      q{tts.main.init.include}                    => q{include_paths parameter must be a ARRAY reference},
      q{tts.util.escape}                          => q{Missing the character to escape},
      q{tts.tokenizer.new.ds}                     => q{Start delimiter is missing},
      q{tts.tokenizer.new.de}                     => q{End delimiter is missing},
      q{tts.tokenizer.tokenize.tmp}               => q{Template string is missing},
      q{tts.tokenizer._get_symbols.regex}         => q{Regex is missing},
      q{tts.io.validate.type}                     => q{No type specified},
      q{tts.io.validate.path}                     => q{No path specified},
      q{tts.io.validate.file}                     => q{validate(file) is not yet implemented},
      q{tts.io.layer.fh}                          => q{Filehandle is absent},
      q{tts.io.slurp.open}                        => q{Error opening '%s' for reading: %s},
      q{tts.io.slurp.taint}                       => q{Can't untaint FH},
      q{tts.io.hls.invalid}                       => q{FH is either absent or invalid},
      q{tts.caller.stack.hash}                    => q{Parameters to stack() must be a HASH},
      q{tts.caller.stack.type}                    => q{Unknown caller stack type: %s},
      q{tts.caller._text_table.module}            => q{Caller stack type 'text_table' requires Text::Table: %s},
      q{tts.cache.new.parent}                     => q{Parent object is missing},
      q{tts.cache.dumper.hash}                    => q{Parameters to dumper() must be a HASHref},
      q{tts.cache.dumper.type}                    => q{Dumper type '%s' is not valid},
      q{tts.cache.develsize.buggy}                => q{Your Devel::Size version (%s) has a known bug. Upgrade Devel::Size to 0.72 or newer or do not use the size() method},
      q{tts.cache.develsize.total}                => q{Devel::Size::total_size(): %s},
      q{tts.cache.hit.meta}                       => q{Can not get meta data: %s},
      q{tts.cache.hit.cache}                      => q{Error loading from disk cache: %s},
      q{tts.cache.populate.write}                 => q{Error writing disk-cache %s : %s},
      q{tts.cache.populate.chmod}                 => q{Can not change file mode},
      q{tts.base.compiler._compile.notmp}         => q{No template specified},
      q{tts.base.compiler._compile.param}         => q{params must be an arrayref!},
      q{tts.base.compiler._compile.opt}           => q{opts must be a hashref!},
      q{tts.base.compiler._wrap_compile.parsed}   => q{nothing to compile},
      q{tts.base.compiler._mini_compiler.notmp}   => q{_mini_compiler(): missing the template},
      q{tts.base.compiler._mini_compiler.noparam} => q{_mini_compiler(): missing the parameters},
      q{tts.base.compiler._mini_compiler.opt}     => q{_mini_compiler(): options must be a hash},
      q{tts.base.compiler._mini_compiler.param}   => q{_mini_compiler(): parameters must be a HASH},
      q{tts.base.examine._examine_type.ftype}     => q{ARRAY does not contain the type},
      q{tts.base.examine._examine_type.fthing}    => q{ARRAY does not contain the data},
      q{tts.base.examine._examine_type.extra}     => q{Type array has unknown extra fields},
      q{tts.base.examine._examine_type.unknown}   => q{Unknown first argument of %s type to compile()},
      q{tts.base.include._include.unknown}        => q{Unknown include type: %s},
      q{tts.base.include._interpolate.bogus_share} => q{Only SCALARs can be shared. You have tried to share a variable }
                                                    .q{type of %s named "%s". Consider converting it to a SCALAR or try }
                                                    .q{the monolith option to enable automatic variable sharing. }
                                                    .q{But please read the fine manual first},
      q{tts.base.include._interpolate.bogus_share_notbare} => q{It looks like you've tried to share an expression (%s) instead of a simple variable.},
      q{tts.base.parser._internal.id}             => q{_internal(): id is missing},
      q{tts.base.parser._internal.rv}             => q{_internal(): id is invalid},
      q{tts.base.parser._parse.unbalanced}        => q{%d unbalanced %s delimiter(s) in template %s},
      q{tts.cache.id.generate.data}               => q{Can't generate id without data!},
      q{tts.cache.id._custom.data}                => q{Can't generate id without data!},
   },
   warning => {
      q{tts.base.include.dynamic.recursion}       => q{%s Deep recursion (>=%d) detected in the included file: %s},
   }
};

my $DEBUG = 0; # Disabled by default
my $DIGEST;    # Will hold digester class name.

sub isaref { my $x = shift; return ref($x) eq 'ARRAY' };
sub ishref { my $x = shift; return ref($x) eq 'HASH'  };
sub iscref { my $x = shift; return ref($x) eq 'CODE'  };

sub L {
   my($type, $id, @param) = @_;
   croak q{Type parameter to L() is missing} if ! $type;
   croak q{ID parameter ro L() is missing}   if ! $id;
   my $root  = $lang->{ $type } || croak "$type is not a valid L() type";
   my $value = $root->{ $id }   || croak "$id is not a valid L() ID";
   return @param ? sprintf($value, @param) : $value;
}

sub fatal {
   my @args = @_;
   return croak L( error => @args );
}

sub escape {
   my($c, $s) = @_;
   fatal('tts.util.escape') if ! $c;
   return $s if ! $s; # false or undef
   my $e = quotemeta $c;
   $s =~ s{$e}{\\$c}xmsg;
   return $s;
}

sub trim {
   my $s = shift;
   return $s if ! $s; # false or undef
   my $extra = shift || EMPTY_STRING;
      $s =~ s{\A \s+   }{$extra}xms;
      $s =~ s{   \s+ \z}{$extra}xms;
   return $s;
}

sub ltrim {
   my $s = shift;
   return $s if ! $s; # false or undef
   my $extra = shift || EMPTY_STRING;
      $s =~ s{\A \s+ }{$extra}xms;
   return $s;
}

sub rtrim {
   my $s = shift;
   return $s if ! $s; # false or undef
   my $extra = shift || EMPTY_STRING;
      $s =~ s{ \s+ \z}{$extra}xms;
   return $s;
}

sub DEBUG {
   my $thing = shift;

   # so that one can use: $self->DEBUG or DEBUG
   $thing = shift if _is_parent_object( $thing );

   $DEBUG = $thing+0 if defined $thing; # must be numeric
   return $DEBUG;
}

sub DIGEST {
   return $DIGEST->new if $DIGEST;

   local $SIG{__DIE__};
   # local $@;
   foreach my $mod ( DIGEST_MODS ) {
     (my $file = $mod) =~ s{::}{/}xmsog;
      $file .= '.pm';
      my $ok = eval { require $file; };
      if ( ! $ok ) {
         LOG( FAILED => "$mod - $file" ) if DEBUG;
         next;
      }
      $DIGEST = $mod;
      last;
   }

   if ( not $DIGEST ) {
      my @report     = DIGEST_MODS;
      my $last_error = pop @report;
      fatal( 'tts.util.digest' => join(', ', @report), $last_error, $@ );
   }

   LOG( DIGESTER => $DIGEST . ' v' . $DIGEST->VERSION ) if DEBUG;
   return $DIGEST->new;
}

sub LOG {
   my @args = @_;
   return MYLOG( @args ) if defined &MYLOG;
   my $self    = ref $args[0] ? shift @args : undef;
   my $id      = shift @args;
   my $message = shift @args;
      $id      = 'DEBUG'        if not defined $id;
      $message = '<NO MESSAGE>' if not defined $message;
      $id      =~ s{_}{ }xmsg;
   $message = sprintf q{[ % 15s ] %s}, $id, $message;
   warn "$message\n";
   return;
}

sub _is_parent_object {
   my $test = shift;
   return ! defined $test       ? 0
         : ref $test            ? 1
         : $test eq __PACKAGE__ ? 1
         : $test eq PARENT      ? 1
         :                        0
         ;
}

1;

__END__

=head1 NAME

Text::Template::Simple::Util - Utility functions

=head1 SYNOPSIS

TODO

=head1 DESCRIPTION

This document describes version C<0.86> of C<Text::Template::Simple::Util>
released on C<5 March 2012>.

Contains utility functions for Text::Template::Simple.

=head1 FUNCTIONS

=head2 DEBUG

Returns the debug status.

=head2 DIGEST

Returns the digester object.

=head2 binary_mode FH, LAYER

Sets the I/O layer of FH in modern perls, only sets binmode on FH otherwise.

=head2 L TYPE, ID [, PARAMS]

Internal method.

=head2 fatal ID [, PARAMS]

Internal method.

=head2 isaref THING

Returns true if C<THING> is an ARRAY.

=head2 ishref THING

Returns true if C<THING> is a HASH.

=head2 iscref THING

Returns true if C<THING> is a CODE.

=head2 trim STRING

Returns the trimmed version of the C<STRING>.

=head2 ltrim STRING

Returns the left trimmed version of the C<STRING>.

=head2 rtrim STRING

Returns the right trimmed version of the C<STRING>.

=head2 escape CHAR, STRING

Escapes all occurrances of C<CHAR> in C<STRING> with backslashes.

=head1 OVERRIDABLE FUNCTIONS

=head2 LOG

If debugging mode is enabled in Text::Template::Simple, all
debugging messages will be captured by this function and will
be printed to C<STDERR>.

If a sub named C<Text::Template::Simple::Util::MYLOG> is defined,
then all calls to C<LOG> will be redirected to this sub. If you want to
save the debugging messages to a file or to a database, you must define
the C<MYLOG> sub.

=head1 AUTHOR

Burak Gursoy <[e-mail]>.

=head1 COPYRIGHT

Copyright 2004 - 2012 Burak Gursoy. All rights reserved.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.12.3 or,
at your option, any later version of Perl 5 you may have available.

=cut