]>
Dogcows Code - chaz/p5-CGI-Ex/blob - t/samples/bench_conf_readers.pl
4 use vars
qw($PLACEHOLDER);
5 use Benchmark
qw(cmpthese);
9 $PLACEHOLDER = chr(186).'~'.chr(186);
13 my $cob = CGI
::Ex
::Conf-
>new;
16 ###----------------------------------------------------------------###
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
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"},
45 ###----------------------------------------------------------------###
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
73 ###----------------------------------------------------------------###
80 my $file = tmpnam
(). '.pl';
85 my $hash = $cob->read_ref($file);
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);
96 $files{g_conf
} = $file2;
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);
104 my $hash = $cob->read_ref($_file);
106 $files{sto
} = $_file;
109 if (eval {require Storable
}) {
110 my $_file = tmpnam
(). '.sto2';
111 &Storable
::store
($conf, $_file);
113 my $hash = &Storable
::retrieve
($_file);
115 $files{sto2
} = $_file;
118 if (eval {require YAML
}) {
119 my $_file = tmpnam
(). '.yaml';
120 &YAML
::DumpFile
($_file, $conf);
122 my $hash = $cob->read_ref($_file);
124 $files{yaml
} = $_file;
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);
133 $files{yaml2
} = $_file;
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);
143 $files{yaml3
} = $_file;
146 if (eval {require Config
::IniHash
}) {
147 my $_file = tmpnam
(). '.ini';
148 &Config
::IniHash
::WriteINI
($_file, $conf);
151 my $hash = $cob->read_ref($_file);
153 $files{ini
} = $_file;
156 if (eval {require XML
::Simple
}) {
157 my $_file = tmpnam
(). '.xml';
158 my $xml = XML
::Simple-
>new->XMLout($conf);
159 open OUT
, ">$_file" || die $!;
163 my $hash = $cob->read_ref($_file);
165 $files{xml
} = $_file;
168 ### tell file locations
169 foreach my $key (sort keys %files) {
170 print "$key => $files{$key}\n";
173 cmpthese
($n, \
%TESTS);
175 ### comment out this line to inspect files
176 unlink $_ foreach values %files;
178 ###----------------------------------------------------------------###
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;
184 ### fh will now lose scope and close itself if necessary
185 my $FH = do { local *FH
; *FH
};
186 open ($FH, $_file) || return {};
193 my ($is_array,$is_hash,$is_multiline);
195 $order = [] if wantarray;
197 while( defined($line = <$FH>) ){
198 last if ! defined $line;
199 last if $x++ > 10000;
201 next if index($line,'#') == 0;
203 if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
204 next if ! length($key);
205 $conf->{$key} .= $line;
209 ### duplicate trim section
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);
216 if ($sep_by_newlines) {
217 @pieces = split(/\s*\n\s*/,$conf->{$key});
218 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
220 @pieces = split(/\s+/,$conf->{$key});
223 foreach my $_val (@pieces){
224 $_val =~ y/+/ / if ! $sep_by_newlines;
225 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
229 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
230 $conf->{$key} = \
@pieces;
232 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
233 shift(@pieces) if scalar(@pieces) % 2;
234 $conf->{$key} = {@pieces};
236 }elsif( ! $is_multiline ){
237 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
238 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
242 ($key,$val) = split(/\s+/,$line,2);
246 if (! length($key)) {
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;
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;
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);
267 if ($sep_by_newlines) {
268 @pieces = split(/\s*\n\s*/,$conf->{$key});
269 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
271 @pieces = split(/\s+/,$conf->{$key});
274 foreach my $_val (@pieces){
275 $_val =~ y/+/ / if ! $sep_by_newlines;
276 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
280 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
281 $conf->{$key} = \
@pieces;
283 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
284 shift(@pieces) if scalar(@pieces) % 2;
285 $conf->{$key} = {@pieces};
287 }elsif( ! $is_multiline ){
288 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
289 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
295 return $order ? ($conf,$order) : $conf;
299 sub generic_conf_write
{
300 my $_file = shift || die "No filename supplied";
306 my $new_conf = shift || die "Missing update hashref";
307 return if ! keys %$new_conf;
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;
313 ### touch the file if necessary
315 open(TOUCH
,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
320 my $conf = &generic_conf_read
($_file) || {};
324 ### remove duplicates and undefs
325 while (($key,$val) = each %$new_conf){
326 $conf->{$key} = $new_conf->{$key};
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
;
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;
354 $_val = $PLACEHOLDER if ! length($_val);
355 $output .= "\t$_key\t$_val\n";
357 }elsif( $ref eq 'ARRAY' ){
358 $output .= "array:$key\n";
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;
368 $_val = $PLACEHOLDER if ! length($_val);
369 $output .= "\t$_val\n";
372 $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
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;
380 $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
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;
389 $output .= "$key\t$val\n";
393 open (CONF
,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
395 truncate CONF
, length($output);
This page took 0.06513 seconds and 4 git commands to generate.