]>
Dogcows Code - chaz/p5-CGI-Ex/blob - t/samples/bench_conf_writers.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 # [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% --
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 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% --
72 ###----------------------------------------------------------------###
81 my $tmpnam = "$dir/bench";
82 my $file = $tmpnam. '.pl';
84 $cob->write_ref($file, $str);
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);
94 $files{g_conf
} = $file2;
97 ### load in the rest of the tests that we support
98 if (eval {require Storable
}) {
99 my $_file = $tmpnam. '.sto';
101 $cob->write_ref($file, $str);
103 $files{sto
} = $_file;
106 if (eval {require Storable
}) {
107 my $_file = $tmpnam. '.sto2';
109 &Storable
::store
($str, $_file);
111 $files{sto2
} = $_file;
114 if (eval {require YAML
}) {
115 my $_file = $tmpnam. '.yaml';
117 $cob->write_ref($_file, $str);
119 $files{yaml
} = $_file;
122 if (eval {require YAML
}) {
123 my $_file = $tmpnam. '.yaml2';
124 $TESTS{yaml2
} = sub {
125 &YAML
::DumpFile
($_file, $str);
127 $files{yaml2
} = $_file;
130 if (eval {require Config
::IniHash
}) {
131 my $_file = $tmpnam. '.ini';
134 $cob->write_ref($_file, $str);
136 $files{ini
} = $_file;
139 if (eval {require XML
::Simple
}) {
140 my $_file = $tmpnam. '.xml';
142 $cob->write_ref($_file, $str);
144 $files{xml
} = $_file;
147 ### tell file locations
148 foreach my $key (sort keys %files) {
149 print "$key => $files{$key}\n";
152 foreach my $key (keys %TESTS) {
153 eval { &{ $TESTS{$key} } };
155 warn "Test for $key failed - skipping";
161 cmpthese
($n, \
%TESTS);
163 ### comment out this line to inspect files
164 unlink $_ foreach values %files;
167 ###----------------------------------------------------------------###
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;
173 ### fh will now lose scope and close itself if necessary
174 my $FH = do { local *FH
; *FH
};
175 open ($FH, $_file) || return {};
182 my ($is_array,$is_hash,$is_multiline);
184 $order = [] if wantarray;
186 while( defined($line = <$FH>) ){
187 last if ! defined $line;
188 last if $x++ > 10000;
190 next if index($line,'#') == 0;
192 if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
193 next if ! length($key);
194 $conf->{$key} .= $line;
198 ### duplicate trim section
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);
205 if ($sep_by_newlines) {
206 @pieces = split(/\s*\n\s*/,$conf->{$key});
207 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
209 @pieces = split(/\s+/,$conf->{$key});
212 foreach my $_val (@pieces){
213 $_val =~ y/+/ / if ! $sep_by_newlines;
214 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
218 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
219 $conf->{$key} = \
@pieces;
221 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
222 shift(@pieces) if scalar(@pieces) % 2;
223 $conf->{$key} = {@pieces};
225 }elsif( ! $is_multiline ){
226 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
227 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
231 ($key,$val) = split(/\s+/,$line,2);
235 if (! length($key)) {
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;
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;
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);
256 if ($sep_by_newlines) {
257 @pieces = split(/\s*\n\s*/,$conf->{$key});
258 @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
260 @pieces = split(/\s+/,$conf->{$key});
263 foreach my $_val (@pieces){
264 $_val =~ y/+/ / if ! $sep_by_newlines;
265 $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
269 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
270 $conf->{$key} = \
@pieces;
272 foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
273 shift(@pieces) if scalar(@pieces) % 2;
274 $conf->{$key} = {@pieces};
276 }elsif( ! $is_multiline ){
277 $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
278 $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
284 return $order ? ($conf,$order) : $conf;
288 sub generic_conf_write
{
289 my $_file = shift || die "No filename supplied";
295 my $new_conf = shift || die "Missing update hashref";
296 return if ! keys %$new_conf;
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;
302 ### touch the file if necessary
304 open(TOUCH
,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
309 my $conf = &generic_conf_read
($_file) || {};
313 ### remove duplicates and undefs
314 while (($key,$val) = each %$new_conf){
315 $conf->{$key} = $new_conf->{$key};
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
;
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;
343 $_val = $PLACEHOLDER if ! length($_val);
344 $output .= "\t$_key\t$_val\n";
346 }elsif( $ref eq 'ARRAY' ){
347 $output .= "array:$key\n";
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;
357 $_val = $PLACEHOLDER if ! length($_val);
358 $output .= "\t$_val\n";
361 $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
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;
369 $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
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;
378 $output .= "$key\t$val\n";
382 open (CONF
,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
384 truncate CONF
, length($output);
This page took 0.06831 seconds and 5 git commands to generate.