# Copyright 2007, 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 . package Gtk2::Ex::CrossHair; use 5.008; use strict; use warnings; use Carp; use List::Util; use Scalar::Util 1.18 'refaddr'; # 1.18 for pure-perl refaddr() fix use POSIX (); # 1.200 for Gtk2::GC auto-release use Gtk2 1.200; use Glib::Ex::SignalIds; use Gtk2::Ex::Xor; use Gtk2::Ex::WidgetBits 31; # v.31 for xy_root_to_widget() # uncomment this to run the ### lines #use Smart::Comments; our $VERSION = 19; # In each CrossHair the private fields are # # xy_widget # The widget to report in the 'moved' signal, or undef. # # root_x,root_y # The current or pending x,y of the crosshair in root coordinates. # root_x is undef if the crosshair is outside any widget and therefore # not to be drawn (in "keyboard" mode rather than implicit-grab button # mode). # # xy_widget and root_x,root_y are set immediately by _maybe_move() for # a mouse motion etc, but the actual drawing of them is later in the # sync_call_handler(). # # wcursor # Gtk2::Ex::WidgetCursor object putting an invisible cursor in the # crosshair widgets. # # The _pw() func gives a hash of per-widget data. Its fields are # # static_ids # Glib::Ex::SignalIds of signal connections made for as long as the # widget is in the crosshair. # dynamic_ids # Glib::Ex::SignalIds of signal connections made only while the # crosshair is active. # gc # A Gtk2::GC shared gc to draw with. Created by the _draw() code when # needed, deleted by style-set etc for colour changes etc. # x,y # Position in widget coordinates at which the crosshair is drawn in # the widget. 'x' doesn't exist in the hash if the position is not # yet decided. 'x' is undef if the cross is entirely outside the # widget and thus there's nothing to draw. # # The per-widget data could be in a Tie::RefHash or inside-out thingie or # similar to keep out of the target widgets. Would that be worthwhile? The # widget already has a handy hash to put things in, may as well use that # than load extra code. # use Glib::Object::Subclass 'Glib::Object', signals => { moved => { param_types => ['Gtk2::Widget', 'Glib::Scalar', 'Glib::Scalar'], return_type => undef }, }, properties => [ Glib::ParamSpec->scalar ('widgets', 'widgets', 'Arrayref of widgets to act on.', Glib::G_PARAM_READWRITE), Glib::ParamSpec->object ('widget', 'widget', 'Single widget to act on.', 'Gtk2::Widget', Glib::G_PARAM_READWRITE), Glib::ParamSpec->object ('add-widget', 'add-widget', 'Add a widget to act on.', 'Gtk2::Widget', 'writable'), Glib::ParamSpec->boolean ('active', 'active', 'Whether to display the crosshair.', 0, Glib::G_PARAM_READWRITE), Glib::ParamSpec->scalar ('foreground', 'foreground', 'The colour to draw the crosshair, either a string name (including hex RGB), a Gtk2::Gdk::Color, or undef for the widget\'s style foreground.', Glib::G_PARAM_READWRITE), Glib::ParamSpec->string ('foreground-name', 'foreground-name', 'The colour to draw the crosshair, as a string colour name.', (eval {Glib->VERSION(1.240);1} ? undef # default : ''), # no undef/NULL before Perl-Glib 1.240 Glib::G_PARAM_READWRITE), Glib::ParamSpec->boxed ('foreground-gdk', 'foreground-gdk', 'The colour to draw the crosshair, as a Gtk2::Gdk::Color object with red,greed,blue fields set (a pixel is looked up on each target widget).', 'Gtk2::Gdk::Color', Glib::G_PARAM_READWRITE), Glib::ParamSpec->int ('line-width', 'line-width', 'The width of the cross lines drawn.', 0, POSIX::INT_MAX(), # limits 0, # default Glib::G_PARAM_READWRITE), ]; sub INIT_INSTANCE { my ($self) = @_; ### CrossHair INIT_INSTANCE $self->{'button'} = 0; $self->{'pwhash'} = []; } sub FINALIZE_INSTANCE { my ($self) = @_; ### CrossHair finalize: "$self" $self->end; } sub _pw { my ($self, $widget) = @_; ### _pw: "@{[$widget||'[undef]']}" return $self->{'pwhash'}->{refaddr($widget)}; } sub _pw_list { my ($self) = @_; return values %{$self->{'pwhash'}}; } sub _widget_list { my ($self) = @_; return map {$_->{'widget'}} _pw_list($self); } sub GET_PROPERTY { my ($self, $pspec) = @_; my $pname = $pspec->get_name; ### CrossHair GET_PROPERTY: $pname if ($pname eq 'widget') { my @widgets = _widget_list($self); if (@widgets > 1) { croak 'Cannot get single \'widget\' property when using multiple widgets'; } return $widgets[0]; } if ($pname eq 'foreground_name') { my $foreground = $self->{'foreground'}; if (Scalar::Util::blessed($foreground) && $foreground->isa('Gtk2::Gdk::Color')) { $foreground = $foreground->to_string; # string "#RRRRGGGGBBBB" } return $foreground; } if ($pname eq 'foreground_gdk') { my $foreground = $self->{'foreground'}; ### $foreground if (defined $foreground && ! Scalar::Util::blessed($foreground)) { # Perl-Glib 1.220 doesn't copy a boxed return like Gtk2::Gdk::Color, # must keep the block of memory in a field $foreground = $self->{'_foreground_gdk'} = Gtk2::Gdk::Color->parse($foreground); } return $foreground; } return $self->{$pname}; } sub SET_PROPERTY { my ($self, $pspec, $newval) = @_; my $pname = $pspec->get_name; my $oldval = $self->{$pname}; ### CrossHair SET_PROPERTY: $pname if ($pname eq 'widget') { $pname = 'widgets'; $newval = [ $newval ]; $self->notify ('widgets'); } elsif ($pname eq 'add_widget') { $pname = 'widgets'; $newval = [ @{$self->{'widgets'}}, $newval ]; $self->notify ('widget'); $self->notify ('widgets'); } if ($pname eq 'widgets') { my $old = $self->{'pwhash'}; my $new = {}; foreach my $widget (@$newval) { my $key = refaddr($widget); $new->{$key} = $old->{$key} || Gtk2::Ex::CrossHair::PerWidget->new (widget => $widget, crosshair => $self); } $self->{'pwhash'} = $new; ### perwidget keys now: keys %{$self->{'pwhash'}} my $xy_widget = $self->{'xy_widget'}; my $root_x = $self->{'root_x'}; my $root_y = $self->{'root_y'}; if ($xy_widget && ! _pw($self,$xy_widget)) { ### xy_widget removed unless ($self->{'xy_widget'} = $xy_widget = List::Util::first (sub {_widget_contains_root_xy ($_, $root_x, $root_y)}, _widgets_list($self))) { # no drawing when not in any widget, per _do_leave_notify() undef $root_x; undef $root_y; } } $self->_maybe_move (_pw($xy_widget), $root_x, $root_y); _wcursor_update ($self); # new widget set $self->notify ('widget'); ### now widgets: "$self->{'widgets'} @{$self->{'widgets'}}" return; } if ($pname eq 'active') { # the extra '$self->notify' calls by running 'start' and 'end' here are # ok, Glib suppresses duplicates while in SET_PROPERTY if ($newval && ! $oldval) { $self->start; } elsif ($oldval && ! $newval) { $self->end; } } elsif ($pname =~ /^foreground/ || $pname eq 'line_width') { if ($pname =~ /^foreground/) { # must copy if 'foreground_gdk' since $newval points to a malloced # copy or something, copy scalar 'foreground' too just in case if (Scalar::Util::blessed($newval) && $newval->isa('Gtk2::Gdk::Color')) { $newval = $newval->copy; } $pname = 'foreground'; $self->notify('foreground'); $self->notify('foreground-name'); $self->notify('foreground-gdk'); } $self->{$pname} = $newval; foreach my $pw (_pw_list($self)) { $pw->change_gc; # new gc's for colour or width } } $self->{$pname} = $newval; # per default GET_PROPERTY } sub start { my ($self, $event) = @_; ### CrossHair start() my $button = $self->{'button'} = (ref $event && $event->can('button') ? $event->button : 0); if ($self->{'active'}) { return; } $self->{'active'} = 1; my $widgets = $self->{'widgets'}; _wcursor_update ($self); # initial root_x,root_y from event if given, or by round trip on the first # realized of $widgets otherwise # my ($root_x, $root_y); if (ref $event) { ($root_x, $root_y) = $event->root_coords; } else { foreach my $widget (@$widgets) { my $root_window = $widget->get_root_window || next; ### root_window: "$root_window" (undef, $root_x, $root_y) = $root_window->get_pointer; last; } } ### root x,y: $root_x, $root_y my $xy_widget; if ($button) { # button mode, use reported event widget as $xy_widget, if it's one of # ours my $eventwidget = Gtk2->get_event_widget ($event); $xy_widget = List::Util::first {$_ == $eventwidget} @$widgets; } elsif (defined $root_x) { # Non-button mode, initial $xy_widget as whichever of $widgets contains # the pointer, if any. After this enter and leave events maintain. $xy_widget = List::Util::first {_widget_contains_root_xy ($_, $root_x, $root_y)} @$widgets; if (! defined $xy_widget) { # no drawing when not in any widget, per _do_leave_notify() undef $root_x; undef $root_y; } } $self->{'xy_widget'} = $xy_widget; $self->{'root_x'} = $root_x; $self->{'root_y'} = $root_y; foreach my $pw (_pw_list($self)) { $pw->start; } $self->notify('active'); _sync_call_handler (\$self); # initial drawing immediately } sub _wcursor_update { my ($self) = @_; ### CrossHair _wcursor_update(): "$self" $self->{'wcursor'} = $self->{'active'} && do { require Gtk2::Ex::WidgetCursor; Gtk2::Ex::WidgetCursor->new (widgets => $self->{'widgets'}, cursor => 'invisible', active => 1) }; } sub end { my ($self) = @_; if (! $self->{'active'}) { return; } $self->signal_emit ('moved', undef, undef, undef); _undraw_all ($self); foreach my $pw (_pw_list($self)) { $pw->end; } $self->{'active'} = 0; _wcursor_update ($self); $self->notify('active'); } #----------------------------------------------------------------------------- sub _maybe_move { my ($self, $pw, $root_x, $root_y) = @_; #### _maybe_move: "@{[$widget||'[undef]']}", $root_x, $root_y my $widget = $pw && $pw->{'widget'}; $self->{'xy_widget'} = $widget; $self->{'root_x'} = $root_x; $self->{'root_y'} = $root_y; $self->{'sync_call'} ||= do { require Gtk2::Ex::SyncCall; ### new SyncCall on: "$self->{'widgets'}->[0]" if (my $widget = List::Util::first {$_->realized} @{$self->{'widgets'}}) { Gtk2::Ex::SyncCall->sync ($widget, \&_sync_call_handler, Gtk2::Ex::Xor::_ref_weak ($self)); } else { $self->signal_emit ('moved', undef, undef, undef); undef; } }; } sub _sync_call_handler { my ($ref_weak_self) = @_; my $self = $$ref_weak_self || return; ### CrossHair _sync_call_handler() $self->{'sync_call'} = undef; if (! $self->{'active'}) { return; } # turned off before sync returned _undraw_all ($self); # erase old _draw ($self); # draw new my ($xy_widget, $x, $y); if ($xy_widget = $self->{'xy_widget'}) { ($x, $y) = @{_pw($self,$xy_widget)}{'x','y'}; } $self->signal_emit ('moved', $xy_widget, $x, $y); } sub _undraw_all { my ($self, $widgets) = @_; $widgets ||= $self->{'widgets'}; ### CrossHair _undraw_all(): "@$widgets" foreach my $pw (values %{$self->{'pwhash'}}) { $pw->undraw; } ### CrossHair _undraw_all() done } #------------------------------------------------------------------------------ # generic helpers sub _event_root_coords { my ($event) = @_; # Do a get_pointer() to support 'pointer-motion-hint-mask'. # Maybe should use $display->get_state here instead of just get_pointer, # but crosshair and lasso at present only work with the mouse, not an # arbitrary input device. if ($event->can('is_hint') && $event->is_hint && (my $window = $event->window)) { return ($window->get_screen->get_root_window->get_pointer)[1,2]; } else { return $event->root_coords; } } # Return true if $x,$y in root window coordinates is within $widget's # allocated rectangle. # FIXME: Would like to exclude parts of $widget which are overlapped by # other widgets and/or windows. # sub _widget_contains_root_xy { my ($widget, $root_x, $root_y) = @_; my ($wx, $wy) = Gtk2::Ex::WidgetBits::xy_root_to_widget ($widget, $root_x, $root_y) or return 0; # $widget unrealized return _widget_contains_xy ($widget, $wx, $wy); } # Return true if $x,$y in widget coordinates is within $widget's allocated # rectangle. The rectangle $widget->allocation gives the size (its x,y # position relative to the windowed parent is ignored). # sub _widget_contains_xy { my ($widget, $x, $y) = @_; ### _widget_contains_xy(): $x,$y return ($x >= 0 && $y >= 0 && do { my $alloc = $widget->allocation; $x < $alloc->width && $y < $alloc->height }); } # sub _rect_contains_xy { # my ($rect, $x) = @_; # return ($rect->x <= $x # && $rect->y <= $y # && $rect->x + $rect->width >= $x # && $rect->y + $rect->height >= $y); # } # sub _xy_widget_to_root { # my ($widget, $x, $y) = @_; # my ($root_x, $root_y) = Gtk2::Ex::WidgetBits::get_root_position ($widget); # if (! defined $root_x) { # return; # if $widget unrealized # } else { # return ($root_x + $x, $root_y + $y); # } # } # _widget_translate_coordinates_toplevel() is the same as # gtk_widget_translate_coordinates, but allows widgets $src and $dst to be # under different toplevels. # # sub _widget_translate_coordinates_toplevel { # my ($src, $dst, $x, $y) = @_; # if (my @ret = $src->translate_coordinates ($dst, $x, $y)) { # return @ret; # } # require Gtk2::Ex::WidgetBits; # my ($src_x, $src_y) = Gtk2::Ex::WidgetBits::get_root_position ($src); # if (! defined $src_x) { # # $src not realized # return; # } # my ($dst_x, $dst_y) = Gtk2::Ex::WidgetBits::get_root_position ($dst); # if (! defined $dst_x) { # # $dst not realized # return; # } # return ($src_x + $x - $dst_x, # $src_y + $y - $dst_y); # } #------------------------------------------------------------------------------ # Not sure about these yet: # # Glib::ParamSpec->enum # ('line-style', # 'line-style', # 'blurb', # 'Gtk2::Gdk::LineStyle', # DEFAULT_LINE_STYLE, # Glib::G_PARAM_READWRITE), # # =item C (default C) # # Attributes for the graphics context (C) used to draw. New # settings here only take effect on the next C. For example, # # $crosshair->{'line_style'} = 'solid'; 1; __END__ =head1 NAME Gtk2::Ex::CrossHair -- crosshair lines drawn following the mouse =for test_synopsis my ($w1, $w2, $event) =head1 SYNOPSIS use Gtk2::Ex::CrossHair; my $crosshair = Gtk2::Ex::CrossHair->new (widgets => [$w1,$w2]); $crosshair->signal_connect (moved => sub { print_pos() }); $crosshair->start ($event); $crosshair->end (); =head1 OBJECT HIERARCHY C is a subclass of C. Glib::Object Gtk2::Ex::CrossHair =head1 DESCRIPTION A CrossHair object draws a horizontal and vertical line through the mouse pointer position on top of one or more widgets' existing contents. This is intended as a visual guide for the user. +-----------------+ | | | +-----------------+ | | mouse | | | | |/ | | | | --------+------ | | --------------- | | | | | | | | | | | | | | +-----------------+ | | | +-----------------+ The idea is to help see relative positions. For example in a graph the horizontal line helps you see which of two peaks is the higher, and the vertical line can extend down to (or into) an X axis scale to see where exactly a particular part of the graph lies. The C callback lets you update a text status line with a position in figures, etc (if you don't display something like that following the mouse all the time). While the crosshair is active the mouse cursor is set invisible in the target windows since the cross is enough feedback and a cursor tends to obscure the lines. This is done with the WidgetCursor mechanism (see L) and so cooperates with other widget or application uses of that. The crosshair is drawn using xors in the widget window (see L). =head1 FUNCTIONS =over 4 =item C<< Gtk2::Ex::CrossHair->new (key => value, ...) >> Create and return a new CrossHair object. Optional key/value pairs set initial properties as per C<< Glib::Object->new >>. Eg. my $ch = Gtk2::Ex::CrossHair->new (widgets => [ $widget ], foreground => 'orange'); =item C<< $crosshair->start () >> =item C<< $crosshair->start ($event) >> =item C<< $crosshair->end () >> Start or end crosshair display. For C the optional C<$event> is a C. If C<$event> is a mouse button press then the crosshair is active as long as that button is pressed. If C<$event> is a keypress, or C, or omitted, then the crosshair is active until explicitly stopped with an C call. =back =head1 PROPERTIES =over 4 =item C (boolean) True when the crosshair is to be drawn, moved, etc. Turning this on or off is the same as calling C or C above, except you can't pass a button press event. =item C (array of C) An arrayref of widgets to draw on. Often this will be just one widget, but multiple widgets can be given to draw in all of them at the same time. The widgets can be under different toplevel windows, but they should be all on the same screen (L|Gtk2::Gdk::Screen>) since mouse pointer movement in any of them is taken to be a position to draw through all of them (with coordinates translated appropriately). =item C (C or C) A single widget to operate on. The C and C properties access the same underlying set of widgets to operate on, you can set or get whichever best suits. But if there's more than one widget you can't get from the single C. =item C (colour scalar, default C) =item C (string, default C) =item C (C object, default C) The colour for the crosshair. This can be =over 4 =item * C (the default) for the widget style C foreground colour in each widget (see L). =item * A string colour name or #RGB form per C<< Gtk2::Gdk::Color->parse >> (see L). =item * A C object with C, C, C fields set. (A pixel value will be looked up in each widget.) =back All three C, C and C access the same underlying setting. C and C exist for use with C where the generic scalar C property can't be set. In the current code, if the foreground is a C object then C reads as its C like "#11112222333", or if foreground is a string name then C reads as parsed to a C. Is this a good idea? Perhaps it will change in the future. =item C (integer, default 0) The width in pixels of the crosshair lines. The default 0 means a 1-pixel "fast" line. Usually 1 pixel is enough but 2 or 3 may make the lines more visible on a high resolution screen. =back =head1 SIGNALS =over 4 =item moved (parameters: crosshair, widget, x, y, userdata) Emitted when the crosshair moves to the given C<$widget> and at X,Y coordinates within that widget (widget relative coordinates). C<$widget> is C if the mouse moves outside any of the crosshair widgets. It's worth noting a subtle difference in C reporting when a crosshair is activated from a button or from the keyboard. A button press causes an implicit grab and all events are reported to that widget's window. C then gives that widget and an X,Y position which might be outside the window area (eg. negative). But for a keyboard or programmatic start C reports the widget currently containing the mouse, or C when not in any. Usually the button press grab is good thing, it means a dragged button keeps reporting about the original window. =back =head1 BUILDABLE CrossHair can be created from C the same as other objects. The class name is C and it will normally be a top-level object with the C property telling it what to act on. drawingwidget orange The C property is the best way to control the colour. The generic C can't be used because it's a Perl scalar type. The C works since C knows how to parse a colour name to a C object, but the Builder also allocates a pixel in the default colormap, which is unnecessary as the CrossHair will do that itself on the target widget's colormap. =head1 BUGS C widgets don't work properly, but instead should be put in a C or similar windowed widget and that passed to the crosshair. Parent window movement, including toplevel window movement, isn't noticed immediately, leaving the drawn crosshair away from the mouse. The next mouse movement updates all widgets though, and often parent widget moves provoke a redraw which will update the crosshair anyway. If a crosshair widget's window is partly overlapped by another window then a keyboard mode start with the pointer in that other window isn't recognised as outside the crosshair window. This results in an initial draw but then no updating until the pointer moves into the crosshaired window. It should be possible to do this correctly. =head1 SEE ALSO L, L, L, L =head1 HOME PAGE L =head1 LICENSE Copyright 2007, 2008, 2009, 2010 Kevin Ryde 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 L. =cut