File Coverage

blib/lib/Gtk2/Ex/Units.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::Units;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2::Pango; # for PANGO_SCALE

use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = qw(em ex char_width digit_width line_height
                    width height
                    set_default_size_with_subsizes
                    size_request_with_subsizes);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

our $VERSION = 48;

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


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

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

sub _to_screen {
  my ($target) = @_;
  if (my $func = $target->can('get_screen')) {
    $target = &$func ($target);
  }
  return ($target
          || croak "No screen for target $target");
}
1

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

{
  package Gtk2::Ex::Units::DummyScreen;
  sub get_width  { return Gtk2::Gdk->screen_width }
  sub get_height { return Gtk2::Gdk->screen_height }
  sub get_width_mm  { return Gtk2::Gdk->screen_width_mm }
  sub get_height_mm { return Gtk2::Gdk->screen_height_mm }
}
{
  my $dummy_screen = bless {}, 'Gtk2::Ex::Units::DummyScreen';
  ### $dummy_screen
  sub _to_screen {
    return $dummy_screen;
  }
}
1
HERE
}

sub _pango_rect {
  my ($target, $str, $want_logical) = @_;
  ### _pango_rect(): [$target, $str]

  if ($target->can('create_pango_layout')) {
    # if widget instead of layout
    $target = $target->create_pango_layout ($str);
  } else {
    $target->set_text ($str);
  }
  # get_extents() returns ($ink_rect,$logical_rect)
  return ($target->get_extents)[$want_logical||0];
}
sub _pango_metrics {
  my ($target) = @_;
  my $context = ($target->can('pango_context')
                 ? $target->pango_context       # Pango::Layout
                 : $target->get_pango_context); # Gtk2::Widget

  my $fontdesc = (($target->can('get_font_description')  # Pango::Layout
                   && $target->get_font_description)
                  || ($target->can('style')              # Gtk2::Widget
                      && $target->style->font_desc)
                  || $context->get_font_description);    # if unset
  return $context->get_metrics ($fontdesc, $context->get_language);
}

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

sub em {
  my ($target) = @_;
  # logical rect to include inter-char spacing, so that "3 em" is roughly
  # the width needed for "MMM"
  return _pango_rect($target,'M',1)->{'width'} / Gtk2::Pango::PANGO_SCALE;
}
sub ex {
  my ($target) = @_;
  return _pango_rect($target,'x')->{'height'} / Gtk2::Pango::PANGO_SCALE;
}
sub line_height {
  my ($target) = @_;
  # ink rect of newline is the line height plus line spacing
  # (whereas log rect of empty is line height without line spacing,
  # or log rect of newline is two line heights plus one line spacing)
  return _pango_rect($target,"\n",0)->{'height'} / Gtk2::Pango::PANGO_SCALE;
}
sub char_width {
  my ($target) = @_;
  return _pango_metrics($target)->get_approximate_char_width
    / Gtk2::Pango::PANGO_SCALE;
}
sub digit_width {
  my ($target) = @_;
  return _pango_metrics($target)->get_approximate_digit_width
    / Gtk2::Pango::PANGO_SCALE;
}

#------------------------------------------------------------------------------
# width

use constant { _pixel => 1,
               _MILLIMETRES_PER_INCH => 25.4 };

sub _mm_width {
  my ($target) = @_;
  my $screen = _to_screen($target);
  return $screen->get_width / $screen->get_width_mm;
}
sub _inch_width {
  my ($target) = @_;
  return _MILLIMETRES_PER_INCH * _mm_width($target);
}
sub _screen_width {
  my ($target) = @_;
  return _to_screen($target)->get_width;
}
my %width = (pixel   => \&_pixel,
             pixels  => \&_pixel,
             char    => \&char_width,
             chars   => \&char_width,
             em      => \&em,
             ems     => \&em,
             digit   => \&digit_width,
             digits  => \&digit_width,
             mm      => \&_mm_width,
             inch    => \&_inch_width,
             inches  => \&_inch_width,
             screen  => \&_screen_width,
             screens => \&_screen_width,
            );

#------------------------------------------------------------------------------
# height

sub _mm_height {
  my ($target) = @_;
  my $screen = _to_screen($target);
  return $screen->get_height / $screen->get_height_mm;
}
sub _inch_height {
  my ($target) = @_;
  return _MILLIMETRES_PER_INCH * _mm_height($target);
}
sub _screen_height {
  my ($target) = @_;
  return _to_screen($target)->get_height;
}

my %height = (pixel   => \&_pixel,
              pixels  => \&_pixel,
              ex      => \&ex,
              exes    => \&ex,
              line    => \&line_height,
              lines   => \&line_height,
              mm      => \&_mm_height,
              inch    => \&_inch_height,
              inches  => \&_inch_height,
              screen  => \&_screen_height,
              screens => \&_screen_height,
             );

#------------------------------------------------------------------------------
# shared

sub width {
  push @_, \%width, \%height;
  goto \&_units;
}
sub height {
  push @_, \%height, \%width;
  goto \&_units;
}
sub _units {
  my ($target, $str, $h, $other) = @_;
  ### _units str: $str

  # it's easy to forget the $target arg, so check
  @_ == 4 or croak 'Units width()/height() expects 2 arguments';

  my ($amount,$unit) = ($str =~ /(.*?)\s*([[:alpha:]_]+)$/s)
    or return $str;

  if (my $func = $h->{$unit}) {
    return $amount * &$func ($target);
  }
  croak "Unrecognised unit \"$unit\"";
}


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

sub set_default_size_with_subsizes {
  my $window = $_[0];
  my $req = size_request_with_subsizes (@_);
  $window->set_default_size ($req->width, $req->height);
}

sub size_request_with_subsizes {
  my ($widget, @elems) = @_;

  # Each change is guarded as it's made, in case the action on a subsequent
  # $widget provokes an error, eg. if not a Gtk2::Widget.  A guard object
  # for each widget is a little less code than say an array of saved
  # settings and a loop to undo them.

  require Scope::Guard;
  my @guard;

  foreach my $elem (@elems) {
    my ($subwidget, $width, $height) = @$elem;
    my ($save_width, $save_height) = $subwidget->get_size_request;
    my $width_pixels = (defined $width
                        ? width($subwidget,$width)
                        : $save_width);
    my $height_pixels = (defined $height
                        ? height($subwidget,$height)
                        : $save_height);
    push @guard, Scope::Guard->new
      (sub { $subwidget->set_size_request ($save_width, $save_height) });
    $subwidget->set_size_request ($width_pixels, $height_pixels);
  }

  return $widget->size_request;
}

1;
__END__