package RDA::Object::Buffer;

# $Id: Buffer.pm,v 1.10 2008/02/25 14:55:26 mschenke Exp $
# ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/lib/RDA/Object/Buffer.pm,v 1.10 2008/02/25 14:55:26 mschenke Exp $
#
# Change History
# 20080225  MSC  Change the copyright notice.

=head1 NAME

RDA::Object::Buffer - Class Used for Objects to Manage Memory Files.

=head1 SYNOPSIS

require RDA::Object::Buffer;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Buffer> class are used to manage memory
files.

The following methods are available:

=cut

BEGIN
{ use Exporter;
  use Symbol;
}

use strict;

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Object::Buffer-E<gt>new([$str])>

The object constructor.

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

=over 16

=item B<    '-blk'     > Blocking indicator

=item B<    '-buf'     > String buffer

=item B<    '-lin'     > Line number

=item B<    '-lgt'     > String buffer length

=item B<    '-min'     > Lower limit of a circular buffer

=item B<    '-max'     > Higher limit of a circular buffer

=item B<    '-pad'     > Padding character

=item B<    '-pos'     > Current position in the string buffer

=back

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

=cut

sub new
{ my $cls = shift;

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

  # Return the object reference
  $slf;
}

sub open
{ my $slf = shift;

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

  # Create the string buffer
  if (@_)
  { my $ref = ref($_[0]) ? $_[0] : \$_[0];
    $$ref = '' unless defined $$ref;
    *$slf->{'-buf'} = $ref;
  }
  else
  { my $buf = '';
    *$slf->{'-buf'} = \$buf;
  }

  # Define other object attributes
  *$slf->{'-blk'} = 0;
  *$slf->{'-lin'} = 0;
  *$slf->{'-lgt'} = length(${*$slf->{'-buf'}});
  *$slf->{'-pad'} = "\0";
  *$slf->{'-pos'} = 0;

  # Return the object reference
  $slf;
}

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

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

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

=head1 BASIC I/O METHODS

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

  delete *$slf->{'-blk'};
  delete *$slf->{'-buf'};
  delete *$slf->{'-lgt'};
  delete *$slf->{'-lin'};
  delete *$slf->{'-min'};
  delete *$slf->{'-max'};
  delete *$slf->{'-pad'};
  delete *$slf->{'-pos'};
  undef *$slf;
  1;
}

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

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

*fileno = $und;

sub getc
{ my ($slf) = @_;
  my $buf;

  $slf->read($buf, 1) ? $buf : undef;
}

sub read
{ my ($slf, undef, $lgt, $off) = @_;
  my ($buf, $max, $pos);

  $buf = *$slf->{'-buf'};
  return undef unless $buf;
  $off = 0 unless defined($off);
  $pos = *$slf->{'-pos'};
  if (exists(*$slf->{'-max'}))
  { $max = *$slf->{'-max'} - $pos;
    if ($lgt > $max)
    { return (defined(read($slf, $_[1], $max, $off)) &&
        seek($slf, *$slf->{'-min'}, 0) &&
        defined(read($slf, $_[1], $lgt - $max, $off + $max))) ? $lgt : undef;
    }
  }
  else
  { $max = *$slf->{'-lgt'} - $pos;
    $lgt = $max if $lgt > $max;
  }
  return undef if $lgt < 0;
  if ($off)
  { substr($_[1], $off) = substr($$buf, $pos, $lgt);
  }
  else
  { $_[1] = substr($$buf, $pos, $lgt);
  }
  *$slf->{'-pos'} += $lgt;
  return $lgt;
}

sub print
{ my $slf = shift;

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

sub printf
{ my $slf = shift;
  my $fmt = shift;

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

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

  return undef unless $slf->opened;
  return 1 unless wantarray;
  ( 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
    int((*$slf->{'-lgt'} + 511) / 512) # blocks
  );
}

*sysread = \&read;

sub syswrite
{ my ($slf, $str, $max, $off) = @_;
  my ($buf, $lgt, $pos);

  $buf = *$slf->{'-buf'};
  return undef unless $buf;
  $pos  = *$slf->{'-pos'};
  $lgt = length($str);
  $off = 0 unless defined($off);
  if ($off)
  { die "Offset outside string" if $off > $lgt;
    if ($off < 0)
    { $off += $lgt;
      die "Offset outside string" if $off < 0;
    }
    my $lgt -= $off;
  }
  $lgt = $max if defined($max) && $max < $lgt;
  substr($$buf, $pos, $lgt) = substr($str, $off, $lgt);
  *$slf->{'-pos'} += $lgt;
  *$slf->{'-lgt'} = length($$buf);
  return $lgt;
}

sub truncate
{ my ($slf, $lgt) = @_;
  my ($buf);

  $buf = *$slf->{'-buf'};
  $lgt = 0 unless defined($lgt);
  if (*$slf->{'-lgt'} < $lgt)
  { $$buf .= (*$slf->{'-pad'} x ($lgt - *$slf->{'-lgt'}));
  }
  else
  { substr($$buf, $lgt) = '';
    *$slf->{'-pos'} = $lgt if $lgt < *$slf->{'-pos'};
  }
  *$slf->{'-lgt'} = $lgt;
  1;
}

=head1 I/O METHODS RELATED TO PERL VARIABLES

See C<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) = @_;

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

=head1 IO::HANDLE LIKE METHOS

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

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

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

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

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

  unless (defined($/))  # No line separator defined
  { *$slf->{'-pos'} = $lgt;
    return substr($$buf, $pos);
  }
  unless (length($/))   # Paragraph mode
  { my ($chr, $eol, $str);
    $str = '';
    $eol = 0;
    while (defined($chr = $slf->getc))
    { if ($chr eq "\n")
      { $eol++;
        next if $eol > 2;
      }
      elsif ($eol > 1)
      { $slf->ungetc($chr);
        last;
      }
      else
      { $eol = 0;
      }
      $str .= $chr;
    }
    return $str;
  }
  my $off = index($$buf, $/, $pos);
  $. = ++*$slf->{'-lin'};
  if ($off < 0)
  { *$slf->{'-pos'} = $lgt;
    return substr($$buf, $pos);
  }
  $lgt = $off - $pos + length($/);
  *$slf->{'-pos'} += $lgt;
  return substr($$buf, $pos, $lgt);
}

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

  die "getlines() called in a scalar context\n" unless wantarray;
  push(@tbl, $lin) while defined($lin = $slf->getline);
  @tbl;
}

*ioctl = $und;

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

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

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

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

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

*untaint = $und;
*write = \&syswrite;

=head1 SEEK METHODS

See 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) = @_;

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

sub seek
{ my ($slf, $off, $typ) = @_;
  my ($buf, $flg, $min, $max, $pos);

  $buf = *$slf->{'-buf'};
  return 0 unless $buf;
  $pos = *$slf->{'-pos'};
  $max = ($flg = exists(*$slf->{'-max'})) ? *$slf->{'-max'} : *$slf->{'-lgt'};

  if ($typ == 0)
  { $pos = $off;
  }
  elsif ($typ == 1)
  { $pos += $off;
  }
  elsif ($typ == 2)
  { $pos = $max + $off;
  }
  else
  { die "Bad whence ($typ)";
  }

  if ($flg)
  { $min = *$slf->{'-min'};
    $pos = $pos + $max - $min while $pos < $min;
    $pos = $pos - $max + $min while $pos > $max;
  }
  else
  { $pos = 0 while $pos < 0;
    $slf->truncate($pos) if $pos > $max;
  }
  *$slf->{'-pos'} = $pos;
  return 1;
}

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

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

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

=head1 OTHER I/O METHODS

=head2 $io->clrlim

This method clears the limits of the circular buffer.

=cut

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

  delete *$slf->{'-max'};
  delete *$slf->{'-min'};
  1;
}

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

This method dumps a buffer. It returns a reference to the buffer object.

=cut

sub dump
{ my $slf = shift;
  my $lvl = shift || 0;
  my ($pre, $ref);

  $pre = '  ' x $lvl;
  print $pre."bless {\n";
  foreach my $key (sort keys(%{*$slf}))
  { if ($key eq '-buf')
    { print "$pre  $key => '...'\n";
    }
    elsif ($key eq '-blk')
    { printf("$pre  $key => 0x%02x\n", *$slf->{$key});
    }
    elsif ($key eq '-pad')
    { printf("$pre  $key => 0x%02x\n", ord(*$slf->{$key}));
    }
    else
    { printf("$pre  $key => 0x%08x\n", *$slf->{$key});
    }
  }
  print "$pre}, RDA::Object::Buffer\n";
  $slf;
}

=head2 $io->getbuf

This method returns the buffer content.

=cut

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

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

=head2 $io->pad([$chr])

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

=cut

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

  $slf->setinfo('-pad', $pad ? substr($pad, 0, 1) : undef);
}

=head2 $io->setlim([$min[,$max]])

This method specifies the buffer area that will be used circularly.

=cut

sub setlim
{ my ($slf, $min, $max) = @_;

  # Resolve default limits
  $max = *$slf->{'-lgt'} unless defined($max);
  $min = 0 unless defined($min);

  # Assign the limits when a valid range is specified
  if ($min < $max)
  { *$slf->{'-max'} = $max;
    *$slf->{'-min'} = $min;
    *$slf->{'-pos'} = $min if *$slf->{'-pos'} < $min || *$slf->{'-max'} >= $max;
    return 1;
  }

  # Indicate an invalid range
  0;
}

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

  (@_) ? 0 : 1;
}

*CLOSE = \&close;

sub DESTROY
{
}

*EOF = \&eof;

sub FILENO
{ return undef;
}

*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(@_);
  }
  $slf;
}

*WRITE = \&syswrite;

1;

__END__

=head1 SEE ALSO

See also L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Value|RDA::Value>,
L<RDA::Object::Data|RDA::Object::Data>,
L<RDA::Object::Html|RDA::Object::Html>,
L<RDA::Object::Parser|RDA::Object::Parser>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Response|RDA::Object::Response>,
L<RDA::Object::Sgml|RDA::Object::Sgml>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Macro::Buffer|RDA::Macro::Buffer>.

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2008, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut