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