]>
Dogcows Code - chaz/p5-CGI-Ex/blob - bench_conf_writers.pl
37b10703b233c2abe9174e542bba54cce471010d
4 use vars
qw($PLACEHOLDER);
5 use Benchmark
qw(cmpthese timethese);
9 $PLACEHOLDER = chr(186).'~'.chr(186);
13 my $cob = CGI
::Ex
::Conf-
>new;
16 ###----------------------------------------------------------------###
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% --
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"},
44 ###----------------------------------------------------------------###
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% --
71 ###----------------------------------------------------------------###
80 my $tmpnam = "$dir/bench";
81 my $file = $tmpnam. '.pl';
83 $cob->write_ref($file, $str);
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);
93 $files{g_conf
} = $file2;
96 ### load in the rest of the tests that we support
97 if (eval {require JSON
}) {
98 my $_file = tmpnam
(). '.json';
100 $cob->write_ref($file, $str);
102 $files{json
} = $_file;
105 if (eval {require Storable
}) {
106 my $_file = $tmpnam. '.sto';
108 $cob->write_ref($file, $str);
110 $files{sto
} = $_file;
113 if (eval {require Storable
}) {
114 my $_file = $tmpnam. '.sto2';
116 &Storable
::store
($str, $_file);
118 $files{sto2
} = $_file;
121 if (eval {require YAML
}) {
122 my $_file = $tmpnam. '.yaml';
124 $cob->write_ref($_file, $str);
126 $files{yaml
} = $_file;
129 if (eval {require YAML
}) {
130 my $_file = $tmpnam. '.yaml2';
131 $TESTS{yaml2
} = sub {
132 &YAML
::DumpFile
($_file, $str);
134 $files{yaml2
} = $_file;
137 if (eval {require Config
::IniHash
}) {
138 my $_file = $tmpnam. '.ini';
141 $cob->write_ref($_file, $str);
143 $files{ini
} = $_file;
146 if (eval {require XML
::Simple
}) {
147 my $_file = $tmpnam. '.xml';
149 $cob->write_ref($_file, $str);
151 $files{xml
} = $_file;
154 ### tell file locations
155 foreach my $key (sort keys %files) {
156 print "$key => $files{$key}\n";
159 foreach my $key (keys %TESTS) {
160 eval { &{ $TESTS{$key} } };
162 warn "Test for $key failed - skipping";
168 cmpthese timethese
($n, \
%TESTS);
170 ### comment out this line to inspect files
171 unlink $_ foreach values %files;
174 ###----------------------------------------------------------------###
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;
180 ### fh will now lose scope and close itself if necessary
181 my $FH = do { local *FH
; *FH
};
182 open ($FH, $_file) || return {};
189 my ($is_array,$is_hash,$is_multiline);
191 $order = [] if wantarray;
193 while( defined($line = <$FH>) ){
194 last if ! defined $line;
195 last if $x++ > 10000;
197 next if index($line,'#') == 0;
199 if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
200 next if ! length($key);
201 $conf->{$key} .= $line;
205 ### duplicate trim section
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);
212 if ($sep_by_newlines) {
213 @pieces = split(/\s*\n\s*/,$conf->{$key});
214 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
216 @pieces = split(/\s+/,$conf->{$key});
219 foreach my $_val (@pieces){
220 $_val =~ y/+/ / if ! $sep_by_newlines;
221 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
225 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
226 $conf->{$key} = \
@pieces;
228 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
229 shift(@pieces) if scalar(@pieces) % 2;
230 $conf->{$key} = {@pieces};
232 }elsif( ! $is_multiline ){
233 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
234 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
238 ($key,$val) = split(/\s+/,$line,2);
242 if (! length($key)) {
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;
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;
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);
263 if ($sep_by_newlines) {
264 @pieces = split(/\s*\n\s*/,$conf->{$key});
265 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
267 @pieces = split(/\s+/,$conf->{$key});
270 foreach my $_val (@pieces){
271 $_val =~ y/+/ / if ! $sep_by_newlines;
272 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
276 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
277 $conf->{$key} = \
@pieces;
279 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
280 shift(@pieces) if scalar(@pieces) % 2;
281 $conf->{$key} = {@pieces};
283 }elsif( ! $is_multiline ){
284 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
285 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
291 return $order ? ($conf,$order) : $conf;
295 sub generic_conf_write
{
296 my $_file = shift || die "No filename supplied";
302 my $new_conf = shift || die "Missing update hashref";
303 return if ! keys %$new_conf;
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;
309 ### touch the file if necessary
311 open(TOUCH
,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
316 my $conf = &generic_conf_read
($_file) || {};
320 ### remove duplicates and undefs
321 while (($key,$val) = each %$new_conf){
322 $conf->{$key} = $new_conf->{$key};
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
;
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;
350 $_val = $PLACEHOLDER if ! length($_val);
351 $output .= "\t$_key\t$_val\n";
353 }elsif( $ref eq 'ARRAY' ){
354 $output .= "array:$key\n";
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;
364 $_val = $PLACEHOLDER if ! length($_val);
365 $output .= "\t$_val\n";
368 $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
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;
376 $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
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;
385 $output .= "$key\t$val\n";
389 open (CONF
,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
391 truncate CONF
, length($output);
This page took 0.066488 seconds and 3 git commands to generate.