# Error.pm: Class Used for Managing Errors

package RDA::Error;

# $Id: Error.pm,v 1.9 2015/05/09 15:21:19 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Error.pm,v 1.9 2015/05/09 15:21:19 RDA Exp $
#
# Change History
# 20150508  MSC  Change the tracing.

=head1 NAME

RDA::Error - Class Used for Managing Errors

=head1 SYNOPSIS

 require RDA::Error;

=head1 DESCRIPTION

The module regroups methods used for managing errors.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string wrap_string);
  use RDA::Object;
}

# Define the global public variables
use vars qw($DMP_BUF $DMP_STK $STRINGS $VERSION @EXPORT_OK @ISA %SDCL);
$DMP_BUF   = 0;
$DMP_STK   = 0;
$VERSION   = sprintf('%d.%02d', q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw(compact_errors expand_error);
@ISA       = qw(RDA::Object Exporter);
%SDCL      = (
  met => {
    'add_error'     => {ret => 0},
    'add_errors'    => {ret => 0},
    'alter_error'   => {ret => 0},
    'dump_errors'   => {ret => 0},
    'format_error'  => {ret => 1},
    'format_errors' => {ret => 1},
    'get_errors'    => {ret => 0},
    'has_errors'    => {ret => 0},
    'last_error'    => {ret => 0},
    'list_errors'   => {ret => 1},
    'move_errors'   => {ret => 0},
    'nest_error'    => {ret => 0},
    'parse_error'   => {ret => 0},
    'pop_error'     => {ret => 0},
    'pop_errors'    => {ret => 1},
    'purge_errors'  => {ret => 0},
    },
  );

# Define the global private constants
my $SEP = " +--------\n";
my $SPC = q{ };

# Define the global private variables

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

=head2 S<$h = RDA::Error-E<gt>new([name =E<gt> $value,...])>

The object constructor. It enables you to specify initial attributes at object
creation time.

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

=over 12

=item S<    B<'err' > > Optional error buffer

=back

=cut

sub new
{ my $cls = shift;

  # Create the object and return its reference
  return bless {err => [], @_}, ref($cls) || $cls;
}

=head2 S<$h-E<gt>abort([$text[,$group]])>

This method adds a new error in the error buffer and stops the code execution.

=cut

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

  $slf->add_error(@arg) if @arg;
  die ".\n";
}

=head2 S<$h-E<gt>add_error($text[,$group])>

This method generates a new error and adds it in the error buffer. It removes
trailing spaces, carriage returns, and line feeds from the error texts. It
skips undefined values and empty lines. It returns the object reference.

=cut

sub add_error
{ my ($slf, $txt, $grp) = @_;
  my ($buf, $cnt, $cur, $det, $rec);

  if (defined($txt))
  { if (defined($grp))
    { if (ref($rec = $grp) eq 'ARRAY'
        || defined($rec = $slf->parse_error($grp)))
      { $buf = $slf->get_errors;
        if (ref($txt) eq 'ARRAY')
        { push(@{$rec}, @{$txt});
        }
        elsif ($txt eq ".\n")
        { push(@{$rec}, $det) if defined($det = pop(@{$buf}));
        }
        else
        { $cur = $rec;
          foreach my $lin (split(/\n/, $txt))
          { $lin =~ s/\.?[\r\s]*$//;
            next unless length($lin);
            push(@{$cur}, [$lin]);
            $cur = $cur->[-1] if $lin =~ m/^[A-Z]+\-\d+:\s.*:$/;
          }
        }
        $cnt = push(@{$buf}, $rec);
      }
    }
    elsif (ref($txt) eq 'ARRAY')
    { $cnt = push(@{$slf->get_errors}, @{$txt});
    }
    elsif ($txt ne ".\n")
    { $cnt = push(@{$slf->get_errors}, $rec)
        if defined($rec = $slf->parse_error($txt));
    }
  }
  else
  { $cnt = push(@{$slf->get_errors}, $rec)
      if ref($rec = $grp) eq 'ARRAY'
      || defined($rec = $slf->parse_error($grp));
  }

  # Dump the caller
  _dump_caller($slf) if $DMP_STK && $cnt;

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>add_errors($error,...)>

This method adds errors in the error buffer. It skips undefined values. It
returns the object reference.

=cut

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

  push(@{$slf->get_errors}, grep {ref($_)} @err);
  return $slf;
}

=head2 S<$h-E<gt>alter_error($message,@arg)>

This method alters the text of the last error using the specified message and
arguments. It returns the new text.

=cut

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

  $rec = $slf->last_error(1);
  return if !defined($err = $rec->[0]) || ref($err);
  $err =~ s/:$//;
  return $rec->[0] = get_string($msg, $err, @arg);
}

=head2 S<$h-E<gt>dump_errors($prefix)>

This method dumps the content of the error buffer.

=cut

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

  $pre = q{} unless defined($pre);
  return join(qq{\n}, map {_dump_errors($pre, $_)} @{$slf->get_errors});
}

sub _dump_errors
{ my ($pre, $val) = @_;

  return ($pre.$val) unless ref($val);
  return (map {_dump_errors("$pre ", $_)} @{$val});
}

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

This method formats the specified error and prefixes each element with its
respective level.

=cut

sub format_error
{ my ($slf, $rec, $flg, $pre) = @_;

  return () unless ref($rec) || ref($rec = $slf->parse_error($rec));
  $flg = 0   unless $flg;
  $pre = q{} unless defined($pre);
  return (($flg > 0) ? _indent_errors($rec, 0, $pre) :
          ($flg < 0) ? _wrap_errors($rec, 0, $pre) :
                       compact_errors($rec, 0));
}

=head2 S<$h-E<gt>format_errors([$flag])>

This method extracts the errors from the error buffer and prefixes them with
their respective level. It returns an empty list if there is no error buffer.

=cut

sub format_errors
{ my ($slf, $flg, $pre) = @_;

  $flg = 0   unless $flg;
  $pre = q{} unless defined($pre);
  return (($flg > 0) ? _indent_errors($slf->get_errors, -1, $pre) :
          ($flg < 0) ? _wrap_errors($slf->get_errors, -1, $pre) :
                       compact_errors($slf->get_errors, -1));
}

sub compact_errors
{ my ($val, $lvl) = @_;

  return ("$lvl:$val") unless ref($val);
  ++$lvl;
  return (map {compact_errors($_, $lvl)} @{$val});
}

sub _indent_errors
{ my ($val, $lvl, $pre) = @_;

  return ($SPC x $lvl.$val) unless ref($val);
  ++$lvl;
  return (map {_indent_errors($_, $lvl, $pre)} @{$val});
}

sub _wrap_errors
{ my ($val, $lvl, $pre) = @_;

  $val = '*undef*' unless defined($val);
  return (($val =~ m/^(\w+-\d+:\s*)(.*)$/)
    ? wrap_string($pre.($SPC x $lvl).$1,   $2, 0)
    : wrap_string($pre.($SPC x $lvl).'* ', $val, 0))
    unless ref($val);
  ++$lvl;
  return (map {_wrap_errors($_, $lvl, $pre)} @{$val});
}

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

This method returns a reference to the error buffer.

=cut

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

  # Return the error buffer from the current object
  return $slf->{'err'} if exists($slf->{'err'});

  # Search the error buffer in a parent object
  while (exists($slf->{'par'}))
  { $slf = $slf->{'par'};
    return $slf->{'err'} if exists($slf->{'err'});
  }

  # Otherwise create the error buffer
  return $slf->{'err'} = [];
}

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

This method indicates if errors have been encountered. It returns the number of
errors.

=cut

sub has_errors
{ return scalar @{shift->get_errors};
}

=head2 S<$h-E<gt>last_error([$flag])>

This method returns the text of the last error. When the flag it set, it
returns the whole error record.

=cut

sub last_error
{ my ($slf, $flg) = @_;
  my ($buf);

  return $flg ? [] : undef unless scalar @{$buf = shift->get_errors};
  return $flg ? $buf->[-1]
              : $buf->[-1]->[0];
}

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

This method returns the error texts as a flat list.

=cut

sub list_errors
{ return (_flat_errors(shift->get_errors));
}

sub _flat_errors
{ my ($val) = @_;

  return ($val) unless ref($val);
  return (map {_flat_errors($_)} @{$val});
}

=head2 S<$h-E<gt>load_errors($ifh)>

This method reads formatted errors from the input file handle and loads them
in the error buffer. It skips empty messages. It closes the file handle at load
completion. It returns the error buffer reference.

=cut

sub load_errors
{ my ($slf, $ifh) = @_;
  my ($buf, $lin, $lvl);

  # Load the errors
  $buf = $slf->get_errors;
  while (defined($lin = $ifh->getline))
  { $lin =~ s/[\n\r\s]+$//;
    $lvl = ($lin =~ s/^(\d+)\:// && $1) ? $1 : 1;
    expand_error($buf, $lin, $lvl) if length($lin);
  }
  close($ifh);

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

sub expand_error
{ my ($buf, $lin, $lvl) = @_;

  if (--$lvl)
  { push(@{$buf}, []) unless @{$buf} && ref($buf->[-1]) eq 'ARRAY';
    expand_error($buf->[-1], $lin, $lvl);
  }
  else
  { push(@{$buf}, [$lin]);
  }
  return;
}

=head2 S<$h-E<gt>move_errors(@sources)>

This method consolidates the errors and returns the number of errors.

=cut

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

  return push(@{$slf->get_errors},
    map {ref($_) ? splice(@{$_->get_errors}) : $slf->parse_error($_)} @arg);
}

=head2 S<$h-E<gt>nest_error($text[,$group])>

This method generates a new error and adds it in the error buffer. It removes
trailing spaces, carriage returns, and line feeds from the error texts. It
skips undefined values and empty lines. It considers all remaining parts as
nested errors. It returns the object reference.

=cut

sub nest_error
{ my ($slf, $txt, $grp) = @_;
  my ($buf, $cnt, $det, $rec, @tbl);

  $buf = $slf->get_errors;
  if (ref($grp) eq 'ARRAY')
  { push(@tbl, $grp);
  }
  if (defined($grp))
  { push(@tbl, split(/\n/, $grp));
  }
  if (ref($txt) eq 'ARRAY')
  { push(@tbl, $txt);
  }
  if (defined($txt))
  { if ($txt eq ".\n")
    { $rec = pop(@{$buf});
    }
    else
    { push(@tbl, split(/\n/, $txt));
    }
  }
  while (defined($det = pop(@tbl)))
  { if (ref($det))
    { push(@{$det}, $rec) if $rec;
      $rec = $det;
    }
    elsif (length($det))
    { $rec = ref($rec) ? [$det, $rec] : [$det];
    }
  }
  if ($rec)
  { push(@{$buf}, $rec);

    # Dump the caller
    _dump_caller($slf) if $DMP_STK && $cnt;
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>parse_error($text)>

This method parses the error text. It removes trailing spaces, carriage
returns, and line feeds. It skips empty lines. When it finds some content, it
returns the error array. Otherwise, it returns an undefined value in a scalar
context or an empty list in an array context.

=cut

sub parse_error
{ my ($slf, $txt) = @_;
  my ($cur, $err);

  if (defined($txt))
  { foreach my $lin (split(/\n/, $txt))
    { $lin =~ s/\.?[\r\s]*$//;
      next unless length($lin);
      if (ref($cur))
      { push(@{$cur}, [$lin]);
        $cur = $cur->[-1] if $lin =~ m/^[A-Z]+\-\d+:\s.*:$/;
      }
      else
      { $cur = $err = [$lin];
      }
    }
  }

  # Return the error
  return () if wantarray && !defined($err);
  return $err;
}

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

This method removes the last error from the error buffer and returns its
reference. It returns an undefined value when the error buffer is empty.

=cut

sub pop_error
{ return pop(@{shift->get_errors});
}

=head2 S<$h-E<gt>pop_errors([$flag])>

This method removes the errors from the error buffer and returns their texts as
a flat list.

=cut

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

  return (map {$flg ? _indent_errors($_, 0, ($flg > 0) ? $SPC : q{&nbsp;})
                    : _flat_errors($_)} splice(@{$slf->get_errors}));
}

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

This method removes the errors from the error buffer and returns them as an
array reference.

=cut

sub purge_errors
{ return [splice(@{shift->get_errors})];
}

# --- Internal routines -------------------------------------------------------

# Dump the calling stack
sub _dump_caller
{ my ($slf) = @_;
  my ($buf, $err, $lvl, $txt, @tbl);

  $buf = $SEP;
  if ($DMP_BUF)
  { $txt = join(qq{\n}, $slf->format_errors(-1));
    $txt =~ s/\n/\n |/gm;
    $buf .= " |\n |$txt\n |\n";
  }
  elsif (@{$err = $slf->get_errors})
  { $txt = join(qq{\n}, _wrap_errors($err->[-1], 0, q{}));
    $txt =~ s/^/ |/gm;
    $buf .= "$txt\n |\n";
  }
  while (@tbl = caller(++$lvl))
  { $buf .= q{ | }.$tbl[1].' at line '.$tbl[2]."\n |   ".$tbl[3].qq{\n};
  }
  $buf .= $SEP;
  syswrite($RDA::Text::TRACE, $buf, length($buf));
  return;
}

1;

__END__

=head1 SEE ALSO

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