File Coverage

blib/lib/Wx/DemoModules/lib/DataObjects.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#############################################################################
## Name:        lib/Wx/DemoModules/lib/DataObjects.pm
## Purpose:     wxPerl demo helper
## Author:      Mattia Barbon
## Modified by:
## Created:     12/09/2001
## RCS-ID:      $Id: DataObjects.pm 2189 2007-08-21 18:15:31Z mbarbon $
## Copyright:   (c) 2001, 2006 Mattia Barbon
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

use Wx::DND;

package Wx::DemoModules::lib::DataObjects;

use strict;
use base qw(Exporter); # for Perl 5.8.1 or earlier

use Wx qw(:brush :pen :bitmap);

our @EXPORT = qw(get_image get_perl_data_object get_bitmap_data_object
                 get_text_data_object get_text_bitmap_data_object);

sub get_image {
  my $bitmap = Wx::Bitmap->new( 100, 100 );
  my $dc = Wx::MemoryDC->new;
  $dc->SelectObject( $bitmap );

  my @brushes = ( wxWHITE_BRUSH, wxBLUE_BRUSH, wxGREEN_BRUSH,
                  wxGREY_BRUSH, wxCYAN_BRUSH );
  $dc->SetBrush( @brushes[rand(5)] );
  $dc->DrawRectangle( 0, 0, 100, 100 );

  $dc->SetPen( wxBLACK_PEN );
  $dc->SetBrush( new Wx::Brush( 'yellow', wxSOLID ) );

  $dc->DrawEllipse( 1, 1, 98, 98 );

  $dc->SetBrush( wxWHITE_BRUSH );
  $dc->DrawEllipse( 20, 20, 25, 25 );
  $dc->DrawEllipse( 100 - 45, 20, 25, 25 );

  $dc->SelectObject( wxNullBitmap );

  return $bitmap;
}

sub get_bitmap_data_object {
  return Wx::BitmapDataObject->new( get_image() );
}

sub get_text_data_object {
  return Wx::TextDataObject->new( "Hello, wxPerl!" );
}

sub get_text_bitmap_data_object {
  my $data = Wx::DataObjectComposite->new;
  my $text = <
This is a yellow face.
EOT
  $text =~ s/\n/\r\n/g;

  $data->Add( Wx::TextDataObject->new( $text ) );
  $data->Add( Wx::BitmapDataObject->new( get_image() ), 1 );

  return $data;
}

sub get_perl_data_object {
    return Wx::DemoModules::lib::DataObjects::Perl->new( @_ );
}

package Wx::DemoModules::lib::DataObjects::Perl;

use strict;
use base qw(Wx::PlDataObjectSimple);

use Storable qw(freeze thaw);

sub new {
    my( $class, $data ) = @_;
    my $self = $class->SUPER::new( Wx::DataFormat->newUser( __PACKAGE__ ) );
	$self->{Data} = $data;
    return $self;
}

sub SetData {
    my( $self, $data ) = @_;
    $self->{Data} = thaw $data ;
    return 1;
}

sub GetDataHere {
    my ($self) = @_;
    return freeze $self->{Data} if ref $self->{Data};
}

sub GetDataSize {
    my( $self ) = @_;
    return length freeze $self->{Data} if ref $self->{Data};
}

sub GetPerlData { $_[0]->{Data} }

1;