# Deflate.pm: Class Used for Deflating Stream Areas

package RDA::Handle::Deflate;

# $Id: Deflate.pm,v 1.13 2015/08/19 21:05:29 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Handle/Deflate.pm,v 1.13 2015/08/19 21:05:29 RDA Exp $
#
# Change History
# 20150819  MSC  Improve the getline method.

=head1 NAME

RDA::Handle::Deflate - Class used for Deflating Stream Areas

=head1 SYNOPSIS

 require RDA::Handle::Deflate;

=head1 DESCRIPTION

The objects of the C<RDA::Handle::Deflate> class are used for deflating stream
areas.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use Compress::Zlib;
  use RDA::Text qw(get_string);
  use Symbol;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants
my $R_BLK = 8192;
my $S_BLK = 16384;

my $BITS    = Compress::Zlib::MAX_WBITS();
my $STA_EOF = Compress::Zlib::Z_STREAM_END();
my $STA_OK  = Compress::Zlib::Z_OK();

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Handle::Deflate-E<gt>new($ifh,$max)>

The object constructor.

C<RDA::Handle::Deflate> is represented by a symbol, which can be used as a file
handle. The following special keys are used:

=over 12

=item S<    B<'buf' > > Buffer

=item S<    B<'eol' > > End-of-line characters protection indicator

=item S<    B<'ifh' > > Input file handle

=item S<    B<'lgt' > > Buffer length

=item S<    B<'lin' > > Line number

=item S<    B<'max' > > Data size

=item S<    B<'obj' > > Inflate object

=item S<    B<'off' > > Initial area offset

=item S<    B<'pos' > > Current position in the stream

=item S<    B<'siz' > > Initial area size

=back

=cut

sub new  ## no critic (Unpack)
{ my $cls = shift;
  my ($slf);

  # Create the buffer object
  $slf = bless Symbol::gensym(), ref($cls) || $cls;
  tie *$slf, $slf;  ## no critic (Tie)
  $slf->open(@_);

  # Return the object reference
  return $slf;
}

sub open  ## no critic (Builtin)
{ my ($slf, $ifh, $max) = @_;
  my ($obj, $sta);

  # Create the object when not yet done
  return $slf->new($ifh, $max) unless ref($slf);

  # Initialize the deflated area
  ($obj, $sta) = Compress::Zlib::inflateInit(
    '-WindowBits' => -$BITS,
    '-Bufsize'    => 32768,
    );
  die get_string('ERR_INIT', $sta) unless $sta == $STA_OK;
  $max = 0 unless defined($max) && $max > 0;  ## no critic (Unless)
  *$slf->{'buf'} = q{};
  *$slf->{'ifh'} = $ifh;
  *$slf->{'lgt'} = 0;
  *$slf->{'obj'} = $obj;
  *$slf->{'off'} = $ifh->tell;
  *$slf->{'pos'} = 0;
  *$slf->{'siz'} = *$slf->{'max'} = $max;

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>save($ofh)>

This method saves the area from the current position.

=cut

sub save
{ my ($slf, $ofh) = @_;
  my ($lgt);

  binmode($ofh);
  if ($lgt = *$slf->{'lgt'})
  { $ofh->syswrite(*$slf->{'buf'}, $lgt);
    *$slf->{'pos'} += $lgt;
  }
  while ($lgt = _read_block($slf))
  { $ofh->syswrite(*$slf->{'buf'}, $lgt);
    *$slf->{'pos'} += $lgt;
  }
  *$slf->{'buf'} = q{};
  *$slf->{'lgt'} = 0;
  return $ofh->close;
}

# Manage object attributes
sub setinfo
{ my ($slf, $key, $val) = @_;
  my ($old);

  $old = *$slf->{$key};
  *$slf->{$key} = $val if defined($val);
  return $old;
}

# Declare a routine for an undefined functionality
my $und = sub { return };

=head1 BASIC I/O METHODS

See L<perlfunc|perlfunc> for complete descriptions of each of the following
methods, which are front ends for the corresponding built-in functions:

    $io->close
    $io->eof
    $io->fileno
    $io->getc
    $io->read(BUF,LEN,[OFFSET])
    $io->print(ARGS)
    $io->printf(FMT,[ARGS])
    $io->stat
    $io->sysread(BUF,LEN,[OFFSET])
    $io->syswrite(BUF,[LEN,[OFFSET]])
    $io->truncate(LEN)

=cut

sub close  ## no critic (Ambiguous,Builtin)
{ my ($slf) = @_;

  CORE::seek(*$slf->{'ifh'}, *$slf->{'max'}, 1) if *$slf->{'max'} > 0;
  delete(*$slf->{'buf'});
  *$slf->{'lgt'} = *$slf->{'max'} = 0;
  return 1;
}

sub eof  ## no critic (Builtin)
{ my ($slf) = @_;

  return (*$slf->{'max'} > 0 || *$slf->{'lgt'} > 0) ? 0 : 1;
}

*fileno = $und;

sub getc  ## no critic (Builtin)
{ my ($slf) = @_;
  my $buf;

  return $buf if $slf->read($buf, 1);
  return;
}

*print = $und;
*printf = $und;

sub read  ## no critic (Builtin,Unpack)
{ my ($slf, undef, $siz, $off) = @_;
  my ($inp, $lgt, $out, $sta);

  return 0 unless $siz > 0;  ## no critic (Unless)

  while (*$slf->{'max'} > 0 && *$slf->{'lgt'} < $siz)
  { $lgt = (*$slf->{'max'} < $R_BLK) ? *$slf->{'max'} : $R_BLK;
    last unless  ## no critic (Unless)
      defined($lgt = *$slf->{'ifh'}->read($inp, $lgt)) && $lgt > 0;
    *$slf->{'max'} -= $lgt;
    ($out, $sta) = *$slf->{'obj'}->inflate(\$inp);
    last unless $sta == $STA_OK || $sta == $STA_EOF;
    *$slf->{'buf'} .= $out;
    *$slf->{'lgt'} += length($out);
    if ($sta == $STA_EOF)
    { *$slf->{'max'} = 0;
      last;
    }
  }

  $lgt = ($siz > *$slf->{'lgt'}) ? *$slf->{'lgt'} : $siz;
  if (defined($off))
  { substr($_[1], $off) = substr(*$slf->{'buf'}, 0, $lgt);
  }
  else
  { $_[1] = substr(*$slf->{'buf'}, 0, $lgt);
  }
  *$slf->{'buf'} = substr(*$slf->{'buf'}, $lgt);
  *$slf->{'lgt'} -= $lgt;
  *$slf->{'pos'} += $lgt;
  return $lgt;
}

*stat = $und;
*sysread = \&read;

*syswrite = $und;
*truncate = $und;

=head1 I/O METHODS RELATED TO PERL VARIABLES

See L<perlvar|perlvar> for complete descriptions of each of the following
methods. The methods return the previous value of the attribute and take an
optional single argument that, when given, sets the value. If no argument
is given, then the previous value is unchanged.

    $|    $io-E<gt>autoflush([BOOL])
    $.    $io-E<gt>input_line_number([NUM])

=cut

*autoflush = $und;

sub input_line_number
{ my ($slf, $val) = @_;

  return $slf->setinfo('lin', $val);
}

=head1 IO::HANDLE LIKE METHODS

See L<IO::Handle|IO::Handle> for complete descriptions of each of the following
methods:

    $io->blocking([BOOL])
    $io->clearerr
    $io->error
    $io->flush
    $io->getline
    $io->getlines
    $io->opened
    $io->printflush(ARGS)
    $io->sync
    $io->ungetc(ORD)
    $io->untaint
    $io->write(BUF,LEN[,OFFSET])

=cut

sub blocking
{ return 1;
}

*clearerr = $und;
*error = $und;
*fcntl = $und;
*flush = $und;

sub getline
{ my ($slf) = @_;
  my ($eol, $lgt, $lin, $str);

  return unless *$slf->{'max'} > 0 || *$slf->{'lgt'} > 0;  ## no critic (Unless)
  unless (defined($/))  # No line separator defined
  { $str = *$slf->{'buf'};
    *$slf->{'pos'} += *$slf->{'lgt'};
    while ($lgt = _read_block($slf))
    { $str .= *$slf->{'buf'};
      *$slf->{'pos'} += *$slf->{'lgt'};
    }
    *$slf->{'buf'} = q{};
    *$slf->{'lgt'} = *$slf->{'max'} = 0;
    return $str;
  }
  if (length($/))   # Line mode
  { return unless defined($str = _read_line($slf, $/));
    $. = ++*$slf->{'lin'};
  }
  else                  # Paragraph mode
  { return unless defined($str = _read_line($slf, qq{\n}));
    $eol = 0;
    while (defined($lin = _read_line($slf, qq{\n})))
    { if ($lin eq qq{\n})
      { $eol++;
        next if $eol > 1;
      }
      elsif ($eol)
      { $lgt = length($lin);
        *$slf->{'buf'} = $lin.*$slf->{'buf'};
        *$slf->{'lgt'} += $lgt;
        *$slf->{'pos'} -= $lgt;
        last;
      }
      else
      { $eol = 0;
      }
      $str .= $lin;
    }
  }
  unless (*$slf->{'eol'})
  { chomp($str);
    $str =~ s/[\n\r\s]+$//;
  }
  return $str;
}

sub _read_block
{ my ($slf) = @_;
  my ($inp, $lgt, $out, $sta);

  $lgt = (*$slf->{'max'} < $R_BLK) ? *$slf->{'max'} : $R_BLK;
  if ($lgt > 0 && defined($lgt = *$slf->{'ifh'}->read($inp, $lgt)) && $lgt > 0)
  { *$slf->{'max'} -= $lgt;
    ($out, $sta) = *$slf->{'obj'}->inflate(\$inp);
    if ($sta == $STA_OK || $sta == $STA_EOF)
    { *$slf->{'max'} = 0 if $sta == $STA_EOF;
      return *$slf->{'lgt'} = length(*$slf->{'buf'} = $out);
    }
  }
  *$slf->{'buf'} = q{};
  return *$slf->{'lgt'} = 0;
}

sub _read_line
{ my ($slf, $eol) = @_;
  my ($buf, $cor, $lgt, $off);

  # Check if the line is in the current block
  $cor = length($eol);
  if (($off = index($buf = *$slf->{'buf'}, $eol)) >= 0)
  { $off += $cor;
    *$slf->{'buf'} = substr($buf, $off);
    *$slf->{'lgt'} -= $off;
    *$slf->{'pos'} += $off;
    return substr($buf, 0, $off);
  }

  # Extract an overlapping line
  $lgt = *$slf->{'lgt'};
  while (_read_block($slf))
  { $buf .= *$slf->{'buf'};
    if (($off = index($buf, $eol, ($lgt < $cor) ? 0 : $lgt - $cor)) >= 0)
    { $off += $cor;
      *$slf->{'buf'} = substr(*$slf->{'buf'}, $cor = $off - $lgt);
      *$slf->{'lgt'} -= $cor;
      *$slf->{'pos'} += $off;
      return substr($buf, 0, $off);
    }
    $lgt += *$slf->{'lgt'};
  }

  # Accept uncomplete last line
  *$slf->{'pos'} += $lgt;
  return $buf;
}

sub getlines
{ my ($slf) = @_;
  my ($lin, @tbl);

  die get_string('BAD_GETLINES') unless wantarray;
  push(@tbl, $lin) while defined($lin = $slf->getline);
  return @tbl;
}

*ioctl = $und;

sub opened
{ return 1;
}

*printflush = $und;
*setbuf = $und;
*setvbuf = $und;
*sync = $und;
*ungetc = $und;
*untaint = $und;
*write = $und;

=head1 SEEK METHODS

See L<IO::Seekable|IO::Seekable> for complete descriptions of each of the
following methods:

    $io->getpos
    $io->setpos($pos)
    $io->seek($pos,$whence)
    $io->sysseek($pos,$whence)
    $io->tell

=cut

sub getpos
{ my ($slf) = @_;

  return *$slf->{'pos'};
}

sub seek  ## no critic (Builtin)
{ my ($slf, $off, $typ) = @_;
  my ($buf, $inp, $lgt, $obj, $out, $siz, $sta);

  if ($typ == 0)
  { $siz = $off - *$slf->{'pos'};
  }
  elsif ($typ == 1)
  { $siz = $off;
  }
  else
  { die get_string('BAD_WHENCE', $typ);
  }

  # Return at the beginning
  if ($siz < 0)
  { $siz += *$slf->{'pos'};
    $siz = 0 if $siz < 0;

    # Adjust the position in the upper stream
    return 0 unless defined(*$slf->{'ifh'}->seek(*$slf->{'off'}, 0));

    # Initialize the deflated area
    ($obj, $sta) = Compress::Zlib::inflateInit(
      '-WindowBits' => -$BITS,
      '-Bufsize'    => 32768,
      );
    die get_string('ERR_INIT', $sta) unless $sta == $STA_OK;

    # Reset the handle
    *$slf->{'buf'} = q{};
    *$slf->{'lgt'} = 0;
    *$slf->{'max'} = *$slf->{'siz'};
    *$slf->{'obj'} = $obj;
    *$slf->{'pos'} = 0;
  }

  # Use buffer data
  $lgt = ($siz > *$slf->{'lgt'}) ? *$slf->{'lgt'} : $siz;
  $siz -= $lgt;
  *$slf->{'buf'} = substr(*$slf->{'buf'}, $lgt);
  *$slf->{'lgt'} -= $lgt;
  *$slf->{'pos'} += $lgt;

  # Read additionnal data
  for (; $siz > 0 && *$slf->{'max'} > 0         ## no critic (Loop)
       ; $siz -= $lgt, *$slf->{'pos'} += $lgt)  ## no critic (Comma)
  { $lgt = (*$slf->{'max'} < $S_BLK) ? *$slf->{'max'} : $S_BLK;
    return 0 unless  ## no critic (Unless)
      defined($lgt = *$slf->{'ifh'}->read($inp, $lgt)) && $lgt > 0;
    *$slf->{'max'} -= $lgt;
    ($out, $sta) = *$slf->{'obj'}->inflate(\$inp);
    unless ($sta == $STA_OK)
    { *$slf->{'max'} = 0;
      $lgt = ($sta == $STA_EOF) ? length($out) : 0;
      if ($lgt < $siz)
      { *$slf->{'pos'} += $lgt;
        return 0;
      }
      $lgt -= $siz;
      *$slf->{'buf'} = substr($out, $siz);
      *$slf->{'lgt'} = $lgt;
      *$slf->{'pos'} += $siz;
      last;
    }
    $lgt = length($out);
    if ($siz < $lgt)
    { $lgt -= $siz;
      *$slf->{'buf'} = substr($out, $siz);
      *$slf->{'lgt'} = $lgt;
      *$slf->{'pos'} += $siz;
      last;
    }
  }
  return 1;
}

sub setpos
{ return 0;
}

*sysseek = \&seek;
*tell = \&getpos;

=head1 OTHER I/O METHODS

=head2 S<$h-E<gt>dump([$level[,$text[,$trace]]])>

This method returns a string containing the object dump. You can provide an
indentation level, a prefix text, and a trace indicator as extra parameters.

=cut

sub dump  ## no critic (Builtin)
{ my ($slf, $lvl, $txt) = @_;
  my ($buf, $pre);

  $lvl = 0 unless defined($lvl);
  $pre = q{  } x $lvl;
  $buf = $pre.$txt."bless {\n";
  foreach my $key (sort keys(%{*$slf}))
  { if ($key eq 'buf')
    { $buf .=  "$pre  $key => '...'\n";
    }
    elsif ($key !~ m/ifh|obj/)
    { $buf .= "$pre  $key => ".*$slf->{$key}.qq{\n};
    }
  }
  $buf .=  "$pre}, RDA::Handle::Deflate";
  return $buf;
}

=head1 TIE METHODS

The following methods are implemented to emulate a file handle:

    BINMODE this
    CLOSE this
    DESTROY this
    EOF this
    FILENO this
    GETC this
    OPEN this, mode, LIST
    PRINT this, LIST
    PRINTF this, format, LIST
    READ this, scalar, length, offset
    READLINE this
    SEEK this, position, whence
    TELL this
    TIEHANDLE classname, LIST
    WRITE this, scalar, length, offset

=cut

sub BINMODE
{ my ($slf, @arg) = shift;

  return (@arg) ? 0 : 1;
}

*CLOSE = \&close;

sub DESTROY
{
}

*EOF = \&eof;
*FILENO = $und;
*GETC = \&getc;
*OPEN = \&open;
*PRINT = $und;
*PRINTF = $und;
*READ = \&read;

sub READLINE
{ goto &getlines if wantarray;
  goto &getline;
}

*SEEK = \&seek;
*TELL = \&getpos;

sub TIEHANDLE
{ my $slf = shift;

  return ref($slf) ? $slf : $slf->new(@_);
}

*WRITE = $und;

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut