# Vector.pm: Class Used for Managing Vectored Data

package RDA::Handle::Vector;

# $Id: Vector.pm,v 1.4 2015/11/09 18:38:44 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Handle/Vector.pm,v 1.4 2015/11/09 18:38:44 RDA Exp $
#
# Change History
# 20151109  MSC  Improve the read method.

=head1 NAME

RDA::Handle::Vector - Class Used for Managing Vectored Data

=head1 SYNOPSIS

 require RDA::Handle::Vector;

=head1 DESCRIPTION

The objects of the C<RDA::Handle::Vector> class are used for managing lines in
an array.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use Symbol;
  use RDA::Text qw(get_string);
  use RDA::Handle::Memory;
  use RDA::Object::Message;
}

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

# Define the global private constants

# Define the global private variables

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

=head2 S<$h = RDA::Handle::Vector-E<gt>new([$data[,$dft]])>

The object constructor.

C<RDA::Handle::Vector> 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' > > Line array

=item S<    B<'eol' > > End of line (for read operations)

=item S<    B<'lgt' > > Line array length

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

=item S<    B<'pad' > > Padding line

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

=back

You can specify a string or a string reference as an argument.

=cut

sub new
{ my ($cls, $dat, $dft) = @_;
  my ($slf, $ref);

  # Treat message data
  $ref = ref($dat);
  $dat = ($ref eq 'RDA::Object::Message') ? $dat->get_data :
         ($ref eq 'RDA::Value::Array')    ? $dat->as_data :
                                            $dat;

  # Create the handle object
  if (defined($dat) || defined($dat = $dft))
  { if (ref($dat) eq 'ARRAY')
    { $slf = bless Symbol::gensym(), ref($cls) || $cls;
      tie *$slf, $slf;  ## no critic (Tie)
      $slf->open($dat);
    }
    else
    { $slf = RDA::Handle::Memory->new($dat);
      $slf->setinfo('eol', 0);
    }
  }

  # Return the handle reference
  return $slf;
}

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

  # Create the handle when not yet done
  return $slf->new($dat) unless ref($slf);

  # Create the line buffer
  *$slf->{'buf'} = (ref($dat) eq 'ARRAY') ? $dat :
                    defined($dat)         ? [$dat] :
                                            [];
  *$slf->{'eol'} = qq{\n};
  *$slf->{'lgt'} = scalar @{*$slf->{'buf'}};
  *$slf->{'pad'} = q{};
  *$slf->{'pos'} = 0;
  delete(*$slf->{'lin'});

  # Return the handle reference
  return $slf;
}

# Manage handle 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 just 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) = @_;

  delete *$slf->{'buf'};
  delete *$slf->{'eol'};
  delete *$slf->{'lgt'};
  delete *$slf->{'lin'};
  delete *$slf->{'pad'};
  delete *$slf->{'pos'};
  undef *$slf;
  return 1;
}

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

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

*fileno = $und;

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

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

sub read  ## no critic (Builtin,Unpack)
{ my ($slf, undef, $lgt, $off) = @_;
  my ($lin, $max);

  if (exists(*$slf->{'lin'}))
  { $lin = delete(*$slf->{'lin'});
  }
  else
  { return unless *$slf->{'buf'} &&  ## no critic (Unless)
      *$slf->{'pos'} < *$slf->{'lgt'};
    $lin = *$slf->{'buf'}->[*$slf->{'pos'}++].*$slf->{'eol'};
  }
  $max = length($lin);
  while ($max < $lgt && *$slf->{'pos'} < *$slf->{'lgt'})
  { $lin .= *$slf->{'buf'}->[*$slf->{'pos'}++].*$slf->{'eol'};
    $max = length($lin);
  }
  if ($lgt < $max)
  { *$slf->{'lin'} = substr($lin, $lgt);
  }
  else
  { $lgt = $max;
  }
  if ($off)
  { substr($_[1], $off) = substr($lin, 0, $lgt);
  }
  else
  { $_[1] = substr($lin, 0, $lgt);
  }
  return $lgt;
}

sub print  ## no critic (Builtin)
{ my $slf = shift;

  $slf->write(join((defined($,) ? $, : q{}), @_).(defined($,) ? $, : q{}));
  return 1;
}

sub printf  ## no critic (Builtin)
{ my $slf = shift;
  my $fmt = shift;

  $slf->write(sprintf($fmt, @_));
  return 1;
}

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

  return unless $slf->opened;
  return 1 unless wantarray;
  ## no critic (Number,Zero)
  return (undef,          # device
          undef,          # inode
          0666,           # filemode
          1,              # links
          $>,             # user identidier
          $),             # group identidier
          undef,          # device identidier
          *$slf->{'lgt'}, # size
          undef,          # atime
          undef,          # mtime
          undef,          # ctime
          512,            # block size
          *$slf->{'lgt'}, # blocks
         );
}

*sysread = \&read;

sub syswrite  ## no critic (Builtin)
{ my ($slf, $str, $lgt, $off) = @_;
  my ($buf, $pos, @lin);

  if (ref($str) eq 'ARRAY')
  { @lin = @{$str};
  }
  elsif (defined($str))
  { @lin = split(/\n/, $str, -1);
  }
  if ($off || $lgt)
  { $lgt = scalar @lin unless defined($lgt);
    $off = 0           unless defined($off);
    @lin = splice(@lin, $off, $lgt);
  }
  $lgt = scalar @lin;

  $buf = *$slf->{'buf'};
  $pos = *$slf->{'pos'};
  splice(@{$buf}, $pos, $lgt, @lin);
  *$slf->{'pos'} += $lgt;
  *$slf->{'lgt'} = scalar @{$buf};
  delete(*$slf->{'lin'});
  return $lgt;
}

sub truncate  ## no critic (Builtin)
{ my ($slf, $lgt) = @_;
  my ($buf, $cnt);

  $buf = *$slf->{'buf'};
  $lgt = 0 unless defined($lgt);
  $cnt = $lgt - *$slf->{'lgt'};
  if ($cnt > 0)
  { push(@{$buf}, *$slf->{'pad'}) while $cnt-- > 0;
  }
  else
  { pop(@{$buf}) while $cnt++ < 0;
  }
  *$slf->{'pos'} = $lgt if *$slf->{'pos'} > $lgt;
  *$slf->{'lgt'} = $lgt;
  delete(*$slf->{'lin'});
  return 1;
}

=head1 I/O METHODS RELATED TO PERL VARIABLES

See L<perlvar|perlvar> for complete descriptions of each of the following
methods. All of them return the previous value of the attribute and takes an
optional single argument that when given will set the value. If no argument
is given 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('pos', $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

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

sub getline
{ my $slf = shift;
  my ($buf, $lgt, $pos);

  if (exists(*$slf->{'lin'}))
  { $buf = delete(*$slf->{'lin'});
    $buf =~ s/\n$//;
    return $buf;
  }

  $buf = *$slf->{'buf'};
  return unless $buf;
  $lgt = *$slf->{'lgt'};
  $pos = *$slf->{'pos'};
  return if $pos >= $lgt;

  unless (defined($/))  # No line separator defined
  { *$slf->{'pos'} = $lgt--;
    return join(q{ }, $buf->[$pos..$lgt]);
  }
  unless (length($/))   # Paragraph mode
  { my ($eol, $lin, @buf);

    $eol = 0;
    while ($pos < $lgt)
    { $lin = $buf->[$pos++];
      if ($lin eq q{})
      { $eol++;
      }
      elsif ($eol)
      { --$pos;
        last;
      }
      else
      { push(@buf, $lin);
      }
    }
    *$slf->{'pos'} = $pos;
    return join(q{ }, @buf);
  }
  return $buf->[*$slf->{'pos'}++];
}

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
{ my ($slf) = @_;

  return defined(*$slf->{'buf'});
}

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

=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, $lgt, $pos);

  $buf = *$slf->{'buf'};
  return 0 unless $buf;
  $pos = *$slf->{'pos'};
  $lgt = *$slf->{'lgt'};

  if ($typ == 0)
  { $pos = $off;
  }
  elsif ($typ == 1)
  { $pos += $off;
  }
  elsif ($typ == 2)
  { $pos = $lgt + $off;
  }
  else
  { die get_string('BAD_WHENCE', $typ);
  }

  $pos = 0 if $pos < 0;
  $slf->truncate($pos) if $pos > $lgt;
  *$slf->{'pos'} = $pos;
  delete(*$slf->{'lin'});
  return 1;
}

sub setpos
{ my ($slf, $pos) = @_;
  my ($lgt);

  return unless defined($pos) && *$slf->{'buf'};
  $lgt = *$slf->{'lgt'} || 0;
  *$slf->{'pos'} = ($pos < 0) ? 0 : ($pos > $lgt) ? $lgt : $pos;
  delete(*$slf->{'lin'});
  return 1;
}

*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 eq 'eol')
    { $buf .= "$pre  $key => "
        .join(q{ }, unpack('H2' x length(*$slf->{$key}), *$slf->{$key}))."\n";
    }
    elsif ($key eq 'pad')
    { $buf .= "$pre  $key => '".*$slf->{$key}."'\n";
    }
    else
    { $buf .= "$pre  $key => ".*$slf->{$key}.qq{\n};
    }
  }
  $buf .=  "$pre}, RDA::Handle::Vector";
  return $buf;
}

=head2 S<$io-E<gt>getbuf>

This method returns the buffer content.

=cut

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

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

=head2 S<$io-E<gt>pad([$line])>

This method manages the padding line. It returns the previous value of
the attribute and takes an optional single argument that when given will set
the value. If no argument is given the previous value is unchanged.

=cut

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

  $pad =~ s/[\n\r]+$// if defined($pad);
  return $slf->setinfo('pad', $pad);
}

=head1 TIE METHODS

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 = shift;

  return (@_) ? 0 : 1;
}

*CLOSE = \&close;

sub DESTROY
{
}

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

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

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

sub TIEHANDLE
{ my $slf = shift;

  unless (ref($slf))
  { $slf = bless Symbol::gensym(), $slf;
    $slf->open(@_);
  }
  return $slf;
}

*WRITE = \&syswrite;

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Object::Message|RDA::Object::Message>,
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