Dogcows Code - chaz/p5-CGI-Ex/blob - t/samples/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 ### load in the rest of the tests that we support
 100 if (eval {require Storable}) {
 101   my $_file = tmpnam(). '.sto';
 102   &Storable::store($conf, $_file);
 103   $TESTS{sto} = sub {
 104     my $hash = $cob->read_ref($_file);
 105   };
 106   $files{sto} = $_file;
 107 }
 108
 109 if (eval {require Storable}) {
 110   my $_file = tmpnam(). '.sto2';
 111   &Storable::store($conf, $_file);
 112   $TESTS{sto2} = sub {
 113     my $hash = &Storable::retrieve($_file);
 114   };
 115   $files{sto2} = $_file;
 116 }
 117
 118 if (eval {require YAML}) {
 119   my $_file = tmpnam(). '.yaml';
 120   &YAML::DumpFile($_file, $conf);
 121   $TESTS{yaml} = sub {
 122     my $hash = $cob->read_ref($_file);
 123   };
 124   $files{yaml} = $_file;
 125 }
 126
 127 if (eval {require YAML}) {
 128   my $_file = tmpnam(). '.yaml2';
 129   &YAML::DumpFile($_file, $conf);
 130   $TESTS{yaml2} = sub {
 131     my $hash = &YAML::LoadFile($_file);
 132   };
 133   $files{yaml2} = $_file;
 134 }
 135
 136 if (eval {require YAML}) {
 137   my $_file = tmpnam(). '.yaml';
 138   &YAML::DumpFile($_file, $conf);
 139   $cob->preload_files($_file);
 140   $TESTS{yaml3} = sub {
 141     my $hash = $cob->read_ref($_file);
 142   };
 143   $files{yaml3} = $_file;
 144 }
 145
 146 if (eval {require Config::IniHash}) {
 147   my $_file = tmpnam(). '.ini';
 148   &Config::IniHash::WriteINI($_file, $conf);
 149   $TESTS{ini} = sub {
 150     local $^W = 0;
 151     my $hash = $cob->read_ref($_file);
 152   };
 153   $files{ini} = $_file;
 154 }
 155
 156 if (eval {require XML::Simple}) {
 157   my $_file = tmpnam(). '.xml';
 158   my $xml = XML::Simple->new->XMLout($conf);
 159   open  OUT, ">$_file" || die $!;
 160   print OUT $xml;
 161   close OUT;
 162   $TESTS{xml} = sub {
 163     my $hash = $cob->read_ref($_file);
 164   };
 165   $files{xml} = $_file;
 166 }
 167
 168 ### tell file locations
 169 foreach my $key (sort keys %files) {
 170   print "$key => $files{$key}\n";
 171 }
 172
 173 cmpthese($n, \%TESTS);
 174
 175 ### comment out this line to inspect files
 176 unlink $_ foreach values %files;
 177
 178 ###----------------------------------------------------------------###
 179
 180 sub generic_conf_read {
 181   my $_file = shift || die "No filename supplied";
 182   my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
 183
 184   ### fh will now lose scope and close itself if necessary
 185   my $FH = do { local *FH; *FH };
 186   open ($FH, $_file) || return {};
 187
 188   my $x = 0;
 189   my $conf = {};
 190   my $key  = '';
 191   my $val;
 192   my $line;
 193   my ($is_array,$is_hash,$is_multiline);
 194   my $order;
 195   $order = [] if wantarray;
 196
 197   while( defined($line = <$FH>) ){
 198     last if ! defined $line;
 199     last if $x++ > 10000;
 200
 201     next if index($line,'#') == 0;
 202
 203     if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
 204       next if ! length($key);
 205       $conf->{$key} .= $line;
 206       $is_multiline = 1;
 207
 208     }else{
 209       ### duplicate trim section
 210       if( length($key) ){
 211         $conf->{$key} =~ s/\s+$//;
 212         if( $is_array || $is_hash ){
 213           $conf->{$key} =~ s/^\s+//;
 214           my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
 215           my @pieces;
 216           if ($sep_by_newlines) {
 217             @pieces = split(/\s*\n\s*/,$conf->{$key});
 218             @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
 219           } else {
 220             @pieces = split(/\s+/,$conf->{$key});
 221           }
 222           if( $urldec ){
 223             foreach my $_val (@pieces){
 224               $_val =~ y/+/ / if ! $sep_by_newlines;
 225               $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 226             }
 227           }
 228           if( $is_array ){
 229             foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 230             $conf->{$key} = \@pieces;
 231           }elsif( $is_hash ){
 232             foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 233             shift(@pieces) if scalar(@pieces) % 2;
 234             $conf->{$key} = {@pieces};
 235           }
 236         }elsif( ! $is_multiline ){
 237           $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
 238           $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 239         }
 240       }
 241
 242       ($key,$val) = split(/\s+/,$line,2);
 243       $is_array = 0;
 244       $is_hash = 0;
 245       $is_multiline = 0;
 246       if (! length($key)) {
 247         next;
 248       } elsif (index($key,'array:') == 0) {
 249         $is_array = $key =~ s/^array://i;
 250       } elsif (index($key,'hash:') == 0) {
 251         $is_hash = $key =~ s/^hash://i;
 252       }
 253       $key =~ y/+/ / if ! $sep_by_newlines;
 254       $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 255       $conf->{$key} = $val;
 256       push @$order, $key if $order;
 257     }
 258   }
 259
 260   ### duplicate trim section
 261   if( length($key) && defined($conf->{$key}) ){
 262     $conf->{$key} =~ s/\s+$//;
 263     if( $is_array || $is_hash ){
 264       $conf->{$key} =~ s/^\s+//;
 265       my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
 266       my @pieces;
 267       if ($sep_by_newlines) {
 268         @pieces = split(/\s*\n\s*/,$conf->{$key});
 269         @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
 270       } else {
 271         @pieces = split(/\s+/,$conf->{$key});
 272       }
 273       if( $urldec ){
 274         foreach my $_val (@pieces){
 275           $_val =~ y/+/ / if ! $sep_by_newlines;
 276           $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 277         }
 278       }
 279       if( $is_array ){
 280         foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 281         $conf->{$key} = \@pieces;
 282       }elsif( $is_hash ){
 283         foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
 284         shift(@pieces) if scalar(@pieces) % 2;
 285         $conf->{$key} = {@pieces};
 286       }
 287     }elsif( ! $is_multiline ){
 288       $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
 289       $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
 290     }
 291   }
 292
 293
 294   close($FH);
 295   return $order ? ($conf,$order) : $conf;
 296 }
 297
 298
 299 sub generic_conf_write{
 300   my $_file = shift || die "No filename supplied";
 301
 302   if (! @_) {
 303     return;
 304   }
 305
 306   my $new_conf = shift || die "Missing update hashref";
 307   return if ! keys %$new_conf;
 308
 309
 310   ### do we allow writing out hashes in a nice way
 311   my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
 312
 313   ### touch the file if necessary
 314   if( ! -e $_file ){
 315     open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
 316     close(TOUCH);
 317   }
 318
 319   ### read old values
 320   my $conf = &generic_conf_read($_file) || {};
 321   my $key;
 322   my $val;
 323
 324   ### remove duplicates and undefs
 325   while (($key,$val) = each %$new_conf){
 326     $conf->{$key} = $new_conf->{$key};
 327   }
 328
 329   ### prepare output
 330   my $output = '';
 331   my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/;
 332   foreach $key (sort keys %$conf){
 333     next if ! defined $conf->{$key};
 334     $val = delete $conf->{$key};
 335     $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg;
 336     $key =~ tr/\ /+/;
 337     my $ref = ref($val);
 338     if( $ref ){
 339       if( $ref eq 'HASH' ){
 340         $output .= "hash:$key\n";
 341         foreach my $_key (sort keys %$val){
 342           my $_val = $val->{$_key};
 343           next if ! defined $_val;
 344           $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 345           $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 346           if ($sep_by_newlines) {
 347             $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
 348             $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
 349             $_key =~ s/\ /%20/g;
 350           } else {
 351             $_val =~ tr/\ /+/;
 352             $_key =~ tr/\ /+/;
 353           }
 354           $_val = $PLACEHOLDER if ! length($_val);
 355           $output .= "\t$_key\t$_val\n";
 356         }
 357       }elsif( $ref eq 'ARRAY' ){
 358         $output .= "array:$key\n";
 359         foreach (@$val){
 360           my $_val = $_;
 361           $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
 362           if ($sep_by_newlines) {
 363             $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
 364             $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
 365           } else {
 366             $_val =~ tr/\ /+/;
 367           }
 368           $_val = $PLACEHOLDER if ! length($_val);
 369           $output .= "\t$_val\n";
 370         }
 371       }else{
 372         $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
 373       }
 374     }else{
 375       if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding
 376         if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){
 377           if ($sep_by_newlines) {
 378             $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg;
 379           } else {
 380             $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
 381             $val =~ y/ /+/;
 382           }
 383         }
 384       }else{
 385         $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
 386         $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg;
 387         $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg;
 388       }
 389       $output .= "$key\t$val\n";
 390     }
 391   }
 392
 393   open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
 394   print CONF $output;
 395   truncate CONF, length($output);
 396   close CONF;
 397
 398   return 1;
 399 }
 400
 401 1;
 402