#############################################################################
## Name:        t/Tests_Helper.pm
## Purpose:     some test helper functions
## Author:      Mattia Barbon
## Modified by:
## Created:     02/06/2001
## RCS-ID:      $Id: Tests_Helper.pm 13 2012-04-22 13:56:50Z mark.dootson@gmail.com $
## Copyright:   (c) 2001-2003, 2005 Mattia Barbon
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package Tests_Helper;

use strict;
use Wx;
require Exporter;

use Test::More ();
*ok = \&Test::More::ok;
*is = \&Test::More::is;
*diag = \&Test::More::diag;

use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);

@ISA = qw(Exporter);

%EXPORT_TAGS =
  ( inheritance => [ qw(test_inheritance test_inheritance_all
                        test_inheritance_start test_inheritance_end) ],
    overload    => [ qw(hijack test_override) ],
  );

@EXPORT_OK = ( qw(test_app app_timeout test_frame in_frame),
               @{$EXPORT_TAGS{inheritance}}, @{$EXPORT_TAGS{overload}} );

sub in_frame($) {
  my $callback = shift;
  my $sub = sub {
    my $frame = Tests_Helper_Frame->new( $callback );

    $frame->Show( 1 );
  };

  test_app( $sub );

  Wx::wxTheApp->MainLoop;
}

sub app_timeout($) {
  test_app( sub {
              my $frame = Wx::Frame->new( undef, -1, 'test' );
              my $timer = Wx::Timer->new( $frame );

              Wx::Event::EVT_TIMER( $frame, -1, sub {
                                      Wx::wxTheApp()->ExitMainLoop;
                                      $frame->Destroy;
                                    } );

              $timer->Start( 500, 1 );
              Wx::WakeUpIdle();
              $frame->Show( 1 );
            } );
}

sub test_app {
  my $function = shift;

  return Tests_Helper_App->new( $function );
}

sub test_frame {
  my( $class, $delete_after ) = @_;
  my @params = @_;

  my $function = sub {
    my $frame = $class->new( @params );

    if( $delete_after ) {
        Wx::Event::EVT_IDLE( $frame,
                             sub { $frame->Destroy } );
        # force idle event delivery
        Wx::Timer->new->Start( 100 );
    }
  };

  my $app = Tests_Helper_App->new( $function );

  return $app;
}

sub test_inheritance {
  my( %perl_inheritance, %cpp_inheritance );

 LOOP: foreach my $i ( @_ ) {
    my $key = $i;
    my $cn = "wx${key}";
    my $ci = Wx::ClassInfo::FindClass( $cn ) or next LOOP;

    while ( 1 ) {
      push @{$cpp_inheritance{$key}}, cpp_2_perl( $cn );

      last unless $ci;
      $cn = $ci->GetBaseClassName1();
      last unless $cn;
      $ci = Wx::ClassInfo::FindClass( $cn );
    }

    my $class = $key;

    while ( $class ) {
      push @{$perl_inheritance{$key}}, "Wx::$class";

      last unless exists $Wx::{"${class}::"}{ISA} && 
        @{ $Wx::{"${class}::"}{ISA} };
      die $class unless defined @{ $Wx::{"${class}::"}{ISA} }[0];
      $class = substr @{ $Wx::{"${class}::"}{ISA} }[0], 4;
    }
  }

 CLASSES: foreach my $i ( keys %perl_inheritance ) {
    my $pi = $perl_inheritance{$i};
    my $ci = $cpp_inheritance{$i};
    my @pi = @$pi;
    my @ci =  @$ci;

  COMPARE: while ( @ci ) {
      my( $c_class ) = shift @ci;
      next if $c_class =~ m/Wx::Generic(?:ListCtrl|ImageList)/;
      next if $c_class =~ m/(?:Base|GTK|X11)$/;
      next if $c_class =~ m/StatusBar/; #FIXME// ad hoc
      next if $c_class eq 'Wx::Object';
      my( $p_class );

      while ( @pi ) {
        $p_class = shift @pi;
        next COMPARE if $c_class eq $p_class;
      }

      ok( 0, $pi->[0] . ' inheritance chain' );
      diag( "C++ : @{$ci}" );
      diag( "Perl: @{$pi}" );

      next CLASSES;
    }

    ok( 1,  $pi->[0] . ' inheritance chain' );
  }
}

{
  my %classes_skip;

  sub test_inheritance_start {
    foreach my $i ( keys %Wx:: ) {
      next unless $i =~ m/^([^_].*)::$/;
      $classes_skip{$1} = 1;
    }
  }

  sub test_inheritance_end {
    my @classes;

    foreach my $i ( keys %Wx:: ) {
      next unless $i =~ m/^([^_].*)::$/;
      next if exists $classes_skip{$1};
      push @classes, $1;
    }

    test_inheritance( @classes );
  }
}

sub test_inheritance_all {
  my @classes;

  foreach my $i ( keys %Wx:: ) {
    next unless $i =~ m/^([^_].*)::$/;
    push @classes, $1;
  }

  test_inheritance( @classes );
}

# utility

sub perl_2_cpp {
  my( $v ) = $_[0];

  $v =~ s/^Wx::/wx/;

  $v;
}

sub cpp_2_perl {
  my( $v ) = $_[0];

  $v =~ s/^wx/Wx::/;

  $v;
}

sub hijack {
  while( @_ ) {
    my( $name, $code ) = ( shift, shift );
    no strict 'refs';
    die "Unknown method name '$name'" unless defined &{$name};
    my $old = \&{$name};
    undef *{$name};
    *{$name} = sub { &$code; goto &$old };
  }
}

sub test_override(&$) {
  my( $code, $method ) = @_;
  my $called = 0;

  local $Test::Builder::Level = $Test::Builder::Level + 1;
  hijack( $method => sub { $called = 1 } );
  $code->();
  ok( $called, $method );
}

package Tests_Helper_App;

use base 'Wx::App';

my $on_init;

sub new {
  my $class = shift;
  my $function = shift;
  $on_init = $function;
  my $this = $class->SUPER::new( @_ );
  $this->SetExitOnFrameDelete(1);
  return $this;
}

sub OnInit {
  &$on_init;

  return 1;
}

package Tests_Helper_Frame;

use base 'Wx::Frame';

sub new {
  my $ref = shift;
  my $callback = shift;
  my $self = $ref->SUPER::new( undef, -1, "Test Frame" );
  my $timer = Wx::Timer->new( $self );

  Wx::Event::EVT_TIMER( $self, -1, sub {
                            &$callback( $self, $_[1] );
                            $self->Destroy;
                        } );

  $timer->Start( 500, 1 );
  Wx::WakeUpIdle();

  return $self;
}

sub Destroy {
    my $self = shift;

    $self->SUPER::Destroy;
    Wx::wxTheApp()->ExitMainLoop;
    Wx::WakeUpIdle();
}

1;

# Local variables: #
# mode: cperl #
# End: #