# Message.pm: Class Used for Managing RDA Messages

package RDA::Object::Message;

# $Id: Message.pm,v 1.20 2015/09/25 07:15:32 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Message.pm,v 1.20 2015/09/25 07:15:32 RDA Exp $
#
# Change History
# 20150924  MSC  Control trailing space removal.

=head1 NAME

RDA::Object::Message - Class Used for Managing RDA Messages

=head1 SYNOPSIS

 require RDA::Object::Message;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Message> class are used to manage RDA
messages. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use IO::Handle;
  use RDA::Text qw(get_string);
  use RDA::Error;
  use RDA::Object;
  use RDA::Object::Rda qw($CREATE $FIL_PERMS);
}

# Define the global public variables
use vars qw($DUMP $STRINGS $VERSION @ISA %SDCL);
$DUMP    = 0;
$VERSION = sprintf('%d.%02d', q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Error RDA::Object Exporter);
%SDCL    = (
  inc => [qw(RDA::Error RDA::Object)],
  met => {
    'add_blocks'   => {ret => 0},
    'add_data'     => {ret => 0},
    'add_env'      => {ret => 0},
    'add_file'     => {ret => 0},
    'add_lines'    => {ret => 0},
    'add_value'    => {ret => 0},
    'attach_file'  => {ret => 0},
    'clear'        => {ret => 0},
    'error'        => {ret => 0},
    'get_data'     => {ret => 0},
    'get_first'    => {ret => 0},
    'get_id'       => {ret => 0},
    'get_request'  => {ret => 0},
    'get_results'  => {ret => 0},
    'get_status'   => {ret => 1},
    'get_value'    => {ret => 1},
    'grep'         => {ret => 1},
    'has_data'     => {ret => 0},
    'has_request'  => {ret => 0},
    'has_results'  => {ret => 0},
    'is_defined'   => {ret => 0},
    'is_error'     => {ret => 0},
    'is_info'      => {ret => 0},
    'is_success'   => {ret => 0},
    'pop_id'       => {ret => 0},
    'reply'        => {ret => 0},
    'save_data'    => {ret => 0},
    'set_info'     => {ret => 0},
    'set_request'  => {ret => 0},
    'set_response' => {ret => 0},
    'set_results'  => {ret => 0},
    'set_value'    => {ret => 0},
    },
  new => 1,
  );

# Define the global private constants
my $EOD = q{___End_of_Data___};
my $EOL = qq{\015\012};

my $DUMP_FMT = q{%s %s %s %s  } x 4;
my $DUMP_MSK = q{a2} x 16;
my $DUMP_SPC = q{  } x 15;

# Define the global private variables
my %tb_msk = map {$_ => 1} qw(authentication password _save);

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

=head2 S<$h = RDA::Object::Message-E<gt>new($message[,key=>value,...])>

The request constructor. This method enables you to specify the message string
and initial attributes.

=head2 S<$h-E<gt>new($message[,key=>value,...])>

The response constructor. This method enables you to specify the message string
and initial attributes.

C<RDA::Object::Message> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'att' > > Message attributes

=item S<    B<'arg' > > Data function argument lists

=item S<    B<'dat' > > Data or data function reference

=item S<    B<'err' > > Error buffer

=item S<    B<'fil' > > File to be added to the response

=item S<    B<'ids' > > Request identifier list

=item S<    B<'msg' > > Message text

=item S<    B<'req' > > Reference to a request item

=item S<    B<'res' > > Reference to a result item

=item S<    B<'rsp' > > Response attributes

=item S<    B<'typ' > > Message type (REQ or RSP)

=back

Internal keys are prefixed by an underscore.

When the key string is a name between parentheses, the value is split in
multiple lines after removing training spaces, carriage returns and line feeds.

=cut

sub new
{ my ($cls, $msg, @arg) = @_;
  my ($key, $slf, $val);

  # Validate the message
  die get_string('BAD_CMD', $msg) unless $msg && $msg =~ m/^\w+\.\w+$/;

  # Create the message object
  if ($val = ref($cls))
  { $slf = bless {
      ids => $cls->{'ids'},
      msg => $msg,
      typ => 'RSP',
      }, $val;
    $slf->{'att'} = $cls->{'rsp'} if exists($cls->{'rsp'});
    $slf->{'err'} = $cls->{'err'} if exists($cls->{'err'});
    $slf->{'res'} = $cls->{'res'} if exists($cls->{'res'});
    $slf->add_file(@{$cls->{'fil'}}) if ref($cls->{'fil'}) eq 'ARRAY';
  }
  else
  { $slf = bless {
      ids => [],
      msg => $msg,
      typ => 'REQ',
      }, $cls;
  }

  # Add the optional attributes
  while (($key, $val) = splice(@arg, 0, 2))
  { next unless $key && defined($val);
    if ($key =~ m/^\((\w+)\)$/)
    { $slf->{'att'}->{$1} = $key = [];
      $val = [$val] unless ref($val) eq 'ARRAY';
      foreach my $itm (@{$val})
      { foreach my $lin (split(/\n/, $itm))
        { $lin =~ s/[\r\s]+$//;
          push(@{$key}, $lin);
        }
      }
    }
    elsif ($key !~ m/\W/)
    { $slf->{'att'}->{$key} = $val;
    }
  }

  # Return the object reference
  return $slf;
}

# Special constructor used when reading incoming messages
sub new_msg
{ my ($cls, $typ, $ids, $msg) = @_;

  return bless {
    ids => [split(/\//, $ids)],
    msg => $msg,
    typ => $typ,
    }, $cls;
}

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

This method returns the message as a string.

=cut

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

  return $slf->{'typ'}.q{(}.$slf->get_id.'):'.$slf->{'msg'};
}

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

This method clones a message.

=cut

sub clone
{ my ($src) = @_;
  my ($dst, $ref, $val);

  $dst = bless {}, ref($src);
  foreach my $key (keys(%{$src}))
  { $ref = ref($val = $src->{$key});
    $dst->{$key} = ($ref eq 'ARRAY') ? [@{$val}] :
                   ($ref eq 'HASH')  ? {%{$val}} :
                                       $val;
  }
  return $dst;
}

=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, $str) = @_;
  my ($buf, $pre);

  $lvl = 0 unless defined($lvl);
  $str = q{} unless defined($str);

  $pre = q{  } x $lvl++;
  $buf = $pre.$str.join(q{ }, $slf->{'typ'}, $slf->get_id, $slf->{'msg'});
  $pre .= q{  };
  if (exists($slf->{'att'}))
  { foreach my $key (sort keys(%{$slf->{'att'}}))
    { $buf .= qq{\n$pre$key=};
      $buf .= (exists($tb_msk{$key}) || $key =~ m{__save$}) ?
          q{...} :
        (ref($slf->{'att'}->{$key}) eq 'ARRAY') ?
          q{(}.join(qq{,\n$pre  },
            map {RDA::Object::encode($_)} @{$slf->{'att'}->{$key}}).q{)} :
        RDA::Object::encode($slf->{'att'}->{$key});
    }
  }
  $buf .= qq{\n$pre<error>\n}.$slf->dump_errors($pre)
    if exists($slf->{'err'}) && @{$slf->{'err'}};
  if (exists($slf->{'dat'}))
  { my ($adr, $dat, $hex, $lgt, $ref, $txt);

    $ref = ref($dat = $slf->{'dat'});
    if ($ref eq 'CODE' || !$DUMP)
    { $buf .= qq{\n$pre<data>};
    }
    elsif ($ref eq 'ARRAY')
    { $buf .= join(qq{\n}, qq{\n___LINES___}, @{$dat}, qq{___EOD___\n});
    }
    elsif (substr($dat, 0, 1024) !~ m/[\000-\011\013-\037\177-\377]/)
    { $buf .= qq{\n___DATA___\n}.$dat.qq{\n___EOD___\n};
    }
    else
    { $adr = 0;
      $buf .= qq{\n___DATA___};
      $lgt = length($dat);
      for (; $lgt > 0 ; $adr += 16, $lgt -= 16)  ## no critic (Comma,Loop)
      { $txt = substr($dat, $adr, ($lgt >= 16) ? 16 : $lgt);
        $hex = sprintf($DUMP_FMT,
          unpack($DUMP_MSK, unpack('H*', $txt).$DUMP_SPC));
        $txt =~ s/[\000-\037\177-\237]/./g;
        $buf .= sprintf("\n x%5.5lx: %s%s", $adr, $hex, $txt);
      }
      $buf .= qq{\n___EOD___\n};
    }
  }
  return $buf;
}

=head2 S<$h-E<gt>error($error[,arg,...])>

The error response constructor. It allows you to specify the error string and
error details. The details are pushed in the error buffer except hash
references, which are used to specify attributes.

=cut

sub error
{ my ($cls, $err, @arg) = @_;
  my ($dat, $lvl, $rec, $slf, $val);

  # Validate the arguments
  die get_string('BAD_REF')         unless ref($cls);
  die get_string('NO_ERROR')        unless $err;
  die get_string('BAD_ERROR', $err) unless $err =~ m/^\w+$/;

  # Create the response object
  $slf = bless {
    ids => $cls->{'ids'},
    msg => "ERROR.$err",
    typ => 'RSP',
    }, ref($cls);
  $slf->{'res'} = $cls->{'res'} if exists($slf->{'res'});

  # Add the optional attributes
  $dat = exists($cls->{'err'}) ? $cls->{'err'} : [];
  foreach my $arg (@arg)
  { if (ref($arg) eq 'HASH')
    { foreach my $key (keys(%{$arg}))
      { $val = $arg->{$key};
        next unless $key && defined($val);
        if ($key =~ m/^\((\w+)\)$/)
        { $slf->{'att'}->{$1} = $key = [];
          $val = [$val] unless ref($val) eq 'ARRAY';
          foreach my $itm (@{$val})
          { foreach my $lin (split(/\n/, $itm))
            { $lin =~ s/[\r\s]+$//;
              push(@{$key}, $lin);
            }
          }
        }
        elsif ($key !~ m/\W/)
        { $slf->{'att'}->{$key} = $val;
        }
      }
    }
    elsif (ref($arg) eq 'ARRAY')
    { push(@{$dat}, @{$arg});
    }
    elsif (defined($arg) && ref($rec = $slf->parse_error($arg)))
    { push(@{$dat}, $rec);
    }
  }
  $slf->{'err'} = $dat if @{$dat};

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>reply($error,message[,key=>value,...])>

The error response constructor. It first adds any provided error in the error
buffer using the C<add_error> method. When errors present in the error buffer,
it generates an C<ERROR> response. Otherwise, it generates an C<OK> response
using the extra arguments as response attributes.

=cut

sub reply
{ my ($slf, $err, $msg, @arg) = @_;

  return $slf->add_error($err)->has_errors
    ? $slf->error($msg)
    : $slf->new("OK.$msg", @arg);
}

=head1 ERROR AND STATUS METHODS

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

This method returns the error buffer reference. It expands the C<_error>
attribute, when needed.

=cut

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

  # Expand the attribute
  unless (exists($slf->{'err'}))
  { my ($buf, $err, $lvl);

    $buf = $slf->{'err'} = [];
    if (exists($slf->{'att'}) && exists($slf->{'att'}->{'_error'}))
    { $err = [$err] unless ref($err = delete($slf->{'att'}->{'_error'}));
      foreach my $lin (@{$err})
      { $lvl = ($lin =~ s/^(\d+)\:// && $1) ? $1 : 1;
        RDA::Error::expand_error($buf, $lin, $lvl);
      }
    }
  }

  # Return the error buffer reference
  return $slf->{'err'};
}

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

This method returns the response status in a scalar context. In a list context,
it returns both status and code.

=cut

sub get_status
{ my ($slf) = @_;
  my ($sta, $cod);

  ($sta, $cod) = split(/\./, ($slf->{'typ'} eq 'RSP') ? $slf->{'msg'} : q{.});
  return ($sta, $cod) if wantarray;
  return $sta;
}

=head2 S<$h-E<gt>is_error([$obj[,$grp]])>

This method indicates if the response reports an error. When an error is
detected, it returns the corresponding code. Otherwise, it returns an empty
string.

When you specify an object reference as an argument, the error lines are also
transferred in its error buffer. You can specify a master error as an extra
argument to regroup transferred errors. It does not transfer errors when the
message is not an error.

=cut

sub is_error
{ my ($slf, $ref, $grp) = @_;
  my ($cod);

  if ($cod = _check_status($slf, 'ERROR'))
  { if (ref($ref))
    { if (ref($grp))
      { $ref->add_error($slf->purge_errors, $grp);
      }
      elsif (defined($grp))
      { local $^W = 0;
        $ref->add_error($slf->purge_errors, sprintf($grp, $cod));
      }
      else
      { $ref->move_errors($slf);
      }
    }
    elsif (defined($ref))
    { $slf->set_value('exit', $ref);
    }
  }
  return $cod;
}

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

This method indicates if the response has an C<INFO> status. Then, it returns
the corresponding code. Otherwise, it returns an empty string.

=cut

sub is_info
{ return _check_status(shift, 'INFO')
}

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

This method indicates if the response indicates a successful completion.
message object. When successful, it returns the corresponding code. Otherwise,
it returns an empty string.

=cut

sub is_success
{ return _check_status(shift, 'OK')
}

sub _check_status
{ my ($slf, $ref) = @_;
  my ($sta, $cod);

  return q{} unless $slf->{'typ'} eq 'RSP';
  ($sta, $cod) = split(/\./, $slf->{'msg'});
  return ($sta eq $ref) ? $cod : q{};
}

=head1 MESSAGE IDENTIFIER METHODS

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

This method returns the identifier path.

=cut

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

  return (scalar @{$slf->{'ids'}}) ? join(q{/}, @{$slf->{'ids'}}) : '0';
}

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

This method pops the last request identifier from the identifier path. It
returns a reference to the message object.

=cut

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

  pop(@{$slf->{'ids'}});
  return $slf;
}

=head2 S<$h-E<gt>set_id($id)>

This method sets the request identifier and returns it.

=cut

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

  $slf->{'typ'} = 'REQ';
  return $slf->{'ids'} = ref($uid) ? $uid->get_id : $uid;
}

=head1 MESSAGE ATTRIBUTE METHODS

=head2 S<$h-E<gt>add_value($name,$value,...)>

This method adds values to an attribute. It ignores undefined values and
references. It returns a reference to the value list associated with this
attribute.

=cut

sub add_value
{ my ($slf, $key, @arg) = @_;
  my ($val, @tbl);

  # Add new values
  if ($key && $key !~ m/\W/ && (@tbl = grep {defined($_) && !ref($_)} @arg))
  { if (exists($slf->{'att'}->{$key}))
    { $val = $slf->{'att'}->{$key};
      $slf->{'att'}->{$key} = $val = [$val] unless ref($val);
      push(@{$val}, @tbl);
    }
    else
    { $slf->{'att'}->{$key} = $val = [@tbl];
    }
    return $val;
  }

  # Return the current value list
  return exists($slf->{'att'}->{$key}) ? $slf->{'att'}->{$key} : [];
}

=head2 S<$h-E<gt>add_env($env)>

This method adds attributes to indicate environment adaptations. They are
passed as a hash reference. It returns a reference to the message object.

=cut

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

  if (ref($env))
  { foreach my $key (keys(%{$env}))
    { if (defined($env->{$key}))
      { $slf->{'att'}->{"set_$key"} = $env->{$key};
      }
      else
      { $slf->{'att'}->{"del_$key"} = 0;
      }
    }
  }
  return $slf;
}

=head2 S<$h-E<gt>clear($pattern)>

This method deletes all message attributes with a name matching the regular
expression. It returns a reference to the message object.

=cut

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

  foreach my $key (keys(%{$slf->{'att'}}))
  { delete($slf->{'att'}->{$key}) if $key =~ $pat;
  }
  return $slf;
}

=head2 S<$h-E<gt>get_first($name,$default)>

This method returns the first value of the specified message attribute or the
default value when the message attribute was not found.

When an array reference is provided as name, it returns the value of the first
defined message attribute from that list.

=cut

sub get_first
{ return [get_value(@_)]->[0];
}

=head2 S<$h-E<gt>get_value($name,$default)>

This method returns the value of the specified message attribute or the default
value when the message attribute was not found.

When an array reference is provided as name, it returns the value of the first
defined message attribute from that list.

When executed in an array context, it returns the results as a list.

=cut

sub get_value
{ my ($slf, $nam, $dft) = @_;

  if (exists($slf->{'att'}))
  { $nam = [$nam] unless ref($nam);
    foreach my $key (@{$nam})
    { next unless exists($slf->{'att'}->{$key});
      $dft = $slf->{'att'}->{$key};
      last;
    }
  }
  if (wantarray)
  { return @{$dft} if ref($dft) eq 'ARRAY';
    return ($dft)  if defined($dft);
    return ();
  }
  return $dft;
}

=head2 S<$h-E<gt>grep($pattern[,$flag])>

This method returns the list of all message attribute names that match the
regular expression. When the flag is set, it returns the non-matching message
attributes.

=cut

sub grep  ## no critic (Builtin)
{ my ($slf, $pat, $inv) = @_;

  return () unless exists($slf->{'att'});
  return (grep {$inv xor $_ =~ $pat} sort keys(%{$slf->{'att'}}));
}

=head2 S<$h-E<gt>is_defined($name,...)>

This method indicates if one of the specified message attributes exists.

=cut

sub is_defined
{ my $slf = shift;

  if (exists($slf->{'att'}))
  { foreach my $key (@_)
    { return 1 if exists($slf->{'att'}->{$key});
    }
  }
  return 0;
}

=head2 S<$h-E<gt>set_response($name[,$value])>

This method defines a response attribute when the value is defined. Otherwise,
the response attribute is deleted. It returns the previous value of the
response attribute.

=cut

sub set_response
{ my ($slf, $key, $val) = @_;
  my $old;

  return unless $key && $key !~ m/\W/;  ## no critic (Unless)
  if (defined($val))
  { ($slf->{'rsp'}->{$key}, $old) = ($val, $slf->{'rsp'}->{$key});
  }
  elsif (exists($slf->{'rsp'}))
  { $old = delete($slf->{'rsp'}->{$key});
  }
  return $old;
}

=head2 S<$h-E<gt>set_value($name[,$value])>

This method defines a message attribute when the value is defined. Otherwise,
the message attribute is deleted. It returns the previous value of the message
attribute.

=cut

sub set_value
{ my ($slf, $key, $val) = @_;
  my $old;

  return unless $key && $key !~ m/\W/;  ## no critic (Unless)
  if (defined($val))
  { ($slf->{'att'}->{$key}, $old) = ($val, $slf->{'att'}->{$key});
  }
  elsif (exists($slf->{'att'}))
  { $old = delete($slf->{'att'}->{$key});
  }
  return $old;
}

=head1 REQUEST AND RESULT MANAGEMENT METHODS

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

This method returns a reference to the associated request.

=cut

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

  die get_string('NO_REQUEST') unless exists($slf->{'req'});
  return $slf->{'req'};
}

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

This method returns a reference to the associated results.

=cut

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

  die get_string('NO_RESULT') unless exists($slf->{'res'});
  return $slf->{'res'};
}

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

This method indicates whether a request is associated to the message.

=cut

sub has_request
{ return exists(shift->{'req'});
}

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

This method indicates whether results are associated to the message.

=cut

sub has_results
{ return exists(shift->{'res'});
}

=head2 S<$h-E<gt>save_results($ofh[,$format])>

This method saves the results. When the flag is set, it uses an XML format,
instead of the RDA format.

=cut

sub save_results
{ my ($slf, $ofh, $flg) = @_;

  die get_string('NO_RESULT') unless exists($slf->{'res'});
  return $flg
    ? $slf->{'res'}->convert($ofh, 'sdp_results')
    : $slf->{'res'}->save($ofh);
}

=head2 S<$h-E<gt>set_request([$item])>

This method associates a request to the message. When the value is not an item
reference, it deletes any existing association. It returns the previous value.

=cut

sub set_request
{ my ($slf, $req) = @_;
  my ($old);

  $old = delete($slf->{'req'});
  $slf->{'req'} = $req if ref($req) eq 'RDA::Object::Item';
  return $old;
}

=head2 S<$h-E<gt>set_results([$item])>

This method associates results to the message. When the value is not an item
reference, it deletes any existing association. It returns the previous value.

=cut

sub set_results
{ my ($slf, $res) = @_;
  my ($old);

  $old = delete($slf->{'res'});
  $slf->{'res'} = $res if ref($res) eq 'RDA::Object::Item';
  return $old;
}

=head1 DATA MANAGEMENT METHODS

=head2 S<$h-E<gt>add_blocks($blk,...)>

This method adds data blocks to the message. It ignores undefined values and
references. It returns a reference to the message object.

=cut

sub add_blocks
{ my $slf = shift;

  # Add the data blocks
  $slf->{'dat'} = q{}
    unless exists($slf->{'dat'}) && !ref($slf->{'dat'});  ## no critic (Unless)
  foreach my $blk (@_)
  { $slf->{'dat'} .= $blk if defined($blk) && !ref($blk);
  }

  # Return the message reference
  return $slf;
}

=head2 S<$h-E<gt>add_data($dat[,$arg,...])>

This method adds data to the message. You can specify the data as following:

=over 2

=item *

A message reference. Its data is transferred to the current message.

=item *

A scalar, which contains the data.

=item *

A reference to a line array

=item *

A function reference. You can specify function arguments as extra method
arguments. The function is first called to determined the data type:

  &$data(0,arg...)

A negative return value indicates that lines are provided. Otherwise, the size
of the binary data should be specified. The data are next fetched in successive
calls:

  &$data(n,arg...)

where C<n> is a number greater than zero. For lines, a single line should be
provided at the time, and an undefined value indicates that no more lines are
available. For binary data, the data could be returns on multiple blocks, with
the content and the size of the block provided as return value. It returns an
empty list indicate the data end.

When C<n> has a value lower than zero, all remaining data are discarded.

=item *

An undefined value. In this case, no data will be added.

=back

It returns a reference to the message object.

=cut

sub add_data
{ my ($slf, $dat, @arg) = @_;

  # Declare the data section
  $dat = $dat->get_info('dat') if ref($dat) eq 'RDA::Object::Message';
  if (defined($dat))
  { $slf->{'dat'} = $dat;
    $slf->{'arg'} = [@arg] if ref($slf->{'dat'}) eq 'CODE';
  }

  # Return the message reference
  return $slf;
}

=head2 S<$h-E<gt>add_file($fil, $flg)>

This method adds a file to the message. The size of the file should not change
during the message generation. When the flag is set, the file is handled by
line instead of by data blocks. In line mode, it removes carriages returns and
line feeds. When the flag is greater than zero, it removes trailing spaces also.

It returns a reference to the message object.

=cut

sub add_file
{ my ($slf, $fil, $flg) = @_;

  # Declare the data section
  die get_string('NO_DATA', $fil) unless $fil && -r $fil;
  $slf->{'dat'} = !defined($flg) ? \&_load_file :
                  ($flg < 0)     ? \&_load_lines :
                  ($flg > 0)     ? \&_load_trimmed :
                                   \&_load_file;
  $slf->{'arg'} = [{fil => $fil, ifh => IO::Handle->new}];

  # Return the message reference
  return $slf;
}

sub _load_file
{ my ($mod, $dat) = @_;
  my ($buf, $ifh, $lgt);

  if ($dat->{'ifh'})
  { if ($mod > 0)
    { $lgt = sysread($dat->{'ifh'}, $buf, 1024);
      return ($buf, $lgt) if $lgt;
    }
    elsif ($mod == 0)
    { return
        unless open($dat->{'ifh'}, q{<}.$dat->{'fil'});  ## no critic (Open)
      binmode($dat->{'ifh'});
      my @sta = stat($dat->{'ifh'});
      return $sta[7];
    }
    $dat->{'ifh'}->close;
    $dat->{'ifh'} = undef;
  }
  return ();
}

sub _load_lines
{ my ($mod, $dat) = @_;
  my ($ifh, $lin, $lgt);

  if ($dat->{'ifh'})
  { if ($mod > 0)
    { if (defined($lin = $dat->{'ifh'}->getline))
      { $lin =~ s/[\n\r]+$//;
        return $lin;
      }
    }
    elsif ($mod == 0)
    { return open($dat->{'ifh'}, q{<}.$dat->{'fil'})  ## no critic (Open)
        ? -1 : undef;
    }
    $dat->{'ifh'}->close;
    $dat->{'ifh'} = undef;
  }
  return;
}

sub _load_trimmed
{ my ($mod, $dat) = @_;
  my ($ifh, $lin, $lgt);

  if ($dat->{'ifh'})
  { if ($mod > 0)
    { if (defined($lin = $dat->{'ifh'}->getline))
      { $lin =~ s/[\n\r\s]+$//;
        return $lin;
      }
    }
    elsif ($mod == 0)
    { return open($dat->{'ifh'}, q{<}.$dat->{'fil'})  ## no critic (Open)
        ? -1 : undef;
    }
    $dat->{'ifh'}->close;
    $dat->{'ifh'} = undef;
  }
  return;
}

=head2 S<$h-E<gt>add_lines($lin,...)>

This method adds data lines to the message. Undefined values and references are
skipped. Trailing spaces, carriages returns and line feeds are removed. It
returns a reference to the message object.

=cut

sub add_lines
{ my $slf = shift;

  # Add the data lines
  $slf->{'dat'} = []
    unless exists($slf->{'dat'}) && ref($slf->{'dat'}) eq 'ARRAY';
  foreach my $lin (@_)
  { next unless defined($lin) && !ref($lin);  ## no critic (Unless)
    $lin =~ s/[\n\r\s]+$//;
    push(@{$slf->{'dat'}}, $lin);
  }

  # Return the message reference
  return $slf;
}

=head2 S<$h-E<gt>attach_file($fil, $flg)>

This method specifies a file to be added as data to the response. The size of
the file should not change during the message generation. When the flag is set,
the file is handled by line instead of by data blocks. In that case, trailing
spaces, carriages returns, and line feeds are removed. It returns a reference
to the message object.

=cut

sub attach_file
{ my ($slf, $fil, $flg) = @_;

  die get_string('NO_DATA', $fil) unless $fil && -r $fil;
  $slf->{'fil'} = [$fil, $flg];
  return $slf;
}

=head1 DATA EXTRACTION METHODS

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

This method returns the data associated with the message.

=cut

sub get_data
{ my ($slf) = @_;
  my ($dat);

  # Treat a data routine
  if (exists($slf->{'dat'}) && ref($dat = $slf->{'dat'}) eq 'CODE')
  { my ($buf, $cnt, $fct, $lgt, @arg);

    $fct = $dat;
    @arg = @{$slf->{'arg'}} if exists($slf->{'arg'});
    $lgt = &$fct($cnt = 0, @arg);
    if (!defined($lgt))
    { $dat = q{};
    }
    elsif ($lgt < 0)
    { $dat = [];
      while (defined($buf = &{$fct}(++$cnt, @arg)))
      { $buf =~ s/[\n\r\s]+$//;
        push(@{$dat}, $buf);
      }
    }
    else
    { $dat = q{};
      $dat .= $buf while (($buf, $lgt) = &{$fct}(++$cnt, @arg));
    }
    $slf->{'dat'} = $dat;
  }

  # Return the data
  return $dat;
}

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

This method indicates whether the message has data. It always returns a true
value when some code is used to get the data.

=cut

sub has_data
{ my ($slf) = @_;
  my ($dat, $ref);

  return 0 unless exists($slf->{'dat'});

  $ref = ref($dat = $slf->{'dat'});
  return
    ($ref eq 'CODE')  ? 1 :
    ($ref eq 'ARRAY') ? (scalar @{$dat}) :
                        length($dat);
}

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

This method indicates whether the message has lines as data. It returns an
undefined value when there are no data.

=cut

sub has_lines
{ my ($slf) = @_;
  my ($ref, @arg);

  return unless exists($slf->{'dat'});
  $ref = ref($slf->{'dat'});
  return 1 if $ref eq 'ARRAY';
  if ($ref eq 'CODE')
  { @arg = @{$slf->{'arg'}} if exists($slf->{'arg'});
    return -1 if &{$slf->{'dat'}}(0, @arg) < 0;
  }
  return 0;
}

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

This method reads the next data element, or an undefined value when no more
data are found.

=cut

sub read_data
{ my ($slf) = @_;
  my ($buf, @arg);

  return unless exists($slf->{'dat'}) && ref($slf->{'dat'}) eq 'CODE';
  @arg = @{$slf->{'arg'}} if exists($slf->{'arg'});
  return &{$slf->{'dat'}}(1, @arg);
}

*getline = \&read_data;

=head2 S<$h-E<gt>save_data($file[,$mode])>

This method saves the message data in a file. The file is only created when
data are present in the message, even with a null size. File permissions can
be specified as an extra argument.

It returns an undefined value when there are no data, 0 when a file has been
created. Otherwise, it returns the file error.

=cut

sub save_data
{ my ($slf, $fil, $mod) = @_;
  my ($buf, $cnt, $dat, $lgt, $ofh, @arg);

  # Abort when no data are present or when the file cannot be created
  return unless exists($slf->{'dat'});
  return $! unless ($ofh = IO::File->new)->open($fil, $CREATE, $FIL_PERMS);

  # Save the data
  if (ref($dat = $slf->{'dat'}) eq 'ARRAY')
  { foreach my $lin (@{$dat})
    { $ofh->syswrite("$lin\n", length($lin) + 1);
    }
  }
  elsif (ref($dat) eq 'CODE')
  { @arg = @{$slf->{'arg'}} if exists($slf->{'arg'});
    if (&$dat($cnt = 0, @arg) < 0)
    { while (defined($buf = &$dat(++$cnt, @arg)))
      { $ofh->syswrite("$buf\n", length($buf) + 1);
      }
    }
    else
    { binmode($ofh);
      while (($buf, $lgt) = &$dat(++$cnt, @arg))
      { $ofh->syswrite($buf, $lgt);
      }
    }
    delete($slf->{'dat'});
  }
  else
  { binmode($ofh);
    $ofh->syswrite($dat, length($dat));
  }
  $ofh->close;

  # Adjust the file permissions when requested
  chmod($mod, $fil) if defined($mod);

  # Indicate a successful completion
  return 0;
}

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

This method skips the unread part of the message.

=cut

sub skip_data
{ my ($slf) = @_;
  my @arg;

  # Eliminate unread data
  if (exists($slf->{'dat'}) && ref($slf->{'dat'}) eq 'CODE')
  { @arg = @{$slf->{'arg'}} if exists($slf->{'arg'});
    &{delete($slf->{'dat'})}(-1, @arg);
  }

  # Indicate a successful completion
  return 0;
}

*close = \&skip_data;

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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