view release on metacpan or  search on metacpan

devel/cross-ids.pl  view on Meta::CPAN

#!/usr/bin/perl -w

# Copyright 2008, 2009, 2010 Kevin Ryde

# This file is part of Gtk2-Ex-Xor.
#
# Gtk2-Ex-Xor 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-Xor 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-Xor.  If not, see <http://www.gnu.org/licenses/>.


use strict;
use warnings;
use FindBin;
use Gtk2 '-init';
use Gtk2::Ex::CrossHair;
use Data::Dumper;

my $progname = $FindBin::Script;

my $widget = Gtk2::Window->new ('toplevel');
$widget->set_size_request (100, 100);
show_wait ($widget);

# temporary warp to have mouse pointer within $widget
my $display = $widget->get_display;
my ($screen,$x,$y) = $display->get_pointer;
my ($widget_x,$widget_y) = $widget->window->get_origin;
$display->warp_pointer($widget->get_screen,$widget_x+50,$widget_y+50);

is_deeply (leftover_fields($widget), [],
           'weaken active - initially no CrossHair data');

my $cross = Gtk2::Ex::CrossHair->new (widget => $widget);
is_deeply (leftover_fields($widget), [],
           'weaken active - initially no CrossHair data');
$cross->start;
diag explain $cross;
# sync and iterate to make the cross draw and use its gc
$display->sync;
MyTestHelpers::main_iterations();

is_deeply (leftover_fields($widget), [],
           'weaken active - initially no CrossHair data');

my $weak_cross = $cross;
Scalar::Util::weaken ($weak_cross);
$cross = undef;
MyTestHelpers::main_iterations();
is ($weak_cross, undef, 'weaken active - destroyed');
is_deeply (leftover_fields($widget), [],
           'weaken active - no CrossHair data left behind');

$widget->destroy;
$display->warp_pointer($screen,$x,$y);
exit 0;
}

  my $toplevel = Gtk2::Window->new('toplevel');
$toplevel->signal_connect (destroy => sub { Gtk2->main_quit });

my $hbox = Gtk2::HBox->new (0, 0);
$toplevel->add ($hbox);

my $frame = Gtk2::Frame->new;
$hbox->pack_start ($frame, 0,0,0);

my $vbox1 = Gtk2::VBox->new (0, 0);
$frame->add ($vbox1);

my $vbox = Gtk2::VBox->new (0, 0);
$hbox->pack_start ($vbox, 1,1,0);

my $area1_width = 400;
my $area1_height = 200;

my $layout = Gtk2::Layout->new;
$layout->set_size_request ($area1_width+20, $area1_height+20);
$vbox->pack_start ($layout, 1, 1, 0);

my $area1 = Gtk2::DrawingArea->new;
$area1->modify_fg ('normal', Gtk2::Gdk::Color->parse ('white'));
$area1->modify_bg ('normal', Gtk2::Gdk::Color->parse ('black'));
$area1->set_name ('one');
$area1->set_size_request (400, 200);
$area1->set_flags ('can-focus');
$area1->grab_focus;
$layout->add ($area1);
$area1->signal_connect (expose_event => sub {
                          print "$progname: area1 expose $area1\n";
                          return Gtk2::EVENT_PROPAGATE;
                        });

{
  my $label = Gtk2::Label->new (" xxx ");
  $vbox->add ($label);
}

my $area2 = Gtk2::DrawingArea->new;
$area2->set_name ('two');
$area2->set_size_request (400, 200);
$area2->set_flags ('can-focus');
$vbox->add ($area2);

{
  my $label = Gtk2::Label->new (" xxx ");
  $vbox->add ($label);
}