# Tie.pm: Class Used to Tie Perl Handles

package RDA::Handle::Tie;

# $Id: Tie.pm,v 1.5 2015/07/09 17:30:26 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Handle/Tie.pm,v 1.5 2015/07/09 17:30:26 RDA Exp $
#
# Change History
# 20150709  MSC  Improve syswrite return value.

=head1 NAME

RDA::Handle::Tie - Class Used to Tie Perl Handles

=head1 SYNOPSIS

 require RDA::Handle::Tie;

=head1 DESCRIPTION

The objects of the C<RDA::Handle::Tie> class are used to tie Perl handles. It
is limited to the data treated by the Perl layer.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use IO::Handle;
  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.5 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants

# Define the global private variables
my $und = sub { return };

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

=head2 S<$h = RDA::Handle::Tie-E<gt>new($out...)>

The object constructor. It takes list of output destinations as arguments.

C<RDA::Handle::Tie> is represented by a blessed array reference.

=cut

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

  # Create the buffer object
  my $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 = shift;

  # Create the object when not yet done
  return $slf->new(@_) unless ref($slf);

  # Assign the outout handles
  @{*$slf} = map {
    (!ref($_))           ? IO::File->new($_) :
    (ref($_) eq 'ARRAY') ? IO::File->new(@{$_}) :
    (ref($_) eq 'GLOB')  ? bless $_, 'IO::Handle' :
                           $_ or return} @_;

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>get_handles>

This method returns a list of all associated handles.

=cut

sub get_handles
{ my $slf = shift;

  return @{*$slf};
}

# Modify all output file handles
sub _alter
{ my ($met, $slf, @arg) = @_;

  foreach my $ofh (@{*$slf})
  { $ofh->$met(@arg);
  }
  return;
}

# Execute an action on all output file handles
sub _exec
{ my ($met, $slf, @arg) = @_;
  my ($ret, @ret);

  foreach my $ofh (@{*$slf})
  { if ($ret = $ofh->$met(@arg))
    { push(@ret, $ret);
    }
    else
    { unshift(@ret, 0);
    }
  }
  return @ret ? $ret[0] : 1;
}

=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)
{ return _exec('close', @_);
}

*eof    = $und;
*fileno = $und;
*getc   = $und;
*read   = $und;

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

  my $buf = join((defined($,) ? $, : q{}), @_).(defined($,) ? $, : q{});
  return $slf->syswrite($buf, length($buf));
}

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

  my $buf = sprintf($fmt, @_);
  return $slf->syswrite($buf, length($buf));
}

*stat    = $und;
*sysread = $und;

sub syswrite  ## no critic (Builtin)
{ return _exec('syswrite', @_);
}

*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

sub autoflush
{ return _alter('autoflush', @_);
}

*input_line_number = $und;

sub output_field_separator
{ return _alter('output_field_separator', @_);
}

sub output_record_separator
{ return _alter('output_record_separator', @_);
}

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

sub clearerr
{ return _exec('clearerr', @_);
}

*error = $und;

sub fcntl  ## no critic (Builtin)
{ return _exec('fcntl', @_);
}

sub flush
{ return _exec('flush', @_);
}

*getline = $und;
*getlines = $und;

sub ioctl  ## no critic (Builtin)
{ return _exec('ioctl', @_);
}

sub opened
{ return 1;
}

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

sub write  ## no critic (Builtin)
{ return _exec('write', @_);
}

=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

*getpos = $und;
*seek = $und;
*setpos = $und;
*sysseek = $und;
*tell = $und;

=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
{ return _alter('binmode', @_);
}

*CLOSE = \&close;

sub DESTROY
{
}

*EOF = $und;
*FILENO = $und;
*GETC = $und;
*OPEN = \&open;
*PRINT = \&print;
*PRINTF = \&printf;
*READ = $und;
*READLINE = $und;
*SEEK = $und;
*TELL = $und;

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::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