File Coverage

blib/lib/Test/Without/Gtk2Things.pm

Criterion	Covered	Total	%
statement	65	312	20.8
branch	3	90	3.3
condition	2	11	18.1
subroutine	18	43	41.8
pod	0	10	0.0
total	88	466	18.8

# Copyright 2010, 2011, 2012 Kevin Ryde

# Gtk2-Ex-WidgetBits is shared by several distributions.
#
# 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 Test::Without::Gtk2Things;
use 5.008;
use strict;
use warnings;

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

our $VERSION = 48;

our $VERBOSE = 0;

# Not sure the without_foo methods are a good idea.  Might prefer a hash of
# names so can associate a gtk version number to a without-ness, to have a
# "without version 2.x" option etc.
#
# FIXME: deleting the whole glob with "undef *Foo::Bar::func" is probably
# not a good idea.  Maybe let Sub::Delete do the work.
#

sub import {
  my $class = shift;
  my $count = 0;

  foreach my $thing (@_) {
    if ($thing eq '-verbose' || $thing eq 'verbose') {
      $VERBOSE++;

    } elsif ($thing eq 'all') {
      foreach my $method ($class->all_without_methods) {
        $class->$method;
        $count++;
      }

    } else {
      (my $method = "without_$thing") =~ tr/-/_/;
      if (! $class->can($method)) {
        die "Unknown thing to disable: $thing";
      }
      $class->$method;
      $count++;
    }
  }
  if ($VERBOSE) {
    print STDERR
      "Test::Without::Gtk2Things -- count without $count thing",
        ($count==1?'':'s'), "\n";
  }
}

# search @ISA with a view to subclasses, but is it a good idea?
sub all_without_methods {
  my ($class) = @_;
  ### all_without_methods(): $class
  my @methods;
  no strict 'refs';
  my @classes = ($class, @{"${class}::ISA"});
  ### @classes
  while (@classes) {
    my $c = shift @classes;
    ### $c
    #     my @keys = keys %{"${c}::"};
    #     ### keys: @keys
    push @methods, grep {/^without_/} keys %{"${c}::"};
    push @classes, grep {/^Test/} @{$c::ISA};
    ### @classes
  }
  ### @methods
  return @methods;
}

# our @ISA = ('TestX');
# {
# package TestX;
# our @ISA = ('TestY');
# }
# print __PACKAGE__->all_without_methods();

#------------------------------------------------------------------------------
# withouts

sub without_blank_cursor {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without CursorType blank-cursor, per Gtk before 2.16\n";
  }

  no warnings 'redefine', 'once';
  {
    my $orig = Glib::Type->can('list_values');
    *Glib::Type::list_values = sub {
      my ($class, $package) = @_;
      my @result = &$orig (@_);
      if ($package eq 'Gtk2::Gdk::CursorType') {
        @result = grep {$_->{'nick'} ne 'blank-cursor'} @result;
      }
      return @result;
    };
  }
  foreach my $func ('new', 'new_for_display') {
    my $orig = Gtk2::Gdk::Cursor->can($func);
    my $new = sub {
      my $cursor_type = $_[-1];
      if ($cursor_type eq 'blank-cursor') {
        require Carp;
        Carp::croak ('Test::Without::Gtk2Things -- no blank-cursor');
      }
      goto $orig;
    };
    my $func = "Gtk2::Gdk::Cursor::$func";
    no strict 'refs';
    *$func = $new;
  }
}

sub without_cell_layout_get_cells {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::CellLayout get_cells() method, per Gtk before 2.12\n";
  }

  _without_methods ('Gtk2::CellLayout', 'get_cells');
}

sub without_draw_as_radio {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::CheckMenuItem/ToggleAction draw-as-radio property, per Gtk before 2.4\n";
  }
  _without_properties ('Gtk2::CheckMenuItem', 'draw-as-radio');
  _without_properties ('Gtk2::ToggleAction', 'draw-as-radio');

  # check the desired effect ...
  {
    if (eval { Gtk2::CheckMenuItem->Glib::Object::new (draw_as_radio => 1) }) {
      die 'Oops, Gtk2::CheckMenuItem create with Glib::Object::new and draw-as-radio still succeeds';
    }
    if (Gtk2::CheckMenuItem->find_property ('draw_as_radio')) {
      die 'Oops, Gtk2::CheckMenuItem find_property("draw_as_radio") still succeeds';
    }
    my $action = Gtk2::ToggleAction->new (name => 'Test-Without-Gtk2Things');
    if (eval { $action->get_draw_as_radio() }) {
      die 'Oops, Gtk2::ToggleAction get_draw_as_radio() still available';
    }
  }
}

sub without_insert_with_values {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without ListStore,TreeStore insert_with_values(), per Gtk before 2.6\n";
  }

  _without_methods ('Gtk2::ListStore', 'insert_with_values');
  _without_methods ('Gtk2::TreeStore', 'insert_with_values');

  # check the desired effect ...
  {
    my $store = Gtk2::ListStore->new ('Glib::String');
    if (eval { $store->insert_with_values(0, 0=>'foo'); 1 }) {
      die 'Oops, Gtk2::ListStore call store->insert_with_values() still succeeds';
    }
  }
  {
    my $store = Gtk2::TreeStore->new ('Glib::String');
    if (eval { $store->insert_with_values(undef, 0, 0=>'foo'); 1 }) {
      die 'Oops, Gtk2::TreeStore call store->insert_with_values() still succeeds';
    }
  }
}

sub without_menuitem_label_property {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::MenuItem label and use-underline properties, per Gtk before 2.16\n";
  }
  _without_properties ('Gtk2::MenuItem', 'label', 'use-underline');

  # check the desired effect ...
  {
    if (eval { Gtk2::MenuItem->Glib::Object::new (label => 'hello') }) {
      die 'Oops, Gtk2::MenuItem create with Glib::Object::new and label still succeeds';
    }
    if (eval { Gtk2::MenuItem->Glib::Object::new ('use-underline' => 1) }) {
      die 'Oops, Gtk2::MenuItem create with Glib::Object::new and use-underline still succeeds';
    }
    if (Gtk2::MenuItem->can('get_label')) {
      die 'Oops, Gtk2::MenuItem still can("get_label")';
    }
  }
}

sub without_warp_pointer {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::Gdk::Display warp_pointer() method, per Gtk before 2.8\n";
  }

  _without_methods ('Gtk2::Gdk::Display', 'warp_pointer');

  # check the desired effect ...
  if (Gtk2::Gdk::Display->can('get_default')) { # new in Gtk 2.2
    if (my $display = Gtk2::Gdk::Display->get_default) {
      if (my $coderef = $display->can('warp_pointer')) {
        die "Oops, display->can(warp_pointer) still true: $coderef";
      }
    }
  }
}

sub without_widget_tooltip {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::Widget tooltips, per Gtk before 2.12\n";
  }
  _without_properties ('Gtk2::Widget',
                       'tooltip-text', 'tooltip-markup', 'has-tooltip');
  _without_methods ('Gtk2::Widget',
                    'get_tooltip_text', 'set_tooltip_text',
                    'get_tooltip_markup', 'set_tooltip_markup',
                    'get_has_tooltip', 'set_has_tooltip',);
  _without_signals ('Gtk2::Widget', 'query-tooltip');
}

sub without_gdkdisplay {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gdk2::Gdk::Display and Gtk2::Gdk::Screen, per Gtk 2.0.x\n";
  }

  # In Gtk 2.2 up Gtk2::Gdk->get_default_root_window() gives a g_log()
  # warning if no Gtk2->init() yet.  Wrap it to quietly give undef the same
  # as in Gtk 2.0.0.
  #
  # Something in recent Gtk or Perl-Gtk or Perl doesn't like running the
  # Gtk2::Gdk::Screen->get_default when that package has otherwise been
  # killed.  How to cleanly test for init-ed?
  #
  {
    my $get_default_screen = Gtk2::Gdk::Screen->can('get_default');
    my $orig = Gtk2::Gdk->can('get_default_root_window') || die;
    no warnings 'redefine';
    *Gtk2::Gdk::get_default_root_window = sub {
      local $SIG{__WARN__} = sub {};
      return &$orig(@_);

      # ### Without get_default_root_window() ...
      # my $x = Gtk2::Gdk::Screen->$get_default_screen();
      # print "$x\n";
      # if (! Gtk2::Gdk::Screen->$get_default_screen()) {
      #   return undef;
      # }
      # # this could have been "goto $orig" but have seen trouble in 5.8.9
      # # jumping to an XSUB like that
      # return &$orig(@_);
    };
  }

  _without_packages ('Gtk2::Gdk::Display', 'Gtk2::Gdk::Screen');

  _without_methods ('Gtk2::Gdk',
                    'get_display_arg_name',
                    'text_property_to_text_list_for_display',
                    'text_property_to_utf8_list_for_display',
                    'utf8_to_compound_text_for_display');
  _without_methods ('Gtk2::Gdk::Cursor',
                    'get_display',
                    'new_for_display','new_from_name','new_from_pixbuf');
  _without_methods ('Gtk2::Gdk::Colormap', 'get_screen');
  _without_methods ('Gtk2::Gdk::Drawable', 'get_display', 'get_screen');
  _without_methods ('Gtk2::Gdk::Font',     'get_display');
  _without_methods ('Gtk2::Gdk::GC',       'get_screen');
  _without_methods ('Gtk2::Gdk::Event',    'get_screen','set_screen',
                    'send_client_message_for_display');
  _without_methods ('Gtk2::Gdk::Visual',   'get_screen');

  # mangle the base Gtk2::Widget class so can() is false for subclasses
  _without_methods ('Gtk2::Widget',        'get_display', 'get_screen',
                    'has_screen');
  _without_signals ('Gtk2::Widget', 'screen-changed');

  _without_methods ('Gtk2::Clipboard',     'get_display', 'get_for_display');
  _without_methods ('Gtk2::Invisible',     'get_screen','set_screen',
                    'new_for_screen');
  _without_methods ('Gtk2::Menu',          'set_screen');
  _without_methods ('Gtk2::MountOperation','get_screen');
  _without_methods ('Gtk2::StatusIcon',    'get_screen','set_screen');
  _without_methods ('Gtk2::Window', 'get_screen','set_screen');
  _without_properties ('Gtk2::Window', 'screen');

  # check the desired effect ...
  if (my $coderef = Gtk2::Gdk::Display->can('get_default')) {
    die "Oops, Gtk2::Gdk::Display->can(get_default) still true: $coderef";
  }
  if (my $coderef = Gtk2::Gdk::Screen->can('get_display')) {
    die "Oops, Gtk2::Gdk::Screen->can(get_display) still true: $coderef";
  }
}

sub without_builder {
  require Gtk2;
  if ($VERBOSE) {
    print STDERR "Test::Without::Gtk2Things -- without Gtk2::Builder and Buildable interface, per Gtk before 2.12\n";
  }
  _without_packages ('Gtk2::Builder');
  _without_interfaces ('Gtk2::Buildable');
}

#------------------------------------------------------------------------------
# removing stuff

sub _without_interfaces {
  _without_packages (@_);

  {
    no warnings 'redefine', 'once';
    my %without;
    @without{@_} = (); # hash slice
    my $orig = UNIVERSAL->can('isa');

    *UNIVERSAL::isa = sub {
      my ($class_or_instance, $type) = @_;
      if (exists $without{$type}) {
        return !1; # false
      }
      goto $orig;
    };
  }
}

sub _without_packages {
  foreach my $package (@_) {
    $package->can('something'); # finish lazy loading, or some such
    no strict 'refs';
    foreach my $name (%{"${package}::"}) {
      my $fullname = "${package}::$name";
      undef *$fullname;
    }
  }
}

sub _without_methods {
  my $class = shift;
  foreach my $method (@_) {
    # force autoload ... umm, or something
    $class->can($method);

    my $fullname = "${class}::$method";
    { no strict 'refs'; undef *$fullname; }
  }

  # check the desired effect ...
  foreach my $method (@_) {
    if (my $coderef = $class->can($method)) {
      die "Oops, $class->can($method) still true: $coderef";
    }
  }
}

sub _without_properties {
  my ($without_class, @without_pnames) = @_;

  foreach my $without_pname (@without_pnames) {
    (my $method = $without_pname) =~ tr/-/_/;
    _without_methods ($without_class, "get_$method", "set_$method");
  }

  my %without_pnames;
  @without_pnames{@without_pnames} = (1) x scalar(@without_pnames); # slice

  no warnings 'redefine', 'once';
  {
    my $orig = Glib::Object->can('list_properties');
    *Glib::Object::list_properties = sub {
      my ($class) = @_;
      if ($class->isa($without_class)) {
        return grep {! $without_pnames{$_->get_name}} &$orig (@_);
      }
      goto $orig;
    };
  }
  {
    my $orig = Glib::Object->can('find_property');
    *Glib::Object::find_property = sub {
      my ($class, $pname) = @_;
      if ($class->isa($without_class)
          && _pnames_match ($pname, \%without_pnames)) {
        ### wrapped find_property() exclude
        return undef;
      }
      goto $orig;
    };
  }
  foreach my $func ('get', 'get_property') {
    my $orig = Glib::Object->can($func);
    my $new = sub {
      if ($_[0]->isa($without_class)) {
        for (my $i = 1; $i < @_; $i++) {
          my $pname = $_[$i];
          if (_pnames_match ($pname, \%without_pnames)) {
            require Carp;
            Carp::croak ("Test-Without-Gtk2Things: no get property $pname");
          }
        }
      }
      goto $orig;
    };
    my $func = "Glib::Object::$func";
    no strict 'refs';
    *$func = $new;
  }
  foreach my $func ('new', 'set', 'set_property') {
    my $orig = Glib::Object->can($func); # force autoload
    my $new = sub {
      if ($_[0]->isa($without_class)) {
        for (my $i = 1; $i < @_; $i += 2) {
          my $pname = $_[$i];
          if (_pnames_match ($pname, \%without_pnames)) {
            require Carp;
            Carp::croak ("Test-Without-Gtk2Things: no set property $pname");
          }
        }
      }
      goto $orig;
    };
    my $func = "Glib::Object::$func";
    no strict 'refs';
    *$func = $new;
  }


  # check the desired effect ...
  foreach my $without_pname (@without_pnames) {
    if (my $pspec = $without_class->find_property($without_pname)) {
      die "Oops, $without_class->find_property() still finds $without_pname: $pspec";
    }
    if (my @pspecs = grep {$_->get_name eq $without_pname}
        $without_class->list_properties) {
      local $, = ' ';
      die "Oops, $without_class->list_properties() still finds $without_pname: @pspecs";
    }
  }
}

sub _pnames_match {
  my ($pname, $without_pnames) = @_;
  ### $pname
  $pname =~ tr/_/-/;
  return $without_pnames->{$pname};
}

sub _without_signals {
  my ($without_class, @without_signames) = @_;

  my %without_signames;
  @without_signames{@without_signames} # hash slice
    = (1) x scalar(@without_signames);

  no warnings 'redefine', 'once';
  {
    require Glib;
    my $orig = Glib::Type->can('list_signals');
    *Glib::Type::list_signals = sub {
      my (undef, $list_class) = @_;
      if ($list_class->isa($without_class)) {
        return grep {! $without_signames{$_->{'signal_name'}}} &$orig (@_);
      }
      goto $orig;
    };
  }
  {
    my $orig = Glib::Object->can('signal_query');
    *Glib::Object::signal_query = sub {
      my ($class, $signame) = @_;
      if ($class->isa($without_class)
          && _pnames_match ($signame, \%without_signames)) {
        ### wrapped signal_query() exclude
        return undef;
      }
      goto $orig;
    };
  }
  foreach my $func ('signal_connect',
                    'signal_connect_after',
                    'signal_connect_swapped',
                    'signal_emit',
                    'signal_add_emission_hook',
                    'signal_remove_emission_hook',
                    'signal_stop_emission_by_name') {
    my $orig = Glib::Object->can($func);
    my $new = sub {
      my ($obj, $signame) = @_;
      if ($obj->isa($without_class)) {
        if (_pnames_match ($signame, \%without_signames)) {
          require Carp;
          Carp::croak ("Test-Without-Gtk2Things: no signal $signame");
        }
      }
      goto $orig;
    };
    my $func = "Glib::Object::$func";
    no strict 'refs';
    *$func = $new;
  }


  # check the desired effect ...
  foreach my $without_signame (@without_signames) {
    if (my $siginfo = $without_class->signal_query($without_signame)) {
      die "Oops, $without_class->signal_query() still finds $without_signame: $siginfo";
    }
    if (my @siginfos = grep {$_->{'signal_name'} eq $without_signame}
        Glib::Type->list_signals($without_class)) {
      local $, = ' ';
      die "Oops, Glib::Type->list_signals($without_class) still finds $without_signame: @siginfos";
    }
  }
}

1;
__END__