Gtk2::Ex::ErrorTextDialog - display error messages in a dialog

 # explicitly adding a message
 use Gtk2::Ex::ErrorTextDialog;
 Gtk2::Ex::ErrorTextDialog->add_message ("Something went wrong");

 # handler for all Glib exceptions
 use Gtk2::Ex::ErrorTextDialog::Handler;
 Glib->install_exception_handler
   (\&Gtk2::Ex::ErrorTextDialog::Handler::exception_handler);

    Gtk2::Widget
      Gtk2::Container
        Gtk2::Bin
          Gtk2::Window
            Gtk2::Dialog
              Gtk2::MessageDialog
                Gtk2::Ex::ErrorTextDialog

    +------------------------------------+
    |   !!    An error has occurred      |
    | +--------------------------------+ |
    | | Something at foo.pl line 123   | |
    | | -----                          | |
    | | Cannot whatever at Bar.pm line | |
    | | 456                            | |
    | |                                | |
    | +--------------------------------+ |
    +------------------------------------+
    |              Clear  Save-As  Close |
    +------------------------------------+

    binding "my_error_keys" {
      bind "F5" { "popup-save-dialog" () }
    }
    class "Gtk2__Ex__ErrorTextDialog" binding:rc "my_error_keys"

# Copyright 2007, 2008, 2009, 2010, 2011 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 <http://www.gnu.org/licenses/>.


package Gtk2::Ex::ErrorTextDialog;
use 5.008001; # for utf8::is_utf8()
use strict;
use warnings;
use Gtk2;
use List::Util 'max';
use Locale::TextDomain 1.16; # version 1.16 for bind_textdomain_filter()
use Locale::TextDomain ('Gtk2-Ex-ErrorTextDialog');
use Locale::Messages;
use POSIX ();
use Glib::Ex::ObjectBits;
use Gtk2::Ex::Units 14; # version 14 for char_width

our $VERSION = 10;

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

Locale::Messages::bind_textdomain_codeset ('Gtk2-Ex-ErrorTextDialog','UTF-8');
Locale::Messages::bind_textdomain_filter  ('Gtk2-Ex-ErrorTextDialog',
                                           \&Locale::Messages::turn_utf_8_on);

use Glib::Object::Subclass
  'Gtk2::MessageDialog',
  signals => { destroy => \&_do_destroy,

               clear =>
               { param_types => [],
                 return_type => undef,
                 class_closure => \&_do_clear,
                 flags => ['run-last','action'] },

               popup_save_dialog =>
               { param_types => [],
                 return_type => undef,
                 class_closure => \&_do_popup_save_dialog,
                 flags => ['run-last','action'] },
             },

  properties => [ Glib::ParamSpec->int
                  ('max-chars',
                   __('Maximum characters'),
                   'Maximum number of characters to retain, or -1 for unlimited.',
                   -1,                 # minimum
                   POSIX::INT_MAX(),   # maximum
                   200_000,            # default
                   Glib::G_PARAM_READWRITE) ];

use constant {
              # not yet documented
              _RESPONSE_CLEAR   => 0,
              _RESPONSE_SAVE    => 1,
              # _NEXT_RESPONSE    => 2,

              # not yet documented ...
              _MESSAGE_SEPARATOR => "--------\n",
             };

my $instance;
our @_instance_pending;

sub instance {
  my ($class) = @_;
  if (! $instance) {
    $instance = $class->new;
    $instance->signal_connect (delete_event=>\&Gtk2::Widget::hide_on_delete);
  }
  return $instance;
}

# return true if $class_or_self is the shared $instance
sub _is_instance {
  my ($class_or_self) = @_;
  return (! ref $class_or_self  # class name means the instance
          || ($instance && $class_or_self == $instance));
}

sub INIT_INSTANCE {
  my ($self) = @_;

  {
    my $title = __('Errors');
    if (defined (my $appname = Glib::get_application_name())) {
      $title = "$appname: $title";
    }
    $self->set_title ($title);
  }
  $self->set (message_type => 'error',
              resizable => 1);

  {
    my $check = $self->{'popup_checkbutton'}
      = Gtk2::CheckButton->new_with_mnemonic (__('_Popup on Error'));
    $check->set_active (1);
    Glib::Ex::ObjectBits::set_property_maybe
        ($check,
         # tooltip-text new in Gtk 2.12
         tooltip_text => __('Whether to popup this dialog when an error occurs.
If errors are occurring repeatedly you might not want a popup every time.'));

    $self->add_action_widget ($check, 'none');
  }
  {
    my $button = $self->add_button ('gtk-save-as', _RESPONSE_SAVE);
    Glib::Ex::ObjectBits::set_property_maybe
        ($button,
         # tooltip-text new in Gtk 2.12
         tooltip_text => __('Save the error messages to a file, perhaps to include in a bug report.
(Cut and paste works too, but saving may be better for very long messages.)'));
  }
  $self->add_buttons ('gtk-clear' => _RESPONSE_CLEAR,
                      'gtk-close' => 'close');

  # connect to self instead of a class handler because as of Gtk2-Perl 1.220
  # a Gtk2::Dialog class handler for 'response' is called with response IDs
  # as numbers, not enum strings like 'close'
  $self->signal_connect (response => \&_do_response);

  my $vbox = $self->vbox;

  my $scrolled = Gtk2::ScrolledWindow->new;
  $scrolled->set_policy ('never', 'always');
  $vbox->pack_start ($scrolled, 1,1,0);

  my $textbuf = $self->{'textbuf'} = Gtk2::TextBuffer->new;
  $textbuf->signal_connect ('changed', \&_do_textbuf_changed, $self);
  _do_textbuf_changed ($textbuf, $self);  # initial settings

  require Gtk2::Ex::TextView::FollowAppend;
  my $textview = $self->{'textview'}
    = Gtk2::Ex::TextView::FollowAppend->new_with_buffer ($textbuf);
  $textview->set (wrap_mode => 'char',
                  editable  => 0);
  $scrolled->add ($textview);

  $vbox->show_all;
  $self->set_default_size_chars (70, 20);
}

# 'destroy' class closure
# this can be called more than once!
sub _do_destroy {
  my ($self) = @_;
  if (DEBUG) { print "ErrorTextDialog destroy $self\n"; }

  # Break circular reference from $textbuf 'changed' signal userdata $self.
  # Nothing for $self->{'save_dialog'} as it's destroy-with-parent already.
  delete $self->{'textbuf'};

  if ($self->_is_instance) {
    # ready for subsequence instance() call to make a new one
    undef $instance;
  }
  $self->signal_chain_from_overridden;
}

# 'changed' signal on the textbuf
sub _do_textbuf_changed {
  my ($textbuf, $self) = @_;
  if (DEBUG) { print "ErrorTextDialog textbuf changed\n"; }
  my $any_errors = ($textbuf->get_char_count != 0);
  _message_dialog_set_text ($self, $any_errors
                            ? __('An error has occurred')
                            : __('No errors'));
  $self->set_response_sensitive (_RESPONSE_CLEAR, $any_errors);
}

# set_default_size() based on desired size_request() with a sensible rows
# and columns size for the TextView.  This is just a default, the user can
# resize to smaller.  Must have 'resizable' turned on in INIT_INSTANCE above
# to make this work (the default from GtkMessageDialog is resizable false).
#
# not documented yet ...
sub set_default_size_chars {
  my ($self, $width_chars, $height_lines) = @_;
  my $textview = $self->{'textview'};
  my $scrolled = $textview->get_parent;

  # Width set on textview so the vertical scrollbar is added on top.  But
  # height set on the scrolled since its vertical scrollbar means any
  # desired height from the textview is ignored.
  #
  Gtk2::Ex::Units::set_default_size_with_subsizes
      ($self,
       [ $scrolled, -1, $height_lines*Gtk2::Ex::Units::line_height($textview)],
       [ $textview, "$width_chars chars", -1 ]);
}

#-----------------------------------------------------------------------------
# button/response actions

sub _do_response {
  my ($self, $response) = @_;
  if ($response eq _RESPONSE_CLEAR) {
    $self->clear;

  } elsif ($response eq _RESPONSE_SAVE) {
    $self->popup_save_dialog;

  } elsif ($response eq 'close') {
    # as per a keyboard close, defaults to raising 'delete-event', which in
    # turn defaults to a destroy
    $self->signal_emit ('close');
  }
}

sub clear {
  my ($self) = @_;
  $self = $self->instance unless ref $self;
  $self->signal_emit ('clear');
}
sub _do_clear {
  my ($self) = @_;
  my $textbuf = $self->{'textbuf'};
  $textbuf->delete ($textbuf->get_start_iter, $textbuf->get_end_iter);
}

sub popup_save_dialog {
  my ($self) = @_;
  $self = $self->instance unless ref $self;
  $self->signal_emit ('popup-save-dialog');
}
sub _do_popup_save_dialog {
  my ($self) = @_;
  $self->_save_dialog->present;
}

# create and return the save dialog -- might make this public one day
sub _save_dialog {
  my ($self) = @_;
  return ($self->{'save_dialog'} ||= do {
    require Gtk2::Ex::ErrorTextDialog::SaveDialog;
    my $save_dialog = Gtk2::Ex::ErrorTextDialog::SaveDialog->new;
    # set_transient_for() is always available, whereas 'transient-for' as
    # property only since gtk 2.10
    $save_dialog->set_transient_for ($self);
    $save_dialog
  });
}

#-----------------------------------------------------------------------------
# messages

sub get_text {
  my ($self) = @_;
  return $self->{'textbuf'}->get('text');
}

sub add_message {
  my ($self, $msg) = @_;
  if (DEBUG) { print "add_message()\n"; }
  $self = $self->instance unless ref $self;

  require Gtk2::Ex::ErrorTextDialog::Handler;
  my $textbuf = $self->{'textbuf'};
  my @msgs;

  if ($self->_is_instance && @_instance_pending) {
    if (DEBUG) { print "  ", scalar(@_instance_pending), " pending\n"; }

    # copy the global in case some warning from the code here extending it,
    # making an infinite loop
    @msgs = @_instance_pending;
    @_instance_pending = ();

    foreach my $pending (@msgs) {
      $pending = Gtk2::Ex::ErrorTextDialog::Handler::_maybe_locale_bytes_to_wide ($pending);
      if ($pending !~ /\n$/) { $pending .= "\n"; }
    }

    # Various internal Perl_warn() and Perl_warner() calls have the warning
    # followed immediately by a second warn call with an extra remark about
    # what might be wrong.  The extras begin with a tab, join them up to the
    # initial warning instead of a separate message.  Do this after
    # bytes->wide crunch, just in case one is wide and the other bytes.
    #
    # The initial message and any continuations are always in
    # @_instance_pending together, because the idle handler deferring lets
    # the continuation go through $SIG{__WARN__} before the code here runs.
    #
    # die() gives similar tab continuations when "propagating" an error (see
    # L<perlfunc/die>), but in that case it's within a single string so
    # needs nothing special.
    #
    for (my $i = 0; $i < $#msgs; ) {
      if ($msgs[$i+1] =~ /^\t/) {
        $msgs[$i] .= splice @msgs, $i+1, 1;
      } else {
        $i++;
      }
    }
  }

  if (defined $msg) {
    $msg = Gtk2::Ex::ErrorTextDialog::Handler::_maybe_locale_bytes_to_wide ($msg);
    if ($msg !~ /\n$/) { $msg .= "\n"; }
    push @msgs, $msg;
  }

  # can have no messages here if the idle handler for @_instance_pending
  # runs after that array has been crunched by an explicit add_message()
  # call
  if (@msgs) {
    if ($textbuf->get_char_count) {
      unshift @msgs, ''; # want separator after existing textbuf text
    }
    my $text = join (_MESSAGE_SEPARATOR, @msgs);
    $textbuf->insert ($textbuf->get_end_iter, $text);
    _truncate ($self);
  }
}

sub _truncate {
  my ($self) = @_;
  my $max_chars = $self->get('max-chars');
  return if ($max_chars == -1);

  my $textbuf = $self->{'textbuf'};
  my $len = $textbuf->get_char_count;
  # extra 82 for $discard_message, possibly translated, and "\n\n"
  return if ($len <= $max_chars + 82);

  # TRANSLATORS: The code currently assumes this string is 80 chars or less.
  my $discard_message = __('[Older messages discarded]');

  $textbuf->delete ($textbuf->get_start_iter,
                    $textbuf->get_iter_at_offset ($len - $max_chars));
  $textbuf->insert ($textbuf->get_start_iter,
                    "$discard_message\n\n");
}

# not sure about this yet, an in particular which popup follows the
# popup-on-error checkbox and which is a programmatic always popup ...
#
# =item C<< Gtk2::Ex::ErrorTextDialog->popup_add_message ($str) >>
#
# =item C<< Gtk2::Ex::ErrorTextDialog->popup_add_message ($str, $parent) >>
#
# =item C<< $errordialog->popup_add_message ($str) >>
#
# =item C<< $errordialog->popup_add_message ($str, $parent) >>
#
# Add C<$str> to the error dialog with C<add_message> below, and popup the
# dialog so it's visible.
#
# Optional C<$parent> is a widget which the error relates to, or C<undef> for
# none.  C<$parent> may help the window manager position the error dialog when
# first displayed, but is not used after that.
#
# not documented yet ...
sub popup_add_message {
  my ($self, $msg, $parent) = @_;
  $self = $self->instance unless ref $self;

  if ($self->{'popup_checkbutton'}->get_active) {
    $self->popup ($parent);
  }
  $self->add_message ($msg);
}
# not documented yet ...
sub popup {
  my ($self, $parent) = @_;
  $self = $self->instance unless ref $self;

  if ($self->mapped) {
    # too intrusive to raise every time
    # $self->window->raise;
  } else {
    # allow for $parent a non-toplevel
    if ($parent) { $parent = $parent->get_toplevel; }
    $self->set_transient_for ($parent);
    $self->present;
    $self->set_transient_for (undef);
  }
}

# ENHANCE-ME: would prefer to show the same string as
# g_log_default_handler(), or even what gperl_log_handler() gives
sub _log_to_string {
  my ($log_domain, $log_level, $message) = @_;

  $log_level -= ['recursion','fatal'];
  $log_level = join('-', @$log_level) || 'LOG';

  return (($log_domain ? "$log_domain-" : "** ")
          . "\U$log_level\E: "
          . (defined $message ? $message : "(no message)"));
}

# probably not wanted ...
# sub popup_add_log {
#   my ($class_or_self, $log_domain, $log_level, $message, $parent) = @_;
#   $self->popup ($parent);
#   $self->add_log ($log_domain, $log_level, $message);
# }
# sub add_log {
#   my ($class_or_self, $log_domain, $log_level, $message) = @_;
#   $class_or_self->add_message
#     (_log_to_string ($log_domain, $log_level, $message));
# }

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

# _message_dialog_set_text() sets the text part of a Gtk2::MessageDialog.
# Gtk 2.10 up has this as a 'text' property, or in past versions it's
# necessary to dig out the label child widget.
#
# It doesn't work to choose between the dialog or sub-widget and to make a
# set() or set_text() call on.  Gtk2::MessageDialog doesn't have a
# set_text() method, and Gtk2::Label doesn't have a 'text' property, so must
# have separate code for the old or new gtk.
#
# This is in a BEGIN block so the unused sub is garbage collected.
#
BEGIN {
  *_message_dialog_set_text = Gtk2::MessageDialog->find_property('text')
    ? sub {
      my ($dialog, $text) = @_;
      $dialog->set (text => $text);
    }
      : sub {
        my ($dialog, $text) = @_;
        my $label = ($dialog->{__PACKAGE__.'--text-widget'} ||= do {
          require List::Util;
          my $l;
          my @w = grep {$_->isa('Gtk2::HBox')} $dialog->vbox->get_children;
          for (;;) {
            if (! @w) {
              require Carp;
              Carp::croak ('_message_dialog_text_widget(): oops, label not found');
            }
            $l = List::Util::first (sub {ref $_ eq 'Gtk2::Label'}, @w)
              and last;
            @w = map {$_->isa('Gtk2::Box') ? $_->get_children : ()} @w;
          }
          $l
        });
        $label->set_text ($text);
      };
}

1;
__END__

# Unused stuff:

  #   {
  #     my $nopopup = $self->{'nopopup'}
  #       = Gtk2::CheckButton->new_with_mnemonic (__('_No Popup'));
  #     if ($nopopup->can('set_tooltip_text')) {
  #       # new style of Gtk 2.12
  #       $nopopup->set_tooltip_text
  #         (__('Check this to not popup automatically.
  # Messages are recorded, but the dialog is not popped up.
  # This is good to ignore a cascade of errors.'));
  #     }
  #     $self->action_area->pack_start ($nopopup, 0,0,0);
  #
  #     if ($nopopup->can('set_tooltip_text')) { # new in Gtk 2.12
  #       $nopopup->set_tooltip_text
  #         (__('Check this to not popup automatically.
  # Messages are recorded, but the dialog is not popped up.
  # This is good to ignore a cascade of errors.'));
  #     }
  #   }

# Truncating on a message boundary ...
#
#   my $str = $textbuf->get('text');
#   my $from = length($str) - $max_chars;
#
#   # if $from is in the middle or just after a separator then that's the
#   # place to truncate; step back by length(_MESSAGE_SEPARATOR) to allow that
#   # to match
#   my $pos = index ($str, _MESSAGE_SEPARATOR,
#                    max (0, $from - length(_MESSAGE_SEPARATOR)));
#   if ($pos < 0) {
#     # $from is somewhere within some huge last message in the buffer, search
#     # backwards to the separator preceding it
#     $pos = rindex ($str, _MESSAGE_SEPARATOR, max (0, $from));
#     return if $pos < 0;  # only one message
#   }
#
#   $pos += length(_MESSAGE_SEPARATOR);
#   $textbuf->delete ($textbuf->get_start_iter,
#                     $textbuf->get_iter_at_offset($pos));

# append a newline to $textbuf if it's non-empty and doesn't already end
# with a newline
# sub _textbuf_ensure_final_newline {
#   my ($textbuf) = @_;
#   my $len = $textbuf->get_char_count || return;  # nothing added if empty
#
#   my $end_iter = $textbuf->get_end_iter;
#   if ($textbuf->get_text ($textbuf->get_iter_at_offset($len-1),
#                           $end_iter,
#                           0) # without invisible text
#       ne "\n") {
#     $textbuf->insert ($end_iter, "\n");
#   }
# }