File Coverage

blib/lib/LaTeXML/Common/Error.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# /=====================================================================\ #
# |  LaTeXML::Common::Error                                             | #
# | Error handler                                                       | #
# |=====================================================================| #
# | Part of LaTeXML:                                                    | #
# |  Public domain software, produced as part of work done by the       | #
# |  United States Government & not subject to copyright in the US.     | #
# |---------------------------------------------------------------------| #
# | Bruce Miller                         #_#     | #
# | http://dlmf.nist.gov/LaTeXML/                              (o o)    | #
# \=========================================================ooo==U==ooo=/ #
package LaTeXML::Common::Error;
use strict;
use warnings;
use LaTeXML::Global;
use LaTeXML::Common::Object;
use Time::HiRes;
use Term::ANSIColor qw(:constants);
use base qw(Exporter);
our @EXPORT = (
  # Error Reporting
  qw(&Fatal &Error &Warn &Info),
  # Progress reporting
  qw(&NoteProgress &NoteProgressDetailed &NoteBegin &NoteEnd),
  # Colored-logging related functions
  qw(&colorizeString)
);

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Color setup
$Term::ANSIColor::AUTORESET = 1;
our $COLORIZED_LOGGING = -t STDERR;

our %color_scheme = (
  details => \&BOLD,
  success => \&GREEN,
  info    => (defined &BRIGHT_BLUE ? \&BRIGHT_BLUE : \&BLUE),    # bright only recently defined
  warning => \&YELLOW,
  error => sub { BOLD RED shift; },
  fatal => sub { BOLD RED UNDERLINE shift; }
);

sub colorizeString {
  my ($string, $alias) = @_;
  return $COLORIZED_LOGGING ? &{ $color_scheme{$alias} }($string) : $string; }

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Error reporting
# Public API

sub Fatal {
  my ($category, $object, $where, $message, @details) = @_;

  # Check if this is a known unsafe fatal and flag it if so (so that we reinitialize in daemon contexts)
  if ((($category eq 'internal') && ($object eq '')) ||
    ($category eq 'too_many_errors')) {
    $LaTeXML::UNSAFE_FATAL = 1; }

  # We'll assume that if the DIE handler is bound (presumably to this function)
  # we're in the outermost call to Fatal; we'll clear the handler so that we don't nest calls.
  die $message if $LaTeXML::IGNORE_ERRORS    # Short circuit, w/no formatting, if in probing eval
    || (($SIG{__DIE__} eq 'DEFAULT') && $^S);    # Also missing class when parsing bindings(?!?!)

  # print STDERR "\nHANDLING FATAL:"
  #   ." ignore=".($LaTeXML::IGNORE_ERRORS || '')
  #   ." handler=".($SIG{__DIE__}||'')
  #   ." parsing=".($^S||'')
  #   ."\n";
  my $inhandler = !$SIG{__DIE__};
  my $ineval    = 0;                # whether we're in an eval should no longer matter!

  # This seemingly should be "local", but that doesn't seem to help with timeout/alarm/term?
  # It should be safe so long as the caller has bound it and rebinds it if necessary.
  $SIG{__DIE__} = 'DEFAULT';    # Avoid recursion while preparing the message.
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;

  if (!$inhandler) {
    local $LaTeXML::BAILOUT = $LaTeXML::BAILOUT;
    if (checkRecursiveError()) {
      $LaTeXML::BAILOUT = 1;
      push(@details, "Recursive Error!"); }
    $state->noteStatus('fatal') if $state && !$ineval;
    my $detail_level = (($verbosity <= 1) && ($category =~ /^(?:timeout|too_many_errors)$/)) ? 0 : 2;
    $message
      = generateMessage(colorizeString("Fatal:" . $category . ":" . ToString($object), 'fatal'),
      $where, $message, $detail_level, @details);
    # If we're about to (really) DIE, we'll bypass the usual status message, so add it here.
    # This really should be handled by the top-level program,
    # after doing all processing within an eval
    # BIZARRE: Note that die adds the "at  " stuff IFF the message doesn't end w/ CR!
    $message .= $state->getStatusMessage . "\n" if $state && !$ineval;
  }
  else {    # If we ARE in a recursive call, the actual message is $details[0]
    $message = $details[0] if $details[0]; }
  # If inside an eval, this won't actually die, but WILL set $@ for caller's use.
  die $message; }

sub checkRecursiveError {
  my @caller;
  for (my $frame = 2 ; @caller = caller($frame) ; $frame++) {
    if ($caller[3] =~ /^LaTeXML::(Global::ToString|Global::Stringify)$/) {
      #      print STDERR "RECURSED ON $caller[3]\n";
      return 1; } }
  return; }

# Note that "100" is hardwired into TeX, The Program!!!
my $MAXERRORS = 100;    # [CONSTANT]

# Should be fatal if strict is set, else warn.
sub Error {
  my ($category, $object, $where, $message, @details) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  if ($state && $state->lookupValue('STRICT')) {
    Fatal($category, $object, $where, $message, @details); }
  else {
    $state && $state->noteStatus('error');
    print STDERR generateMessage(colorizeString("Error:" . $category . ":" . ToString($object), 'error'),
      $where, $message, 1, @details)
      if $verbosity >= -2; }
  if ($state && ($state->getStatus('error') || 0) > $MAXERRORS) {
    Fatal('too_many_errors', $MAXERRORS, $where, "Too many errors (> $MAXERRORS)!"); }
  return; }

# Warning message; results may be OK, but somewhat unlikely
sub Warn {
  my ($category, $object, $where, $message, @details) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  $state && $state->noteStatus('warning');
  print STDERR generateMessage(colorizeString("Warning:" . $category . ":" . ToString($object), 'warning'),
    $where, $message, 0, @details)
    if $verbosity >= -1;
  return; }

# Informational message; results likely unaffected
# but the message may give clues about subsequent warnings or errors
sub Info {
  my ($category, $object, $where, $message, @details) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  $state && $state->noteStatus('info');
  print STDERR generateMessage(colorizeString("Info:" . $category . ":" . ToString($object), 'info'),
    $where, $message, -1, @details)
    if $verbosity >= 0;
  return; }

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Progress Reporting
#**********************************************************************
# Progress reporting.

sub NoteProgress {
  my (@stuff) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  print STDERR @stuff if $verbosity >= 0;
  return; }

sub NoteProgressDetailed {
  my (@stuff) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  print STDERR @stuff if $verbosity >= 1;
  return; }

sub NoteBegin {
  my ($stage) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  if ($state && ($verbosity >= 0)) {
    $state->assignMapping('NOTE_TIMERS', $stage, [Time::HiRes::gettimeofday]);
    print STDERR "\n($stage..."; }
  return; }

sub NoteEnd {
  my ($stage) = @_;
  my $state = $STATE;
  my $verbosity = $state && $state->lookupValue('VERBOSITY') || 0;
  if (my $start = $state && $state->lookupMapping('NOTE_TIMERS', $stage)) {
    $state->assignMapping('NOTE_TIMERS', $stage, undef);
    if ($verbosity >= 0) {
      my $elapsed = Time::HiRes::tv_interval($start, [Time::HiRes::gettimeofday]);
      print STDERR sprintf(" %.2f sec)", $elapsed); } }
  return; }

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Handlers for perl's die & warn
# We'll try to decode some common errors to make them more usable
# for build systems.

my $quoted_re     = qr/\"([^\"]*)\"/;                                                   # [CONSTANT]
my $cantcall_re   = qr/Can't call method/;                                              # [CONSTANT]
my $cantlocate_re = qr/Can't locate object method/;                                     # [CONSTANT]
my $undef_re      = qr/Undefined subroutine/;                                           # [CONSTANT]
my $noself_re     = qr/on an undefined value|without a package or object reference/;    # [CONSTANT]
my $via_re        = qr/via package/;                                                    # [CONSTANT]
my $at_re         = qr/(at .*)/;                                                        # [CONSTANT]

sub perl_die_handler {
  my (@line) = @_;
  if ($LaTeXML::IGNORE_ERRORS) {    # Just get out now, if we're ignoring errors within an eval.
    local $SIG{__DIE__} = undef;
    die @line; }
  # We try to find a meaningful name for where the error occurred;
  # That's the thing that is "misdefined", after all.
  # Not completely sure we're looking in the right place up the stack, though.
  if ($line[0] =~ /^$cantcall_re\s+$quoted_re\s+($noself_re)\s+$at_re$/) {
    my ($method, $kind, $where) = ($1, $2, $3);
    Fatal('misdefined', callerName(1), $where,
      "Can't call method '$method' $kind", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^$undef_re\s+(\S+)\s+called $at_re$/) {
    my ($function, $where) = ($1, $2);
    Fatal('misdefined', callerName(1), $where,
      "Undefined subroutine '$function' called", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^$cantlocate_re\s+$quoted_re\s+$via_re\s+$quoted_re\s+\(.*\)\s+$at_re/) {
    my ($method, $class, $where) = ($1, $2, $3);
    Fatal('misdefined', callerName(1), $where,
      "Can't locate method '$method' via '$class'", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^Can't locate \S* in \@INC \(you may need to install the (\S*) module\) \(\@INC contains: ([^\)]*)\) $at_re$/) {
    my ($class, $inc, $where) = ($1, $2);
    Fatal('misdefined', callerName(1), $where,
      "Can't locate class '$class' (not installed or misspelled?)", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^Can't use\s+(\w*)\s+\([^\)]*\) as (.*?) ref(?:\s+while "strict refs" in use)? at (.*)$/) {
    my ($gottype, $wanttype, $where) = ($1, $2, $3);
    Fatal('misdefined', callerName(1), $where,
      "Can't use $gottype as $wanttype reference", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^File (.*?) had an error:/) {
    my ($file) = ($1);
    Fatal('misdefined', $file, undef, @line); }
  else {
    Fatal('perl', 'die', undef, "Perl died", @line); }
  return; }

sub perl_warn_handler {
  my (@line) = @_;
  return if $LaTeXML::IGNORE_ERRORS;
  if ($line[0] =~ /^Use of uninitialized value (.*?)(\s?+in .*?)\s+(at\s+.*?\s+line\s+\d+)\.$/) {
    my ($what, $how, $where) = ($1 || 'value', $2, $3);
    Warn('uninitialized', $what, $where, "Use of uninitialized value $what $how", @line[1 .. $#line]); }
  elsif ($line[0] =~ /^(.*?)\s+(at\s+.*?\s+line\s+\d+)\.$/) {
    my ($warning, $where) = ($1, $2);
    Warn('perl', 'warn', undef, $warning, $where, @line[1 .. $#line]); }
  else {
    Warn('perl', 'warn', undef, "Perl warning", @line); }
  return; }

# The following handlers SHOULD report the problem,
# even when within a "safe" eval that's ignoring errors.
# Moreover, we'd really like to be able to throw all the way to
# the top-level containing eval.  How to do that?
sub perl_interrupt_handler {
  my (@line) = @_;
  $LaTeXML::IGNORE_ERRORS = 0;    # NOT ignored
  $LaTeXML::UNSAFE_FATAL = 1;
  Fatal('interrupt', 'interrupted', undef, "LaTeXML was interrupted", @_);
  return; }

sub perl_timeout_handler {
  my (@line) = @_;
  $LaTeXML::IGNORE_ERRORS = 0;    # NOT ignored
  $LaTeXML::UNSAFE_FATAL = 1;
  Fatal('timeout', 'timedout', undef, "Conversion timed out", @_);
  return; }

sub perl_terminate_handler {
  my (@line) = @_;
  $LaTeXML::IGNORE_ERRORS = 0;    # NOT ignored
  $LaTeXML::UNSAFE_FATAL = 1;
  Fatal('terminate', 'terminated', undef, "Conversion was terminated", @_);
  return; }
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internals
# Synthesize an error message describing what happened, and where.
# $detail specifies the level of detail
#   $detail == -1 : no context or stack
#   $detail == 0  : context, no stack
#   $detail == +1 : context & stack
# including a level requesting full stack trace?

sub generateMessage {
  my ($errorcode, $where, $message, $detail, @extra) = @_;
  #----------------------------------------
  # Generate location information; basic and for stack trace.
  # If we've been given an object $where, where the error occurred, use it.
  my $docloc = getLocation($where);

  # $message and each of @extra should be single lines
  @extra = grep { $_ ne '' } map { split("\n", $_) } grep { defined $_ } $message, @extra;
  # make 1st line be 1st line of message
  $message = shift(@extra);
  #  $message =~ s/\n.*//g;
  # The initial portion of the message will consist of:
  $message = '' unless defined $message;
  my @lines = (
    # Start with the error code & primary error message
    $errorcode . ' ' . $message,
    # Followed by single line location of where the message occurred (if we know)
    ($docloc ? ($docloc) : ()),
    # and then any additional message lines supplied
    @extra);

  #----------------------------------------
  # Now add some additional context
  # NOTE: Should skip this for INFO
  # NOTE: Need to pass more of this onto the objects themselves....
  # What should it be called?
  #   showErrorContext() ?????
  $detail = 0 unless defined $detail;
  # Increment $detail if $verbosity > 0, unless $detail = -1,
  my $verbosity = ($STATE && $STATE->lookupValue('VERBOSITY')) || 0;
  if (($detail > -1) && ($verbosity > 0)) {
    $detail = 0 if defined $verbosity && $verbosity < -1;
    $detail++ if defined $verbosity && $verbosity > +1; }

  # FIRST line of stack trace information ought to look at the $where
  my $wheretype = ref $where;
  if ($detail <= 0) { }    # No extra context
  elsif ($wheretype =~ /^XML::LibXML/) {
    push(@lines, "Node is " . Stringify($where)); }
  ## Hmm... if we're being verbose or level is high, we might do this:
  ### "Currently in ".$doc->getInsertionContext); }
  elsif ($wheretype =~ 'LaTeXML::Core::Gullet') {
    push(@lines, $where->showUnexpected); }    # Or better?
  elsif ($wheretype =~ 'LaTeXML::Core::Stomach') {
    push(@lines,
      "Recently digested: " . join(' ', map { Stringify($_) } @LaTeXML::LIST))
      if $verbosity > 1; }

  #----------------------------------------
  # Add Stack Trace, if that seems worthwhile.
  if (($detail > 1) && ($verbosity > 0)) {
    push(@lines, "Stack Trace:", stacktrace()); }
  elsif ($detail > -1) {
    my $nstack = ($detail > 1 ? undef : ($detail > 0 ? 4 : 1));
    if (my @objects = objectStack($nstack)) {
      my $top = shift(@objects);
      push(@lines, "In " . trim(Stringify($$top[0])) . ' ' . Stringify($$top[1]));
      push(@objects, ['...']) if @objects && defined $nstack;
      push(@lines, join('', (map { ' <= ' . trim(Stringify($$_[0])) } @objects))) if @objects;
    } }

  # finally, join the result into a block of lines, indenting all but the 1st line.
  return "\n" . join("\n\t", @lines) . "\n"; }

sub Locator {
  my ($object) = @_;
  return ($object && $object->can('getLocator') ? $object->getLocator : "???"); }

# A more organized abstraction along there likes of $where->whereAreYou
# might be useful?
sub getLocation {
  my ($where) = @_;
  my $wheretype = ref $where;
  if ($wheretype && ($wheretype =~ /^XML::LibXML/)) {
    my $box = $LaTeXML::DOCUMENT && $LaTeXML::DOCUMENT->getNodeBox($where);
    return Locator($box) if $box; }
  elsif ($wheretype && $where->can('getLocator')) {
    return $where->getLocator; }
  elsif (defined $where) {
    return $where; }
  # Otherwise, try to guess where the error came from!
  elsif ($LaTeXML::DOCUMENT) {    # During construction?
    my $node = $LaTeXML::DOCUMENT->getNode;
    my $box  = $LaTeXML::DOCUMENT->getNodeBox($node);
    return Locator($box) if $box; }
  if ($LaTeXML::BOX) {            # In constructor?
    return Locator($LaTeXML::BOX); }
  if ($STATE && $STATE->getStomach) {
    my $gullet = $STATE->getStomach->getGullet;
    # NOTE: Problems here.
    # (1) With obsoleting Tokens as a Mouth, we can get pointless "Anonymous String" locators!
    # (2) If gullet is the source, we probably want to include next token, etc or
    return $gullet->getLocator(); }
  # # If in postprocessing
  # if($LaTeXML::Post::PROCESSOR && $LaTeXML::Post::DOCUMENT){
  #   return 'in '. $LaTeXML::Post::PROCESSOR->getName
  #     . ' on '. $LaTeXML::Post::DOCUMENT->siteRelativeDestination; }
  return; }

sub callerName {
  my ($frame) = @_;
  my %info = caller_info(($frame || 0) + 2);
  return $info{sub}; }

sub callerInfo {
  my ($frame) = @_;
  my %info = caller_info(($frame || 0) + 2);
  return "$info{call} @ $info{file} line $info{line}"; }

#======================================================================
# This portion adapted from Carp; simplified (but hopefully still correct),
# allow stringify overload, handle methods, make more concise!
#======================================================================
my $MAXARGS = 8;     # [CONSTANT]
my $MAXLEN  = 40;    # Or more? [CONSTANT]

sub trim {
  my ($string) = @_;
  return $string unless defined $string;
  $string = substr($string, 0, $MAXLEN - 3) . "..." if (length($string) > $MAXLEN);
  $string =~ s/\n/\x{240D}/gs;    # symbol for CR
  return $string; }

sub caller_info {
  my ($i) = @_;

  my (%info, @args);
  { package DB;
    @info{qw(package file line sub has_args wantarray evaltext is_require)}
      = caller($i);
    @args = @DB::args; }
  return () unless defined $info{package};
  # Work out the effective sub name, or eval, or method ...
  my $call = '';
  if (defined $info{evaltext}) {
    my $eval = $info{evaltext};
    if ($info{is_require}) {
      $call = "require $eval"; }
    else {
      $eval =~ s/([\\\'])/\\$1/g;
      $call = "eval '" . trim($eval) . "'"; } }
  elsif ($info{sub} eq '(eval)') {
    $call = "eval {...}"; }
  else {
    $call = $info{sub};
    my $method = $call;
    $method =~ s/^.*:://;
    # If $arg[0] is blessed, and `can' do $method, then we'll guess it's a method call?
    if ($info{has_args} && @args
      && ref $args[0] && ((ref $args[0]) !~ /^(?:SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE)$/)
      && $args[0]->can($method)) {
      $call = format_arg(shift(@args)) . "->" . $method; } }
  # Append arguments, if any.
  if ($info{has_args}) {
    @args = map { format_arg($_) } @args;
    if (@args > $MAXARGS) {
      $#args = $MAXARGS; push(@args, '...'); }
    $call .= '(' . join(',', @args) . ')'; }
  $info{call} = $call;
  return %info; }

sub format_arg {
  my ($arg) = @_;
  if    (not defined $arg) { $arg = 'undef'; }
  elsif (ref $arg)         { $arg = Stringify($arg); }    # Allow overloaded stringify!
  elsif ($arg =~ /^-?[\d.]+\z/) { }                       # Leave numbers alone.
  else {                                                  # Otherwise, string, so quote
    $arg =~ s/'/\\'/g;                                    # Slashify '
    $arg =~ s/([[:cntrl:]])/ "\\".chr(ord($1)+ord('A'))/ge;
    $arg = "'$arg'" }
  return trim($arg); }

# Semi-traditional (but reformatted) stack trace
sub stacktrace {
  my $frame = 0;
  my $trace = "";
  while (my %info = caller_info($frame++)) {
    next if $info{sub} =~ /^LaTeXML::Common::Error/;
##    $info{call} = '' if $info{sub} =~ /^LaTeXML::Common::Error::(?:Fatal|Error|Warn|Info)/;
    $trace .= "\t$info{call} @ $info{file} line $info{line}\n"; }
  return $trace; }

# Extract blessed `interesting' objects on stack.
# Get a maximum of $maxdepth objects (if $maxdepth is defined).
sub objectStack {
  my ($maxdepth) = @_;
  my $frame      = 0;
  my @objects    = ();
  while (1) {
    my (%info, @args);
    { package DB;
      @info{qw(package file line sub has_args wantarray evaltext is_require)} = caller($frame++);
      @args = @DB::args; }
    last unless defined $info{package};
    next if ($info{sub} eq '(eval)') || !$info{has_args} || !@args;
    my $self = $args[0];
    # If $arg[0] is blessed, and `can' do $method, then we'll guess it's a method call?
    # We'll collect such objects provided they can ->getLocator
    if ((ref $self) && ((ref $self) !~ /^(?:SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE)$/)) {
      my $method = $info{sub};
      $method =~ s/^.*:://;
      if ($self->can($method)) {
        next if @objects && ($self eq $objects[-1][0]);    # but don't duplicate
        if ($self->can('getLocator')) {                    # Digestion object?
          push(@objects, [$self, Locator($self)]); }
        elsif ($self->isa('LaTeXML::Post::Processor') || $self->isa('LaTeXML::Post::Document')) {
          push(@objects, [$self, '->' . $method]); }
        last if $maxdepth && (scalar(@objects) >= $maxdepth); } } }
  return @objects; }

#**********************************************************************
1;

__END__