#!/usr/bin/perl -w

=head1 NAME

memory_app.pl - Test memory usage and benchmark speed comparison with CGI::Application

=cut

use Benchmark qw(cmpthese timethese);
use strict;

my $swap = {
    one   => "ONE",
    two   => "TWO",
    three => "THREE",
    a_var => "a",
    hash  => {a => 1, b => 2},
    code  => sub {"($_[0])"},
};

my $form = q{([% has_errors %])(<TMPL_VAR has_errors>)<form name=foo><input type=text name="bar" value=""><input type=text name="baz"></form>};
my $str_ht = $form . (q{Well hello there (<TMPL_VAR script_name>)} x 20) ."\n";
my $str_tt = $form . (q{Well hello there ([% script_name %])}      x 20) ."\n";

my $template_ht = \$str_ht;
my $template_tt = \$str_tt;

###----------------------------------------------------------------###
use Scalar::Util;
use Time::HiRes;
use CGI;
use CGI::Ex::Dump qw(debug);
use Template::Alloy load => 'Parse', 'Play', 'HTML::Template', 'Template';
$Template::VERSION = 2.18;
#use HTML::Template;

my $tests = {
    'C::A - bare' => sub {
        package FooBare;
        require CGI::Application;
        @FooBare::ISA = qw(CGI::Application);

        sub setup {
            my $self = shift;
            $self->start_mode('main');
            $self->mode_param(path_info => 1);
            $self->run_modes(main => sub { "Simple test" });
        }

        FooBare->new->run;
    },
    'C::E::A - bare' => sub {
        package FooBare;
        require CGI::Ex::App;
        @FooBare::ISA = qw(CGI::Ex::App);

        sub main_run_step {
            my $self = shift;
            print "Content-Type: text/html\r\n\r\n";
            #$self->cgix->print_content_type;
            print "Simple test";
            1;
        }

        FooBare->navigate({form => {}});
    },
    'Handwritten - bare' => sub {
        package FooBare2;

        sub new { bless {}, __PACKAGE__ }

        sub main {
            my $self = shift;
            print "Content-Type: text/html\r\n\r\n";
            print "Simple test";
        }

        FooBare2->new->main;
    },
    #'CGI::Prototype - bare' => sub {
    #    package FooBare;
    #    require CGI::Prototype;
    #},

    ###----------------------------------------------------------------###

    #'C::A - simple htonly' => sub {
    #    require CGI::Application;
    #    my $t = CGI::Application->new->load_tmpl($template_ht, die_on_bad_params => 0);
    #    $t->param(script_name => 2);
    #    print $t->output;
    #},
    #'C::E::A - simple htonly' => sub {
    #    require CGI::Ex::App;
    #    my $out = '';
    #    CGI::Ex::App->new->template_obj({SYNTAX => 'hte'})->process($template_ht, {script_name=>2}, \$out);
    #    print $out;
    #},

    'C::A - simple ht' => sub {
        package FooHT;
        require CGI::Application;
        @FooHT::ISA = qw(CGI::Application);

        sub setup {
            my $self = shift;
            $self->start_mode('main');
            $self->mode_param(path_info => 1);
            $self->run_modes(main => sub {
                my $self = shift;
                my $t = $self->load_tmpl($template_ht, die_on_bad_params => 0);
                $t->param('script_name', $0);
                return $t->output();
            });
        }

        FooHT->new->run;
    },
    'C::E::A - simple ht' => sub {
        package FooHT;
        require CGI::Ex::App;
        @FooHT::ISA = qw(CGI::Ex::App);

        sub main_file_print { $template_ht }
        sub template_args { {SYNTAX => 'hte'} } # , GLOBAL_CACHE => 1, COMPILE_PERL => 2} }
        sub fill_template {}
        sub print_out { my ($self, $step, $out) = @_; print "Content-Type: text/html\r\n\r\n$$out" }

        FooHT->navigate({no_history => 1, form => {}});
    },
    'C::A - simple tt' => sub {
        package FooTT;
        require CGI::Application;
        @FooTT::ISA = qw(CGI::Application);
        require CGI::Application::Plugin::TT;
        CGI::Application::Plugin::TT->import;

        sub setup {
            my $self = shift;
            $self->start_mode('main');

            $self->run_modes(main => sub {
                my $self = shift;
                return $self->tt_process($template_tt, {script_name => $0});
            });
        }

        FooTT->new->run;
    },
    'C::E::A - simple tt' => sub {
        package FooTT;
        require CGI::Ex::App;
        @FooTT::ISA = qw(CGI::Ex::App);
        sub main_file_print { $template_tt }
        sub fill_template {}
        sub print_out { my ($self, $step, $out) = @_; print "Content-Type: text/html\r\n\r\n$$out" }
        FooTT->navigate({no_history => 1, form => {}});
    },

    ###----------------------------------------------------------------###

    'C::A - complex ht' => sub {
        package FooComplexHT;
        require CGI::Application;
        @FooComplexHT::ISA = qw(CGI::Application);
        require CGI::Application::Plugin::ValidateRM;
        CGI::Application::Plugin::ValidateRM->import('check_rm');
        require CGI::Application::Plugin::FillInForm;
        CGI::Application::Plugin::FillInForm->import('fill_form');

        sub setup {
            my $self = shift;
            $self->start_mode('main');
            $self->mode_param(path_info => 1);
            $self->run_modes(main => sub {
                my $self = shift;
                my ($results, $err_page) = $self->check_rm('error_page','_profile');
                return $err_page if $err_page;
                die "Got here";
            });
        }

        sub error_page {
            my $self = shift;
            my $errs = shift;
            my $t = $self->load_tmpl($template_ht, die_on_bad_params => 0);
            $t->param('script_name', $0);
            $t->param($errs) if $errs;
            $t->param(has_errors => 1) if $errs;
            my $q = $self->query;
            $q->param(bar => 'BAROOSELVELT');
            return $self->fill_form(\$t->output, $q);
        }

        sub _profile { return {required => [qw(bar baz)], msgs => {prefix => 'err_'}} };

        FooComplexHT->new->run;
    },
    'C::E::A - complex ht' => sub {
        package FooComplexHT;
        require CGI::Ex::App;
        @FooComplexHT::ISA = qw(CGI::Ex::App);

        sub main_file_print { $template_ht }
        sub main_hash_fill  { {bar => 'BAROOSELVELT'} }
        sub main_hash_validation { {bar => {required => 1}, baz => {required => 1}} }
        sub main_finalize { die "Got here" }
        sub template_args { {SYNTAX => 'hte'} } # , GLOBAL_CACHE => 1, COMPILE_PERL => 2} }
        sub print_out { my ($self, $step, $out) = @_; print "Content-Type: text/html\r\n\r\n$$out" }

        local $ENV{'REQUEST_METHOD'} = 'POST';
        FooComplexHT->navigate({no_history => 1, form => {}});
    },
    'C::A - complex tt' => sub {
        package FooComplexTT;
        require CGI::Application;
        @FooComplexTT::ISA = qw(CGI::Application);
        require CGI::Application::Plugin::TT;
        CGI::Application::Plugin::TT->import;
        require CGI::Application::Plugin::ValidateRM;
        CGI::Application::Plugin::ValidateRM->import('check_rm');
        require CGI::Application::Plugin::FillInForm;
        CGI::Application::Plugin::FillInForm->import('fill_form');

        sub setup {
            my $self = shift;
            $self->start_mode('main');

            $self->run_modes(main => sub {
                my $self = shift;
                my ($results, $err_page) = $self->check_rm('error_page','_profile');
                return $err_page if $err_page;
                die "Got here";
            });
        }

        sub error_page {
            my $self = shift;
            my $errs = shift;
            my $out = $self->tt_process($template_tt, {script_name => $0, %{$errs || {}}, has_errors => ($errs ? 1 : 0)});
            my $q = $self->query;
            $q->param(bar => 'BAROOSELVELT');
            return $self->fill_form(\$out, $q);
        }

        sub _profile { return {required => [qw(bar baz)], msgs => {prefix => 'err_'}} };

        FooComplexTT->new->run;
    },
    'C::E::A - complex tt' => sub {
        package FooComplexTT;
        require CGI::Ex::App;
        @FooComplexTT::ISA = qw(CGI::Ex::App);
        sub main_file_print { $template_tt }
        sub main_hash_fill  { {bar => 'BAROOSELVELT'} }
        sub main_hash_validation { {bar => {required => 1}, baz => {required => 1}} }
        sub main_finalize { die "Got here" }
        sub print_out { my ($self, $step, $out) = @_; print "Content-Type: text/html\r\n\r\n$$out" }

        local $ENV{'REQUEST_METHOD'} = 'POST';
        FooComplexTT->navigate({no_history => 1, form => {}});
    },

    #'Template::Alloy - bare ht' => sub { require Template::Alloy; Template::Alloy->import('HTE') },
    #'Template::Alloy - bare tt' => sub { require Template::Alloy; Template::Alloy->import('TT') },
};

#perl -d:DProf samples/devel/memory_app.pl ; dprofpp tmon.out
#select($_) if open($_, ">>/dev/null");
$tests->{'C::E::A - complex tt'}->()
#    for 1 .. 1000
    ;
#exit;

###----------------------------------------------------------------###

my %_INC = %INC;
my @pids;
foreach my $name (sort keys %$tests) {
    my $pid = fork;
    if (! $pid) {
        $0 = "$0 - $name";
        my $fh;
        select($fh) if open($fh, ">>/dev/null");
        $tests->{$name}->() for 1 .. 1;
        sleep 1;
        select STDOUT;
        print "$name times: (@{[times]})\n";
        print "$name $_\n" foreach sort grep {! $_INC{$_}} keys %INC;
        sleep 15;
        exit;
    }
    push @pids, $pid;
}

sleep 2;
#    print "Parent - $_\n" foreach sort keys %INC;
print grep {/\Q$0\E/} `ps fauwx`;
kill 15, @pids;

###----------------------------------------------------------------###

exit if grep {/no_?bench/i} @ARGV;


foreach my $type (qw(bare simple complex)) {
    my $hash = {};
    open(my $fh, ">>/dev/null") || die "Can't access /dev/null: $!";
    foreach my $name (keys %$tests) {
        next if $name !~ /\b$type\b/;
        (my $copy = $name) =~ s/\s*\b$type\b//;
        $hash->{$copy} = sub {
            select $fh;
            $tests->{$name}->();
            select STDOUT;
        };
    }
    print "-------------------------------------------------\n";
    print "--- Testing $type\n";
    cmpthese timethese -2, $hash;
}

=head1 NOTES

Abbreviations:

  C::E::A - CGI::Ex::App
  C::A    - CGI::Application

The tests are currently run with the following code:

  use Template::Alloy load => 'Parse', 'Play', 'HTML::Template', 'Template';

This assures that CGI::Application will use the same templating system
as CGI::Ex::App so that template system issues don't affect overall
performance.  With the line commented out and CGI::Application using
HTML::Template (ht), C::A has a slight speed benefit, though it still
uses more memory.  With the line commented out and CGI::Application
using Template (tt), C::E::A is 2 to 3 times faster and uses a lot
less memory.

=head1 SAMPLE OUTPUT

  paul     23927  4.3  0.5   8536  6016 pts/1    S+   11:36   0:00  |       \_ perl samples/devel/memory_app.pl
  paul     23928  1.0  0.5   8988  5992 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::A - bare
  paul     23929  2.0  0.6   9988  7152 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::A - complex ht
  paul     23930  2.5  0.7  10172  7336 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::A - complex tt
  paul     23931  1.0  0.5   8988  6024 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::A - simple ht
  paul     23932  1.5  0.6   9308  6276 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::A - simple tt
  paul     23933  0.0  0.5   8536  5200 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::E::A - bare
  paul     23934  1.0  0.6   9328  6384 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::E::A - complex ht
  paul     23935  1.0  0.6   9328  6392 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::E::A - complex tt
  paul     23936  0.0  0.5   8536  5272 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::E::A - simple ht
  paul     23937  0.0  0.5   8668  5344 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - C::E::A - simple tt
  paul     23938  0.0  0.4   8536  5076 pts/1    S+   11:36   0:00  |           \_ samples/devel/memory_app.pl - Handwritten - bare
  -------------------------------------------------
  --- Testing bare
  Benchmark: running C::A -, C::E::A -, Handwritten - for at least 2 CPU seconds...
      C::A -:  3 wallclock secs ( 2.08 usr +  0.01 sys =  2.09 CPU) @ 3196.17/s (n=6680)
   C::E::A -:  3 wallclock secs ( 1.99 usr +  0.19 sys =  2.18 CPU) @ 6164.68/s (n=13439)
  Handwritten -:  1 wallclock secs ( 2.15 usr +  0.00 sys =  2.15 CPU) @ 266711.16/s (n=573429)
                    Rate        C::A -     C::E::A - Handwritten -
  C::A -          3196/s            --          -48%          -99%
  C::E::A -       6165/s           93%            --          -98%
  Handwritten - 266711/s         8245%         4226%            --
  -------------------------------------------------
  --- Testing simple
  Benchmark: running C::A - ht, C::A - tt, C::E::A - ht, C::E::A - tt for at least 2 CPU seconds...
   C::A - ht:  2 wallclock secs ( 2.04 usr +  0.00 sys =  2.04 CPU) @ 709.80/s (n=1448)
   C::A - tt:  2 wallclock secs ( 2.12 usr +  0.01 sys =  2.13 CPU) @ 600.47/s (n=1279)
  C::E::A - ht:  2 wallclock secs ( 2.14 usr +  0.01 sys =  2.15 CPU) @ 663.26/s (n=1426)
  C::E::A - tt:  3 wallclock secs ( 2.16 usr +  0.01 sys =  2.17 CPU) @ 589.40/s (n=1279)
                Rate C::E::A - tt    C::A - tt C::E::A - ht    C::A - ht
  C::E::A - tt 589/s           --          -2%         -11%         -17%
  C::A - tt    600/s           2%           --          -9%         -15%
  C::E::A - ht 663/s          13%          10%           --          -7%
  C::A - ht    710/s          20%          18%           7%           --
  -------------------------------------------------
  --- Testing complex
  Benchmark: running C::A - ht, C::A - tt, C::E::A - ht, C::E::A - tt for at least 2 CPU seconds...
   C::A - ht:  2 wallclock secs ( 2.00 usr +  0.00 sys =  2.00 CPU) @ 438.50/s (n=877)
   C::A - tt:  3 wallclock secs ( 2.16 usr +  0.00 sys =  2.16 CPU) @ 383.80/s (n=829)
  C::E::A - ht:  2 wallclock secs ( 2.14 usr +  0.01 sys =  2.15 CPU) @ 457.21/s (n=983)
  C::E::A - tt:  2 wallclock secs ( 2.13 usr +  0.00 sys =  2.13 CPU) @ 417.37/s (n=889)
                Rate    C::A - tt C::E::A - tt    C::A - ht C::E::A - ht
  C::A - tt    384/s           --          -8%         -12%         -16%
  C::E::A - tt 417/s           9%           --          -5%          -9%
  C::A - ht    438/s          14%           5%           --          -4%
  C::E::A - ht 457/s          19%          10%           4%           --

=cut