view release on metacpan or  search on metacpan

t/MyTestHelpers.pm  view on Meta::CPAN

  if ($gtk2_loaded) {
    MyTestHelpers::diag ("Perl-Gtk2    version ",Gtk2->VERSION);
  }
  if ($glib_loaded) { # when loaded
    MyTestHelpers::diag ("Perl-Glib    version ",Glib->VERSION);
    MyTestHelpers::diag ("Compiled against Glib version ",
                         Glib::MAJOR_VERSION(), ".",
                         Glib::MINOR_VERSION(), ".",
                         Glib::MICRO_VERSION(), ".");
    MyTestHelpers::diag ("Running on       Glib version ",
                         Glib::major_version(), ".",
                         Glib::minor_version(), ".",
                         Glib::micro_version(), ".");
  }
  if ($gtk2_loaded) {
    MyTestHelpers::diag ("Compiled against Gtk version ",
                         Gtk2::MAJOR_VERSION(), ".",
                         Gtk2::MINOR_VERSION(), ".",
                         Gtk2::MICRO_VERSION(), ".");
    MyTestHelpers::diag ("Running on       Gtk version ",
                         Gtk2::major_version(), ".",
                         Gtk2::minor_version(), ".",
                         Gtk2::micro_version(), ".");
  }
  if ($gtk1_loaded) {
    MyTestHelpers::diag ("Running on       Gtk version ",
                         Gtk->major_version(), ".",
                         Gtk->minor_version(), ".",
                         Gtk->micro_version(), ".");
  }
}

# Return true if there's any signal handlers connected to $obj.
#
# Signal IDs are from 1 up, don't pass 0 to signal_handler_is_connected()
# since in Glib 2.4.1 it spits out a g_log() error.
#
sub any_signal_connections {
  my ($obj) = @_;
  my @connected = grep {$obj->signal_handler_is_connected ($_)} (1 .. 500);
  if (@connected) {
    my $connected = join(',',@connected);
    MyTestHelpers::diag ("$obj signal handlers connected: $connected");
    return $connected;
  }
  return undef;
}

# wait for $signame to be emitted on $widget, with a timeout
sub wait_for_event {
  my ($widget, $signame) = @_;
  if (DEBUG) { MyTestHelpers::diag ("wait_for_event() $signame on ",$widget); }
  my $done = 0;
  my $got_event = 0;
  my $sig_id = $widget->signal_connect
    ($signame => sub {
       if (DEBUG) { MyTestHelpers::diag ("wait_for_event()   $signame received"); }
       $done = 1;
       return 0; # Gtk2::EVENT_PROPAGATE (new in Gtk2 1.220)
     });
  my $timer_id = Glib::Timeout->add
    (30_000, # 30 seconds
     sub {
       $done = 1;
       MyTestHelpers::diag ("wait_for_event() oops, timeout waiting for $signame on ",$widget);
       return 1; # Glib::SOURCE_CONTINUE (new in Glib 1.220)
     });
  if ($widget->can('get_display')) {
    # display new in Gtk 2.2
    $widget->get_display->sync;
  } else {
    # in Gtk 2.0 gdk_flush() is a sync actually
    Gtk2::Gdk->flush;
  }

  my $count = 0;
  while (! $done) {
    if (DEBUG >= 2) { MyTestHelpers::diag ("wait_for_event()   iteration $count"); }
    Gtk2->main_iteration;
    $count++;
  }
  MyTestHelpers::diag ("wait_for_event(): '$signame' ran $count events/iterations\n");

  $widget->signal_handler_disconnect ($sig_id);
  Glib::Source->remove ($timer_id);
}


#-----------------------------------------------------------------------------
# X11::Protocol helpers

sub X11_chosen_screen_number {
  my ($X) = @_;
  my $i;
  foreach $i (0 .. $#{$X->{'screens'}}) {
    if ($X->{'screens'}->[$i]->{'root'} == $X->{'root'}) {
      return $i;
    }
  }
  die "Oops, current screen not found";
}

sub X11_server_info {
  my ($X) = @_;
  MyTestHelpers::diag("");
  MyTestHelpers::diag("X server info");
  MyTestHelpers::diag("vendor: ",$X->{'vendor'});
  MyTestHelpers::diag("release_number: ",$X->{'release_number'});
  MyTestHelpers::diag("protocol_major_version: ",$X->{'protocol_major_version'});
  MyTestHelpers::diag("protocol_minor_version: ",$X->{'protocol_minor_version'});
  MyTestHelpers::diag("byte_order: ",$X->{'byte_order'});
  MyTestHelpers::diag("num screens: ",scalar(@{$X->{'screens'}}));
  MyTestHelpers::diag("width_in_pixels:  ",$X->{'width_in_pixels'});
  MyTestHelpers::diag("height_in_pixels: ",$X->{'height_in_pixels'});
  MyTestHelpers::diag("width_in_millimeters:  ",$X->{'width_in_millimeters'});
  MyTestHelpers::diag("height_in_millimeters: ",$X->{'height_in_millimeters'});

  MyTestHelpers::diag("root_visual: ",$X->{'root_visual'});
  my $visual_info = $X->{'visuals'}->{$X->{'root_visual'}};
  MyTestHelpers::diag("  depth: ",$visual_info->{'depth'});
  MyTestHelpers::diag("  class: ",$visual_info->{'class'},