File Coverage

blib/lib/Gtk2/Ex/ErrorTextDialog/Handler.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# Copyright 2009, 2010, 2011, 2013 Kevin Ryde

# This file is part of Gtk2-Ex-ErrorTextDialog.
#
# Gtk2-Ex-ErrorTextDialog is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Gtk2-Ex-ErrorTextDialog is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Gtk2-Ex-ErrorTextDialog.  If not, see .


# If there's both errors and warnings from a "require" file then a
# $SIG{'__WARN__'} handler can run while PL_error_count is non-zero.  In
# that case it's not possible to load modules within the warn handler, they
# get "BEGIN not safe after compilation error".
#
# The strategy against this is to pre-load enough to get a message to STDERR
# and install a Glib idle handler to load Gtk2::Ex::ErrorTextDialog and
# create that dialog.
#
package Gtk2::Ex::ErrorTextDialog::Handler;
use 5.008001; # for utf8::is_utf8() and PerlIO::get_layers()
use strict;
use warnings;
use Devel::GlobalDestruction ();
use Glib;
use Encode;
use I18N::Langinfo;  # CODESET
use PerlIO;          # for F_UTF8

our $VERSION = 11;

# set this to 1 for some diagnostic prints (to STDERR)
use constant DEBUG => 0;

my $_idle_another_message;
my $_idle_recursions = 0;
my $_idle_handler_id;

our $exception_handler_depth = 0;

sub exception_handler {
  my ($msg) = @_;
  if (DEBUG) { print STDERR "exception_handler() $exception_handler_depth\n"; }

  # Normally $SIG handlers run with themselves shadowed out, and the Glib
  # exception handler doesn't re-invoke, so suspect warnings or errors in
  # the code here won't recurse normally, but have this as some protection
  # just in case.
  #
  if ($exception_handler_depth >= 3) {
    return 1; # stay installed
  }
  if ($exception_handler_depth >= 2) {
    print STDERR "ErrorTextDialog Handler: ignoring recursive exception_handler calls\n";
    return 1; # stay installed
  }
  local $exception_handler_depth = $exception_handler_depth + 1;
  if (DEBUG) { print STDERR "  depth now $exception_handler_depth\n"; }

  #--------------------------------------------

  if (_fh_prints_wide('STDERR')) {
    $msg = _maybe_locale_bytes_to_wide ($msg);
  }
  print STDERR $msg;

  #--------------------------------------------

  if ($_idle_recursions == 4) {
    $_idle_recursions++;
    print STDERR "ErrorTextDialog Handler: repeated messages adding to dialog, skip GUI from now on\n";

  } elsif ($_idle_recursions < 4
           && ! Devel::GlobalDestruction::in_global_destruction()) {
    $_idle_another_message = 1;
    push @Gtk2::Ex::ErrorTextDialog::_instance_pending, $msg;

    # try to protect against unbounded growth of @_instance_pending
    if (@Gtk2::Ex::ErrorTextDialog::_instance_pending > 500) {
      splice @Gtk2::Ex::ErrorTextDialog::_instance_pending, 0, -500,
        '[Big slew of pending messages truncated ...]';
    }

    $_idle_handler_id ||= Glib::Idle->add
      (\&_idle_handler, undef, Glib::G_PRIORITY_HIGH);
  }

  if (DEBUG) { print STDERR "exception_handler() end\n"; }
  return 1; # stay installed
}

# $_idle_handler_id is zapped at the start so exception_handler() will add
# another _idle_handler() for any further messages generated within the
# present _idle_handler() run.  Anything before popup_add_message() will be
# covered by the present run, but anything after it needs another run.
#
# $_idle_recursions is incremented at the start as a worst case assumption
# that the code will die.  Then if the code runs successfully to the end it
# can be cleared.  It's cleared only if there were no further messages
# generated from within _idle_handler().  Further messages are noted by
# exception_handler() setting $_idle_another_message.
#
sub _idle_handler {
  $_idle_recursions++;
  $_idle_another_message = 0;
  undef $_idle_handler_id;
  if (DEBUG) { print STDERR "idle_handler() runs $_idle_recursions\n"; }

  require Gtk2::Ex::ErrorTextDialog;
  Gtk2::Ex::ErrorTextDialog->popup_add_message (undef);

  if (! $_idle_another_message) {
    $_idle_recursions = 0;
  }
  if (DEBUG) {
    print STDERR "idle_handler() end, recursions now $_idle_recursions\n";
  }
  return 0; # Glib::SOURCE_REMOVE
}

sub log_handler {
  require Gtk2::Ex::ErrorTextDialog;
  exception_handler (Gtk2::Ex::ErrorTextDialog::_log_to_string (@_));
}

#-----------------------------------------------------------------------------
# generic helpers

# _fh_prints_wide($fh) returns true if wide chars can be printed to file
# handle $fh.
#
# PerlIO::get_layers() is pre-loaded, probably, but PerlIO::F_UTF8() from
# PerlIO.pm is not.
#
sub _fh_prints_wide {
  my ($fh) = @_;
  return (PerlIO::get_layers($fh, output => 1, details => 1))[-1] # top flags
    & PerlIO::F_UTF8();
}

# If $str is not wide, and it has some non-ascii, then try to decode them in
# the locale charset.  PERLQQ means bad stuff is escaped.
sub _maybe_locale_bytes_to_wide {
  my ($str) = @_;
  if (! utf8::is_utf8 ($str) && $str =~ /[^[:ascii:]]/) {
    require Encode;
    $str = Encode::decode (_locale_charset_or_ascii(),
                           $str, Encode::FB_PERLQQ());
  }
  return $str;
}

# _locale_charset_or_ascii() returns the locale charset from I18N::Langinfo,
# or 'ASCII' if nl_langinfo() is not available.
#
# langinfo() croaks "nl_langinfo() not implemented on this architecture" if
# not available.  Though anywhere able to run Gtk would have nl_langinfo(),
# wouldn't it?
#
my $_locale_charset_or_ascii;
sub _locale_charset_or_ascii {
  goto $_locale_charset_or_ascii;
}
BEGIN {
  $_locale_charset_or_ascii = sub {
    my $subr = sub { I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()) };
    if (! eval { &$subr(); 1 }) {
      $subr = sub { 'ASCII' };
    }
    goto ($_locale_charset_or_ascii = $subr);
  };
}


1;
__END__