#!/usr/bin/perl -w
use strict;
use Wx qw(wxTheClipboard);
use Wx::DND;
use lib '../../t';
use Tests_Helper qw(in_frame);
use Test::More;
BEGIN {
if( !Wx::wxMAC ) {
plan 'tests' => 9;
} else {
plan 'tests' => 11;
}
}
my $FORMAT = 'Wx::Perl::MyCustomFormat';
my $silent = 1;
in_frame(
sub {
my $self = shift;
my $complex = { x => [ qw(a b c), { 'c' => 'd' } ] };
my $copied = MyDataObject->new( $complex );
wxTheClipboard->Open;
wxTheClipboard->Clear;
ok( !wxTheClipboard->IsSupported( Wx::DataFormat->newUser( $FORMAT ) ),
"clipboard empty" );
$silent = 0;
ok( wxTheClipboard->SetData( $copied ), "copying succeeds" );
undef $copied;
my $pasted = MyDataObject->new;
ok( wxTheClipboard->IsSupported( Wx::DataFormat->newUser( $FORMAT ) ),
"format supported" );
# intermittent non-repeatable failure on MSW and GTK
# On GTK I see when running tests on a VM accessed by
# VNC that doesn't have the focus on the client machine.
# I had assumed this was a GTK + Visual Box + VNC
# issue - but I recently have seen this on MSW box (no
# VNC present, not VM). Can't repeat the problem on MSW.
# What to do? The 'undef copied' above looks suspicious
# but all the code behind it looks correct to me re ref
# counting the Perl SV and not destroying the C++ data.
TODO: {
local $TODO = 'intermittent failure to GetData on wxMSW and wxGTK';
ok( wxTheClipboard->GetData( $pasted ), "pasting succeeds" );
}
isnt( $pasted->GetPerlData, $complex, "Check that identity is not the same" );
TODO: {
local $TODO = 'intermittent failure to GetPerlData on wxMSW and wxGTK';
is_deeply( $pasted->GetPerlData, $complex, "Correctly copied" );
wxTheClipboard->Close;
}
} );
package MyDataObject;
use strict;
use base qw(Wx::PlDataObjectSimple);
use Storable;
use Test::More;
sub new {
my( $class, $data ) = @_;
my $self = $class->SUPER::new( Wx::DataFormat->newUser( $FORMAT ) );
$self->{data} = $data;
return $self;
}
sub SetData {
my( $self, $serialized ) = @_;
$self->{data} = Storable::thaw $serialized;
ok( 1, "SetData called" ) unless $silent;
return 1;
}
sub GetDataHere {
my( $self ) = @_;
ok( 1, "GetDataHere called" ) unless $silent;
return Storable::freeze $self->{data};
}
sub GetDataSize {
my( $self ) = @_;
ok( 1, "GetDataSize called" ) unless $silent;
return length Storable::freeze $self->{data};
}
sub GetPerlData { $_[0]->{data} }
1;