X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=samples%2Fbenchmark%2Fbench_conf_readers.pl;fp=samples%2Fbenchmark%2Fbench_conf_readers.pl;h=20f1b45f753e7c5d5f042070026738ff586a5254;hb=4eee158dce82376f2f37de29d91c53f60a24aebe;hp=0000000000000000000000000000000000000000;hpb=85070b46d0a93ddbeef07341421adb8389a55418;p=chaz%2Fp5-CGI-Ex diff --git a/samples/benchmark/bench_conf_readers.pl b/samples/benchmark/bench_conf_readers.pl new file mode 100644 index 0000000..20f1b45 --- /dev/null +++ b/samples/benchmark/bench_conf_readers.pl @@ -0,0 +1,419 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw($PLACEHOLDER); +use Benchmark qw(cmpthese); +use CGI::Ex::Conf; +use POSIX qw(tmpnam); + +$PLACEHOLDER = chr(186).'~'.chr(186); + +my $n = -2; + +my $cob = CGI::Ex::Conf->new; +my %files = (); + +###----------------------------------------------------------------### + +# Rate yaml2 yaml xml ini g_conf pl sto sto2 yaml3 +#yaml2 159/s -- -1% -72% -80% -91% -95% -98% -98% -100% +#yaml 160/s 1% -- -72% -80% -91% -95% -98% -98% -100% +#xml 565/s 255% 253% -- -28% -68% -84% -93% -94% -100% +#ini 785/s 393% 391% 39% -- -55% -78% -90% -91% -99% +#g_conf 1756/s 1004% 998% 211% 124% -- -50% -78% -80% -98% +#pl 3524/s 2115% 2103% 524% 349% 101% -- -55% -61% -97% +#sto 7838/s 4826% 4799% 1288% 898% 346% 122% -- -12% -93% +#sto2 8924/s 5508% 5477% 1480% 1037% 408% 153% 14% -- -92% +#yaml3 113328/s 71115% 70730% 19961% 14336% 6353% 3116% 1346% 1170% -- #memory + +my $str = '{ + foo => {key1 => "bar", key2 => "ralph"}, + pass => {key1 => "word", key2 => "ralph"}, + garbage => {key1 => "can", key2 => "ralph"}, + mighty => {key1 => "ducks", key2 => "ralph"}, + quack => {key1 => "moo", key2 => "ralph"}, + one1 => {key1 => "val1", key2 => "ralph"}, + one2 => {key1 => "val2", key2 => "ralph"}, + one3 => {key1 => "val3", key2 => "ralph"}, + one4 => {key1 => "val4", key2 => "ralph"}, + one5 => {key1 => "val5", key2 => "ralph"}, + one6 => {key1 => "val6", key2 => "ralph"}, + one7 => {key1 => "val7", key2 => "ralph"}, + one8 => {key1 => "val8", key2 => "ralph"}, +}'; + +###----------------------------------------------------------------### + +# Rate yaml yaml2 xml g_conf pl sto sto2 yaml3 +#yaml 431/s -- -2% -61% -91% -94% -97% -98% -100% +#yaml2 438/s 2% -- -60% -91% -94% -97% -98% -100% +#xml 1099/s 155% 151% -- -78% -85% -92% -94% -99% +#g_conf 4990/s 1057% 1038% 354% -- -33% -64% -72% -96% +#pl 7492/s 1637% 1609% 582% 50% -- -46% -58% -93% +#sto 13937/s 3130% 3078% 1169% 179% 86% -- -22% -88% +#sto2 17925/s 4055% 3988% 1532% 259% 139% 29% -- -84% +#yaml3 114429/s 26423% 25996% 10316% 2193% 1427% 721% 538% -- # memory + +#$str = '{ +# foo => "bar", +# pass => "word", +# garbage => "can", +# mighty => "ducks", +# quack => "moo", +# one1 => "val1", +# one2 => "val2", +# one3 => "val3", +# one4 => "val4", +# one5 => "val5", +# one6 => "val6", +# one7 => "val7", +# one8 => "val8", +#}'; + +###----------------------------------------------------------------### + +my $conf = eval $str; + +my %TESTS = (); + +### do perl +my $file = tmpnam(). '.pl'; +open OUT, ">$file"; +print OUT $str; +close OUT; +$TESTS{pl} = sub { + my $hash = $cob->read_ref($file); +}; +$files{pl} = $file; + +### do a generic conf_write +my $file2 = tmpnam(). '.g_conf'; +&generic_conf_write($file2, $conf); +local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read; +$TESTS{g_conf} = sub { + my $hash = $cob->read_ref($file2); +}; +$files{g_conf} = $file2; + + +if (eval {require JSON}) { + my $_file = tmpnam(). '.json'; + my $str = JSON::objToJson($conf, {pretty => 1, indent => 2}); + open(my $fh, ">$_file"); + print $fh $str; + $TESTS{json} = sub { + my $hash = $cob->read_ref($_file); + }; + $TESTS{json2} = sub { + open(my $fh, "<$_file") || die "Couldn't open file: $!"; + read($fh, my $str, -s $_file); + my $hash = JSON::jsonToObj($str); + }; + $files{json} = $_file; +} + + +### load in the rest of the tests that we support +if (eval {require Storable}) { + my $_file = tmpnam(). '.sto'; + &Storable::store($conf, $_file); + $TESTS{sto} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{sto} = $_file; +} + +if (eval {require Storable}) { + my $_file = tmpnam(). '.sto2'; + &Storable::store($conf, $_file); + $TESTS{sto2} = sub { + my $hash = &Storable::retrieve($_file); + }; + $files{sto2} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml'; + &YAML::DumpFile($_file, $conf); + $TESTS{yaml} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{yaml} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml2'; + &YAML::DumpFile($_file, $conf); + $TESTS{yaml2} = sub { + my $hash = &YAML::LoadFile($_file); + }; + $files{yaml2} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml'; + &YAML::DumpFile($_file, $conf); + $cob->preload_files($_file); + $TESTS{yaml3} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{yaml3} = $_file; +} + +if (eval {require Config::IniHash}) { + my $_file = tmpnam(). '.ini'; + &Config::IniHash::WriteINI($_file, $conf); + $TESTS{ini} = sub { + local $^W = 0; + my $hash = $cob->read_ref($_file); + }; + $files{ini} = $_file; +} + +if (eval {require XML::Simple}) { + my $_file = tmpnam(). '.xml'; + my $xml = XML::Simple->new->XMLout($conf); + open OUT, ">$_file" || die $!; + print OUT $xml; + close OUT; + $TESTS{xml} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{xml} = $_file; +} + +### tell file locations +foreach my $key (sort keys %files) { + print "$key => $files{$key}\n"; +} + +cmpthese($n, \%TESTS); + +### comment out this line to inspect files +unlink $_ foreach values %files; + +###----------------------------------------------------------------### + +sub generic_conf_read { + my $_file = shift || die "No filename supplied"; + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### fh will now lose scope and close itself if necessary + my $FH = do { local *FH; *FH }; + open ($FH, $_file) || return {}; + + my $x = 0; + my $conf = {}; + my $key = ''; + my $val; + my $line; + my ($is_array,$is_hash,$is_multiline); + my $order; + $order = [] if wantarray; + + while( defined($line = <$FH>) ){ + last if ! defined $line; + last if $x++ > 10000; + + next if index($line,'#') == 0; + + if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){ + next if ! length($key); + $conf->{$key} .= $line; + $is_multiline = 1; + + }else{ + ### duplicate trim section + if( length($key) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + ($key,$val) = split(/\s+/,$line,2); + $is_array = 0; + $is_hash = 0; + $is_multiline = 0; + if (! length($key)) { + next; + } elsif (index($key,'array:') == 0) { + $is_array = $key =~ s/^array://i; + } elsif (index($key,'hash:') == 0) { + $is_hash = $key =~ s/^hash://i; + } + $key =~ y/+/ / if ! $sep_by_newlines; + $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + $conf->{$key} = $val; + push @$order, $key if $order; + } + } + + ### duplicate trim section + if( length($key) && defined($conf->{$key}) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + + close($FH); + return $order ? ($conf,$order) : $conf; +} + + +sub generic_conf_write{ + my $_file = shift || die "No filename supplied"; + + if (! @_) { + return; + } + + my $new_conf = shift || die "Missing update hashref"; + return if ! keys %$new_conf; + + + ### do we allow writing out hashes in a nice way + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### touch the file if necessary + if( ! -e $_file ){ + open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!"; + close(TOUCH); + } + + ### read old values + my $conf = &generic_conf_read($_file) || {}; + my $key; + my $val; + + ### remove duplicates and undefs + while (($key,$val) = each %$new_conf){ + $conf->{$key} = $new_conf->{$key}; + } + + ### prepare output + my $output = ''; + my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/; + foreach $key (sort keys %$conf){ + next if ! defined $conf->{$key}; + $val = delete $conf->{$key}; + $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg; + $key =~ tr/\ /+/; + my $ref = ref($val); + if( $ref ){ + if( $ref eq 'HASH' ){ + $output .= "hash:$key\n"; + foreach my $_key (sort keys %$val){ + my $_val = $val->{$_key}; + next if ! defined $_val; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/\ /%20/g; + } else { + $_val =~ tr/\ /+/; + $_key =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_key\t$_val\n"; + } + }elsif( $ref eq 'ARRAY' ){ + $output .= "array:$key\n"; + foreach (@$val){ + my $_val = $_; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + } else { + $_val =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_val\n"; + } + }else{ + $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref + } + }else{ + if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding + if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){ + if ($sep_by_newlines) { + $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg; + } else { + $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ y/ /+/; + } + } + }else{ + $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg; + $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg; + } + $output .= "$key\t$val\n"; + } + } + + open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]"; + print CONF $output; + truncate CONF, length($output); + close CONF; + + return 1; +} + +1; +