version 0.75

version 0.75 - see Changes

Author: bulk88

API.h

@@ -8,6 +8,7 @@
     #
  */
 
+#define NEED_sv_2pv_flags
 #include "ppport.h"
 
 /* see https://rt.cpan.org/Ticket/Display.html?id=80217
@@ -139,8 +140,11 @@ typedef struct {
 //with static asserts
 #define CALL_PL_ST_EXTEND 3
 
-#define PREP_SV_SET(sv) if(SvTHINKFIRST((sv))) sv_force_normal_flags((sv), SV_COW_DROP_PV)
-
+#if PERL_BCDVERSION >= 0x5007001
+#  define PREP_SV_SET(sv) if(SvTHINKFIRST((sv))) sv_force_normal_flags((sv), SV_COW_DROP_PV)
+#else
+#  define PREP_SV_SET(sv) if(SvTHINKFIRST((sv))) sv_force_normal((sv))
+#endif
 //C=Callback, CIATP=Callback::IATPatch
 #define W32AC_T HV
 #define W32ACIATP_T HV
@@ -150,3 +154,41 @@ typedef struct {
 #ifndef WC_NO_BEST_FIT_CHARS
 #  define WC_NO_BEST_FIT_CHARS 0x00000400
 #endif
+
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+
+/* prototype to pass -Wmissing-prototypes */
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+    const GV *const gv = CvGV(cv);
+
+    PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+    if (gv) {
+        const char *const gvname = GvNAME(gv);
+        const HV *const stash = GvSTASH(gv);
+        const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+        if (hvname)
+            Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
+        else
+            Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
+    } else {
+        /* Pants. I don't think that it should be possible to get here. */
+        Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+    }
+}
+#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define croak_xs_usage(a,b)	S_croak_xs_usage(aTHX_ a,b)
+#else
+#define croak_xs_usage		S_croak_xs_usage
+#endif
+
+#endif

API.pm

@@ -58,7 +58,7 @@ use File::Basename ();
 #######################################################################
 # STATIC OBJECT PROPERTIES
 #
-$VERSION = '0.74';
+$VERSION = '0.75';
 
 #### some package-global hash to
 #### keep track of the imported

Callback.pm

@@ -16,7 +16,7 @@ use strict;
 use warnings;
 use vars qw( $VERSION @ISA $Stage2FuncPtrPkd );
 
-$VERSION = '0.74';
+$VERSION = '0.75';
 
 
 require Exporter;      # to export the constants to the main:: space
@@ -42,9 +42,12 @@ use Config;
 BEGIN {
     #there is supposed to be 64 bit IVs on 32 bit perl compatibility here
     #but it is untested
-    eval "sub IVSIZE () { ".length(pack('J',0))." }";
+    #Win64 added in 5.7.3
+    eval "sub IVSIZE () { ".length(pack($] >= 5.007003 ? 'J' : 'I' ,0))." }";
     #what kind of stack processing/calling convention/machine code we needed
     eval "sub ISX64 () { ".(index($Config{'archname'},"MSWin32-x64") == 0 ?  1 : 0)." }";
+    eval 'sub OPV () {'.$].'}';
+    sub OPV();
     sub CONTEXT_XMM0();
     sub CONTEXT_RAX();
     *UseMI64 = *Win32::API::UseMI64; #keep UseMI64 out of export list
@@ -53,6 +56,9 @@ BEGIN {
     *PTRSIZE = *Win32::API::PTRSIZE;
     sub PTRLET ();
     *PTRLET = *Win32::API::Type::pointer_pack_type;
+    if(OPV <= 5.008000){ #dont have unpackstring in C
+        eval('sub _CallUnpack {return unpack($_[0], $_[1]);}');
+    }
 }
 #######################################################################
 # dynamically load in the API extension module.
@@ -179,14 +185,19 @@ sub MakeStruct {
 if(! ISX64 ) {
 *RunCB  = sub {#32 bits
     my $self = $_[0];
-    my (@pass_arr, $return, $typeletter, $inbytes);
+    my (@pass_arr, $return, $typeletter, $inbytes, @arr);
     $inbytes = $self->{inbytes};
     #first is ebp copy then ret address
     $inbytes += PTRSIZE * 2;
     my $paramcount = $inbytes / PTRSIZE ;
-    my $stackstr = unpack('P['.$inbytes.']', pack(PTRLET, $_[1]));
-    my @arr = unpack("(a[".PTRLET."])[$paramcount]",$stackstr);
-    #print Dumper(\@arr);
+    my $stackstr = unpack('P'.$inbytes, pack(PTRLET, $_[1]));
+    #pack () were added in 5.7.2
+    if (OPV > 5.007002) {
+        @arr = unpack("(a[".PTRLET."])[$paramcount]",$stackstr);
+    } else {
+        #letter can not be used for size, must be numeric on 5.6
+        @arr = unpack(("a4") x $paramcount,$stackstr);
+    }
     shift @arr, shift @arr; #remove ebp copy and ret address
     $paramcount -= 2;
     $return = &{$self->{sub}}(@{MakeParamArr($self, \@arr)});

Callback/Callback.xs

@@ -79,10 +79,6 @@ BOOL WINAPI DllMain(
 #define boolSV(b) ((b) ? &sv_yes : &sv_no)
 #endif
 
-#ifndef PL_na
-#	define PL_na na
-#endif
-
 #ifndef SvPV_nolen
 #	define SvPV_nolen(sv) SvPV(sv, PL_na)
 #endif
@@ -482,6 +478,9 @@ PREINIT:
     int iTypes;
     AV * Types;
     I32 lenTypes;
+#if (PERL_API_VERSION_LE(5, 8, 0))
+    SV * unpacktypeSV = sv_newmortal();
+#endif
 PPCODE:
     //intypes array ref is always created in PM file
     Types = (AV*)SvRV(*hv_fetch(self, "intypes", sizeof("intypes")-1, 0));
@@ -582,8 +581,17 @@ PPCODE:
             }
             goto HAVEUNPACKED;
         }
+#if ! (PERL_API_VERSION_LE(5, 8, 0))
         PUTBACK;    
         unpackstring(&type, &type+1, packedParam, packedParam+SvCUR(packedParamSV), 0);
+#else /* dont have unpackstring */
+        PUSHMARK(SP);
+        PUSHs(unpacktypeSV);
+        PUSHs(packedParamSV);
+        PUTBACK;
+        sv_setpvn(unpacktypeSV,&type, 1);
+        call_pv("Win32::API::Callback::_CallUnpack", G_SCALAR);
+#endif
         SPAGAIN;
         unpackedParamSV = POPs;
 #ifdef USEMI64

Callback/Makefile.PL

@@ -32,5 +32,6 @@ sub MY::post_constants {
         )),
         'VERSION_FROM' => '../API.pm',
         'dist'	=> {COMPRESS => 'gzip -9f', SUFFIX => 'gz'},
+        ($] > 5.007000 ? () : (TYPEMAPS => ['../typemap56'])),
     );
 

Callback/t/02_Callback.t

@@ -9,7 +9,7 @@ use strict;
 use Config;
 use Test::More;
 use Math::Int64 qw( int64 hex_to_uint64 uint64_to_hex);
-plan tests => 21;
+plan tests => 20;
 use vars qw(
     $function
     $result
@@ -18,11 +18,11 @@ use vars qw(
 );
 
 BEGIN {
-    eval "sub PTR_SIZE () { ".length(pack('J',0))." }";
+    eval "sub PTR_SIZE () { ".length(pack(($] <= 5.007002 ? 'L':'J'),0))." }";
 }
 use_ok('Win32::API');
 use_ok('Win32::API::Callback');
-use_ok('Win32::API::Test');
+use Win32::API::Test;
 
 
 ok(1, 'loaded');
@@ -46,21 +46,6 @@ diag('Compiler version:', $cc_vers);
         'N',
         'N'
     );
-#make the the ActiveState distropref patch succeed
-=pod
-}
-
-SKIP: {
-
-	skip('because callbacks currently /SEGFAULT/ all compilers but MSVC 6+', 1)
-		unless $cc_name eq 'cl' && $cc_vers >= 12;
-
-	$result = $function->Call( $callback, 21 );
-	is($result, 42, 'callback function works');
-}
-
-#
-=cut
     ok($callback, 'callback function defined');
 
     $function = new Win32::API($test_dll, 'do_callback', 'KI', 'I');
@@ -80,16 +65,16 @@ $callback = Win32::API::Callback->new(
         $chr = $_[0] & 0xFF; #x64 fill high bits with garbage
         die "bad char" if chr($chr) ne 'P';
         if(PTR_SIZE == 4){
-            my ($low,$high) = unpack('JJ', $_[1]);
+            my ($low,$high) = unpack(IV_LET.IV_LET, $_[1]);
             die "bad unsigned int64" if $low != 0xABCDEF12;
             die "bad unsigned int64" if $high != 0x12345678;
         }else{
             print "0x".unpack('H[16]', $_[1])."\n";
             no warnings 'portable', 'overflow'; #silence on 32 bits
             die "bad unsigned int64" if $_[1] != eval "0x12345678ABCDEF12";
         }
-        my $f4char = unpack('P[4]',pack('J',$_[2]));
-        die "bad 4 char struct" if $f4char ne "JAPH";
+        my $f4char = unpack('P4',pack(IV_LET,$_[2]));
+        die "bad 4 char struct \"$f4char\"" if $f4char ne "JAPH";
         die "bad float" if $_[3] != 2.5;
         die "bad double" if $_[4] != 3.5;
         return 70000;
@@ -117,7 +102,7 @@ SKIP: {
             $chr = $_[0] & 0xFF; #x64 fill high bits with garbage
             die "bad char" if chr($chr) ne 'P';
             die "bad unsigned int64" if $_[1] != hex_to_uint64("0x12345678ABCDEF12");
-            my $f4char = unpack('P[4]',pack('J',$_[2]));
+            my $f4char = unpack('P4',pack(IV_LET,$_[2]));
             die "bad 4 char struct" if $f4char ne "JAPH";
             die "bad float" if $_[3] != 2.5;
             die "bad double" if $_[4] != 3.5;
@@ -172,15 +157,15 @@ $callback = Win32::API::Callback->new(
         $chr = $_[0] & 0xFF;
         die "bad char" if chr($chr) ne 'P';
         if(PTR_SIZE == 4){
-            my ($low,$high) = unpack('JJ', $_[1]);
+            my ($low,$high) = unpack(IV_LET.IV_LET, $_[1]);
             die "bad unsigned int64" if $low != 0xABCDEF12;
             die "bad unsigned int64" if $high != 0x12345678;
         }else{
             no warnings 'portable', 'overflow'; #silence on 32 bits
             die "bad unsigned int64" if $_[1] != 0x12345678ABCDEF12;
         }
         my $f4char; 
-        $f4char = unpack('P[4]',pack('J',$_[2]));
+        $f4char = unpack('P4',pack(IV_LET,$_[2]));
         die "bad 4 char struct" if $f4char ne "JAPH";
         die "bad float" if $_[3] != 2.5;
         die "bad double" if $_[4] != 3.5;
@@ -232,7 +217,7 @@ $callback = Win32::API::Callback->new(
         #print Dumper(\@_);
         ok(@_ == 0,  "@_ should be empty");
         if(PTR_SIZE == 4){
-            return pack('JJ', 0x30004000, 0x80002000);
+            return pack(IV_LET.IV_LET, 0x30004000, 0x80002000);
         }
         else{
             no warnings 'portable', 'overflow'; #silence on 32 bits
@@ -248,7 +233,7 @@ $result = $function->Call($callback);
 {
     no warnings 'portable', 'overflow'; #silence on 32 bits
     is($result,
-       PTR_SIZE == 4 ? pack('JJ', 0x30004000, 0x80002000) : 0x8000200030004000
+       PTR_SIZE == 4 ? pack(IV_LET.IV_LET, 0x30004000, 0x80002000) : 0x8000200030004000
        , "do_callback_void_q was successful");
 }
 #

Callback/t/iat.t

@@ -37,7 +37,7 @@ $ptrsize = PTR_SIZE;
 my $i = 0;
 $callback = Win32::API::Callback->new(
     sub {
-        my($low, $hi) = unpack('LL', unpack('P[8]', pack('J', $_[0])));
+        my($low, $hi) = unpack('LL', unpack('P8', pack(IV_LET , $_[0])));
         $hi = 0;
         $low = $i;
         $i++;
@@ -161,7 +161,7 @@ tco\276\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0PE\0\0L\1\6\0\223\0028P\0
 undef($patch); #done let old IATPatch change the GLR for the next call, DESTROY happens
 #after the obj was assigned to but before next line
 $patch = Win32::API::Callback::IATPatch ->new($callback,
-    unpack('J', pack('P', $BrokenModule)), 'kernel32.dll', 'QueryPerformanceCounter');
+    unpack(IV_LET, pack('P', $BrokenModule)), 'kernel32.dll', 'QueryPerformanceCounter');
 ok($^E == 193 && ! defined $patch , "IATPatch claims corrupt DLL is corrupt ".($^E+0));
 #193 = ERROR_BAD_EXE_FORMAT
 $patch = Win32::API::Callback::IATPatch ->new($callback,

Callback/t/threading_fails.t

@@ -22,6 +22,8 @@ sub cb {
 }
 my $callback = Win32::API::Callback->new(\&cb, "L", "N");
 
+diag("This might crash");
+
 #$callback->{'code'}, no other way to do it ATM, even though not "public"
 my $hnd = $function->Call(0, 0, $callback->{'code'}, 0, 0, 0);
 ok($hnd, "CreateThread worked");

Changes

@@ -1,5 +1,13 @@
 History of Win32::API perl extension.
 
+2013-01-09  Win32::API v0.75    bulk88
+   - Fixed/added, alpha Perl 5.6.2 support has been added, ::API will compile,
+     will not crash except for randomly threading_fails.t . Many tests fail due
+     to prerequities not being met. 00_API.t should pass on 5.6.2 with zero
+     failures wWITHOUT prereqs. Other tests require Math::Int64 and
+     Encode::compat.
+   - Removed, distropref workaround for ActiveState's PPM system (AS fixed it)
+
 2012-11-21  Win32::API v0.74    bulk88
    - Fixed, non threaded Perl fix from Reini Urban
    - Fixed, Perl 5.8 in Struct.pm syntax error (cpantesters report)

MANIFEST

@@ -73,3 +73,4 @@ Test.pm
 TODO
 Type.pm
 TYPEMAP
+typemap56

Test.pm

@@ -108,6 +108,8 @@ BEGIN {
     eval ' sub PTR_LET () { "'
     .($Config{ptrsize} == 8 ? 'Q' : 'L').
     '" }';
+    eval 'sub IV_LET () { '.($] <= 5.007002 ? 'L':'J').' }';
+    eval 'sub IV_SIZE () { '.length(pack(IV_LET(),0)).' }';
     package Win32::API::Test;
 }
 

Type.pm

@@ -16,7 +16,7 @@ use strict;
 use warnings;
 use vars qw( %Known %PackSize %Modifier %Pointer $VERSION @ISA );
 
-$VERSION = '0.66';
+$VERSION = '0.67';
 
 use Carp;
 BEGIN{
@@ -279,7 +279,7 @@ sub Pack {
         else{
             if(length($_[2]) < 8){
                 warn("Win32::API::Call value for 64 bit integer is under 8 bytes long");
-                $_[2] = pack('a[8]', $_[2]);
+                $_[2] = pack('a8', $_[2]);
             }
         }
         return;