require
5.006 ;
our
(
@ISA
,
$VERSION
);
@ISA
=
qw(IO::File Exporter)
;
$VERSION
=
'2.106'
;
sub
saveStatus
{
my
$self
=
shift
;
${
*$self
->{ErrorNo} } =
shift
() + 0 ;
${
*$self
->{Error} } =
''
;
return
${
*$self
->{ErrorNo} } ;
}
sub
saveErrorString
{
my
$self
=
shift
;
my
$retval
=
shift
;
${
*$self
->{Error} } =
shift
;
${
*$self
->{ErrorNo} } =
shift
() + 0
if
@_
;
return
$retval
;
}
sub
croakError
{
my
$self
=
shift
;
$self
->saveErrorString(0,
$_
[0]);
Carp::croak
$_
[0];
}
sub
closeError
{
my
$self
=
shift
;
my
$retval
=
shift
;
my
$errno
=
*$self
->{ErrorNo};
my
$error
= ${
*$self
->{Error} };
$self
->
close
();
*$self
->{ErrorNo} =
$errno
;
${
*$self
->{Error} } =
$error
;
return
$retval
;
}
sub
error
{
my
$self
=
shift
;
return
${
*$self
->{Error} } ;
}
sub
errorNo
{
my
$self
=
shift
;
return
${
*$self
->{ErrorNo} } ;
}
sub
writeAt
{
my
$self
=
shift
;
my
$offset
=
shift
;
my
$data
=
shift
;
if
(
defined
*$self
->{FH}) {
my
$here
=
tell
(
*$self
->{FH});
return
$self
->saveErrorString(
undef
,
"Cannot seek to end of output filehandle: $!"
, $!)
if
$here
< 0 ;
seek
(
*$self
->{FH},
$offset
, IO::Handle::SEEK_SET)
or
return
$self
->saveErrorString(
undef
,
"Cannot seek to end of output filehandle: $!"
, $!) ;
defined
*$self
->{FH}->
write
(
$data
,
length
$data
)
or
return
$self
->saveErrorString(
undef
, $!, $!) ;
seek
(
*$self
->{FH},
$here
, IO::Handle::SEEK_SET)
or
return
$self
->saveErrorString(
undef
,
"Cannot seek to end of output filehandle: $!"
, $!) ;
}
else
{
substr
(${
*$self
->{Buffer} },
$offset
,
length
(
$data
)) =
$data
;
}
return
1;
}
sub
outputPayload
{
my
$self
=
shift
;
return
$self
->output(
@_
);
}
sub
output
{
my
$self
=
shift
;
my
$data
=
shift
;
my
$last
=
shift
;
return
1
if
length
$data
== 0 && !
$last
;
if
(
*$self
->{FilterContainer} ) {
*_
= \
$data
;
&{
*$self
->{FilterContainer} }();
}
if
(
length
$data
) {
if
(
defined
*$self
->{FH} ) {
defined
*$self
->{FH}->
write
(
$data
,
length
$data
)
or
return
$self
->saveErrorString(0, $!, $!);
}
else
{
${
*$self
->{Buffer} } .=
$data
;
}
}
return
1;
}
sub
getOneShotParams
{
return
(
'multistream'
=> [IO::Compress::Base::Common::Parse_boolean, 1],
);
}
our
%PARAMS
= (
'autoclose'
=> [IO::Compress::Base::Common::Parse_boolean, 0],
'encode'
=> [IO::Compress::Base::Common::Parse_any,
undef
],
'strict'
=> [IO::Compress::Base::Common::Parse_boolean, 1],
'append'
=> [IO::Compress::Base::Common::Parse_boolean, 0],
'binmodein'
=> [IO::Compress::Base::Common::Parse_boolean, 0],
'filtercontainer'
=> [IO::Compress::Base::Common::Parse_code,
undef
],
);
sub
checkParams
{
my
$self
=
shift
;
my
$class
=
shift
;
my
$got
=
shift
|| IO::Compress::Base::Parameters::new();
$got
->parse(
{
%PARAMS
,
$self
->getExtraParams(),
*$self
->{OneShot} ?
$self
->getOneShotParams()
: (),
},
@_
) or
$self
->croakError(
"${class}: "
.
$got
->getError()) ;
return
$got
;
}
sub
_create
{
my
$obj
=
shift
;
my
$got
=
shift
;
*$obj
->{Closed} = 1 ;
my
$class
=
ref
$obj
;
$obj
->croakError(
"$class: Missing Output parameter"
)
if
!
@_
&& !
$got
;
my
$outValue
=
shift
;
my
$oneShot
= 1 ;
if
(!
$got
)
{
$oneShot
= 0 ;
$got
=
$obj
->checkParams(
$class
,
undef
,
@_
)
or
return
undef
;
}
my
$lax
= !
$got
->getValue(
'strict'
) ;
my
$outType
= IO::Compress::Base::Common::whatIsOutput(
$outValue
);
$obj
->ckOutputParam(
$class
,
$outValue
)
or
return
undef
;
if
(
$outType
eq
'buffer'
) {
*$obj
->{Buffer} =
$outValue
;
}
else
{
my
$buff
=
""
;
*$obj
->{Buffer} = \
$buff
;
}
my
$merge
=
$got
->getValue(
'merge'
) ;
my
$appendOutput
=
$got
->getValue(
'append'
) ||
$merge
;
*$obj
->{Append} =
$appendOutput
;
*$obj
->{FilterContainer} =
$got
->getValue(
'filtercontainer'
) ;
if
(
$merge
)
{
if
((
$outType
eq
'buffer'
&&
length
$$outValue
== 0 ) ||
(
$outType
ne
'buffer'
&& (! -e
$outValue
|| (-w _ && -z _))) )
{
$merge
= 0 }
}
$obj
->ckParams(
$got
)
or
$obj
->croakError(
"${class}: "
.
$obj
->error());
if
(
$got
->getValue(
'encode'
)) {
my
$want_encoding
=
$got
->getValue(
'encode'
);
*$obj
->{Encoding} = IO::Compress::Base::Common::getEncoding(
$obj
,
$class
,
$want_encoding
);
my
$x
=
*$obj
->{Encoding};
}
else
{
*$obj
->{Encoding} =
undef
;
}
$obj
->saveStatus(STATUS_OK) ;
my
$status
;
if
(!
$merge
)
{
*$obj
->{Compress} =
$obj
->mkComp(
$got
)
or
return
undef
;
*$obj
->{UnCompSize} = U64->new;
*$obj
->{CompSize} = U64->new;
if
(
$outType
eq
'buffer'
) {
${
*$obj
->{Buffer} } =
''
unless
$appendOutput
;
}
else
{
if
(
$outType
eq
'handle'
) {
*$obj
->{FH} =
$outValue
;
setBinModeOutput(
*$obj
->{FH}) ;
*$obj
->{Handle} = 1 ;
if
(
$appendOutput
)
{
seek
(
*$obj
->{FH}, 0, IO::Handle::SEEK_END)
or
return
$obj
->saveErrorString(
undef
,
"Cannot seek to end of output filehandle: $!"
, $!) ;
}
}
elsif
(
$outType
eq
'filename'
) {
no
warnings;
my
$mode
=
'>'
;
$mode
=
'>>'
if
$appendOutput
;
*$obj
->{FH} = IO::File->new(
"$mode $outValue"
)
or
return
$obj
->saveErrorString(
undef
,
"cannot open file '$outValue': $!"
, $!) ;
*$obj
->{StdIO} = (
$outValue
eq
'-'
);
setBinModeOutput(
*$obj
->{FH}) ;
}
}
*$obj
->{Header} =
$obj
->mkHeader(
$got
) ;
$obj
->output(
*$obj
->{Header} )
or
return
undef
;
$obj
->beforePayload();
}
else
{
*$obj
->{Compress} =
$obj
->createMerge(
$outValue
,
$outType
)
or
return
undef
;
}
*$obj
->{Closed} = 0 ;
*$obj
->{AutoClose} =
$got
->getValue(
'autoclose'
) ;
*$obj
->{Output} =
$outValue
;
*$obj
->{ClassName} =
$class
;
*$obj
->{Got} =
$got
;
*$obj
->{OneShot} = 0 ;
return
$obj
;
}
sub
ckOutputParam
{
my
$self
=
shift
;
my
$from
=
shift
;
my
$outType
= IO::Compress::Base::Common::whatIsOutput(
$_
[0]);
$self
->croakError(
"$from: output parameter not a filename, filehandle or scalar ref"
)
if
!
$outType
;
$self
->croakError(
"$from: output buffer is read-only"
)
if
$outType
eq
'buffer'
&& Scalar::Util::readonly(${
$_
[0] });
return
1;
}
sub
_def
{
my
$obj
=
shift
;
my
$class
= (
caller
)[0] ;
my
$name
= (
caller
(1))[3] ;
$obj
->croakError(
"$name: expected at least 1 parameters\n"
)
unless
@_
>= 1 ;
my
$input
=
shift
;
my
$haveOut
=
@_
;
my
$output
=
shift
;
my
$x
= IO::Compress::Base::Validator->new(
$class
,
*$obj
->{Error},
$name
,
$input
,
$output
)
or
return
undef
;
push
@_
,
$output
if
$haveOut
&&
$x
->{Hash};
*$obj
->{OneShot} = 1 ;
my
$got
=
$obj
->checkParams(
$name
,
undef
,
@_
)
or
return
undef
;
$x
->{Got} =
$got
;
if
(
$x
->{GlobMap})
{
$x
->{oneInput} = 1 ;
foreach
my
$pair
(@{
$x
->{Pairs} })
{
my
(
$from
,
$to
) =
@$pair
;
$obj
->_singleTarget(
$x
, 1,
$from
,
$to
,
@_
)
or
return
undef
;
}
return
scalar
@{
$x
->{Pairs} } ;
}
if
(!
$x
->{oneOutput} )
{
my
$inFile
= (
$x
->{inType} eq
'filenames'
||
$x
->{inType} eq
'filename'
);
$x
->{inType} =
$inFile
?
'filename'
:
'buffer'
;
foreach
my
$in
(
$x
->{oneInput} ?
$input
:
@$input
)
{
my
$out
;
$x
->{oneInput} = 1 ;
$obj
->_singleTarget(
$x
,
$inFile
,
$in
, \
$out
,
@_
)
or
return
undef
;
push
@$output
, \
$out
;
}
return
1 ;
}
return
$obj
->_singleTarget(
$x
, 1,
$input
,
$output
,
@_
);
Carp::croak
"should not be here"
;
}
sub
_singleTarget
{
my
$obj
=
shift
;
my
$x
=
shift
;
my
$inputIsFilename
=
shift
;
my
$input
=
shift
;
if
(
$x
->{oneInput})
{
$obj
->getFileInfo(
$x
->{Got},
$input
)
if
isaScalar(
$input
) || (isaFilename(
$input
) and
$inputIsFilename
) ;
my
$z
=
$obj
->_create(
$x
->{Got},
@_
)
or
return
undef
;
defined
$z
->_wr2(
$input
,
$inputIsFilename
)
or
return
$z
->closeError(
undef
) ;
return
$z
->
close
() ;
}
else
{
my
$afterFirst
= 0 ;
my
$inputIsFilename
= (
$x
->{inType} ne
'array'
);
my
$keep
=
$x
->{Got}->clone();
for
my
$element
(
@$input
)
{
my
$isFilename
= isaFilename(
$element
);
if
(
$afterFirst
++ )
{
defined
addInterStream(
$obj
,
$element
,
$isFilename
)
or
return
$obj
->closeError(
undef
) ;
}
else
{
$obj
->getFileInfo(
$x
->{Got},
$element
)
if
isaScalar(
$element
) ||
$isFilename
;
$obj
->_create(
$x
->{Got},
@_
)
or
return
undef
;
}
defined
$obj
->_wr2(
$element
,
$isFilename
)
or
return
$obj
->closeError(
undef
) ;
*$obj
->{Got} =
$keep
->clone();
}
return
$obj
->
close
() ;
}
}
sub
_wr2
{
my
$self
=
shift
;
my
$source
=
shift
;
my
$inputIsFilename
=
shift
;
my
$input
=
$source
;
if
(!
$inputIsFilename
)
{
$input
= \
$source
if
!
ref
$source
;
}
if
(
ref
$input
&&
ref
$input
eq
'SCALAR'
)
{
return
$self
->
syswrite
(
$input
,
@_
) ;
}
if
( !
ref
$input
|| isaFilehandle(
$input
))
{
my
$isFilehandle
= isaFilehandle(
$input
) ;
my
$fh
=
$input
;
if
( !
$isFilehandle
)
{
$fh
= IO::File->new(
"<$input"
)
or
return
$self
->saveErrorString(
undef
,
"cannot open file '$input': $!"
, $!) ;
}
binmode
$fh
;
my
$status
;
my
$buff
;
my
$count
= 0 ;
while
(
$status
=
read
(
$fh
,
$buff
, 16 * 1024)) {
$count
+=
length
$buff
;
defined
$self
->
syswrite
(
$buff
,
@_
)
or
return
undef
;
}
return
$self
->saveErrorString(
undef
, $!, $!)
if
!
defined
$status
;
if
( (!
$isFilehandle
||
*$self
->{AutoClose}) &&
$input
ne
'-'
)
{
$fh
->
close
()
or
return
undef
;
}
return
$count
;
}
Carp::croak
"Should not be here"
;
return
undef
;
}
sub
addInterStream
{
my
$self
=
shift
;
my
$input
=
shift
;
my
$inputIsFilename
=
shift
;
if
(
*$self
->{Got}->getValue(
'multistream'
))
{
$self
->getFileInfo(
*$self
->{Got},
$input
)
if
isaScalar(
$input
) || isaFilename(
$input
) ;
return
$self
->newStream();
}
elsif
(
*$self
->{Got}->getValue(
'autoflush'
))
{
}
return
1 ;
}
sub
getFileInfo
{
}
sub
TIEHANDLE
{
return
$_
[0]
if
ref
(
$_
[0]);
die
"OOPS\n"
;
}
sub
UNTIE
{
my
$self
=
shift
;
}
sub
DESTROY
{
my
$self
=
shift
;
local
($., $@, $!, $^E, $?);
$self
->
close
() ;
%{
*$self
} = () ;
undef
$self
;
}
sub
filterUncompressed
{
}
sub
syswrite
{
my
$self
=
shift
;
my
$buffer
;
if
(
ref
$_
[0] ) {
$self
->croakError(
*$self
->{ClassName} .
"::write: not a scalar reference"
)
unless
ref
$_
[0] eq
'SCALAR'
;
$buffer
=
$_
[0] ;
}
else
{
$buffer
= \
$_
[0] ;
}
if
(
@_
> 1) {
my
$slen
=
defined
$$buffer
?
length
(
$$buffer
) : 0;
my
$len
=
$slen
;
my
$offset
= 0;
$len
=
$_
[1]
if
$_
[1] <
$len
;
if
(
@_
> 2) {
$offset
=
$_
[2] || 0;
$self
->croakError(
*$self
->{ClassName} .
"::write: offset outside string"
)
if
$offset
>
$slen
;
if
(
$offset
< 0) {
$offset
+=
$slen
;
$self
->croakError(
*$self
->{ClassName} .
"::write: offset outside string"
)
if
$offset
< 0;
}
my
$rem
=
$slen
-
$offset
;
$len
=
$rem
if
$rem
<
$len
;
}
$buffer
= \
substr
(
$$buffer
,
$offset
,
$len
) ;
}
return
0
if
(!
defined
$$buffer
||
length
$$buffer
== 0) && !
*$self
->{FlushPending};
if
(
*$self
->{Encoding}) {
$$buffer
=
*$self
->{Encoding}->encode(
$$buffer
);
}
else
{
$] >= 5.008 and ( utf8::downgrade(
$$buffer
, 1)
or Carp::croak
"Wide character in "
.
*$self
->{ClassName} .
"::write:"
);
}
$self
->filterUncompressed(
$buffer
);
my
$buffer_length
=
defined
$$buffer
?
length
(
$$buffer
) : 0 ;
*$self
->{UnCompSize}->add(
$buffer_length
) ;
my
$outBuffer
=
''
;
my
$status
=
*$self
->{Compress}->compr(
$buffer
,
$outBuffer
) ;
return
$self
->saveErrorString(
undef
,
*$self
->{Compress}{Error},
*$self
->{Compress}{ErrorNo})
if
$status
== STATUS_ERROR;
*$self
->{CompSize}->add(
length
$outBuffer
) ;
$self
->outputPayload(
$outBuffer
)
or
return
undef
;
return
$buffer_length
;
}
sub
print
{
my
$self
=
shift
;
if
(
defined
$\) {
if
(
defined
$,) {
defined
$self
->
syswrite
(
join
($,,
@_
) . $\);
}
else
{
defined
$self
->
syswrite
(
join
(
""
,
@_
) . $\);
}
}
else
{
if
(
defined
$,) {
defined
$self
->
syswrite
(
join
($,,
@_
));
}
else
{
defined
$self
->
syswrite
(
join
(
""
,
@_
));
}
}
}
sub
printf
{
my
$self
=
shift
;
my
$fmt
=
shift
;
defined
$self
->
syswrite
(
sprintf
(
$fmt
,
@_
));
}
sub
_flushCompressed
{
my
$self
=
shift
;
my
$outBuffer
=
''
;
my
$status
=
*$self
->{Compress}->flush(
$outBuffer
,
@_
) ;
return
$self
->saveErrorString(0,
*$self
->{Compress}{Error},
*$self
->{Compress}{ErrorNo})
if
$status
== STATUS_ERROR;
if
(
defined
*$self
->{FH} ) {
*$self
->{FH}->clearerr();
}
*$self
->{CompSize}->add(
length
$outBuffer
) ;
$self
->outputPayload(
$outBuffer
)
or
return
0;
return
1;
}
sub
flush
{
my
$self
=
shift
;
$self
->_flushCompressed(
@_
)
or
return
0;
if
(
defined
*$self
->{FH} ) {
defined
*$self
->{FH}->flush()
or
return
$self
->saveErrorString(0, $!, $!);
}
return
1;
}
sub
beforePayload
{
}
sub
_newStream
{
my
$self
=
shift
;
my
$got
=
shift
;
my
$class
=
ref
$self
;
$self
->_writeTrailer()
or
return
0 ;
$self
->ckParams(
$got
)
or
$self
->croakError(
"newStream: $self->{Error}"
);
if
(
$got
->getValue(
'encode'
)) {
my
$want_encoding
=
$got
->getValue(
'encode'
);
*$self
->{Encoding} = IO::Compress::Base::Common::getEncoding(
$self
,
$class
,
$want_encoding
);
}
else
{
*$self
->{Encoding} =
undef
;
}
*$self
->{Compress} =
$self
->mkComp(
$got
)
or
return
0;
*$self
->{Header} =
$self
->mkHeader(
$got
) ;
$self
->output(
*$self
->{Header} )
or
return
0;
*$self
->{UnCompSize}->
reset
();
*$self
->{CompSize}->
reset
();
$self
->beforePayload();
return
1 ;
}
sub
newStream
{
my
$self
=
shift
;
my
$got
=
$self
->checkParams(
'newStream'
,
*$self
->{Got},
@_
)
or
return
0 ;
$self
->_newStream(
$got
);
}
sub
reset
{
my
$self
=
shift
;
return
*$self
->{Compress}->
reset
() ;
}
sub
_writeTrailer
{
my
$self
=
shift
;
my
$trailer
=
''
;
my
$status
=
*$self
->{Compress}->
close
(
$trailer
) ;
return
$self
->saveErrorString(0,
*$self
->{Compress}{Error},
*$self
->{Compress}{ErrorNo})
if
$status
== STATUS_ERROR;
*$self
->{CompSize}->add(
length
$trailer
) ;
$trailer
.=
$self
->mkTrailer();
defined
$trailer
or
return
0;
return
$self
->output(
$trailer
);
}
sub
_writeFinalTrailer
{
my
$self
=
shift
;
return
$self
->output(
$self
->mkFinalTrailer());
}
sub
close
{
my
$self
=
shift
;
return
1
if
*$self
->{Closed} || !
*$self
->{Compress} ;
*$self
->{Closed} = 1 ;
untie
*$self
if
$] >= 5.008 ;
*$self
->{FlushPending} = 1 ;
$self
->_writeTrailer()
or
return
0 ;
$self
->_writeFinalTrailer()
or
return
0 ;
$self
->output(
""
, 1 )
or
return
0;
if
(
defined
*$self
->{FH}) {
if
((!
*$self
->{Handle} ||
*$self
->{AutoClose}) && !
*$self
->{StdIO}) {
$! = 0 ;
*$self
->{FH}->
close
()
or
return
$self
->saveErrorString(0, $!, $!);
}
delete
*$self
->{FH} ;
$! = 0 ;
}
return
1;
}
sub
tell
{
my
$self
=
shift
;
return
*$self
->{UnCompSize}->get32bit() ;
}
sub
eof
{
my
$self
=
shift
;
return
*$self
->{Closed} ;
}
sub
seek
{
my
$self
=
shift
;
my
$position
=
shift
;
my
$whence
=
shift
;
my
$here
=
$self
->
tell
() ;
my
$target
= 0 ;
if
(
$whence
== IO::Handle::SEEK_SET) {
$target
=
$position
;
}
elsif
(
$whence
== IO::Handle::SEEK_CUR ||
$whence
== IO::Handle::SEEK_END) {
$target
=
$here
+
$position
;
}
else
{
$self
->croakError(
*$self
->{ClassName} .
"::seek: unknown value, $whence, for whence parameter"
);
}
return
1
if
$target
==
$here
;
$self
->croakError(
*$self
->{ClassName} .
"::seek: cannot seek backwards"
)
if
$target
<
$here
;
my
$offset
=
$target
-
$here
;
my
$buffer
;
defined
$self
->
syswrite
(
"\x00"
x
$offset
)
or
return
0;
return
1 ;
}
sub
binmode
{
1;
}
sub
fileno
{
my
$self
=
shift
;
return
defined
*$self
->{FH}
?
*$self
->{FH}->
fileno
()
:
undef
;
}
sub
opened
{
my
$self
=
shift
;
return
!
*$self
->{Closed} ;
}
sub
autoflush
{
my
$self
=
shift
;
return
defined
*$self
->{FH}
?
*$self
->{FH}->autoflush(
@_
)
:
undef
;
}
sub
input_line_number
{
return
undef
;
}
sub
_notAvailable
{
my
$name
=
shift
;
return
sub
{ Carp::croak
"$name Not Available: File opened only for output"
; } ;
}
{
no
warnings
'once'
;
*read
= _notAvailable(
'read'
);
*READ
= _notAvailable(
'read'
);
*readline
= _notAvailable(
'readline'
);
*READLINE
= _notAvailable(
'readline'
);
*getc
= _notAvailable(
'getc'
);
*GETC
= _notAvailable(
'getc'
);
*FILENO
= \
&fileno
;
*PRINT
= \
&print
;
*PRINTF
= \
&printf
;
*WRITE
= \
&syswrite
;
*write
= \
&syswrite
;
*SEEK
= \
&seek
;
*TELL
= \
&tell
;
*EOF
= \
&eof
;
*CLOSE
= \
&close
;
*BINMODE
= \
&binmode
;
}
1;
Hide Show 44 lines of Pod