← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:53 2010

File /project/perl/lib/IO/Compress/Base/Common.pm
Statements Executed 122
Statement Execution Time 12.5ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
0000s0sIO::Compress::Base::Common::::BEGIN IO::Compress::Base::Common::BEGIN
0000s0sIO::Compress::Base::Common::::ParseParameters IO::Compress::Base::Common::ParseParameters
0000s0sIO::Compress::Base::Common::::cleanFileGlobString IO::Compress::Base::Common::cleanFileGlobString
0000s0sIO::Compress::Base::Common::::createSelfTiedObject IO::Compress::Base::Common::createSelfTiedObject
0000s0sIO::Compress::Base::Common::::getEncoding IO::Compress::Base::Common::getEncoding
0000s0sIO::Compress::Base::Common::::hasEncode IO::Compress::Base::Common::hasEncode
0000s0sIO::Compress::Base::Common::::isaFileGlobString IO::Compress::Base::Common::isaFileGlobString
0000s0sIO::Compress::Base::Common::::isaFilehandle IO::Compress::Base::Common::isaFilehandle
0000s0sIO::Compress::Base::Common::::isaFilename IO::Compress::Base::Common::isaFilename
0000s0sIO::Compress::Base::Common::::oneTarget IO::Compress::Base::Common::oneTarget
0000s0sIO::Compress::Base::Common::::setBinModeInput IO::Compress::Base::Common::setBinModeInput
0000s0sIO::Compress::Base::Common::::setBinModeOutput IO::Compress::Base::Common::setBinModeOutput
0000s0sIO::Compress::Base::Common::::whatIs IO::Compress::Base::Common::whatIs
0000s0sIO::Compress::Base::Common::::whatIsInput IO::Compress::Base::Common::whatIsInput
0000s0sIO::Compress::Base::Common::::whatIsOutput IO::Compress::Base::Common::whatIsOutput
0000s0sIO::Compress::Base::Parameters::::_checkTypeIO::Compress::Base::Parameters::_checkType
0000s0sIO::Compress::Base::Parameters::::cloneIO::Compress::Base::Parameters::clone
0000s0sIO::Compress::Base::Parameters::::newIO::Compress::Base::Parameters::new
0000s0sIO::Compress::Base::Parameters::::parseIO::Compress::Base::Parameters::parse
0000s0sIO::Compress::Base::Parameters::::parsedIO::Compress::Base::Parameters::parsed
0000s0sIO::Compress::Base::Parameters::::setErrorIO::Compress::Base::Parameters::setError
0000s0sIO::Compress::Base::Parameters::::valueIO::Compress::Base::Parameters::value
0000s0sIO::Compress::Base::Parameters::::valueOrDefaultIO::Compress::Base::Parameters::valueOrDefault
0000s0sIO::Compress::Base::Parameters::::wantValueIO::Compress::Base::Parameters::wantValue
0000s0sU64::::BEGIN U64::BEGIN
0000s0sU64::::add U64::add
0000s0sU64::::clone U64::clone
0000s0sU64::::equal U64::equal
0000s0sU64::::get32bit U64::get32bit
0000s0sU64::::getHigh U64::getHigh
0000s0sU64::::getLow U64::getLow
0000s0sU64::::getPacked_V32 U64::getPacked_V32
0000s0sU64::::getPacked_V64 U64::getPacked_V64
0000s0sU64::::new U64::new
0000s0sU64::::newUnpack_V32 U64::newUnpack_V32
0000s0sU64::::newUnpack_V64 U64::newUnpack_V64
0000s0sU64::::pack_V64 U64::pack_V64
0000s0sU64::::reset U64::reset
0000s0sValidator::::croakError Validator::croakError
0000s0sValidator::::new Validator::new
0000s0sValidator::::saveErrorString Validator::saveErrorString
0000s0sValidator::::validateInputArray Validator::validateInputArray
0000s0sValidator::::validateInputFilenames Validator::validateInputFilenames
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IO::Compress::Base::Common;
2
33109µs125µsuse strict ;
# spent 25µs making 1 call to strict::import
4387µs1121µsuse warnings;
# spent 121µs making 1 call to warnings::import
53618µs116µsuse bytes;
# spent 16µs making 1 call to bytes::import
6
73102µs1236µsuse Carp;
# spent 236µs making 1 call to Exporter::import
8396µs1202µsuse Scalar::Util qw(blessed readonly);
# spent 202µs making 1 call to Exporter::import
93545µs1155µsuse File::GlobMapper;
# spent 155µs making 1 call to Exporter::import
10
1117µsrequire Exporter;
1216µsour ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13111µs@ISA = qw(Exporter);
1415µs$VERSION = '2.005';
15
16116µs@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
17 isaFileGlobString cleanFileGlobString oneTarget
18 setBinModeInput setBinModeOutput
19 ckInOutParams
20 createSelfTiedObject
21 getEncoding
22
23 WANT_CODE
24 WANT_EXT
25 WANT_UNDEF
26 WANT_HASH
27
28 STATUS_OK
29 STATUS_ENDSTREAM
30 STATUS_EOF
31 STATUS_ERROR
32 );
33
34111µs%EXPORT_TAGS = ( Status => [qw( STATUS_OK
35 STATUS_ENDSTREAM
36 STATUS_EOF
37 STATUS_ERROR
38 )]);
39
40
413120µs1191µsuse constant STATUS_OK => 0;
# spent 191µs making 1 call to constant::import
42388µs1179µsuse constant STATUS_ENDSTREAM => 1;
# spent 179µs making 1 call to constant::import
43394µs1190µsuse constant STATUS_EOF => 2;
# spent 190µs making 1 call to constant::import
443611µs1176µsuse constant STATUS_ERROR => -1;
# spent 176µs making 1 call to constant::import
45
46sub hasEncode()
47{
48 if (! defined $HAS_ENCODE) {
49 eval
50 {
51 require Encode;
52 Encode->import();
53 };
54
55 $HAS_ENCODE = $@ ? 0 : 1 ;
56 }
57
58 return $HAS_ENCODE;
59}
60
61sub getEncoding($$$)
62{
63 my $obj = shift;
64 my $class = shift ;
65 my $want_encoding = shift ;
66
67 $obj->croakError("$class: Encode module needed to use -Encode")
68 if ! hasEncode();
69
70 my $encoding = Encode::find_encoding($want_encoding);
71
72 $obj->croakError("$class: Encoding '$want_encoding' is not available")
73 if ! $encoding;
74
75 return $encoding;
76}
77
7814µsour ($needBinmode);
791105µs$needBinmode = ($^O eq 'MSWin32' ||
80 ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
81 ? 1 : 1 ;
82
83sub setBinModeInput($)
84{
85 my $handle = shift ;
86
87 binmode $handle
88 if $needBinmode;
89}
90
91sub setBinModeOutput($)
92{
93 my $handle = shift ;
94
95 binmode $handle
96 if $needBinmode;
97}
98
99sub isaFilehandle($)
100{
1013998µs123µs use utf8; # Pragma needed to keep Perl 5.6.0 happy
# spent 23µs making 1 call to utf8::import
102 return (defined $_[0] and
103 (UNIVERSAL::isa($_[0],'GLOB') or
104 UNIVERSAL::isa($_[0],'IO::Handle') or
105 UNIVERSAL::isa(\$_[0],'GLOB'))
106 )
107}
108
109sub isaFilename($)
110{
111 return (defined $_[0] and
112 ! ref $_[0] and
113 UNIVERSAL::isa(\$_[0], 'SCALAR'));
114}
115
116sub isaFileGlobString
117{
118 return defined $_[0] && $_[0] =~ /^<.*>$/;
119}
120
121sub cleanFileGlobString
122{
123 my $string = shift ;
124
125 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
126
127 return $string;
128}
129
130399µs1195µsuse constant WANT_CODE => 1 ;
# spent 195µs making 1 call to constant::import
131390µs1197µsuse constant WANT_EXT => 2 ;
# spent 197µs making 1 call to constant::import
132390µs1178µsuse constant WANT_UNDEF => 4 ;
# spent 178µs making 1 call to constant::import
133#use constant WANT_HASH => 8 ;
13431.39ms1175µsuse constant WANT_HASH => 0 ;
# spent 175µs making 1 call to constant::import
135
136sub whatIsInput($;$)
137{
138 my $got = whatIs(@_);
139
140 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
141 {
142 #use IO::File;
143 $got = 'handle';
144 $_[0] = *STDIN;
145 #$_[0] = new IO::File("<-");
146 }
147
148 return $got;
149}
150
151sub whatIsOutput($;$)
152{
153 my $got = whatIs(@_);
154
155 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
156 {
157 $got = 'handle';
158 $_[0] = *STDOUT;
159 #$_[0] = new IO::File(">-");
160 }
161
162 return $got;
163}
164
165sub whatIs ($;$)
166{
167 return 'handle' if isaFilehandle($_[0]);
168
169 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
170 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
171 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
172 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
173
174 return 'undef' if ! defined $_[0] && $undef ;
175
176 if (ref $_[0]) {
177 return '' if blessed($_[0]); # is an object
178 #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
179 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
180 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
181 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
182 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
183 return '';
184 }
185
186 return 'fileglob' if $extended && isaFileGlobString($_[0]);
187 return 'filename';
188}
189
190sub oneTarget
191{
192 return $_[0] =~ /^(code|handle|buffer|filename)$/;
193}
194
195sub Validator::new
196{
197 my $class = shift ;
198
199 my $Class = shift ;
200 my $error_ref = shift ;
201 my $reportClass = shift ;
202
203 my %data = (Class => $Class,
204 Error => $error_ref,
205 reportClass => $reportClass,
206 ) ;
207
208 my $obj = bless \%data, $class ;
209
210 local $Carp::CarpLevel = 1;
211
212 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
213 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
214
215 my $oneInput = $data{oneInput} = oneTarget($inType);
216 my $oneOutput = $data{oneOutput} = oneTarget($outType);
217
218 if (! $inType)
219 {
220 $obj->croakError("$reportClass: illegal input parameter") ;
221 #return undef ;
222 }
223
224# if ($inType eq 'hash')
225# {
226# $obj->{Hash} = 1 ;
227# $obj->{oneInput} = 1 ;
228# return $obj->validateHash($_[0]);
229# }
230
231 if (! $outType)
232 {
233 $obj->croakError("$reportClass: illegal output parameter") ;
234 #return undef ;
235 }
236
237
238 if ($inType ne 'fileglob' && $outType eq 'fileglob')
239 {
240 $obj->croakError("Need input fileglob for outout fileglob");
241 }
242
243# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
244# {
245# $obj->croakError("input must ne filename or fileglob when output is a hash");
246# }
247
248 if ($inType eq 'fileglob' && $outType eq 'fileglob')
249 {
250 $data{GlobMap} = 1 ;
251 $data{inType} = $data{outType} = 'filename';
252 my $mapper = new File::GlobMapper($_[0], $_[1]);
253 if ( ! $mapper )
254 {
255 return $obj->saveErrorString($File::GlobMapper::Error) ;
256 }
257 $data{Pairs} = $mapper->getFileMap();
258
259 return $obj;
260 }
261
262 $obj->croakError("$reportClass: input and output $inType are identical")
263 if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
264
265 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
266 {
267 my $glob = cleanFileGlobString($_[0]);
26831.45ms my @inputs = glob($glob);
269
270 if (@inputs == 0)
271 {
272 # TODO -- legal or die?
273 die "globmap matched zero file -- legal or die???" ;
274 }
275 elsif (@inputs == 1)
276 {
277 $obj->validateInputFilenames($inputs[0])
278 or return undef;
279 $_[0] = $inputs[0] ;
280 $data{inType} = 'filename' ;
281 $data{oneInput} = 1;
282 }
283 else
284 {
285 $obj->validateInputFilenames(@inputs)
286 or return undef;
287 $_[0] = [ @inputs ] ;
288 $data{inType} = 'filenames' ;
289 }
290 }
291 elsif ($inType eq 'filename')
292 {
293 $obj->validateInputFilenames($_[0])
294 or return undef;
295 }
296 elsif ($inType eq 'array')
297 {
298 $data{inType} = 'filenames' ;
299 $obj->validateInputArray($_[0])
300 or return undef ;
301 }
302
303 return $obj->saveErrorString("$reportClass: output buffer is read-only")
304 if $outType eq 'buffer' && readonly(${ $_[1] });
305
306 if ($outType eq 'filename' )
307 {
308 $obj->croakError("$reportClass: output filename is undef or null string")
309 if ! defined $_[1] || $_[1] eq '' ;
310
311 if (-e $_[1])
312 {
313 if (-d _ )
314 {
315 return $obj->saveErrorString("output file '$_[1]' is a directory");
316 }
317 }
318 }
319
320 return $obj ;
321}
322
323sub Validator::saveErrorString
324{
325 my $self = shift ;
326 ${ $self->{Error} } = shift ;
327 return undef;
328
329}
330
331sub Validator::croakError
332{
333 my $self = shift ;
334 $self->saveErrorString($_[0]);
335 croak $_[0];
336}
337
338
339
340sub Validator::validateInputFilenames
341{
342 my $self = shift ;
343
344 foreach my $filename (@_)
345 {
346 $self->croakError("$self->{reportClass}: input filename is undef or null string")
347 if ! defined $filename || $filename eq '' ;
348
349 next if $filename eq '-';
350
351 if (! -e $filename )
352 {
353 return $self->saveErrorString("input file '$filename' does not exist");
354 }
355
356 if (-d _ )
357 {
358 return $self->saveErrorString("input file '$filename' is a directory");
359 }
360
361 if (! -r _ )
362 {
363 return $self->saveErrorString("cannot open file '$filename': $!");
364 }
365 }
366
367 return 1 ;
368}
369
370sub Validator::validateInputArray
371{
372 my $self = shift ;
373
374 if ( @{ $_[0] } == 0 )
375 {
376 return $self->saveErrorString("empty array reference") ;
377 }
378
379 foreach my $element ( @{ $_[0] } )
380 {
381 my $inType = whatIsInput($element);
382
383 if (! $inType)
384 {
385 $self->croakError("unknown input parameter") ;
386 }
387 elsif($inType eq 'filename')
388 {
389 $self->validateInputFilenames($element)
390 or return undef ;
391 }
392 else
393 {
394 $self->croakError("not a filename") ;
395 }
396 }
397
398 return 1 ;
399}
400
401#sub Validator::validateHash
402#{
403# my $self = shift ;
404# my $href = shift ;
405#
406# while (my($k, $v) = each %$href)
407# {
408# my $ktype = whatIsInput($k);
409# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
410#
411# if ($ktype ne 'filename')
412# {
413# return $self->saveErrorString("hash key not filename") ;
414# }
415#
416# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
417# if (! $valid{$vtype})
418# {
419# return $self->saveErrorString("hash value not ok") ;
420# }
421# }
422#
423# return $self ;
424#}
425
426sub createSelfTiedObject
427{
428 my $class = shift || (caller)[0] ;
429 my $error_ref = shift ;
430
431 my $obj = bless Symbol::gensym(), ref($class) || $class;
432 tie *$obj, $obj if $] >= 5.005;
433 *$obj->{Closed} = 1 ;
434 $$error_ref = '';
435 *$obj->{Error} = $error_ref ;
436 my $errno = 0 ;
437 *$obj->{ErrorNo} = \$errno ;
438
439 return $obj;
440}
441
442
443
444#package Parse::Parameters ;
445#
446#
447#require Exporter;
448#our ($VERSION, @ISA, @EXPORT);
449#$VERSION = '2.000_08';
450#@ISA = qw(Exporter);
451
452112µs$EXPORT_TAGS{Parse} = [qw( ParseParameters
453 Parse_any Parse_unsigned Parse_signed
454 Parse_boolean Parse_custom Parse_string
455 Parse_multiple Parse_writable_scalar
456 )
457 ];
458
459113µspush @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
460
4613108µs1207µsuse constant Parse_any => 0x01;
# spent 207µs making 1 call to constant::import
462391µs1182µsuse constant Parse_unsigned => 0x02;
# spent 182µs making 1 call to constant::import
4633107µs1171µsuse constant Parse_signed => 0x04;
# spent 171µs making 1 call to constant::import
464393µs1176µsuse constant Parse_boolean => 0x08;
# spent 176µs making 1 call to constant::import
465391µs1172µsuse constant Parse_string => 0x10;
# spent 172µs making 1 call to constant::import
466395µs1214µsuse constant Parse_custom => 0x12;
# spent 214µs making 1 call to constant::import
467
468#use constant Parse_store_ref => 0x100 ;
469390µs1181µsuse constant Parse_multiple => 0x100 ;
# spent 181µs making 1 call to constant::import
4703100µs1208µsuse constant Parse_writable => 0x200 ;
# spent 208µs making 1 call to constant::import
471394µs1178µsuse constant Parse_writable_scalar => 0x400 | Parse_writable ;
# spent 178µs making 1 call to constant::import
472
473391µs1168µsuse constant OFF_PARSED => 0 ;
# spent 168µs making 1 call to constant::import
4743120µs1192µsuse constant OFF_TYPE => 1 ;
# spent 192µs making 1 call to constant::import
475392µs1182µsuse constant OFF_DEFAULT => 2 ;
# spent 182µs making 1 call to constant::import
476391µs1191µsuse constant OFF_FIXED => 3 ;
# spent 191µs making 1 call to constant::import
4773102µs1177µsuse constant OFF_FIRST_ONLY => 4 ;
# spent 177µs making 1 call to constant::import
4783296µs1174µsuse constant OFF_STICKY => 5 ;
# spent 174µs making 1 call to constant::import
479
480
481
482sub ParseParameters
483{
484 my $level = shift || 0 ;
485
486 my $sub = (caller($level + 1))[3] ;
487 local $Carp::CarpLevel = 1 ;
488 my $p = new IO::Compress::Base::Parameters() ;
489 $p->parse(@_)
490 or croak "$sub: $p->{Error}" ;
491
492 return $p;
493}
494
495#package IO::Compress::Base::Parameters;
496
497377µs123µsuse strict;
# spent 23µs making 1 call to strict::import
498385µs1118µsuse warnings;
# spent 118µs making 1 call to warnings::import
49932.62ms1242µsuse Carp;
# spent 242µs making 1 call to Exporter::import
500
501sub IO::Compress::Base::Parameters::new
502{
503 my $class = shift ;
504
505 my $obj = { Error => '',
506 Got => {},
507 } ;
508
509 #return bless $obj, ref($class) || $class || __PACKAGE__ ;
510 return bless $obj, 'IO::Compress::Base::Parameters' ;
511}
512
513sub IO::Compress::Base::Parameters::setError
514{
515 my $self = shift ;
516 my $error = shift ;
517 my $retval = @_ ? shift : undef ;
518
519 $self->{Error} = $error ;
520 return $retval;
521}
522
523#sub getError
524#{
525# my $self = shift ;
526# return $self->{Error} ;
527#}
528
529sub IO::Compress::Base::Parameters::parse
530{
531 my $self = shift ;
532
533 my $default = shift ;
534
535 my $got = $self->{Got} ;
536 my $firstTime = keys %{ $got } == 0 ;
537
538 my (@Bad) ;
539 my @entered = () ;
540
541 # Allow the options to be passed as a hash reference or
542 # as the complete hash.
543 if (@_ == 0) {
544 @entered = () ;
545 }
546 elsif (@_ == 1) {
547 my $href = $_[0] ;
548 return $self->setError("Expected even number of parameters, got 1")
549 if ! defined $href or ! ref $href or ref $href ne "HASH" ;
550
551 foreach my $key (keys %$href) {
552 push @entered, $key ;
553 push @entered, \$href->{$key} ;
554 }
555 }
556 else {
557 my $count = @_;
558 return $self->setError("Expected even number of parameters, got $count")
559 if $count % 2 != 0 ;
560
561 for my $i (0.. $count / 2 - 1) {
562 push @entered, $_[2* $i] ;
563 push @entered, \$_[2* $i+1] ;
564 }
565 }
566
567
568 while (my ($key, $v) = each %$default)
569 {
570 croak "need 4 params [@$v]"
571 if @$v != 4 ;
572
573 my ($first_only, $sticky, $type, $value) = @$v ;
574 my $x ;
575 $self->_checkType($key, \$value, $type, 0, \$x)
576 or return undef ;
577
578 $key = lc $key;
579
580 if ($firstTime || ! $sticky) {
581 $x = [ $x ]
582 if $type & Parse_multiple;
583
584 $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
585 }
586
587 $got->{$key}[OFF_PARSED] = 0 ;
588 }
589
590 my %parsed = ();
591 for my $i (0.. @entered / 2 - 1) {
592 my $key = $entered[2* $i] ;
593 my $value = $entered[2* $i+1] ;
594
595 #print "Key [$key] Value [$value]" ;
596 #print defined $$value ? "[$$value]\n" : "[undef]\n";
597
598 $key =~ s/^-// ;
599 my $canonkey = lc $key;
600
601 if ($got->{$canonkey} && ($firstTime ||
602 ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
603 {
604 my $type = $got->{$canonkey}[OFF_TYPE] ;
605 my $parsed = $parsed{$canonkey};
606 ++ $parsed{$canonkey};
607
608 return $self->setError("Muliple instances of '$key' found")
609 if $parsed && $type & Parse_multiple == 0 ;
610
611 my $s ;
612 $self->_checkType($key, $value, $type, 1, \$s)
613 or return undef ;
614
615 $value = $$value ;
616 if ($type & Parse_multiple) {
617 $got->{$canonkey}[OFF_PARSED] = 1;
618 push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
619 }
620 else {
621 $got->{$canonkey} = [1, $type, $value, $s] ;
622 }
623 }
624 else
625 { push (@Bad, $key) }
626 }
627
628 if (@Bad) {
629 my ($bad) = join(", ", @Bad) ;
630 return $self->setError("unknown key value(s) @Bad") ;
631 }
632
633 return 1;
634}
635
636sub IO::Compress::Base::Parameters::_checkType
637{
638 my $self = shift ;
639
640 my $key = shift ;
641 my $value = shift ;
642 my $type = shift ;
643 my $validate = shift ;
644 my $output = shift;
645
646 #local $Carp::CarpLevel = $level ;
647 #print "PARSE $type $key $value $validate $sub\n" ;
648
649 if ($type & Parse_writable_scalar)
650 {
651 return $self->setError("Parameter '$key' not writable")
652 if $validate && readonly $$value ;
653
654 if (ref $$value)
655 {
656 return $self->setError("Parameter '$key' not a scalar reference")
657 if $validate && ref $$value ne 'SCALAR' ;
658
659 $$output = $$value ;
660 }
661 else
662 {
663 return $self->setError("Parameter '$key' not a scalar")
664 if $validate && ref $value ne 'SCALAR' ;
665
666 $$output = $value ;
667 }
668
669 return 1;
670 }
671
672# if ($type & Parse_store_ref)
673# {
674# #$value = $$value
675# # if ref ${ $value } ;
676#
677# $$output = $value ;
678# return 1;
679# }
680
681 $value = $$value ;
682
683 if ($type & Parse_any)
684 {
685 $$output = $value ;
686 return 1;
687 }
688 elsif ($type & Parse_unsigned)
689 {
690 return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
691 if $validate && ! defined $value ;
692 return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
693 if $validate && $value !~ /^\d+$/;
694
695 $$output = defined $value ? $value : 0 ;
696 return 1;
697 }
698 elsif ($type & Parse_signed)
699 {
700 return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
701 if $validate && ! defined $value ;
702 return $self->setError("Parameter '$key' must be a signed int, got '$value'")
703 if $validate && $value !~ /^-?\d+$/;
704
705 $$output = defined $value ? $value : 0 ;
706 return 1 ;
707 }
708 elsif ($type & Parse_boolean)
709 {
710 return $self->setError("Parameter '$key' must be an int, got '$value'")
711 if $validate && defined $value && $value !~ /^\d*$/;
712 $$output = defined $value ? $value != 0 : 0 ;
713 return 1;
714 }
715 elsif ($type & Parse_string)
716 {
717 $$output = defined $value ? $value : "" ;
718 return 1;
719 }
720
721 $$output = $value ;
722 return 1;
723}
724
725
726
727sub IO::Compress::Base::Parameters::parsed
728{
729 my $self = shift ;
730 my $name = shift ;
731
732 return $self->{Got}{lc $name}[OFF_PARSED] ;
733}
734
735sub IO::Compress::Base::Parameters::value
736{
737 my $self = shift ;
738 my $name = shift ;
739
740 if (@_)
741 {
742 $self->{Got}{lc $name}[OFF_PARSED] = 1;
743 $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
744 $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
745 }
746
747 return $self->{Got}{lc $name}[OFF_FIXED] ;
748}
749
750sub IO::Compress::Base::Parameters::valueOrDefault
751{
752 my $self = shift ;
753 my $name = shift ;
754 my $default = shift ;
755
756 my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
757
758 return $value if defined $value ;
759 return $default ;
760}
761
762sub IO::Compress::Base::Parameters::wantValue
763{
764 my $self = shift ;
765 my $name = shift ;
766
767 return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
768
769}
770
771sub IO::Compress::Base::Parameters::clone
772{
773 my $self = shift ;
774 my $obj = { };
775 my %got ;
776
777 while (my ($k, $v) = each %{ $self->{Got} }) {
778 $got{$k} = [ @$v ];
779 }
780
781 $obj->{Error} = $self->{Error};
782 $obj->{Got} = \%got ;
783
784 return bless $obj, 'IO::Compress::Base::Parameters' ;
785}
786
787package U64;
788
7893102µs1210µsuse constant MAX32 => 0xFFFFFFFF ;
# spent 210µs making 1 call to constant::import
790391µs1178µsuse constant LOW => 0 ;
# spent 178µs making 1 call to constant::import
79131.10ms1176µsuse constant HIGH => 1;
# spent 176µs making 1 call to constant::import
792
793sub new
794{
795 my $class = shift ;
796
797 my $high = 0 ;
798 my $low = 0 ;
799
800 if (@_ == 2) {
801 $high = shift ;
802 $low = shift ;
803 }
804 elsif (@_ == 1) {
805 $low = shift ;
806 }
807
808 bless [$low, $high], $class;
809}
810
811sub newUnpack_V64
812{
813 my $string = shift;
814
815 my ($low, $hi) = unpack "V V", $string ;
816 bless [ $low, $hi ], "U64";
817}
818
819sub newUnpack_V32
820{
821 my $string = shift;
822
823 my $low = unpack "V", $string ;
824 bless [ $low, 0 ], "U64";
825}
826
827sub reset
828{
829 my $self = shift;
830 $self->[HIGH] = $self->[LOW] = 0;
831}
832
833sub clone
834{
835 my $self = shift;
836 bless [ @$self ], ref $self ;
837}
838
839sub getHigh
840{
841 my $self = shift;
842 return $self->[HIGH];
843}
844
845sub getLow
846{
847 my $self = shift;
848 return $self->[LOW];
849}
850
851sub get32bit
852{
853 my $self = shift;
854 return $self->[LOW];
855}
856
857sub add
858{
859 my $self = shift;
860 my $value = shift;
861
862 if (ref $value eq 'U64') {
863 $self->[HIGH] += $value->[HIGH] ;
864 $value = $value->[LOW];
865 }
866
867 my $available = MAX32 - $self->[LOW] ;
868
869 if ($value > $available) {
870 ++ $self->[HIGH] ;
871 $self->[LOW] = $value - $available - 1;
872 }
873 else {
874 $self->[LOW] += $value ;
875 }
876}
877
878sub equal
879{
880 my $self = shift;
881 my $other = shift;
882
883 return $self->[LOW] == $other->[LOW] &&
884 $self->[HIGH] == $other->[HIGH] ;
885}
886
887sub getPacked_V64
888{
889 my $self = shift;
890
891 return pack "V V", @$self ;
892}
893
894sub getPacked_V32
895{
896 my $self = shift;
897
898 return pack "V", $self->[LOW] ;
899}
900
901sub pack_V64
902{
903 my $low = shift;
904
905 return pack "V V", $low, 0;
906}
907
908
909package IO::Compress::Base::Common;
910
911133µs1;
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.