File Coverage

blib/lib/Gtk2/Ex/Dashes.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# Copyright 2010 Kevin Ryde

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

package Gtk2::Ex::Dashes;
use 5.008;
use strict;
use warnings;
use Gtk2;
use List::Util qw(min max);
use POSIX ();

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

our $VERSION = 2;

use Glib::Object::Subclass
  'Gtk2::Misc',
  signals => { size_request      => \&_do_size_request,
               expose_event      => \&_do_expose_event,
               style_set         => \&_do_style_or_direction,
               direction_changed => \&_do_style_or_direction,
             },
  properties => [ Glib::ParamSpec->enum
                  ('orientation',
                   'orientation',
                   'Horizontal or vertical line draw.',
                   'Gtk2::Orientation',
                   'horizontal',
                   Glib::G_PARAM_READWRITE),
                ];

# Multiplied by $widget->style->ythickness.
# For default theme thickness 2 pixels this gives dash segments 5 pixels
# same as Gtk2::TearoffMenuItem.
use constant _DASH_FACTOR => 2.5;

sub INIT_INSTANCE {
  my ($self) = @_;
  $self->set_flags('no-window');
}

sub SET_PROPERTY {
  my ($self, $pspec, $newval) = @_;
  my $pname = $pspec->get_name;
  my $oldval = $self->get($pname);
  $self->{$pname} = $newval;

  # if ($pname eq 'orientation')   # the only property
  #
  if ($oldval ne $newval) {
    $self->queue_resize;
    $self->queue_draw;
  }
}

# 'size-request' class closure
sub _do_size_request {
  my ($self, $req) = @_;

  my ($width, $height) = $self->get_padding;
  $width *= 2;
  $height *= 2;
  if ($self->get('orientation') eq 'horizontal') {
    $height += $self->style->ythickness;
  } else {
    $width += $self->style->xthickness;
  }
  ### size_request: "$width x $height"
  $req->width ($width);
  $req->height ($height);
}

sub _do_expose_event {
  my ($self, $event) = @_;
  my $clip = $event->area;  # Gtk2::Gdk::Rectangle
  ### expose: $self->get_name, $clip->values

  my $horizontal = ($self->get('orientation') eq 'horizontal');
  my $style      = $self->style;
  my $state      = $self->state;
  my $win        = $self->window;
  my $thickness  = ($horizontal ? $style->ythickness : $style->xthickness);
  my $dash_len   = POSIX::ceil (_DASH_FACTOR * $thickness);
  ### $dash_len
  my $dash_step  = 2 * $dash_len;

  my ($alloc_x, $alloc_y, $alloc_width, $alloc_height)
    = $self->allocation->values;  # Gtk2::Gdk::Rectangle
  ### alloc: "$alloc_x,$alloc_y ${alloc_width}x$alloc_height"

  my ($xalign, $yalign) = $self->get_alignment;
  if ($self->get_direction eq 'rtl') { $xalign = 1 - $xalign; }
  ### align: $xalign, $yalign

  {
    my ($xpad, $ypad) = $self->get_padding;
    ### padding: $xpad, $ypad
    if ($xpad || $ypad) {
      # apply padding by pretending allocation is that much smaller
      ### rect shrink from: $clip->values

      $alloc_x += $xpad;
      $alloc_y += $ypad;
      if (($alloc_width -= 2*$xpad) <= 0
          || ($alloc_height -= 2*$ypad) <= 0
          || ! ($clip = $clip->intersect (Gtk2::Gdk::Rectangle->new
                                          ($alloc_x, $alloc_y,
                                           $alloc_width, $alloc_height)))) {
        ### expose of the pad border region, or allocation smaller than padding
        ### nothing to draw
        return 0; # Gtk2::EVENT_PROPAGATE
      }
      ### to: $clip->values
    }
  }

  if ($horizontal) {
    my $clip_x = $clip->x;

    # vertically according to yalign
    my $y = $alloc_y + POSIX::floor
      (($alloc_height - $thickness) * $yalign
       + 0.5); # round
    ### $y

    # ENHANCE-ME: if $y puts the line entirely above or below the clip
    # region then skip the loop.  What can be assumed about how $ythickness
    # affects how much above and below $y the paint_hline() will go?

    # horizontal beginning according to xalign
    my $x = $clip_x
      + ((POSIX::floor (($alloc_width - $dash_len)  * $xalign
                        + 0.5) # round
          + $alloc_x
          - $clip_x)
         % -$dash_step); # at or just before $clip_x
    ### $x

    my $end = $clip_x + $clip->width; # clip rect
    for ( ; $x < $end; $x += $dash_step) {
      $style->paint_hline ($win, $state, $clip, $self, __PACKAGE__,
                           $x, $x+$dash_len, $y);
    }
  } else {
    my $clip_y = $clip->y;

    # horizontally according to xalign
    my $x = $alloc_x + POSIX::floor
      (($alloc_width - $thickness) * $xalign
       + 0.5); # round

    # vertical beginning according to yalign
    my $y = $clip_y
      + ((POSIX::floor (($alloc_height - $dash_len)  * $yalign
                        + 0.5) # round
          + $alloc_y
          - $clip_y)
         % -$dash_step); # at or just before $clip_y

    my $end = $clip_y + $clip->height; # clip rect
    for ( ; $y < $end; $y += $dash_step) {
      $style->paint_vline ($win, $state, $clip, $self, __PACKAGE__,
                           $y, $y+$dash_len, $x);
    }
  }
  return 0; # Gtk2::EVENT_PROPAGATE
}

# 'style-set' and 'direction-changed' class closure handler
# Sharing style-set and direction-changed saves a little code.
#
# queue_resize() is not wanted for direction-changed, but does no harm.  As
# of Gtk 2.18 the GtkWidget code in gtk_widget_real_direction_changed()
# (previously gtk_widget_direction_changed()) in fact does a queue_resize()
# itself.  Could avoid it by not chaining up, but perhaps GtkWidget will do
# something important there in the future.  Either way a direction change
# should be infrequent so it doesn't matter much.
#
sub _do_style_or_direction {
  my ($self) = @_;
  ### Dashes _do_style_or_direction(): @_
  $self->queue_resize;
  $self->queue_draw;
  return shift->signal_chain_from_overridden(@_);
}

1;
__END__