Update of /cvsroot/perl-win32-gui/Win32-GUI/Win32-GUI-DropFiles/t
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2364/Win32-GUI-DropFiles/t
Added Files:
01_load.t 02_old_callback.t 03_new_callback.t
04_GetDroppedFiles.t 05_GetDroppedFile.t 06_GetDropPos.t
07_DragQueryFile.t 08_DragQueryPoint.t 09_DragFinish.t
10_Unicode.t 11_invalid_handles.t 98_pod.t 99_pod_coverage.t
DropTest.pm
Log Message:
Add Win32::GUI::DropFiles
--- NEW FILE: 99_pod_coverage.t ---
#!perl -wT
# Win32::GUI::DropFiles test suite.
# $Id: 99_pod_coverage.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
# Check the POD covers all method calls
use strict;
use warnings;
use Test::More;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
if $@;
plan skip_all => "Pod Coverage tests for Win32::GUI::DropFiles done by core" if
$ENV{W32G_CORE};
all_pod_coverage_ok();
--- NEW FILE: 10_Unicode.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 10_Unicode.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles Unicode support
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
#No unicode support before WinNT
plan skip_all => "No Unicode filename support in Win95/98/ME" if
Win32::GetOSVersion() < 2;
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing Uniocde Support" if
$@;
eval "use Unicode::String";
plan skip_all => "Unicode::String required for testing Unicode Support" if
$@;
}
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my @tests = (
# Ascii chars only
[ "AB", "C", "Longer Name with spaces", ],
# Simley face
[ "\x{263A}", ],
# Hello World - multi-lingual
[ "Hello world",
"\x{039A}\x{03B1}\x{03BB}\x{3B7}\x{03BC}\x{1F73}\x{03C1}\x{03B1}",
"\x{03B1}\x{1F79}\x{03C3}\x{03BC}\x{03B5},
\x{30B3}\x{30F3}\x{30CB}\x{30C1}\x{30CF}",
],
# Thai
[ "\x{0E4F}
\x{0E41}\x{0E1C}\x{0E48}\x{0E19}\x{0E14}\x{0E34}\x{0E19}\x{0E2E}\x{0E31}\x{0E48}\x{0E19}\x{0E40}\x{0E2A}\x{0E37}\x{0E48}\x{0E2D}\x{0E21}\x{0E42}\x{0E17}\x{0E23}\x{0E21}\x{0E41}\x{0E2A}\x{0E19}\x{0E2A}\x{0E31}\x{0E07}\x{0E40}\x{0E27}\x{0E0A}",
"\x{0E1E}\x{0E23}\x{0E30}\x{0E1B}\x{0E01}\x{0E40}\x{0E01}\x{0E28}\x{0E01}\x{0E2D}\x{0E07}\x{0E1A}\x{0E39}\x{0E4A}\x{0E01}\x{0E39}\x{0E49}\x{0E02}\x{0E36}\x{0E49}\x{0E19}\x{0E43}\x{0E2B}\x{0E21}\x{0E48}",
],
);
plan tests => 1 * scalar @tests;
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
my $files;
while($files = shift @tests) {
my $dt = DropTest->new(files => $files, wide => 1);
$dt->PostDropMessage($W);
Win32::GUI::Dialog();
}
exit(0);
sub drop {
my ($self, $dropobj) = @_;
my @f = $dropobj->GetDroppedFiles();
ok(eq_set($files,[EMAIL PROTECTED]), "Correct set of files found");
return -1;
}
--- NEW FILE: 98_pod.t ---
#!perl -wT
# Win32::GUI::DropFiles test suite.
# $Id: 98_pod.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
# Check that our pod documentation has valid syntax
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
plan skip_all => "Pod tests for Win32::GUI::DropFiles done by core" if
$ENV{W32G_CORE};
all_pod_files_ok();
--- NEW FILE: 03_new_callback.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 03_new_callback.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI DropFiles callback after loading Win32::GUI::DropFiles
# - check pre-requsites
# - check both OEM and NEM callbacks
# - check callback parameter types
# - check that DragFinish is called
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing New Callback API" if
$@;
}
plan tests => 7;
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my $dropobj = DropTest->new();
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
-eventmodel => "byname",
);
Win32::GUI::DoEvents();
# Do the OEM tests
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
# Check that the receiver freed the handle
ok($dropobj->Free(), "OEM frees the drop object");
# Now do the NEM tests:
$W->Change(-eventmodel => "byref");
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
ok($dropobj->Free(), "NEM frees the drop object");
exit(0);
sub win_DropFiles {
my ($dropobj) = shift;
ok(defined $dropobj, "OEM callback, dropobj defined");
isa_ok($dropobj, "Win32::GUI::DropFiles", "OEM dropobj is a
Win32::GUI::DropFiles object");
return -1;
}
sub drop {
my ($self, $dropobj) = @_;
is($self, $W, "NEM callback gets window object");
ok(defined $dropobj, "NEM callback, dropobj defined");
isa_ok($dropobj, "Win32::GUI::DropFiles","NEM dropobj is a
Win32::GUI::DropFiles object");
return -1;
}
--- NEW FILE: 07_DragQueryFile.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 07_DragQueryFile.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles DragQueryFile() function
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing DragQueryFile()" if
$@;
}
plan tests => 33;
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
# Some Useful constants:
sub EINVAL() {22}
sub ERROR_INVALID_INDEX() {1413}
# Cygwin doesn't provide Win32 extended errors, so $^E == $!
my $EXPECTED_E = (lc $^O eq "cygwin") ? EINVAL : ERROR_INVALID_INDEX;
my @files = ( "A", "B", "Longer Name with spaces" );
my $dropobj = DropTest->new(
files => [EMAIL PROTECTED],
);
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
exit(0);
sub drop {
my ($self, $dropobj) = @_;
# DragQueryFile with no params returns the number of files
is(Win32::GUI::DropFiles::DragQueryFile($dropobj), scalar @files, "Correct
number of files when passed object");
is(Win32::GUI::DropFiles::DragQueryFile($dropobj->{-handle}), scalar
@files, "Correct number of files when passed handle");
is($dropobj->DragQueryFile(), scalar @files, "Correct number of files when
called as method");
# DragQueryFile with one param returns file name
my $count = $dropobj->GetDroppedFiles();
{
my @f;
for (0..$count-1) {
push @f, Win32::GUI::DropFiles::DragQueryFile($dropobj, $_);
}
ok(eq_set([EMAIL PROTECTED],[EMAIL PROTECTED]), "Correct set of files
found when passed object");
# Test out of range indices
for my $index (-1, $count, 1000) {
my($r, $e);
$!=$^E=0;
$r = Win32::GUI::DropFiles::DragQueryFile($dropobj,$index);
$e = $^E; # record value of $^E immediately
is($r, undef , "Out of range index ($index) returns undef when
passed object");
SKIP: {
skip "Can't test error values if no error", 2 if defined $r;
cmp_ok($!, '==', EINVAL, "errno set to EINVAL");
cmp_ok($^E, '==', $EXPECTED_E, "GetLastError returns
ERROR_INVALID_INDEX");
}
}
}
{
my @f;
for (0..$count-1) {
push @f, Win32::GUI::DropFiles::DragQueryFile($dropobj->{-handle},
$_);
}
ok(eq_set([EMAIL PROTECTED],[EMAIL PROTECTED]), "Correct set of files
found when passed handle");
# Test out of range indices
for my $index (-1, $count, 1000) {
my($r, $e);
$!=$^E=0;
$r =
Win32::GUI::DropFiles::DragQueryFile($dropobj->{-handle},$index);
$e = $^E; # record value of $^E immediately
is($r, undef , "Out of range index ($index) returns undef when
passed handle");
SKIP: {
skip "Can't test error values if no error", 2 if defined $r;
cmp_ok($!, '==', EINVAL, "errno set to EINVAL");
cmp_ok($^E, '==', $EXPECTED_E, "GetLastError returns
ERROR_INVALID_INDEX");
}
}
}
{
my @f;
for (0..$count-1) {
push @f, $dropobj->DragQueryFile($_);
}
ok(eq_set([EMAIL PROTECTED],[EMAIL PROTECTED]), "Correct set of files
found when called as method");
# Test out of range indices
for my $index (-1, $count, 1000) {
my($r, $e);
$!=$^E=0;
$r = $dropobj->DragQueryFile($index);
$e = $^E; # record value of $^E immediately
is($r, undef , "Out of range index ($index) returns undef when
called as method");
SKIP: {
skip "Can't test error values if no error", 2 if defined $r;
cmp_ok($!, '==', EINVAL, "errno set to EINVAL");
cmp_ok($^E, '==', $EXPECTED_E, "GetLastError returns
ERROR_INVALID_INDEX");
}
}
}
return -1;
}
--- NEW FILE: 08_DragQueryPoint.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 08_DragQueryPoint.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles DragQueryPoint() function
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing DragQueryPoint()" if
$@;
}
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my @testdata = (
{ x => 100, y => 120, c => 1 },
{ x => 1, y => -1, c => 0 },
);
my $numtests = scalar @testdata;
plan tests => 9 * $numtests;
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
my $testnum;
for (0..$numtests-1) {
$testnum = $_;
my $dropobj = DropTest->new(
x => $testdata[$testnum]->{x},
y => $testdata[$testnum]->{y},
client => $testdata[$testnum]->{c},
);
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
}
exit(0);
sub drop {
my ($self, $dropobj) = @_;
# DragQueryPoint returns a list of x, y, client info
{
my ($x, $y, $c) = Win32::GUI::DropFiles::DragQueryPoint($dropobj);
is($x, $testdata[$testnum]->{x}, "X-pos reported correctly when passed
object");
is($y, $testdata[$testnum]->{y}, "Y-pos reported correctly when passed
object");
is($c, $testdata[$testnum]->{c}, "client pos reported correctly when
passed object");
}
{
my ($x, $y, $c) =
Win32::GUI::DropFiles::DragQueryPoint($dropobj->{-handle});
is($x, $testdata[$testnum]->{x}, "X-pos reported correctly when passed
handle");
is($y, $testdata[$testnum]->{y}, "Y-pos reported correctly when passed
handle");
is($c, $testdata[$testnum]->{c}, "client pos reported correctly when
passed handle");
}
{
my ($x, $y, $c) = $dropobj->DragQueryPoint();
is($x, $testdata[$testnum]->{x}, "X-pos reported correctly when called
as method");
is($y, $testdata[$testnum]->{y}, "Y-pos reported correctly when called
as method");
is($c, $testdata[$testnum]->{c}, "client pos reported correctly when
called as method");
}
return -1;
}
--- NEW FILE: 01_load.t ---
#!perl -wT
# Win32::GUI::DropFiles test suite
# $Id: 01_load.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# - check pre-requsites
# - check module loads
# - check module has a version
# - check we didn't import lots of constants from Win32::GUI
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# Pre-requisites: Bail out if we havent got Test::More
eval "use Test::More";
if($@) {
# As we haven't got Test::More, can't use diag()
print "#\n# Test::More required to perform any Win32::GUI::DragDrop test\n";
chomp $@;
$@ =~ s/^/# /gm;
print "[EMAIL PROTECTED]";
print "Bail Out! Test::More not available\n";
exit(1);
}
plan( tests => 4 );
# Pre-requisites: Check that we're on windows or cygwin
# bail out if we're not
if ( not ($^O =~ /MSwin32|cygwin/i)) {
diag("\nWin32::GUI can only run on MSWin32 or cygwin, not '$^O'");
print "Bail out! Incompatible Operating System\n";
}
pass("Correct OS: $^O");
# Check that Win32::GUI::DropFiles loads, and bail out of all
# tests if it doesn't
use_ok('Win32::GUI::DropFiles')
or print STDOUT "Bail out! Can't load Win32::GUI::DropFiles";
# Check that Win32::GUI::DropFiles has a version
ok(defined $Win32::GUI::DropFiles::VERSION, "Win32::GUI::DropFiles version
check");
# Check that we didn't accidently import lots of constants from Win32::GUI
ok(!defined &Win32::GUI::DropFiles::ES_WANTRETURN, "No Win32::GUI constants");
--- NEW FILE: 05_GetDroppedFile.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 05_GetDroppedFile.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles GetDroppedFile() method
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing GetDroppedFile()" if
$@;
}
plan tests => 10;
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
# Some Useful constants:
sub EINVAL() {22}
sub ERROR_INVALID_INDEX() {1413}
# Cygwin doesn't provide Win32 extended errors, so $^E == $!
my $EXPECTED_E = (lc $^O eq "cygwin") ? EINVAL : ERROR_INVALID_INDEX;
my @files = ( "A", "B", "Longer Name with spaces" );
my $dropobj = DropTest->new(
files => [EMAIL PROTECTED],
);
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
exit(0);
sub drop {
my ($self, $dropobj) = @_;
# GetDroppedFiles in scalar context returns number of files
my $count = $dropobj->GetDroppedFiles();
my @f;
for (0..$count-1) {
push @f, $dropobj->GetDroppedFile($_);
}
ok(eq_set([EMAIL PROTECTED],[EMAIL PROTECTED]), "Correct set of files
found");
# Test out of range indices
for my $index (-1, $count, 1000) {
my($r, $e);
$!=$^E=0;
$r = $dropobj->GetDroppedFile($index);
$e = $^E; # record value of $^E immediately
is($r, undef , "Out of range index ($index) returns undef");
SKIP: {
skip "Can't test error values if no error", 2 if defined $r;
cmp_ok($!, '==', EINVAL, "errno set to EINVAL");
cmp_ok($^E, '==', $EXPECTED_E, "GetLastError returns
ERROR_INVALID_INDEX");
}
}
return -1;
}
--- NEW FILE: 04_GetDroppedFiles.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 04_GetDroppedFiles.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles GetDroppedFiles() method
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing GetDroppedFiles()"
if $@;
}
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my @tests = (
[ "A", "B", "Longer Name with spaces" ],
[], # no files should never happen, but just in case ...
);
plan tests => 2 * scalar @tests;
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
my $files;
while($files = shift @tests) {
my $dt = DropTest->new(files => $files);
$dt->PostDropMessage($W);
Win32::GUI::Dialog();
}
exit(0);
sub drop {
my ($self, $dropobj) = @_;
# GetDroppedFiles in scalar context returns number of files
is(scalar $dropobj->GetDroppedFiles(), scalar @{$files}, "Correct number of
files");
# GetDroppedFiles in list context returns the list of files
my @f = $dropobj->GetDroppedFiles();
ok(eq_set($files,[EMAIL PROTECTED]), "Correct set of files found");
return -1;
}
--- NEW FILE: 11_invalid_handles.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 11_invalid_handles.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles win32 API doesn't barf with invalid handles
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI::DropFiles will load.
use Test::More;
use Win32::GUI::DropFiles;
my @handles = (0, int(rand(2**32)),);
plan tests => 6 * scalar @handles;
# Useful Constants:
sub EINVAL() {22}
sub ERROR_INVALID_HANDLE() {6}
# On cygwin, $^E == $! (no OS extended errors)
my $EXPECTED_E = ERROR_INVALID_HANDLE;
if(lc $^O eq "cygwin") {
$EXPECTED_E = EINVAL;
}
for my $h (@handles) {
my ($r, $e);
# DragQueryFile
$!=0;$^E=0;
$r = Win32::GUI::DropFiles::DragQueryFile($h);
$e = $^E; # Record $^E immediately after call
is($r , undef, "DragQueryFile: Invalid handle $h returns undef");
SKIP: {
skip "DragQueryFiles: Can't test error codes if we didn't get an
error", 2 if defined $r;
cmp_ok($!, "==", EINVAL, "DragQueryFile: Errno set to EINVAL");
cmp_ok($e, "==", $EXPECTED_E, "DragQueryFile: LastError set to
ERROR_INVALID_HANDLE");
}
# DragQueryPoint
$!=0;$^E=0;
$r = Win32::GUI::DropFiles::DragQueryPoint($h);
$e = $^E; # Record $^E immediately after call
is($r, undef, "DragQueryPoint: Invalid handle $h returns undef");
SKIP: {
skip "DragQueryPoint: Can't test error codes if we didn't get an
error", 2 if defined $r;
cmp_ok($!, "==", EINVAL, "DragQueryPoint: Errno set to EINVAL");
cmp_ok($^E, "==", $EXPECTED_E, "DragQueryPoint: LastError set to
ERROR_INVALID_HANDLE");
}
# DragFinish
# DragFinish sets LastError inconsistently, using ERROR_INVALID_PARAMETER
# on win98 and ERROR_INVALID_HANDLE on winNT. Also on WinNT, doesn't
# consider 0 to be invalid. As there is no return value from DragFinish,
# the user can't tell if there was an error or not, so doen't know if
# $^E contains anything useful or not, so we don't need to do the test.
}
--- NEW FILE: 02_old_callback.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 02_old_callback.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI DropFiles callback without loading Win32::GUI::DropFiles
# This is really a Win32::GUI test, not a Win32::GUI::Dropfiles test,
# but is here for completeness
# This old callback format is kept for backwards compatibility with
# The GUI Loft's Win32::GUI::DragDrop package.
# - check pre-requsites
# - check both OEM and NEM callbacks
# - check callback parameter types
# - check that DragFinish is called
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing Old Callack API" if
$@;
}
plan tests => 7;
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
my $dropobj = DropTest->new();
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
-eventmodel => "byname",
);
Win32::GUI::DoEvents();
# Do the OEM tests
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
# Check that the receiver freed the handle
ok($dropobj->Free(), "OEM frees the drop object");
# Now do the NEM tests:
$W->Change(-eventmodel => "byref");
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
ok($dropobj->Free(), "NEM frees the drop object");
exit(0);
sub win_DropFiles {
my ($drophandle) = shift;
ok(defined $drophandle, "OEM callback, drophandle defined");
is(ref($drophandle), "", "OEM drophandle is a scalar");
return -1;
}
sub drop {
my ($self, $drophandle) = @_;
is($self, $W, "NEM callback gets window object");
ok(defined $drophandle, "NEM callback, drophandle defined");
is(ref($drophandle), "", "NEM drophandle is a scalar");
return -1;
}
--- NEW FILE: DropTest.pm ---
package DropTest;
# $Id: DropTest.pm,v 1.1 2006/04/25 21:38:19 robertemay Exp $
# package to hide away the complexity of generating a WM_DROPEVENT on a window.
# Written by Robert May, April 2006
#
# This would be an ideal candidate for implementing in XS within a
Win32::GUI::Test
# module
#
use strict;
use warnings;
use Win32();
use Win32::GUI();
use Win32::API();
Win32::API->Import('Kernel32', 'GlobalAlloc', 'LL', 'L') || die "No
GlobalAlloc: $^E";
Win32::API->Import('Kernel32', 'GlobalLock', 'L', 'L') || die "No GlobalLock:
$^E";
Win32::API->Import('Kernel32', 'GlobalUnlock', 'L', 'L') || die "No
GlobalUnlock: $^E";
Win32::API->Import('Kernel32', 'GlobalFree', 'L', 'L') || die "No GlobalFree:
$^E";
Win32::API->Import('Kernel32', 'GlobalFlags', 'L', 'L') || die "No GlobalFree:
$^E";
Win32::API->Import("kernel32", "RtlMoveMemory", "LPI", "V") || die "No
RtlMoveMemory: $^E";
sub WM_DROPFILES() {563}
sub NO_ERROR() {0}
sub GHND() {0x0042} # GHND = GMEM_MOVEABLE|GMEM_ZERO_INIT = 0x0042
sub GMEM_INVALID_HANDLE() {32768}
sub new {
my $class = shift;
my %options = @_;
$options{x} ||= 0;
$options{y} ||= 0;
$options{wide} ||= 0;
$options{client} = 1 unless defined $options{client};
my $files = [];
if(exists $options{files}) {
if(ref($options{files}) eq "ARRAY") {
for my $file (@{$options{files}}) {
push @{$files}, $file;
}
}
else {
die("files option must be an array ref");
}
}
else {
$files = ['File1', 'File2', 'File3',];
}
if($options{wide}) {
require Unicode::String; # use this in place of Encode, as Encode does
not ship with Perl 5.6
for my $file (@{$files}) {
$file = Unicode::String::utf8($file)->byteswap->ucs2;
}
}
$options{files} = $files;
return bless \%options, $class;
}
sub PostDropMessage {
my ($self,$dest) = @_;
# always create a new handle, as the receiver is supposed to free it.
my $hdrop = $self->_create_new_drop_handle();
$dest->PostMessage(WM_DROPFILES, $hdrop, 0);
# The recieving process should free the hdrop handle,
# and the handle should be invalid sometime after this call
# Check using isFree before calling PostDropMessage again
return;
}
# return TRUE if the hdrop handle associated with the object is freed (invalid)
# if not freed, free it and return false
sub Free {
my ($self) = @_;
my $hdrop = $self->{hdrop};
return 1 unless $hdrop;
my $locks = GlobalFlags($hdrop);
delete $self->{hdrop};
return 1 if $locks == GMEM_INVALID_HANDLE;
GlobalFree($hdrop);
return 0;
}
sub _create_new_drop_handle
{
my ($self) = @_;
# Free any previous handle, and warn us if it wasn't freed
if(!$self->Free()) {
warn "Old drop handle not freed - check for error";
}
# DROPFILES struct:
# typedef struct _DROPFILES {
# DWORD pFiles;
# POINT pt;
# BOOL fNC;
# BOOL fWide;
# } DROPFILES, *LPDROPFILES;
# followed by double NULL terminated string structure
my $term = "x";
$term = "xx" if $self->{wide};
my $buffer = pack("LLLLL" . "a*$term" x @{$self->{files}} . $term,
20, # sizeof(DROPFILES) - string ptr offset
$self->{x},
$self->{y},
$self->{client} ? 0 : 1,
$self->{wide} ? 1 : 0,
@{$self->{files}},
);
my $size = length($buffer);
my $hdrop = GlobalAlloc(GHND, $size) or die "GlobalAlloc failed: $^E";
my $ptr = GlobalLock($hdrop) or die "GlobalLock failed: $^E";
RtlMoveMemory($ptr, $buffer, $size);
GlobalUnlock($hdrop);
return $self->{hdrop} = $hdrop;
}
sub dump {
my $self = shift;
if($self->{hdrop}) {
my $hdrop = $self->{hdrop};
print "Dumping handle: $hdrop\n";
my $ptr = GlobalLock($hdrop);
die "GlobalLock failed: $^E" unless $ptr;
# Get the header (HROPFILES) structure
my ($poff, $x, $y, $nc, $fwide) = unpack("LLLLL", unpack("P20",
pack("L", $ptr)));
print " poff:\t$poff\n";
print " x:\t$x\n";
print " y:\t$y\n";
print " nc:\t$nc\n";
print " wide:\t$fwide\n";
my $count = 0;
$ptr += $poff;
# This is probably hideously slow, but as it's only for debug ...
my $pack_str = "C";
my $char_len = 1;
if($fwide) {
$pack_str = "v";
$char_len = 2;
}
my $last_char_null = 0;
my $file = "";
while(1) {
my $char = unpack($pack_str, unpack("P$char_len", pack("L", $ptr)));
$ptr += $char_len;
last if $last_char_null && $char == 0;
if($char == 0) {
$last_char_null = 1;
printf " File $count: $file [%vx]\n", $file;
$count++;
$file = "";
next;
}
$last_char_null = 0;
$file .= chr $char;
}
GlobalUnlock($hdrop);
}
else {
print "No data to dump\n";
}
return;
}
sub DESTROY
{
# free the handle if necessary
$_[0]->Free();
}
# Static function to determine if a drop handle is valid or not
sub isValidHandle
{
my $handle = shift;
my $locks = GlobalFlags($handle);
return 0 if $locks == GMEM_INVALID_HANDLE;
return 1;
}
1; # End of DropTest.pm
--- NEW FILE: 09_DragFinish.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 09_DragFinish.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles DragFinish() function
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing DragFinish()" if $@;
}
plan tests => 1;
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my $dropobj = DropTest->new();
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
exit(0);
sub drop {
my ($self, $dropobj) = @_;
#Calling DragFinish should make the HDROP handle invalid
Win32::GUI::DropFiles::DragFinish($dropobj->{-handle});
is(DropTest::isValidHandle($dropobj->{-handle}), 0, "handle invalidated");
return -1;
}
--- NEW FILE: 06_GetDropPos.t ---
#!perl -w
# Win32::GUI::DropFiles test suite
# $Id: 06_GetDropPos.t,v 1.1 2006/04/25 21:38:19 robertemay Exp $
#
# Test Win32::GUI::DropFiles GetDropPos() method
use strict;
use warnings;
BEGIN { $| = 1 } # Autoflush
# We assume that 01_load.t has been run, so we know we have Test::More
# and that Win32::GUI and Win32::GUI::DropFiles will load.
use Test::More;
BEGIN {
eval "use Win32::API 0.41";
plan skip_all => "Win32::API 0.41 required for testing GetDropPos()" if $@;
}
# Load our helpers
use FindBin;
use lib "$FindBin::Bin";
use DropTest;
use Win32::GUI 1.03_02;
use Win32::GUI::DropFiles;
my @testdata = (
{ x => 100, y => 120, c => 1 },
{ x => 1, y => -1, c => 0 },
);
my $numtests = scalar @testdata;
plan tests => 6 * $numtests;
my $W = Win32::GUI::Window->new(
-name => 'win',
-title => "Win32::GUI DropFiles Test",
-size => [400,300],
-onDropFiles => \&drop,
);
Win32::GUI::DoEvents();
my $testnum;
for (0..$numtests-1) {
$testnum = $_;
my $dropobj = DropTest->new(
x => $testdata[$testnum]->{x},
y => $testdata[$testnum]->{y},
client => $testdata[$testnum]->{c},
);
$dropobj->PostDropMessage($W);
Win32::GUI::Dialog();
}
exit(0);
sub drop {
my ($self, $dropobj) = @_;
# GetDropPos in scalar context returns client area or not
is($dropobj->GetDropPos(), $testdata[$testnum]->{c}, "Correct client
indication");
# In list context give x, y and client indicators:
{ my ($x, $y) = $dropobj->GetDropPos();
is($x, $testdata[$testnum]->{x}, "X-pos reported correctly");
is($y, $testdata[$testnum]->{y}, "Y-pos reported correctly");
}
{ my ($x, $y, $client) = $dropobj->GetDropPos();
is($x, $testdata[$testnum]->{x}, "X-pos reported correctly");
is($y, $testdata[$testnum]->{y}, "Y-pos reported correctly");
is($client, $testdata[$testnum]->{c}, "client pos reported correctly");
}
return -1;
}
