File Coverage

blib/lib/Template/Benchmark.pm

Criterion	Covered	Total	%
statement	241	351	68.6
branch	57	122	46.7
condition	26	46	56.5
subroutine	37	45	82.2
pod	11	11	100.0
total	372	575	64.7

package Template::Benchmark;

use warnings;
use strict;

use Benchmark;

use File::Temp;
use File::Path qw(mkpath rmtree);
use File::Spec;
use IO::File;
use Scalar::Util;

use Module::Pluggable ( search_path => 'Template::Benchmark::Engines',
                        sub_name    => 'engine_plugins' );

our $VERSION = '1.09_01';

my @valid_features = qw/
    literal_text
    scalar_variable
    hash_variable_value
    array_variable_value
    deep_data_structure_value
    array_loop_value
    hash_loop_value
    records_loop_value
    array_loop_template
    hash_loop_template
    records_loop_template
    constant_if_literal
    variable_if_literal
    constant_if_else_literal
    variable_if_else_literal
    constant_if_template
    variable_if_template
    constant_if_else_template
    variable_if_else_template
    constant_expression
    variable_expression
    complex_variable_expression
    constant_function
    variable_function
    /;

my @valid_cache_types = qw/
    uncached_string
    uncached_disk
    disk_cache
    shared_memory_cache
    memory_cache
    instance_reuse
    /;

my %option_defaults = (
    #  Feature options: these should only default on if they're
    #  widely supported, so that the default benchmark covers
    #  most template engines.
    literal_text                => 1,
    scalar_variable             => 1,
    hash_variable_value         => 0,
    array_variable_value        => 0,
    deep_data_structure_value   => 0,
    array_loop_value            => 0,
    hash_loop_value             => 0,
    records_loop_value          => 1,
    array_loop_template         => 0,
    hash_loop_template          => 0,
    records_loop_template       => 1,
    constant_if_literal         => 0,
    variable_if_literal         => 1,
    constant_if_else_literal    => 0,
    variable_if_else_literal    => 1,
    constant_if_template        => 0,
    variable_if_template        => 1,
    constant_if_else_template   => 0,
    variable_if_else_template   => 1,
    constant_expression         => 0,
    variable_expression         => 0,
    complex_variable_expression => 0,
    constant_function           => 0,
    variable_function           => 0,

    #  Cache types.
    uncached_string             => 1,
    uncached_disk               => 1,
    disk_cache                  => 1,
    shared_memory_cache         => 1,
    memory_cache                => 1,
    instance_reuse              => 1,

    #  Other options.
    template_repeats    => 30,
    duration            => 10,
    dataset             => 'original',
    style               => 'none',
    keep_tmp_dirs       => 0,
    skip_output_compare => 0,

    #  Plugin control.
    only_plugin      => {},
    skip_plugin      => {},
    features_from    => {},
    cache_types_from => {},
    );

#  Which engines to try first as the 'reference output' for templates.
#  Note that this is merely a matter of author convenience: all template
#  engine outputs must match, this merely determines which should be
#  cited as 'correct' in the case of a mismatch.  This should generally
#  be a template engine that provides most features, otherwise it won't
#  be an _available_ template engine when we need it.
#  For author convenience I'm using Template::Sandbox as the prefered
#  reference, however Template::Toolkit will make a better reference
#  choice once this module has stabilized.
my $reference_preference = 'TS';

my %datasets = (
    original => {
        hash1 => {
            scalar_variable => 'I is a scalar, yarr!',
            hash_variable   => {
                'hash_value_key' =>
                    'I spy with my little eye, something beginning with H.',
                },
            array_variable   => [ qw/I have an imagination honest/ ],
            this => { is => { a => { very => { deep => { hash => {
                #  No longer "it's", to avoid HTML-escaping inconsistencies
                structure => "My god, it be full of hashes.",
                } } } } } },
            template_if_true  => 'True dat',
            template_if_false => 'Nay, Mister Wilks',
            },
        hash2 => {
            array_loop => [ qw/five four three two one coming ready or not/ ],
            hash_loop  => {
                aaa => 'first',
                bbb => 'second',
                ccc => 'third',
                ddd => 'fourth',
                eee => 'fifth',
                },
            records_loop => [
                { name => 'Joe Bloggs',      age => 16,  },
                { name => 'Fred Bloggs',     age => 23,  },
                { name => 'Nigel Bloggs',    age => 43,  },
                { name => 'Tarquin Bloggs',  age => 143, },
                { name => 'Geoffrey Bloggs', age => 13,  },
                ],
            variable_if      => 1,
            variable_if_else => 0,
            variable_expression_a => 20,
            variable_expression_b => 10,
            variable_function_arg => 'Hi there',
            },
        },
    );

sub new
{
    my $this = shift;
    my ( $self, $class, $options, $var_hash1, $var_hash2, %temp_options,
        %keep_cache_types );

    $self = {};
    $class = ref( $this ) || $this;
    bless $self, $class;

    $self->{ options } = {};
    $options = $self->{ options };
    while( my $opt = shift )
    {
        if( $opt eq 'only_plugin'   or $opt eq 'skip_plugin' or
            $opt eq 'features_from' or $opt eq 'cache_types_from' )
        {
            my $val = shift();
            $options->{ $opt } ||= {};
            if( ref( $val ) )
            {
                $val = [ grep { $val->{ $_ } } keys( %{$val} ) ]
                    if ref( $val ) eq 'HASH';
                foreach ( @{$val} )
                {
                    $options->{ $opt }->{ $_ } = 1;
                }
            }
            else
            {
                $options->{ $opt }->{ $val } = 1;
            }
        }
        else
        {
            #  TODO: should be croak
            die "Unknown constructor option '$opt'"
                unless exists $option_defaults{ $opt };
            $self->{ options }->{ $opt } = shift();
        }
    }
    foreach my $opt ( keys( %option_defaults ) )
    {
        $options->{ $opt } = $option_defaults{ $opt }
            unless defined $options->{ $opt };
    }

    delete $options->{ only_plugin }
        unless scalar( keys( %{$options->{ only_plugin }} ) );
    delete $options->{ skip_plugin }
        unless scalar( keys( %{$options->{ skip_plugin }} ) );
    delete $options->{ features_from }
        unless scalar( keys( %{$options->{ features_from }} ) );
    delete $options->{ cache_types_from }
        unless scalar( keys( %{$options->{ cache_types_from }} ) );

    if( ref( $options->{ dataset } ) )
    {
        #  TODO: should be croaks really.
        die "Option 'dataset' must be a dataset name or a hashref, got: " .
            ref( $options->{ dataset } )
            unless ref( $options->{ dataset } ) eq 'HASH';
        die "Option 'dataset' hashref is missing required 'hash1' key"
            unless defined( $options->{ dataset }->{ hash1 } );
        die "Option 'dataset' hashref is missing required 'hash2' key"
            unless defined( $options->{ dataset }->{ hash2 } );
        $var_hash1 = $options->{ dataset }->{ hash1 };
        $var_hash2 = $options->{ dataset }->{ hash2 };
    }
    else
    {
        #  TODO: should be croaks really.
        die "Unknown dataset name '$options->{ dataset }'"
            unless defined( $datasets{ $options->{ dataset } } );
        $var_hash1 = $datasets{ $options->{ dataset } }->{ hash1 };
        $var_hash2 = $datasets{ $options->{ dataset } }->{ hash2 };
    }

    if( $options->{ features_from } )
    {
        $self->{ features } = [ @valid_features ];
        foreach my $plugin ( $self->engine_plugins() )
        {
            my $leaf = _engine_leaf( $plugin );

            next unless $options->{ features_from }->{ $leaf };

            eval "use $plugin";
            next if $@;

            $self->{ features } = [ grep
                {
                    defined( $plugin->feature_syntax( $_ ) )
                } @{$self->{ features }} ];
        }
    }
    else
    {
        $self->{ features } =
            [
            grep { $options->{ $_ } } @valid_features
            ];
    }
    #  TODO: sanity-check some features are left.

    if( $options->{ cache_types_from } )
    {
        $self->{ cache_types } = [ @valid_cache_types ];
        %keep_cache_types = ();
    }
    else
    {
        $self->{ cache_types } =
            [ grep { $options->{ $_ } } @valid_cache_types ];
    }
    #  TODO: sanity-check some cache_types are left.

    $self->{ engines } = [];
    $self->{ engine_errors } = {};
    foreach my $plugin ( $self->engine_plugins() )
    {
        my $leaf = _engine_leaf( $plugin );

        #  Force-require any features_from or cache_types_from plugin,
        #  regardless of their only_plugin or skip_plugin settings.
        if( ( not $options->{ features_from } or
              not $options->{ features_from }->{ $leaf } ) and
            ( not $options->{ cache_types_from } or
              not $options->{ cache_types_from }->{ $leaf } ) )
        {
            if( $options->{ only_plugin } )
            {
                next unless $options->{ only_plugin }->{ $leaf };
            }
            if( $options->{ skip_plugin } )
            {
                next if $options->{ skip_plugin }->{ $leaf };
            }
        }
        eval "use $plugin";
        if( $@ )
        {
            $self->engine_error( $leaf, "Engine plugin load failure: $@" );
        }
        else
        {
            push @{$self->{ engines }}, $plugin;
        }
    }

    %temp_options = (
        TMPDIR   => 1,
        );
    $temp_options{ CLEANUP } = 0 if $self->{ options }->{ keep_tmp_dirs };

    $self->{ file_temp } =
        File::Temp->newdir( 'benchmark_XXXX', %temp_options )
        or die "Unable to create File::Temp";

    $self->{ template_dir } = File::Spec->catfile(
        $self->{ file_temp }->dirname(),
        'templates',
        );
    $self->{ cache_dir }    = File::Spec->catfile(
        $self->{ file_temp }->dirname(),
        'caches',
        );
    #  TODO: failure check.
    mkpath( $self->{ template_dir } )
        or die "Unable to make template dir '$self->{ template_dir }': $!";
    mkpath( $self->{ cache_dir } )
        or die "Unable to make cache dir '$self->{ cache_dir }': $!";

    $self->{ feature_repeats } =
        {
        map
        {
            $_ =>
                (
                #  Retain positive integer values.
                ( Scalar::Util::looks_like_number( $options->{ $_ } ) &&
                  ( int( $options->{ $_ } ) == $options->{ $_ } ) &&
                  ( $options->{ $_ } > 0 ) ) ?
                $options->{ $_ } :
                #  Normalize the rest to 1 or 0 based on true/false.
                #  TODO: probably should warn.
                ( $options->{ $_ } ? 1 : 0 )
                )
        } @{$self->{ features }}
        };

    $self->{ templates }           = {};
    $self->{ benchmark_functions } = {};
    $self->{ descriptions }        = {};
    $self->{ engine_for_tag }      = {};
    ENGINE: foreach my $engine ( @{$self->{ engines }} )
    {
        my ( %benchmark_functions, $template_dir, $cache_dir, $template,
            $template_filename, $fh, $descriptions, $missing_syntaxes, $leaf );

        $leaf = _engine_leaf( $engine );

        $template_dir =
            File::Spec->catfile( $self->{ template_dir }, $leaf );
        $cache_dir    =
            File::Spec->catfile( $self->{ cache_dir },    $leaf );
        #  TODO: failure check
        mkpath( $template_dir );
        mkpath( $cache_dir );

        foreach my $cache_type ( @{$self->{ cache_types }} )
        {
            my ( $method, @method_args, $functions );

            $method = "benchmark_functions_for_${cache_type}";

            next unless $engine->can( $method );

            @method_args = ();
            push @method_args, $template_dir
                unless $cache_type eq 'uncached_string';
            push @method_args, $cache_dir
                unless $cache_type =~ /^uncached/o;

            eval { $functions = $engine->$method( @method_args ); };
            if( $@ )
            {
                $self->engine_error( $leaf,
                    "Error calling ${method}(): $@" );
                next;
            }

            next unless $functions and scalar( keys( %{$functions} ) );
            $benchmark_functions{ $cache_type } = $functions;
        }

        %keep_cache_types = map { $_ => 1 }
            keys( %keep_cache_types ),
            grep { $benchmark_functions{ $_ } } @valid_cache_types
            if $options->{ cache_types_from } and
               $options->{ cache_types_from }->{ $leaf };

        unless( %benchmark_functions )
        {
            $self->engine_error( $leaf, 'No matching benchmark functions.' );
            next ENGINE;
        }

#print "Looking at $leaf.\n";
#use Data::Dumper;
#print "  features: " . Data::Dumper::Dumper( $self->{ features } ) . "\n";

        $template = '';
        $missing_syntaxes = '';
        foreach my $feature ( @{$self->{ features }} )
        {
            my ( $feature_syntax );

            $feature_syntax = $engine->feature_syntax( $feature );
            if( defined( $feature_syntax ) )
            {
                $template .= ( $feature_syntax . "\n" ) x
                    ( $self->{ feature_repeats }->{ $feature } || 1 );
            }
            else
            {
                $missing_syntaxes .= ' ' . $feature;
            }
        }

        if( $missing_syntaxes )
        {
            $self->engine_error( $leaf,
                "No syntaxes provided for:$missing_syntaxes." );
            next ENGINE;
        }

        $template = $template x $options->{ template_repeats };
        #  Allow the plugin a chance to rewrite the repeated sections,
        #  ie: some engines require unique loop names/labels.
        $template = $engine->preprocess_template( $template )
            if $engine->can( 'preprocess_template' );

        $template_filename =
            File::Spec->catfile( $template_dir, $leaf . '.txt' );
        $fh = IO::File->new( "> $template_filename" );
        unless( $fh )
        {
            $self->engine_error( $leaf,
                "Unable to write $template_filename: $!" );
            next ENGINE;
        }
        $fh->print( $template );
        $fh->close();

        $template_filename = $leaf . '.txt';

        $descriptions = $engine->benchmark_descriptions();

        foreach my $type ( keys( %benchmark_functions ) )
        {
            $self->{ benchmark_functions }->{ $type } ||= {};

            foreach my $tag ( keys( %{$benchmark_functions{ $type }} ) )
            {
                my ( $function );

                $function = $benchmark_functions{ $type }->{ $tag };
                if( $type =~ /_string$/ )
                {
                    $self->{ benchmark_functions }->{ $type }->{ $tag } =
                        sub
                        {
                            $function->( $template,
                                $var_hash1, $var_hash2 );
                        };
                }
                else
                {
                    $self->{ benchmark_functions }->{ $type }->{ $tag } =
                        sub
                        {
                            $function->( $template_filename,
                                $var_hash1, $var_hash2 );
                        };
                }
                #  TODO: warn on duplicates.
                $self->{ descriptions }->{ $tag }   = $descriptions->{ $tag };
                $self->{ engine_for_tag }->{ $tag } = $leaf;
            }
        }
    }

    if( $options->{ cache_types_from } )
    {
        #  We need to delete any benchmark functions that crept in
        #  before we figured out what cache types we needed.
        $self->{ benchmark_functions } = {
            map { $_ => $self->{ benchmark_functions }->{ $_ } }
            grep { $keep_cache_types{ $_ } }
            keys( %{$self->{ benchmark_functions }} )
            };
    }

    #  Strip any cache types that ended up with no functions.
    $self->{ cache_types } = [
        grep { $self->{ benchmark_functions }->{ $_ } }
            @{$self->{ cache_types }}
        ];

    return( $self );
}

sub benchmark
{
    my ( $self ) = @_;
    my ( $duration, $style, $result, $reference, @outputs, $errors );

    $duration = $self->{ options }->{ duration };
    $style    = $self->{ options }->{ style };
    $errors   = {};

    #  First up, check each benchmark function produces the same
    #  output as all the others.  This also serves to ensure that
    #  the caches become populated for those benchmarks that are
    #  cached.
    #  We run the benchmark function twice, and use the output
    #  of the second, this is to make sure we're using the output
    #  of the cached template, otherwise we could end up with a
    #  function that produces the right output when building the
    #  cache but then benchmarks insanely well because there's
    #  an error in running the cached version so it no-ops all
    #  the expensive work.
    @outputs = ();
    $reference = 0;
    foreach my $type ( @{$self->{ cache_types }} )
    {
        foreach my $tag
            ( keys( %{$self->{ benchmark_functions }->{ $type }} ) )
        {
            my ( $output );

            #  First to cache.
            eval { $self->{ benchmark_functions }->{ $type }->{ $tag }->(); };
            if( $@ )
            {
                $self->engine_error(
                    $self->{ engine_for_tag }->{ $tag },
                    "Error running benchmark function for $tag: $@",
                    $errors );
                delete $self->{ benchmark_functions }->{ $type }->{ $tag };
                next;
            }
            #  And second for output.
            $output = eval {
                $self->{ benchmark_functions }->{ $type }->{ $tag }->();
                };
            if( $@ )
            {
                $self->engine_error(
                    $self->{ engine_for_tag }->{ $tag },
                    "Error running benchmark function for $tag: $@",
                    $errors );
                delete $self->{ benchmark_functions }->{ $type }->{ $tag };
                next;
            }
            $output = ${$output} if $output and ref( $output );
            #  [rt #59247] Normalize newline endings, some template engines
            #  produce UNIX and some Windows line-endings when on Windows.
            $output =~ s/\r//g if $output;
            push @outputs, [ $type, $tag, $output ];
            $reference = $#outputs if $tag eq $reference_preference;
        }
        #  Prune if all our functions have errored and been pruned.
        delete $self->{ benchmark_functions }->{ $type }
            unless %{$self->{ benchmark_functions }->{ $type }};
    }

    #  Strip any cache types that ended up with no functions.
    $self->{ cache_types } = [
        grep { $self->{ benchmark_functions }->{ $_ } }
            @{$self->{ cache_types }}
        ];

    unless( @outputs )
    {
        $result =
            {
                result => 'NO BENCHMARKS TO RUN',
            };
        $result->{ errors } = $errors if %{$errors};
        return( $result );
    }

#use Data::Dumper;
#print "Outputs: ", Data::Dumper::Dumper( \@outputs ), "\n";

    #  TODO: this nasty hackery is surely telling me I need a
    #        Template::Benchmark::Result object.
    $result = {
        result    => 'MISMATCHED TEMPLATE OUTPUT',
        reference =>
            {
                type   => $outputs[ $reference ]->[ 0 ],
                tag    => $outputs[ $reference ]->[ 1 ],
                output => $outputs[ $reference ]->[ 2 ],
            },
        descriptions => { %{$self->{ descriptions }} },
        failures => [],
        };
    $result->{ errors } = $errors if %{$errors};

    unless( $self->{ options }->{ skip_output_compare } )
    {
        foreach my $output ( @outputs )
        {
            push @{$result->{ failures }},
                {
                    type   => $output->[ 0 ],
                    tag    => $output->[ 1 ],
                    output => defined( $output->[ 2 ] ) ?
                              $output->[ 2 ] : "[no content returned]\n",
                }
                if !defined( $output->[ 2 ] ) or
                   $output->[ 2 ] ne $result->{ reference }->{ output };
        }

        return( $result ) unless $#{$result->{ failures }} == -1;
    }

    #  OK, all template output matched, time to do the benchmarks.

    delete $result->{ failures };
    $result->{ result } = 'SUCCESS';

    $result->{ start_time } = time();
    $result->{ title } = 'Template Benchmark @' .
        localtime( $result->{ start_time } );

    $result->{ benchmarks } = [];
    if( $duration )
    {
        foreach my $type ( @{$self->{ cache_types }} )
        {
            my ( $timings, $comparison );

            $timings = Benchmark::timethese( -$duration,
                $self->{ benchmark_functions }->{ $type }, $style );
            $comparison = Benchmark::cmpthese( $timings, $style );

            push @{$result->{ benchmarks }},
                {
                    type       => $type,
                    timings    => $timings,
                    comparison => $comparison,
                };
        }
    }

    return( $result );
}

sub DESTROY
{
    my ( $self ) = @_;

    #  Use a DESTROY to clean up, so that we occur in case of errors.
    if( $self->{ options }->{ keep_tmp_dirs } )
    {
        print "Not removing cache dir ", $self->{ cache_dir }, "\n"
            if $self->{ cache_dir };
        print "Not removing template dir ", $self->{ template_dir }, "\n"
            if $self->{ template_dir };
    }
    else
    {
        #  Try to make our benchmark closures go out of scope so they
        #  release any locks before we try to delete the temp dirs...
        delete $self->{ benchmark_functions };
    }
}

sub default_options { return( %option_defaults ); }
sub valid_cache_types { return( @valid_cache_types ); }
sub valid_features { return( @valid_features ); }

sub engines
{
    my ( $self ) = @_;
    return( @{$self->{ engines }} );
}

sub features
{
    my ( $self ) = @_;
    return( @{$self->{ features }} );
}

sub engine_errors
{
    my ( $self ) = @_;
    return( $self->{ engine_errors } );
}

sub engine_error
{
    my ( $self, $engine, $error, $errors ) = @_;
    my ( $leaf );

    $errors = $self->{ engine_errors } unless $errors;
    $leaf   = _engine_leaf( $engine );

    #  TODO: warn if an option asks us to?

    $errors->{ $leaf } ||= [];
    push @{$errors->{ $leaf }}, $error;
}

sub number_of_benchmarks
{
    my ( $self ) = @_;
    my ( $num_benchmarks );

    $num_benchmarks = 0;
    foreach my $type ( @{$self->{ cache_types }} )
    {
        $num_benchmarks +=
            scalar( keys( %{$self->{ benchmark_functions }->{ $type }} ) );
    }

    return( $num_benchmarks );
}

sub estimate_benchmark_duration
{
    my ( $self ) = @_;
    my ( $duration );

    $duration = $self->{ options }->{ duration };

    return( $duration * $self->number_of_benchmarks() );
}

sub _engine_leaf
{
    my ( $engine ) = @_;

    $engine =~ /\:\:([^\:]*)$/;
    return( $1 || $engine );
}

1;

__END__