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