#!/usr/bin/perl -w
use strict;
if( !eval( "require Time::HiRes;" ) ) {
print "Time::HiRes not installed; benchmarks cannot be done\n";
}
opendir( DIR, "./bench" );
my @files = readdir(DIR);
closedir( DIR );
foreach my $file ( @files ) {
if( $file =~ m/(.+)\.tmpl/ ) {
print "Processing $file\n";
tmplfile( './bench/'.$file, $1 );
print "\n";
}
}
sub tmplfile {
my $file = shift;
my $name = shift;
open(TMPL,"$file");
$/ = undef;
my $tmpl = <TMPL>;
close(TMPL);
$tmpl =~ s/#([c+0-])/#-$1/g;
#print $tmpl;
my @parts = split('#-',$tmpl);
open(OUT,">./bench/one$name.pl");
my $div;
sub has_cc {
my $div = (substr($ENV{'PATH'},0,1) eq '/') ? ':' : ';';
my @path = split($div,$ENV{'PATH'});
foreach my $dir ( @path ) {
return 1 if( -e "$dir/cc" ||
-e "$dir/gcc" ||
-e "$dir/cc.exe" ||
-e "$dir/gcc.exe" ); }
return 0;
}
if( $^O eq 'MSWin32' && !has_cc() ) { $div = '\\'; }
else { $div = '/'; }
print OUT <<START;
#!/usr/bin/perl
use strict;
my \$div = "\\$div";
my \$maxlen = 26;
my \$file = \$ARGV[1] || 'test.xml';
my ( \$root, \$s, \$s2, \$s3, \$usec, \$usec2, \$usec3, \$sa, \$sb, \$sc, \$base1, \$base2, \$base3 );
my \$onlyone = \$ARGV[2] ? 1 : 0;
tabit("-Module-",'load ','parse ','total') if( !\$onlyone );
exit if( !\$ARGV[0] );
use Time::HiRes qw(gettimeofday);
# For fairness; try to get the file to be read into memory cache
{
open(FILE,'<', \$file) or die "Couldn't open \$!";
local \$/ = undef; my \$cache = <FILE>;
close(FILE);
}
START
#{
# (\$s, \$usec) = gettimeofday();
# if( eval( "require XML::Bare;" ) ) {
# (\$s2, \$usec2) = gettimeofday();
# my \$ob = new XML::Bare( file => \$file );
# \$root = \$ob->parse();
# (\$s3, \$usec3) = gettimeofday();
# timeit('XML::Bare',1);
# }
#}
#START
my $comment = '';
my $i = -1;
foreach my $part ( @parts ) {
my @requires;
$part = '#'.$part;
my $type = '';
my $module = '';
if( $part =~ m/#([c\-0\+]) (.+)\n/ ) {
$type = $1;
my $name = $2;
$module = $name if( $name =~ m/\w/ );
}
if( $part =~ m/#([c\-0\+]\+?)\n/ ) {
$type = $1;
}
#print "[$type $module]\n";
if( $type eq 'c' ) {
$part =~ s/c\n//g;
$part = "##".$part."##";
$part =~ s/^##[#c \n]+//;
$part =~ s/[ \n]+##$//;
$comment = $part;
next;
}
if( $type eq '0' ) {
if( $module ) {
$part =~ s/(#0)\W*.*/$1/;
}
while( $part =~ m/(require [A-Za-z\:]+;)/g ) {
my $req = $1;
if( !$module ) {
my $fmod = $req;
$fmod =~ s/require //; $fmod =~ s/;//;
$module = $fmod;
}
push( @requires, $req );
}
$part =~ s/require [A-Za-z\:]+;\n//g;
$part = "##".$part."##";
$part =~ s/^##[#0 \n]+//;
$part =~ s/[ \n]+##$//;
print OUT "
if( \$ARGV[0]*1 >= $i ) {
(\$s, \$usec) = gettimeofday();
if( eval( '@requires' ) ) {
(\$s2, \$usec2) = gettimeofday();
$part
(\$s3, \$usec3) = gettimeofday();
unload('$module');
timeit('$module',1);
}
}
";
}
if( $type eq '-' ) {
if( $module ) {
$part =~ s/(#[\-\0\+])\W*.*/$1/;
}
while( $part =~ m/(require [A-Za-z\:]+;)/g ) {
my $req = $1;
if( !$module ) {
my $fmod = $req;
$fmod =~ s/require //; $fmod =~ s/;//;
$module = $fmod;
}
push( @requires, $req );
}
$part =~ s/require [A-Za-z\:]+;\n//g;
$part = "##".$part."##";
$part =~ s/^##[#\- \n]+//;
$part =~ s/[ \n]+##$//;
print OUT "
if( \$ARGV[0] eq '$i' ) {
(\$s, \$usec) = gettimeofday();
if( eval( '@requires' ) ) {
(\$s2, \$usec2) = gettimeofday();
$part
(\$s3, \$usec3) = gettimeofday();
unload('$module');
timeit('$module');
}
}
";
}
if( $type eq '+' ) {
$part = "##".$part."##";
$part =~ s/^##[#\+ \n]+//;
$part =~ s/[ \n]+##$//;
print OUT "
if( \$ARGV[0] eq '$i' ) {
$part
}
";
}
if( $type eq '0+' ) {
$part = "##".$part."##";
$part =~ s/^##[0#\+ \n]+//;
$part =~ s/[ \n]+##$//;
print OUT "
#if( \$ARGV[0] eq '$i' ) {
$part
#}
";
}
$i++;
}
print OUT <<END;
sub unload {
my \$module = shift;
my \@parts = split(' ',\$module);
\$module = \$parts[0];
\$module =~ s/::/\\//g;
\$module.='.pm';
delete \$INC{\$module};
}
sub timeit {
my \$name = shift;
my \$base = shift;
\$sa = \$s2-\$s + ((\$usec2-\$usec)/1000000);
\$sb = \$s3-\$s2 + ((\$usec3-\$usec2)/1000000);
\$sc = \$s3-\$s + ((\$usec3-\$usec)/1000000);
if( \$base ) {
\$base1 = \$sa;
\$base2 = \$sb;
\$base3 = \$sc;
}
\$sa /= \$base1; \$sb /= \$base2; \$sc /= \$base3;
\$sa = fixed( \$sa ); \$sb = fixed( \$sb ); \$sc = fixed( \$sc );
if( !\$base || !\$onlyone ) {
tabit( \$name,\$sa,\$sb,\$sc);
}
}
sub tabit {
my ( \$a, \$b, \$c, \$d ) = \@_;
my \$len = length( \$a );
print \$a;
for( 0..(\$maxlen-\$len) ) { print ' '; }
print "\$b \$c \$d\n";
}
sub fixed {
my \$in = shift;
\$in *= 10000;
\$in = int( \$in );
\$in /= 10000;
my \$a = "\$in";
my \$len = length( \$a );
if( \$len > 8 ) { \$a = substr( \$a, 8 ); }
if( \$len < 8 ) {
while( \$len < 8 ) {
\$a = "\${a} ";
\$len = length( \$a );
}
}
return \$a;
}
END
close(OUT);
open( SH, ">./bench/$name.pl" );
my $end = $i+1;
print SH "#!/usr/bin/perl
";
if( $comment ) {
print SH "
print <<END;
$comment
END
";
}
print SH
"print `perl one$name.pl $end`;
my \$file = \$ARGV[0] || 'test.xml';
for my \$i ( 0..$i ) {
print `perl one$name.pl \$i \$file 1`
}
";
#print SH "#!/bin/bash
#perl bench.pl $end
#for (( i=1;i<=$i;i++ )); do
#perl bench.pl \$i \$1 1
#done
#";
close( SH );
}