File Coverage

blib/lib/Gtk2/Ex/WidgetBits.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# Copyright 2007, 2008, 2009, 2010, 2011, 2012 Kevin Ryde

# This file is part of Gtk2-Ex-WidgetBits.
#
# Gtk2-Ex-WidgetBits 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-WidgetBits 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-WidgetBits.  If not, see .

package Gtk2::Ex::WidgetBits;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2;

# uncomment this to run the ### lines
#use Smart::Comments;

our $VERSION = 48;

# get_root_position() might be done as
#
#     my $toplevel = $widget->get_toplevel;
#     my $window = $toplevel->window || return; # if unrealized
#     return $widget->translate_coordinates ($toplevel,
#                                            $window->get_position);
#
# if it can be assumed the toplevel widget of a hierarchy has its window a
# child of the root window (after possible window manager frame).  Or
# alternately just get_toplevel() could eliminate the 'no-window' test if it
# can be assumed the toplevel is a windowed widget.  All of which is of
# course true of GtkWindow, and probably ends up right for GtkPlug too, but
# could a custom toplevel widget do something tricky?
#
sub get_root_position {
  my ($widget) = @_;
  my $window = $widget->window || return; # if unrealized
  require Gtk2::Ex::GdkBits;
  my ($x, $y) = Gtk2::Ex::GdkBits::window_get_root_position ($window);
  if ($widget->flags & 'no-window') {
    my $alloc = $widget->allocation;
    $x += $alloc->x;
    $y += $alloc->y;
  }
  return ($x, $y);
}
sub warp_pointer {
  my ($widget, $x, $y) = @_;
  my ($origin_x, $origin_y) = get_root_position ($widget)
    or croak "Cannot warp on unrealized $widget";
  my $screen = $widget->get_screen;
  my $display = $widget->get_display;
  $display->warp_pointer ($screen, $origin_x + $x, $origin_y + $y);
}

sub xy_root_to_widget {
  my ($widget, $root_x, $root_y) = @_;
  ### _xy_root_to_widget(): "$widget", $root_x, $root_y
  my ($x, $y) = Gtk2::Ex::WidgetBits::get_root_position ($widget);
  if (! defined $x) {
    ### widget unrealized
    return;
  } else {
    return ($root_x - $x, $root_y - $y);
  }
}

#------------------------------------------------------------------------------

sub xy_distance_mm {
  my ($widget, $x1, $y1, $x2, $y2) = @_;
  my ($xmm, $ymm) = pixel_size_mm ($widget)
    or return undef;
  return _hypot ($xmm * ($x1 - $x2),
                 $ymm * ($y1 - $y2));
}

sub pixel_aspect_ratio {
  my ($widget) = @_;
  my ($xmm, $ymm) = pixel_size_mm ($widget)
    or return undef;
  return ($xmm / $ymm);
}

if (Gtk2::Gdk::Screen->can('get_width')) {
  eval "\n#line ".(__LINE__+1)." \"".__FILE__."\"\n" . <<'HERE' or die;
  ### using widget->screen

sub pixel_size_mm {
  my ($widget) = @_;

  # gtk_widget_get_screen() returns the default screen if the widget is not
  # yet in a toplevel, so test gtk_widget_has_screen() first.  Often just
  # that default screen would be good enough, but best not to be sloppy with
  # that sort of thing if potentially multi-display.
  #
  $widget->has_screen
    or return; # no values
  my $screen = $widget->get_screen;
  return ($screen->get_width_mm / $screen->get_width,
          $screen->get_height_mm / $screen->get_height);

  # Pointless in Gtk 2.14, the monitor sizes are always -1.
  # Xinerama 1.1 doesn't give monitor sizes in millimetres, only pixel areas.
  #
  # For a multi-monitor screen an individual monitor size is used if
  # available.  Currently the calculation only looks at a single monitor
  # containing or nearest to the widget, using C.  No
  # attempt is made to tell if the line x1,y1 to x2,y2 crosses multiple
  # monitors.
  #
  #   # xinerama new in Gtk 2.14 (2008) and Gtk2-Perl 1.191 (Aug 2008)
  #   if (my $func = $screen->can('get_monitor_at_window')) {
  #     # no position on the screen until realized
  #     if (my $win = $widget->window) {
  #       my $mnum = $func->($screen, $win);
  #       my $rect = $screen->get_monitor_geometry ($mnum);
  #       my $width_mm = $screen->get_monitor_width_mm ($mnum);
  #       my $height_mm = $screen->get_monitor_height_mm ($mnum);
  #       # sizes -1 if not known
  #       if ($width_mm != -1 && $height_mm != -1) {
  #         return ($width_mm / $rect->width,
  #                 $height_mm / $rect->height);
  #       }
  #     }
  #   }
}
1
HERE

} else {
  eval "\n#line ".(__LINE__+1)." \"".__FILE__."\"\n" . <<'HERE' or die;
  ### using Gtk 2.0.x single-screen size

# Gtk 2.0.x single-screen sizes
sub pixel_size_mm {
  return (Gtk2::Gdk->screen_width_mm / Gtk2::Gdk->screen_width,
          Gtk2::Gdk->screen_height_mm / Gtk2::Gdk->screen_height);
}
1
HERE
}

#------------------------------------------------------------------------------
# generic

# cf Math::Libm hypot()
sub _hypot {
  my ($x, $y) = @_;
  return sqrt ($x ** 2 + $y ** 2);
}

1;
__END__