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

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