File Coverage

blib/lib/Gtk2/Ex/ErrorTextDialog.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

# Copyright 2007, 2008, 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 .


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 = 11;

# 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 RESPONSE_CLEAR => 0;
use constant RESPONSE_SAVE  => 1;

# not yet documented ...
use constant _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', $self->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' => $self->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 ($self->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 $self->RESPONSE_CLEAR) {
    $self->clear;

  } elsif ($response eq $self->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), 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 below, and popup the
# dialog so it's visible.
#
# Optional C<$parent> is a widget which the error relates to, or C 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($messagedialog,$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__