Dogcows Code - chaz/p5-CGI-Ex/blob - samples/benchmark/bench_conf_readers.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use vars qw($PLACEHOLDER);
   5 use Benchmark qw(cmpthese);
   6 use CGI::Ex::Conf;
   7 use POSIX qw(tmpnam);
   8
   9 $PLACEHOLDER = chr(186).'~'.chr(186);
  10
  11 my $n = -2;
  12
  13 my $cob   = CGI::Ex::Conf->new;
  14 my %files = ();
  15
  16 ###----------------------------------------------------------------###
  17
  18 #           Rate  yaml2   yaml    xml    ini g_conf     pl    sto   sto2  yaml3
  19 #yaml2     159/s     --    -1%   -72%   -80%   -91%   -95%   -98%   -98%  -100%
  20 #yaml      160/s     1%     --   -72%   -80%   -91%   -95%   -98%   -98%  -100%
  21 #xml       565/s   255%   253%     --   -28%   -68%   -84%   -93%   -94%  -100%
  22 #ini       785/s   393%   391%    39%     --   -55%   -78%   -90%   -91%   -99%
  23 #g_conf   1756/s  1004%   998%   211%   124%     --   -50%   -78%   -80%   -98%
  24 #pl       3524/s  2115%  2103%   524%   349%   101%     --   -55%   -61%   -97%
  25 #sto      7838/s  4826%  4799%  1288%   898%   346%   122%     --   -12%   -93%
  26 #sto2     8924/s  5508%  5477%  1480%  1037%   408%   153%    14%     --   -92%
  27 #yaml3  113328/s 71115% 70730% 19961% 14336%  6353%  3116%  1346%  1170%     -- #memory
  28
  29 my $str = '{
  30   foo     => {key1 => "bar",   key2 => "ralph"},
  31   pass    => {key1 => "word",  key2 => "ralph"},
  32   garbage => {key1 => "can",   key2 => "ralph"},
  33   mighty  => {key1 => "ducks", key2 => "ralph"},
  34   quack   => {key1 => "moo",   key2 => "ralph"},
  35   one1    => {key1 => "val1",  key2 => "ralph"},
  36   one2    => {key1 => "val2",  key2 => "ralph"},
  37   one3    => {key1 => "val3",  key2 => "ralph"},
  38   one4    => {key1 => "val4",  key2 => "ralph"},
  39   one5    => {key1 => "val5",  key2 => "ralph"},
  40   one6    => {key1 => "val6",  key2 => "ralph"},
  41   one7    => {key1 => "val7",  key2 => "ralph"},
  42   one8    => {key1 => "val8",  key2 => "ralph"},
  43 }';
  44
  45 ###----------------------------------------------------------------###
  46
  47 #           Rate   yaml  yaml2    xml g_conf     pl    sto   sto2  yaml3
  48 #yaml      431/s     --    -2%   -61%   -91%   -94%   -97%   -98%  -100%
  49 #yaml2     438/s     2%     --   -60%   -91%   -94%   -97%   -98%  -100%
  50 #xml      1099/s   155%   151%     --   -78%   -85%   -92%   -94%   -99%
  51 #g_conf   4990/s  1057%  1038%   354%     --   -33%   -64%   -72%   -96%
  52 #pl       7492/s  1637%  1609%   582%    50%     --   -46%   -58%   -93%
  53 #sto     13937/s  3130%  3078%  1169%   179%    86%     --   -22%   -88%
  54 #sto2    17925/s  4055%  3988%  1532%   259%   139%    29%     --   -84%
  55 #yaml3  114429/s 26423% 25996% 10316%  2193%  1427%   721%   538%     -- # memory
  56
  57 #$str = '{
  58 #  foo     => "bar",
  59 #  pass    => "word",
  60 #  garbage => "can",
  61 #  mighty  => "ducks",
  62 #  quack   => "moo",
  63 #  one1    => "val1",
  64 #  one2    => "val2",
  65 #  one3    => "val3",
  66 #  one4    => "val4",
  67 #  one5    => "val5",
  68 #  one6    => "val6",
  69 #  one7    => "val7",
  70 #  one8    => "val8",
  71 #}';
  72
  73 ###----------------------------------------------------------------###
  74
  75 my $conf = eval $str;
  76
  77 my %TESTS = ();
  78
  79 ### do perl
  80 my $file = tmpnam(). '.pl';
  81 open OUT, ">$file";
  82 print OUT $str;
  83 close OUT;
  84 $TESTS{pl} = sub {
  85   my $hash = $cob->read_ref($file);
  86 };
  87 $files{pl} = $file;
  88
  89 ### do a generic conf_write
  90 my $file2 = tmpnam(). '.g_conf';
  91 &generic_conf_write($file2, $conf);
  92 local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read;
  93 $TESTS{g_conf} = sub {
  94   my $hash = $cob->read_ref($file2);
  95 };
  96 $files{g_conf} = $file2;
  97
  98
  99 if (eval {require JSON}) {
 100   my $_file = tmpnam(). '.json';
 101   my $str = JSON::objToJson($conf, {pretty => 1, indent => 2});
 102   open(my $fh, ">$_file");
 103   print $fh $str;
 104   $TESTS{json} = sub {
 105     my $hash = $cob->read_ref($_file);
 106   };
 107   $TESTS{json2} = sub {
 108     open(my $fh, "<$_file") || die "Couldn't open file: $!";
 109     read($fh, my $str, -s $_file);
 110     my $hash = JSON::jsonToObj($str);
 111   };
 112   $files{json} = $_file;
 113 }
 114
 115
 116 ### load in the rest of the tests that we support
 117 if (eval {require Storable}) {
 118   my $_file = tmpnam(). '.sto';
 119   &Storable::store($conf, $_file);
 120   $TESTS{sto} = sub {
 121     my $hash = $cob->read_ref($_file);
 122   };
 123   $files{sto} = $_file;
 124 }
 125
 126 if (eval {require Storable}) {
 127   my $_file = tmpnam(). '.sto2';
 128   &Storable::store($conf, $_file);
 129   $TESTS{sto2} = sub {
 130     my $hash = &Storable::retrieve($_file);
 131   };
 132   $files{sto2} = $_file;
 133 }
 134
 135 if (eval {require YAML}) {
 136   my $_file = tmpnam(). '.yaml';
 137   &YAML::DumpFile($_file, $conf);
 138   $TESTS{yaml} = sub {
 139     my $hash = $cob->read_ref($_file);
 140   };
 141   $files{yaml} = $_file;
 142 }
 143
 144 if (eval {require YAML}) {
 145   my $_file = tmpnam(). '.yaml2';
 146   &YAML::DumpFile($_file, $conf);
 147   $TESTS{yaml2} = sub {
 148     my $hash = &YAML::LoadFile($_file);
 149   };
 150   $files{yaml2} = $_file;
 151 }
 152
 153 if (eval {require YAML}) {
 154   my $_file = tmpnam(). '.yaml';
 155   &YAML::DumpFile($_file, $conf);
 156   $cob->preload_files($_file);
 157   $TESTS{yaml3} = sub {
 158     my $hash = $cob->read_ref($_file);
 159   };
 160   $files{yaml3} = $_file;
 161 }
 162
 163 if (eval {require Config::IniHash}) {
 164   my $_file = tmpnam(). '.ini';
 165   &Config::IniHash::WriteINI($_file, $conf);
 166   $TESTS{ini} = sub {
 167     local $^W = 0;
 168     my $hash = $cob->read_ref($_file);
 169   };
 170   $files{ini} = $_file;
 171 }
 172
 173 if (eval {require XML::Simple}) {
 174   my $_file = tmpnam(). '.xml';
 175   my $xml = XML::Simple->new->XMLout($conf);
 176   open  OUT, ">$_file" || die $!;
 177   print OUT $xml;
 178   close OUT;
 179   $TESTS{xml} = sub {
 180     my $hash = $cob->read_ref($_file);
 181   };
 182   $files{xml} = $_file;
 183 }
 184
 185 ### tell file locations
 186 foreach my $key (sort keys %files) {
 187   print "$key => $files{$key}\n";
 188 }
 189
 190 cmpthese($n, \%TESTS);
 191
 192 ### comment out this line to inspect files
 193 unlink $_ foreach values %files;
 194
 195 ###----------------------------------------------------------------###
 196
 197 sub generic_conf_read {
 198   my $_file = shift || die "No filename supplied";
 199   my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
 200
 201   ### fh will now lose scope and close itself if necessary
 202   my $FH = do { local *FH; *FH };
 203   open ($FH, $_file) || return {};
 204
 205   my $x = 0;
 206   my $conf = {};
 207   my $key  = '';
 208   my $val;
 209   my $line;
 210   my ($is_array,$is_hash,$is_multiline);
 211   my $order;
 212   $order = [] if wantarray;
 213
 214   while( defined($line = <$FH>) ){
 215     last if ! defined $line;
 216     last if $x++ > 10000;
 217
 218     next if index($line,'#') == 0;
 219
 220     if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
 221       next if ! length($key);
 222       $conf->{$key} .= $line;
 223       $is_multiline = 1;
 224
 225     }else{
 226       ### duplicate trim section
 227       if( length($key) ){
 228         $conf->{$key} =~ s/\s+$//;
 229         if( $is_array || $is_hash ){
 230           $conf->{$key} =~ s/^\s+//;
 231           my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
 232           my @pieces;
 233           if ($sep_by_newlines) {
 234             @pieces = split(/\s*\n\s*/,$conf->{$key});
 235             @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
 236           } else {
 237             @pieces = split(/\s+/,$conf->{$key});
 238           }
 239           if( $urldec ){
 240             foreach my $_val (@pieces){
 241               $_val =~ y/+/ / if ! $sep_by_newlines;
 242               $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 243             }
 244           }
 245           if( $is_array ){
 246             foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 247             $conf->{$key} = \@pieces;
 248           }elsif( $is_hash ){
 249             foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 250             shift(@pieces) if scalar(@pieces) % 2;
 251             $conf->{$key} = {@pieces};
 252           }
 253         }elsif( ! $is_multiline ){
 254           $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
 255           $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 256         }
 257       }
 258
 259       ($key,$val) = split(/\s+/,$line,2);
 260       $is_array = 0;
 261       $is_hash = 0;
 262       $is_multiline = 0;
 263       if (! length($key)) {
 264         next;
 265       } elsif (index($key,'array:') == 0) {
 266         $is_array = $key =~ s/^array://i;
 267       } elsif (index($key,'hash:') == 0) {
 268         $is_hash = $key =~ s/^hash://i;
 269       }
 270       $key =~ y/+/ / if ! $sep_by_newlines;
 271       $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 272       $conf->{$key} = $val;
 273       push @$order, $key if $order;
 274     }
 275   }
 276
 277   ### duplicate trim section
 278   if( length($key) && defined($conf->{$key}) ){
 279     $conf->{$key} =~ s/\s+$//;
 280     if( $is_array || $is_hash ){
 281       $conf->{$key} =~ s/^\s+//;
 282       my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
 283       my @pieces;
 284       if ($sep_by_newlines) {
 285         @pieces = split(/\s*\n\s*/,$conf->{$key});
 286         @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
 287       } else {
 288         @pieces = split(/\s+/,$conf->{$key});
 289       }
 290       if( $urldec ){
 291         foreach my $_val (@pieces){
 292           $_val =~ y/+/ / if ! $sep_by_newlines;
 293           $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 294         }
 295       }
 296       if( $is_array ){
 297         foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 298         $conf->{$key} = \@pieces;
 299       }elsif( $is_hash ){
 300         foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 301         shift(@pieces) if scalar(@pieces) % 2;
 302         $conf->{$key} = {@pieces};
 303       }
 304     }elsif( ! $is_multiline ){
 305       $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
 306       $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 307     }
 308   }
 309
 310
 311   close($FH);
 312   return $order ? ($conf,$order) : $conf;
 313 }
 314
 315
 316 sub generic_conf_write{
 317   my $_file = shift || die "No filename supplied";
 318
 319   if (! @_) {
 320     return;
 321   }
 322
 323   my $new_conf = shift || die "Missing update hashref";
 324   return if ! keys %$new_conf;
 325
 326
 327   ### do we allow writing out hashes in a nice way
 328   my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
 329
 330   ### touch the file if necessary
 331   if( ! -e $_file ){
 332     open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
 333     close(TOUCH);
 334   }
 335
 336   ### read old values
 337   my $conf = &generic_conf_read($_file) || {};
 338   my $key;
 339   my $val;
 340
 341   ### remove duplicates and undefs
 342   while (($key,$val) = each %$new_conf){
 343     $conf->{$key} = $new_conf->{$key};
 344   }
 345
 346   ### prepare output
 347   my $output = '';
 348   my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/;
 349   foreach $key (sort keys %$conf){
 350     next if ! defined $conf->{$key};
 351     $val = delete $conf->{$key};
 352     $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg;
 353     $key =~ tr/\ /+/;
 354     my $ref = ref($val);
 355     if( $ref ){
 356       if( $ref eq 'HASH' ){
 357         $output .= "hash:$key\n";
 358         foreach my $_key (sort keys %$val){
 359           my $_val = $val->{$_key};
 360           next if ! defined $_val;
 361           $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 362           $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 363           if ($sep_by_newlines) {
 364             $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
 365             $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
 366             $_key =~ s/\ /%20/g;
 367           } else {
 368             $_val =~ tr/\ /+/;
 369             $_key =~ tr/\ /+/;
 370           }
 371           $_val = $PLACEHOLDER if ! length($_val);
 372           $output .= "\t$_key\t$_val\n";
 373         }
 374       }elsif( $ref eq 'ARRAY' ){
 375         $output .= "array:$key\n";
 376         foreach (@$val){
 377           my $_val = $_;
 378           $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 379           if ($sep_by_newlines) {
 380             $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
 381             $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
 382           } else {
 383             $_val =~ tr/\ /+/;
 384           }
 385           $_val = $PLACEHOLDER if ! length($_val);
 386           $output .= "\t$_val\n";
 387         }
 388       }else{
 389         $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
 390       }
 391     }else{
 392       if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding
 393         if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){
 394           if ($sep_by_newlines) {
 395             $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg;
 396           } else {
 397             $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
 398             $val =~ y/ /+/;
 399           }
 400         }
 401       }else{
 402         $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
 403         $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg;
 404         $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg;
 405       }
 406       $output .= "$key\t$val\n";
 407     }
 408   }
 409
 410   open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
 411   print CONF $output;
 412   truncate CONF, length($output);
 413   close CONF;
 414
 415   return 1;
 416 }
 417
 418 1;
 419