git.maemo.org Git - pkg-perl/blob - deb-src/libwx-perl/libwx-perl-0.96/ext/dnd/t/03_pldatabject.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Wx qw(wxTheClipboard);
   5 use Wx::DND;
   6 use lib '../../t';
   7 use Tests_Helper qw(in_frame);
   8 use Test::More;
   9 BEGIN {
  10     if( !Wx::wxMAC ) {
  11         plan 'tests' => 9;
  12     } else {
  13         plan 'tests' => 11;
  14     }
  15 }
  16
  17 my $FORMAT = 'Wx::Perl::MyCustomFormat';
  18 my $silent = 1;
  19
  20 in_frame(
  21     sub {
  22         my $self = shift;
  23         my $complex = { x => [ qw(a b c), { 'c' => 'd' } ] };
  24         my $copied = MyDataObject->new( $complex );
  25
  26         wxTheClipboard->Open;
  27         wxTheClipboard->Clear;
  28
  29         ok( !wxTheClipboard->IsSupported( Wx::DataFormat->newUser( $FORMAT ) ),
  30             "clipboard empty" );
  31
  32         $silent = 0;
  33
  34         ok( wxTheClipboard->SetData( $copied ), "copying succeeds" );
  35
  36         undef $copied;
  37
  38         my $pasted = MyDataObject->new;
  39
  40         ok( wxTheClipboard->IsSupported( Wx::DataFormat->newUser( $FORMAT ) ),
  41             "format supported" );
  42         ok( wxTheClipboard->GetData( $pasted ), "pasting succeeds" );
  43         isnt( $pasted->GetPerlData, $complex, "Check that identity is not the same" );
  44
  45         is_deeply( $pasted->GetPerlData, $complex, "Correctly copied" );
  46
  47         wxTheClipboard->Close;
  48     } );
  49
  50 package MyDataObject;
  51
  52 use strict;
  53 use base qw(Wx::PlDataObjectSimple);
  54 use Storable;
  55 use Test::More;
  56
  57 sub new {
  58     my( $class, $data ) = @_;
  59     my $self = $class->SUPER::new( Wx::DataFormat->newUser( $FORMAT ) );
  60
  61     $self->{data} = $data;
  62
  63     return $self;
  64 }
  65
  66 sub SetData {
  67     my( $self, $serialized ) = @_;
  68
  69     $self->{data} = Storable::thaw $serialized;
  70     ok( 1, "SetData called" ) unless $silent;
  71
  72     return 1;
  73 }
  74
  75 sub GetDataHere {
  76     my( $self ) = @_;
  77
  78     ok( 1, "GetDataHere called" ) unless $silent;
  79
  80     return Storable::freeze $self->{data};
  81 }
  82
  83 sub GetDataSize {
  84     my( $self ) = @_;
  85
  86     ok( 1, "GetDataSize called" ) unless $silent;
  87
  88     return length Storable::freeze $self->{data};
  89 }
  90
  91 sub GetPerlData { $_[0]->{data} }
  92
  93 1;