# Copyright 2010, 2011 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 <http://www.gnu.org/licenses/>.

package Test::Without::Gtk2Things;
use 5.008;
use strict;
use warnings;

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

our $VERSION = 41;

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.
  {
    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 {
      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 ('Gtk2::Widget', "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) = @_;
  ### $want
  ### $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__

=for stopwords Gtk2-Ex-WidgetBits Gtk withouts tooltip Ryde

=head1 NAME

Test::Without::Gtk2Things - disable selected Gtk2 methods for testing

=head1 SYNOPSIS

 # perl -MTest::Without::Gtk2Things=insert_with_values foo.t

 # or
 use Test::Without::Gtk2Things 'insert_with_values';

=head1 DESCRIPTION

This module removes or disables selected features from C<Gtk2> in order to
simulate an older version (or other restrictions).  It can be used for
development or testing to check code which adapts itself to available
features or which is meant to run on older Gtk.  There's only a couple of
"without" things as yet.

Obviously the best way to test application code on older Gtk is to run it on
an older Gtk, but making a full environment for that can be difficult.

=head2 Usage

From the command line use a C<-M> module load (per L<perlrun>) for a program
or test script,

    perl -MTest::Without::Gtk2Things=insert_with_values foo.t

Or the same through C<Test::Harness> in a C<MakeMaker> test run

    HARNESS_PERL_SWITCHES="-MTest::Without::Gtk2Things=blank_cursor" \
      make test

A test script can do the same with a C<use>,

    use Test::Without::Gtk2Things 'insert_with_values';

Or an equivalent explicit import,

    require Test::Without::Gtk2Things;
    Test::Without::Gtk2Things->import('insert_with_values');

In each case generally the "withouts" should be established before loading
application code in case it checks features at C<BEGIN> time.

Currently C<Test::Without::Gtk2Things> loads C<Gtk2> if not already loaded,
but don't rely on that.  A mangle-after-load instead might be good, if it
could be done reliably.

=head1 WITHOUT THINGS

=over

=item C<verbose>

Have C<Test::Without::Gtk2Things> print some diagnostic messages to C<STDERR>.
For example,

    perl -MTest::Without::Gtk2Things=verbose,blank_cursor foo.t

    Test::Without::Gtk2Things -- without CursorType blank-cursor, per Gtk before 2.16
    ...

=item C<blank_cursor>

Remove C<blank-cursor> from the C<Gtk2::Gdk::CursorType> enumeration.
Currently this means removing from C<< Glib::Type->list_values >>, and
making C<< Gtk2::Gdk::Cursor->new >> and C<new_for_display> throw an error
if asked for that type.

Object properties of type C<Gtk2::Gdk::CursorType> are are not affected
(they can still be set to C<blank-cursor>), but perhaps that could be done
in the future.  Blank cursors within Gtk itself are unaffected.

C<blank-cursor> is new in Gtk 2.16.  In earlier versions an invisible cursor
can be made by applications with a no-pixels-set bitmap as described by
C<gdk_cursor_new> in such earlier versions.  (See L<Gtk2::Ex::WidgetCursor>
for some help with that.)

=item C<builder>

Remove C<Gtk2::Builder> and the C<Gtk2::Buildable> interface, as per Gtk
before 2.12.

The Buildable interface is removed by removing the class and by mangling
C<UNIVERSAL::isa()> to pretend nothing is a Buildable.  Actual package
C<@ISA> lists are not changed currently.  This should mean Buildable still
works in C code, but not from Perl (neither currently loaded nor later
loaded classes).

In a Perl widget implementation it can be fairly easy to support Gtk
pre-2.12 by omitting the Buildable interface if not available.

    use Glib::Object::Subclass
      'Gtk2::DrawingArea',
      interfaces => [ # Buildable new in Gtk 2.12, omit otherwise
                      Gtk2::Widget->isa('Gtk2::Buildable')
                      ? ('Gtk2::Buildable')
                      : (),
      ];

=item C<cell_layout_get_cells>

Remove the C<get_cells> method from the C<Gtk2::CellLayout> interface.  That
interface method is new in Gtk 2.12 and removal affects all widget classes
implementing that interface.  In earlier Gtk versions C<Gtk2::CellView> and
C<Gtk2::TreeViewColumn> have individual C<get_cell_renderers> methods.
Those methods are unaffected by this without.

=item C<draw_as_radio>

Remove the C<Gtk2::CheckMenuItem> and C<Gtk2::ToggleAction> C<draw-as-radio>
property and corresponding explicit get/set methods.

C<draw-as-radio> on those two classes is new in Gtk 2.4.  For prior versions
it was only a builtin drawing feature of C<Gtk2::RadioMenuItem>, or some
such.  Simply skipping it may be good enough in those prior versions.

=item C<gdkdisplay>

Remove C<Gtk2::Gdk::Display> and C<Gtk2::Gdk::Screen> classes, and the
various C<get_display>, C<set_screen>, etc widget methods, as would be the
case in Gtk 2.0.x.

In Gtk 2.0.x there was a single implicit screen and display, and some
methods for querying their attributes (see L<Gtk2::Gdk>).  Most widget code
doesn't need to do much with a screen or display object, and it can be
reasonably easy to support 2.0.x by checking for a C<set_screen> method etc
if say putting a dialog on the same screen as its originating main window.

=item C<insert_with_values>

Remove the C<insert_with_values> method from C<Gtk2::ListStore> and
C<Gtk2::TreeStore>.  That method is new in Gtk 2.6.  In earlier versions
separate C<insert> and C<set> calls are necessary.

=item C<menuitem_label_property>

Remove from C<Gtk2::MenuItem> C<label> and C<use-underline> properties and
corresponding explicit C<get_label>, C<set_use_underline> etc methods.

C<label> and C<use-underline> are new in Gtk 2.16.  (For prior versions
C<new_with_label> or C<new_with_mnemonic> create and set a child label
widget.)

=item C<widget_tooltip>

Remove from C<Gtk2::Widget> base tooltip support new in Gtk 2.12.  This
means the C<tooltip-text>, C<tooltip-markup> and C<has-tooltip> properties,
their direct get/set methods such as C<< $widget->set_tooltip_text >>, and
the C<query-tooltip> signal.

For code supporting both earlier and later than 2.12 it may be enough to
just skip the tooltip setups for the earlier versions.  See
C<set_property_maybe> in L<Glib::Ex::ObjectBits> for some help with that.

=back

=head1 BUGS

It's not possible to C<no Test::Without::Gtk2Things> to restore removed
things.  Once removed they're gone for the whole program run.

=head1 SEE ALSO

L<Gtk2>,
L<Test::Without::Module>,
L<Test::Weaken::Gtk2>

L<Glib::Ex::ObjectBits> C<set_property_maybe()> for skipping non-existent
properties.

=head1 COPYRIGHT

Copyright 2010, 2011 Kevin Ryde

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 L<http://www.gnu.org/licenses/>.

=cut
