Permalink
Browse files

General perltidy applied to everything

  • Loading branch information...
1 parent 8ba7176 commit ebbafaffc6b2c895c7a73bfa8d6e0ce97ec2a39a @cosimo committed Feb 12, 2012
Showing with 1,475 additions and 1,418 deletions.
  1. +147 −117 API.pm
  2. +47 −42 Callback.pm
  3. +25 −23 Callback/t/02_Callback.t
  4. +25 −22 Callback/t/03_Jim_Shaw.t
  5. +9 −8 Callback/t/04_rt_53914.t
  6. +8 −4 Changes
  7. +2 −0 MANIFEST
  8. +2 −2 META.yml
  9. +2 −3 README
  10. +171 −151 Struct.pm
  11. +60 −63 Test.pm
  12. +95 −71 Type.pm
  13. +8 −6 samples/GetCursorPos.pl
  14. +125 −143 samples/Win32/kernel32.pm
  15. +8 −6 samples/callback1.pl
  16. +4 −4 samples/callback2.pl
  17. +67 −59 samples/callback3.pl
  18. +36 −31 samples/cdinfo.pl
  19. +128 −130 samples/chres.pl
  20. +6 −9 samples/ejectcd.pl
  21. +11 −11 samples/hideconsole.pl
  22. +23 −37 samples/kernel32.pl
  23. +3 −3 samples/locales.pl
  24. +71 −80 samples/packing.pl
  25. +14 −26 samples/resolution.pl
  26. +24 −31 samples/rndcolors.pl
  27. +50 −38 samples/wininfo.pl
  28. +33 −51 t/00_API.t
  29. +37 −32 t/01_Struct.t
  30. +10 −9 t/02_GetProcess.t
  31. +9 −9 t/03_undef.t
  32. +13 −13 t/04_rt_48006.t
  33. +102 −93 t/05_more_struct.t
  34. +100 −91 t/StructTest.pl
View
264 API.pm
@@ -4,7 +4,7 @@
#######################################################################
#
# Win32::API - Perl Win32 API Import Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
@@ -15,17 +15,18 @@
package Win32::API;
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
@ISA = qw( Exporter DynaLoader );
use vars qw( $DEBUG );
$DEBUG = 0;
-sub DEBUG {
- if ($Win32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
return 0;
}
}
@@ -37,12 +38,12 @@ use File::Basename ();
#######################################################################
# STATIC OBJECT PROPERTIES
#
-$VERSION = '0.64';
+$VERSION = '0.65';
-#### some package-global hash to
-#### keep track of the imported
+#### some package-global hash to
+#### keep track of the imported
#### libraries and procedures
-my %Libraries = ();
+my %Libraries = ();
my %Procedures = ();
@@ -55,11 +56,12 @@ bootstrap Win32::API;
# PUBLIC METHODS
#
sub new {
- my($class, $dll, $proc, $in, $out, $callconvention) = @_;
- my $hdll;
+ my ($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ my $hdll;
my $self = {};
if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+
# need to convert $dll to win32 path
# isn't there an API for this?
my $newdll = `cygpath -w "$dll"`;
@@ -69,62 +71,68 @@ sub new {
}
#### avoid loading a library more than once
- if(exists($Libraries{$dll})) {
+ if (exists($Libraries{$dll})) {
DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
$hdll = $Libraries{$dll};
- } else {
+ }
+ else {
DEBUG "Win32::API::new: Loading library '$dll'\n";
$hdll = Win32::API::LoadLibrary($dll);
+
# $Libraries{$dll} = $hdll;
}
#### if the dll can't be loaded, set $! to Win32's GetLastError()
- if(!$hdll) {
+ if (!$hdll) {
$! = Win32::GetLastError();
- DEBUG "FAILED Loading library '$dll': $!\n";
- delete $Libraries{$dll};
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
return undef;
}
#### determine if we have a prototype or not
- if( (not defined $in) and (not defined $out) ) {
- ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) = parse_prototype( $proc );
+ if ((not defined $in) and (not defined $out)) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) =
+ parse_prototype($proc);
return undef unless $proc;
$self->{proto} = 1;
- } else {
+ }
+ else {
$self->{in} = [];
- if(ref($in) eq 'ARRAY') {
+ if (ref($in) eq 'ARRAY') {
foreach (@$in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- } else {
+ push(@{$self->{in}}, type_to_num($_));
+ }
+ }
+ else {
my @in = split '', $in;
foreach (@in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
+ push(@{$self->{in}}, type_to_num($_));
+ }
}
- $self->{out} = type_to_num($out);
+ $self->{out} = type_to_num($out);
$self->{cdecl} = calltype_to_num($callconvention);
}
#### first try to import the function of given name...
my $hproc = Win32::API::GetProcAddress($hdll, $proc);
#### ...then try appending either A or W (for ASCII or Unicode)
- if(!$hproc) {
+ if (!$hproc) {
my $tproc = $proc;
$tproc .= (IsUnicode() ? "W" : "A");
+
# print "Win32::API::new: procedure not found, trying '$tproc'...\n";
$hproc = Win32::API::GetProcAddress($hdll, $tproc);
}
#### ...if all that fails, set $! accordingly
- if(!$hproc) {
+ if (!$hproc) {
$! = Win32::GetLastError();
- DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
return undef;
}
- DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
#### ok, let's stuff the object
$self->{procname} = $proc;
@@ -136,16 +144,17 @@ sub new {
$Libraries{$dll} = $hdll;
$Procedures{$dll}++;
- DEBUG "Object blessed!\n";
+ DEBUG "Object blessed!\n";
#### cast the spell
bless($self, $class);
return $self;
}
sub Import {
- my($class, $dll, $proc, $in, $out, $callconvention) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0;
+ my ($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention)
+ or return 0;
my $P = (caller)[0];
eval qq(
sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
@@ -157,17 +166,17 @@ sub Import {
# PRIVATE METHODS
#
sub DESTROY {
- my($self) = @_;
+ my ($self) = @_;
#### decrease this library's procedures reference count
$Procedures{$self->{dllname}}--;
#### once it reaches 0, free it
- if($Procedures{$self->{dllname}} == 0) {
+ if ($Procedures{$self->{dllname}} == 0) {
DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
Win32::API::FreeLibrary($Libraries{$self->{dllname}});
delete($Libraries{$self->{dllname}});
- }
+ }
}
# Convert calling convention string (_cdecl|__stdcall)
@@ -190,132 +199,153 @@ sub calltype_to_num {
sub type_to_num {
my $type = shift;
- my $out = shift;
+ my $out = shift;
my $num;
-
- if( $type eq 'N'
- or $type eq 'n'
- or $type eq 'l'
- or $type eq 'L'
- ) {
+
+ if ( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L')
+ {
$num = 1;
- } elsif($type eq 'P'
- or $type eq 'p'
- ) {
+ }
+ elsif ($type eq 'P'
+ or $type eq 'p')
+ {
$num = 2;
- } elsif($type eq 'I'
- or $type eq 'i'
- ) {
+ }
+ elsif ($type eq 'I'
+ or $type eq 'i')
+ {
$num = 3;
- } elsif($type eq 'f'
- or $type eq 'F'
- ) {
+ }
+ elsif ($type eq 'f'
+ or $type eq 'F')
+ {
$num = 4;
- } elsif($type eq 'D'
- or $type eq 'd'
- ) {
+ }
+ elsif ($type eq 'D'
+ or $type eq 'd')
+ {
$num = 5;
- } elsif($type eq 'c'
- or $type eq 'C'
- ) {
+ }
+ elsif ($type eq 'c'
+ or $type eq 'C')
+ {
$num = 6;
- } else {
+ }
+ else {
$num = 0;
- }
- unless(defined $out) {
- if( $type eq 's'
- or $type eq 'S'
- ) {
+ }
+ unless (defined $out) {
+ if ( $type eq 's'
+ or $type eq 'S')
+ {
$num = 51;
- } elsif($type eq 'b'
- or $type eq 'B'
- ) {
+ }
+ elsif ($type eq 'b'
+ or $type eq 'B')
+ {
$num = 22;
- } elsif($type eq 'k'
- or $type eq 'K'
- ) {
+ }
+ elsif ($type eq 'k'
+ or $type eq 'K')
+ {
$num = 101;
- }
+ }
}
return $num;
}
sub parse_prototype {
- my($proto) = @_;
-
+ my ($proto) = @_;
+
my @in_params = ();
- my @in_types = ();
- if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $callconvention= $2;
- my $proc = $3;
- my $params = $4;
-
+ my @in_types = ();
+ if ($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $callconvention = $2;
+ my $proc = $3;
+ my $params = $4;
+
$params =~ s/^\s+//;
$params =~ s/\s+$//;
-
- DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
-
+
foreach my $param (split(/\s*,\s*/, $params)) {
- my($type, $name);
- if($param =~ /(\S+)\s+(\S+)/) {
+ my ($type, $name);
+ if ($param =~ /(\S+)\s+(\S+)/) {
($type, $name) = ($1, $2);
}
-
- if(Win32::API::Type::is_known($type)) {
- if(Win32::API::Type::is_pointer($type)) {
+
+ if (Win32::API::Type::is_known($type)) {
+ if (Win32::API::Type::is_pointer($type)) {
DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
+ $type,
+ Win32::API::Type->packing($type),
type_to_num('P');
push(@in_params, type_to_num('P'));
- } else {
+ }
+ else {
DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
- type_to_num( Win32::API::Type->packing( $type ) );
- push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ $type,
+ Win32::API::Type->packing($type),
+ type_to_num(Win32::API::Type->packing($type));
+ push(@in_params, type_to_num(Win32::API::Type->packing($type)));
}
- } elsif( Win32::API::Struct::is_known( $type ) ) {
+ }
+ elsif (Win32::API::Struct::is_known($type)) {
DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
$type, 'S', type_to_num('S');
push(@in_params, type_to_num('S'));
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ }
+ else {
+ warn
+ "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
push(@in_params, type_to_num('I'));
}
push(@in_types, $type);
-
+
}
DEBUG "parse_prototype: IN=[ @in_params ]\n";
-
- if(Win32::API::Type::is_known($ret)) {
- if(Win32::API::Type::is_pointer($ret)) {
+ if (Win32::API::Type::is_known($ret)) {
+ if (Win32::API::Type::is_pointer($ret)) {
DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
+ $ret,
+ Win32::API::Type->packing($ret),
type_to_num('P');
- return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) );
- } else {
+ return ($proc, \@in_params, \@in_types, type_to_num('P'),
+ calltype_to_num($callconvention));
+ }
+ else {
DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
- type_to_num( Win32::API::Type->packing( $ret ) );
- return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)), calltype_to_num($callconvention) );
+ $ret,
+ Win32::API::Type->packing($ret),
+ type_to_num(Win32::API::Type->packing($ret));
+ return (
+ $proc, \@in_params, \@in_types,
+ type_to_num(Win32::API::Type->packing($ret)),
+ calltype_to_num($callconvention)
+ );
}
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) );
+ }
+ else {
+ warn
+ "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ($proc, \@in_params, \@in_types, type_to_num('I'),
+ calltype_to_num($callconvention));
}
- } else {
+ }
+ else {
warn "Win32::API::parse_prototype: bad prototype '$proto'";
return undef;
}
-}
+}
1;
View
89 Callback.pm
@@ -4,26 +4,27 @@
#######################################################################
#
# Win32::API::Callback - Perl Win32 API Import Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
#######################################################################
package Win32::API::Callback;
-$VERSION = '0.64';
+$VERSION = '0.65';
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
@ISA = qw( Exporter DynaLoader );
-sub DEBUG {
- if ($WIN32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
- return 0;
- }
+sub DEBUG {
+ if ($WIN32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
+ return 0;
+ }
}
use Win32::API;
@@ -37,18 +38,21 @@ use Win32::API::Struct;
#
sub AUTOLOAD {
- my($constname);
+ my ($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
+
#reset $! to zero to reset any current errors.
- $!=0;
+ $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
- } else {
- ($pack,$file,$line) = caller;
- die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
+ }
+ else {
+ ($pack, $file, $line) = caller;
+ die
+ "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
}
}
eval "sub $AUTOLOAD { $val }";
@@ -65,37 +69,38 @@ bootstrap Win32::API::Callback;
# PUBLIC METHODS
#
sub new {
- my($class, $proc, $in, $out) = @_;
+ my ($class, $proc, $in, $out) = @_;
my %self = ();
- # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
-
- $self{in} = [];
- if(ref($in) eq 'ARRAY') {
- foreach (@$in) {
- push(@{ $self{in} }, Win32::API::type_to_num($_));
- }
- } else {
- my @in = split '', $in;
- foreach (@in) {
- push(@{ $self{in} }, Win32::API::type_to_num($_));
- }
- }
- $self{out} = Win32::API::type_to_num($out);
- $self{sub} = $proc;
- my $self = bless \%self, $class;
-
- DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
+ # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+
+ $self{in} = [];
+ if (ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{$self{in}}, Win32::API::type_to_num($_));
+ }
+ }
+ else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{$self{in}}, Win32::API::type_to_num($_));
+ }
+ }
+ $self{out} = Win32::API::type_to_num($out);
+ $self{sub} = $proc;
+ my $self = bless \%self, $class;
+
+ DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
my $hproc = CallbackCreate($self);
- DEBUG "(PM)Callback::new: hproc=$hproc\n";
+ DEBUG "(PM)Callback::new: hproc=$hproc\n";
#### ...if that fails, set $! accordingly
- if(!$hproc) {
+ if (!$hproc) {
$! = Win32::GetLastError();
return undef;
}
-
+
#### ok, let's stuff the object
$self->{code} = $hproc;
$self->{sub} = $proc;
@@ -105,11 +110,11 @@ sub new {
}
sub MakeStruct {
- my($self, $n, $addr) = @_;
- DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
- my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
- $struct->FromMemory($addr);
- return $struct;
+ my ($self, $n, $addr) = @_;
+ DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
+ my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
+ $struct->FromMemory($addr);
+ return $struct;
}
1;
View
48 Callback/t/02_Callback.t
@@ -7,12 +7,13 @@
use strict;
use Config;
-use Test::More; plan tests => 8;
-use vars qw(
- $function
- $result
- $callback
- $test_dll
+use Test::More;
+plan tests => 8;
+use vars qw(
+ $function
+ $result
+ $callback
+ $test_dll
);
use_ok('Win32::API');
@@ -28,35 +29,36 @@ my $cc_name = Win32::API::Test::compiler_name();
my $cc_vers = Win32::API::Test::compiler_version();
my $callback;
-diag('Compiler name:', $cc_name);
+diag('Compiler name:', $cc_name);
diag('Compiler version:', $cc_vers);
SKIP: {
- skip('because bombs on gcc', 2) if $cc_name =~ /g?cc/;
+ skip('because bombs on gcc', 2) if $cc_name =~ /g?cc/;
- $callback = Win32::API::Callback->new(
- sub {
- my($value) = @_;
- return $value*2;
- },
- 'N', 'N'
- );
- ok($callback, 'callback function defined');
+ $callback = Win32::API::Callback->new(
+ sub {
+ my ($value) = @_;
+ return $value * 2;
+ },
+ 'N',
+ 'N'
+ );
+ ok($callback, 'callback function defined');
- $function = new Win32::API($test_dll, 'do_callback', 'KI', 'I');
- ok(defined($function), 'defined function do_callback()');
- diag('$^E=', $^E);
+ $function = new Win32::API($test_dll, 'do_callback', 'KI', 'I');
+ ok(defined($function), 'defined function do_callback()');
+ diag('$^E=', $^E);
}
SKIP: {
- skip('because callbacks currently /SEGFAULT/ all compilers but MSVC 6+', 1)
- unless $cc_name eq 'cl' && $cc_vers >= 12;
+ 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');
+ $result = $function->Call($callback, 21);
+ is($result, 42, 'callback function works');
}
#
View
47 Callback/t/03_Jim_Shaw.t
@@ -5,7 +5,7 @@
#
# Given a process ID and optionally a window class,
# return the windows matching the request with classnames.
-# Then we can monitor for unwanted dialogs in crusty
+# Then we can monitor for unwanted dialogs in crusty
# applications that we automated the starting of with
# CreateProcess() and stored the PID. Also we can use OLE
# to monitor for evil text in places where the original
@@ -14,10 +14,10 @@
# However, due to some issues on Windows 2003 with Callback
# (which is probably environmental - no issues on XP),
# I've opted to use a non-callback funtion to achive the
-# same result: GetWindow(xx,GW_HWNDNEXT) and
+# same result: GetWindow(xx,GW_HWNDNEXT) and
# GetWindow(xx,GW_CHILD)
#
-# The problem I had was running this code on Windows
+# The problem I had was running this code on Windows
# 2003 SP2 machines. It was throwing access violation
# DrWatsons when the Perl was based anywhere except
# C:\Perl. I was aiming for D:\sausage\perl.
@@ -37,11 +37,14 @@
use strict;
use warnings;
-use Test::More; plan skip_all => 'Unclear why it fails';
+use Test::More;
+plan skip_all => 'Unclear why it fails';
+
#plan tests => 8;
use Win32::API;
use Win32::API::Callback;
+
#$Win32::API::DEBUG=1;
use Data::Dumper;
@@ -52,12 +55,12 @@ use_ok('Win32::API::Test');
ok(1, 'loaded');
-Win32::API->Import("user32", "GetWindowThreadProcessId", "NP", "N");
-Win32::API->Import("user32", "GetClassName", "NPI", "I");
-Win32::API->Import("user32", "GetWindowTextLength", "N", "I");
-Win32::API->Import("user32", "GetWindowText", "NPI", "I");
-Win32::API->Import("user32", "GetDesktopWindow", "", "N");
-Win32::API->Import("user32", "EnumChildWindows", "NKP", "I");
+Win32::API->Import("user32", "GetWindowThreadProcessId", "NP", "N");
+Win32::API->Import("user32", "GetClassName", "NPI", "I");
+Win32::API->Import("user32", "GetWindowTextLength", "N", "I");
+Win32::API->Import("user32", "GetWindowText", "NPI", "I");
+Win32::API->Import("user32", "GetDesktopWindow", "", "N");
+Win32::API->Import("user32", "EnumChildWindows", "NKP", "I");
my %_window_pids;
my $max_str = 1024;
@@ -69,34 +72,34 @@ my $window_enumerator = sub {
my $pid_raw_value = "\x0" x Win32::API::Type->sizeof("LPDWORD");
GetWindowThreadProcessId($hwnd, $pid_raw_value);
- my $window_pid = Win32::API::Type::Unpack("LPDWORD",$pid_raw_value);
+ my $window_pid = Win32::API::Type::Unpack("LPDWORD", $pid_raw_value);
print "window_enumerator - hwnd=[$hwnd], PID=[$window_pid]\n";
if ($window_pid) {
- my $class_size=Win32::API::Type->sizeof("CHAR*")*$max_str;
- my $window_class="\x0" x $class_size;
+ my $class_size = Win32::API::Type->sizeof("CHAR*") * $max_str;
+ my $window_class = "\x0" x $class_size;
GetClassName($hwnd, $window_class, $class_size);
- $window_class=~s/\0//g;
- $_window_pids{$window_pid}{$hwnd}{window_class}=$window_class;
- my $text_size=GetWindowTextLength($hwnd);
- if (Win32::API::IsUnicode()) {
- $text_size=$text_size*2;
+ $window_class =~ s/\0//g;
+ $_window_pids{$window_pid}{$hwnd}{window_class} = $window_class;
+ my $text_size = GetWindowTextLength($hwnd);
+ if (Win32::API::IsUnicode()) {
+ $text_size = $text_size * 2;
}
$text_size++;
- my $window_text="\x0" x $text_size;
+ my $window_text = "\x0" x $text_size;
GetWindowText($hwnd, $window_text, $text_size);
- $window_text=~s/\0//g;
- $_window_pids{$window_pid}{$hwnd}{window_text}=$window_text;
+ $window_text =~ s/\0//g;
+ $_window_pids{$window_pid}{$hwnd}{window_text} = $window_text;
}
return 1;
};
-my $callback_routine = Win32::API::Callback->new($window_enumerator,"NN","I");
+my $callback_routine = Win32::API::Callback->new($window_enumerator, "NN", "I");
sub get_window_pids {
my ($callback) = @_;
View
17 Callback/t/04_rt_53914.t
@@ -18,14 +18,14 @@ plan tests => 2;
use_ok('Win32::API::Callback');
-Win32::API->Import('kernel32', 'SetConsoleCtrlHandler', 'KL', 'L');
+Win32::API->Import('kernel32', 'SetConsoleCtrlHandler', 'KL', 'L');
Win32::API->Import('kernel32', 'GenerateConsoleCtrlEvent', 'LL', 'L');
-Win32::API->Import('kernel32', 'GetLastError', '', 'L');
+Win32::API->Import('kernel32', 'GetLastError', '', 'L');
sub cb {
my ($dwCtrlType) = @_;
- open (FILE, '>', 'QUIT.TXT');
+ open(FILE, '>', 'QUIT.TXT');
print FILE "RECEIVED SIGNAL: $dwCtrlType\n";
close FILE;
@@ -34,15 +34,16 @@ sub cb {
my $callback = Win32::API::Callback->new(\&cb, "L", "L");
-SetConsoleCtrlHandler($callback, 1) # add handler
- or die "Error: " . GetLastError() . "\n";
+SetConsoleCtrlHandler($callback, 1) # add handler
+ or die "Error: " . GetLastError() . "\n";
END { unlink "QUIT.TXT"; }
diag("callback installed, sleep 1, generate Ctrl-C signal");
sleep(1);
+
#GenerateConsoleCtrlEvent(0, 0); # generate the Ctrl-C signal
-GenerateConsoleCtrlEvent(1, 0); # generate the Ctrl-Break signal
+GenerateConsoleCtrlEvent(1, 0); # generate the Ctrl-Break signal
diag("callback called or not");
sleep(2);
-ok (-f "QUIT.TXT", "QUIT.TXT exists, ctrl-c signalhandler called");
-SetConsoleCtrlHandler($callback, 0); # remove handler
+ok(-f "QUIT.TXT", "QUIT.TXT exists, ctrl-c signalhandler called");
+SetConsoleCtrlHandler($callback, 0); # remove handler
View
12 Changes
@@ -1,5 +1,9 @@
History of Win32::API perl extension.
+2012-02-12 Win32::API v0.65 Cosimo
+
+ - No changes other than passing all files through perltidy
+
2011-08-28 Win32::API v0.64 Cosimo
- Small improvement to Makefile.PLs to build or not build
@@ -8,7 +12,7 @@ History of Win32::API perl extension.
2011-07-19 Win32::API v0.63 kmx
- - Fix for the strawberry perl 5.14.1/x64
+ - Fix for the strawberry perl 5.14.1/x64
the upgraded gcc toolchain (4.4.6) uses different underscoring
2011-03-26 Win32::API v0.62 Cosimo
@@ -33,7 +37,7 @@ History of Win32::API perl extension.
- Fixed RT #48006
(https://rt.cpan.org/Ticket/Display.html?id=48006)
- - Added a minimal TODO file, so I can remember where I left off
+ - Added a minimal TODO file, so I can remember where I left off
2009-07-02 Win32::API v0.59 Cosimo
@@ -76,7 +80,7 @@ History of Win32::API perl extension.
- Integrated patch from Salvador Ortiz Garcia (sog at msg com mx)
which fixes RT #14660. There was a bug in arguments type packing
- unpacking of char* (and other pointer types).
+ unpacking of char* (and other pointer types).
2008-03-04 Win32::API v0.54 Cosimo
@@ -141,7 +145,7 @@ History of Win32::API perl extension.
- API_test.dll building phase has been removed. Now there is only
a prebuilt version of it, suitable for all compilers to link and
use, I hope.
-
+
Why does Cygwin gcc compile an entirely different API_test.dll?
I checked the tdump of msvc and gcc and the gcc version is
missing all the kernel32 imports. I don't know why this happens.
View
2 MANIFEST
@@ -33,6 +33,8 @@ Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.yml
+MYMETA.json
+MYMETA.yml
README
samples/callback1.pl
samples/callback2.pl
View
4 META.yml
@@ -1,9 +1,9 @@
--- #YAML:1.0
name: Win32-API
-version: 0.62
+version: 0.65
abstract: Perl Win32 API Import Facility
license: perl
-author:
+author:
- Cosimo Streppone <cosimo@cpan.org>
- Aldo Calpini <dada@perl.it>
generated_by: ExtUtils::MakeMaker version 6.42
View
5 README
@@ -3,10 +3,10 @@
# Win32::API - Perl Win32 API Import Facility
# ^^^^^^^^^^
#
-# Version: 0.60 (19 Mar 2011)
+# Version: 0.65 (12 Feb 2012)
#
-# Original author: Aldo Calpini <dada@perl.it>
# Current maintainer: Cosimo Streppone <cosimo@cpan.org>
+# Original author: Aldo Calpini <dada@perl.it>
#
#######################################################################
@@ -36,4 +36,3 @@ Full documentation is available in POD format inside API.pm.
The possibilities are nearly infinite (but not all are good :-).
Enjoy it.
-
View
322 Struct.pm
@@ -1,6 +1,6 @@
#
# Win32::API::Struct - Perl Win32 API struct Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
@@ -19,26 +19,27 @@ require DynaLoader;
my %Known = ();
-sub DEBUG {
- if ($Win32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
return 0;
}
}
sub typedef {
- my $class = shift;
+ my $class = shift;
my $struct = shift;
- my($type, $name);
+ my ($type, $name);
my $self = {
- align => undef,
+ align => undef,
typedef => [],
};
- while(defined($type = shift)) {
+ while (defined($type = shift)) {
$name = shift;
$name =~ s/;$//;
- push( @{ $self->{typedef} }, [ recognize($type, $name) ] );
+ push(@{$self->{typedef}}, [recognize($type, $name)]);
}
$Known{$struct} = $self;
@@ -47,19 +48,19 @@ sub typedef {
sub recognize {
- my($type, $name) = @_;
- my($size, $packing);
+ my ($type, $name) = @_;
+ my ($size, $packing);
if (is_known($type)) {
$packing = '>';
return ($name, $packing, $type);
}
- else {
+ else {
$packing = Win32::API::Type::packing($type);
- return undef unless defined $packing;
- if($name =~ s/\[(.*)\]$//) {
- $size = $1;
- $packing = $packing . '*' . $size;
+ return undef unless defined $packing;
+ if ($name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $packing . '*' . $size;
}
DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n";
return ($name, $packing, $type);
@@ -68,35 +69,38 @@ sub recognize {
sub new {
my $class = shift;
- my($type, $name);
- my $self = {
- typedef => [],
- };
- if($#_ == 0) {
+ my ($type, $name);
+ my $self = {typedef => [],};
+ if ($#_ == 0) {
if (is_known($_[0])) {
DEBUG "(PM)Struct::new: got '$_[0]'\n";
$self->{typedef} = $Known{$_[0]}->{typedef};
- foreach my $member (@{ $self->{typedef} }) {
+ foreach my $member (@{$self->{typedef}}) {
($name, $packing, $type) = @$member;
next unless defined $name;
- if($packing eq '>') {
+ if ($packing eq '>') {
$self->{$name} = Win32::API::Struct->new($type);
}
}
$self->{__typedef__} = $_[0];
- } else {
+ }
+ else {
carp "Unknown Win32::API::Struct '$_[0]'";
return undef;
}
- } else {
- while(defined($type = shift)) {
+ }
+ else {
+ while (defined($type = shift)) {
$name = shift;
+
# print "new: found member $name ($type)\n";
- if(not exists $Win32::API::Type::Known{$type}) {
+ if (not exists $Win32::API::Type::Known{$type}) {
warn "Unknown Win32::API::Struct type '$type'";
return undef;
- } else {
- push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] );
+ }
+ else {
+ push(@{$self->{typedef}},
+ [$name, $Win32::API::Type::Known{$type}, $type]);
}
}
}
@@ -105,31 +109,34 @@ sub new {
sub members {
my $self = shift;
- return map {$_->[0]} @{ $self->{typedef} };
+ return map { $_->[0] } @{$self->{typedef}};
}
sub sizeof {
- my $self = shift;
- my $size = 0;
+ my $self = shift;
+ my $size = 0;
my $align = 0;
my $first = '';
- for my $member (@{ $self->{typedef} }) {
- my($name, $packing, $type) = @{$member};
+ for my $member (@{$self->{typedef}}) {
+ my ($name, $packing, $type) = @{$member};
next unless defined $name;
if (ref $self->{$name} eq q{Win32::API::Struct}) {
+
# If member is a struct, recursively calculate its size
# FIXME for subclasses
$size += $self->{$name}->sizeof();
- }
- else {
+ }
+ else {
+
# Member is a simple type (LONG, DWORD, etc...)
- if($packing =~ /\w\*(\d+)/) { # Arrays (ex: 'c*260')
+ if ($packing =~ /\w\*(\d+)/) { # Arrays (ex: 'c*260')
$size += Win32::API::Type::sizeof($type) * $1;
$first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
- DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = " . $size
+ . "\n";
}
- else { # Simple types
+ else { # Simple types
my $type_size = Win32::API::Type::sizeof($type);
$align = $type_size if $type_size > $align;
my $type_align = (($size + $type_size) % $type_size);
@@ -139,7 +146,7 @@ sub sizeof {
}
}
- my $struct_size = $size;
+ my $struct_size = $size;
if (defined $align && $align > 0) {
$struct_size += ($size % $align);
}
@@ -148,158 +155,167 @@ sub sizeof {
}
sub align {
- my $self = shift;
- my $align = shift;
-
- if (not defined $align) {
-
- if (! (defined $self->{align} && $self->{align} eq 'auto')) {
- return $self->{align};
- }
-
- $align = 0;
-
- foreach my $member (@{ $self->{typedef} }) {
- my($name, $packing, $type) = @$member;
-
- if(ref( $self->{$name} ) eq "Win32::API::Struct") {
- #### ????
- } else {
- if($packing =~ /\w\*(\d+)/) {
- #### ????
- } else {
- $align = Win32::API::Type::sizeof($type)
- if Win32::API::Type::sizeof($type) > $align;
- }
- }
- }
- return $align;
- } else {
- $self->{align} = $align;
-
- }
+ my $self = shift;
+ my $align = shift;
+
+ if (not defined $align) {
+
+ if (!(defined $self->{align} && $self->{align} eq 'auto')) {
+ return $self->{align};
+ }
+
+ $align = 0;
+
+ foreach my $member (@{$self->{typedef}}) {
+ my ($name, $packing, $type) = @$member;
+
+ if (ref($self->{$name}) eq "Win32::API::Struct") {
+ #### ????
+ }
+ else {
+ if ($packing =~ /\w\*(\d+)/) {
+ #### ????
+ }
+ else {
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ }
+ }
+ }
+ return $align;
+ }
+ else {
+ $self->{align} = $align;
+
+ }
}
sub getPack {
- my $self = shift;
- my $packing = "";
+ my $self = shift;
+ my $packing = "";
my $packed_size = 0;
- my($type, $name, $type_size, $type_align);
- my @items = ();
- my @recipients = ();
-
+ my ($type, $name, $type_size, $type_align);
+ my @items = ();
+ my @recipients = ();
+
my $align = $self->align();
-
- foreach my $member (@{ $self->{typedef} }) {
+
+ foreach my $member (@{$self->{typedef}}) {
($name, $type, $orig) = @$member;
- if($type eq '>') {
- my($subpacking, $subitems, $subrecipients, $subpacksize) = $self->{$name}->getPack();
- DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
- push(@items, @$subitems);
- push(@recipients, @$subrecipients);
+ if ($type eq '>') {
+ my ($subpacking, $subitems, $subrecipients, $subpacksize) =
+ $self->{$name}->getPack();
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
+ push(@items, @$subitems);
+ push(@recipients, @$subrecipients);
$packing .= $subpacking;
$packed_size += $subpacksize;
- } else {
- if($type =~ /\w\*(\d+)/) {
+ }
+ else {
+ if ($type =~ /\w\*(\d+)/) {
my $size = $1;
$type = "a$size";
}
-
- DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
-
- if($type eq 'p') {
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
+
+ if ($type eq 'p') {
$type = ($Config{ptrsize} == 8) ? 'Q' : 'L';
push(@items, Win32::API::PointerTo($self->{$name}));
- } else {
+ }
+ else {
push(@items, $self->{$name});
}
push(@recipients, $self);
- $type_size = Win32::API::Type::sizeof($orig);
+ $type_size = Win32::API::Type::sizeof($orig);
$type_align = (($packed_size + $type_size) % $type_size);
$packing .= "x" x $type_align . $type;
$packed_size += $type_size + $type_align;
}
}
- DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n";
+ DEBUG
+ "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n";
- return($packing, [@items], [@recipients], $packed_size);
+ return ($packing, [@items], [@recipients], $packed_size);
}
sub Pack {
my $self = shift;
- my($packing, $items, $recipients) = $self->getPack();
+ my ($packing, $items, $recipients) = $self->getPack();
DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n";
$self->{buffer} = pack($packing, @$items);
if (DEBUG) {
- for my $i (0..$self->sizeof-1) {
+ for my $i (0 .. $self->sizeof - 1) {
printf "#pack# %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
}
}
- $self->{buffer_recipients} = $recipients
+ $self->{buffer_recipients} = $recipients;
}
sub getUnpack {
- my $self = shift;
- my $packing = "";
+ my $self = shift;
+ my $packing = "";
my $packed_size = 0;
- my($type, $name, $type_size, $type_align);
+ my ($type, $name, $type_size, $type_align);
my @items = ();
my $align = $self->align();
- foreach my $member (@{ $self->{typedef} }) {
+ foreach my $member (@{$self->{typedef}}) {
($name, $type, $orig) = @$member;
- if($type eq '>') {
- my($subpacking, @subitems, $subpacksize) = $self->{$name}->getUnpack();
+ if ($type eq '>') {
+ my ($subpacking, @subitems, $subpacksize) = $self->{$name}->getUnpack();
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
$packing .= $subpacking;
- $packed_size += $subpacksize;
+ $packed_size += $subpacksize;
push(@items, @subitems);
- } else {
- if($type =~ /\w\*(\d+)/) {
+ }
+ else {
+ if ($type =~ /\w\*(\d+)/) {
my $size = $1;
$type = "Z$size";
- }
- DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
- $type_size = Win32::API::Type::sizeof($orig);
- $type_align = (($packed_size + $type_size) % $type_size);
- $packing .= "x" x $type_align . $type;
- $packed_size += $type_size + $type_align;
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
+ $type_size = Win32::API::Type::sizeof($orig);
+ $type_align = (($packed_size + $type_size) % $type_size);
+ $packing .= "x" x $type_align . $type;
+ $packed_size += $type_size + $type_align;
push(@items, $name);
}
}
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n";
- return($packing, @items, $packed_size);
+ return ($packing, @items, $packed_size);
}
sub Unpack {
my $self = shift;
- my($packing, @items) = $self->getUnpack();
+ my ($packing, @items) = $self->getUnpack();
my @itemvalue = unpack($packing, $self->{buffer});
DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n";
- foreach my $i (0..$#items) {
+ foreach my $i (0 .. $#items) {
my $recipient = $self->{buffer_recipients}->[$i];
DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
- $recipient->{__typedef__},
- $items[$i],
- $itemvalue[$i],
- $itemvalue[$i],
- ;
+ $recipient->{__typedef__},
+ $items[$i],
+ $itemvalue[$i],
+ $itemvalue[$i],
+ ;
$recipient->{$items[$i]} = $itemvalue[$i];
- # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$items[$i]}\n";
+
+ # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$items[$i]}\n";
}
}
sub FromMemory {
- my($self, $addr) = @_;
+ my ($self, $addr) = @_;
DEBUG "(PM)Struct::FromMemory: doing Pack\n";
$self->Pack();
DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof;
- $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof );
+ $self->{buffer} = Win32::API::ReadMemory($addr, $self->sizeof);
$self->Unpack();
DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
DEBUG "(PM)Struct::FromMemory: structure is now:\n";
@@ -308,26 +324,28 @@ sub FromMemory {
}
sub Dump {
- my $self = shift;
+ my $self = shift;
my $prefix = shift;
- foreach my $member (@{ $self->{typedef} }) {
+ foreach my $member (@{$self->{typedef}}) {
($name, $packing, $type) = @$member;
- if( ref($self->{$name}) ) {
+ if (ref($self->{$name})) {
$self->{$name}->Dump($name);
- } else {
+ }
+ else {
printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
}
}
-}
+}
sub is_known {
my $name = shift;
- if(exists $Known{ $name }) {
- return 1;
- } else {
- if($name =~ s/^LP//) {
- return exists $Known{ $name };
+ if (exists $Known{$name}) {
+ return 1;
+ }
+ else {
+ if ($name =~ s/^LP//) {
+ return exists $Known{$name};
}
return 0;
}
@@ -343,42 +361,44 @@ sub EXISTS {
sub FETCH {
my $self = shift;
- my $key = shift;
-
- if($key eq 'sizeof') {
+ my $key = shift;
+
+ if ($key eq 'sizeof') {
return $self->sizeof;
}
- my @members = map { $_->[0] } @{ $self->{typedef} };
- if(grep(/^\Q$key\E$/, @members)) {
+ my @members = map { $_->[0] } @{$self->{typedef}};
+ if (grep(/^\Q$key\E$/, @members)) {
return $self->{$key};
- } else {
+ }
+ else {
warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
- }
+ }
}
sub STORE {
my $self = shift;
- my($key, $val) = @_;
- my @members = map { $_->[0] } @{ $self->{typedef} };
- if(grep(/^\Q$key\E$/, @members)) {
+ my ($key, $val) = @_;
+ my @members = map { $_->[0] } @{$self->{typedef}};
+ if (grep(/^\Q$key\E$/, @members)) {
$self->{$key} = $val;
- } else {
+ }
+ else {
warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
}
}
sub FIRSTKEY {
my $self = shift;
- my @members = map { $_->[0] } @{ $self->{typedef} };
- return $members[0];
+ my @members = map { $_->[0] } @{$self->{typedef}};
+ return $members[0];
}
sub NEXTKEY {
- my $self = shift;
- my $key = shift;
- my @members = map { $_->[0] } @{ $self->{typedef} };
- for my $i (0..$#members-1) {
- return $members[$i+1] if $members[$i] eq $key;
+ my $self = shift;
+ my $key = shift;
+ my @members = map { $_->[0] } @{$self->{typedef}};
+ for my $i (0 .. $#members - 1) {
+ return $members[$i + 1] if $members[$i] eq $key;
}
return undef;
}
View
123 Test.pm
@@ -1,36 +1,35 @@
#
# Win32::API::Test - Test helper package for Win32::API
-#
+#
# Cosimo Streppone <cosimo@cpan.org>
#
package Win32::API::Test;
sub is_perl_64bit () {
- use Config;
- # was $Config{archname} =~ /x64/;
- return 1 if $Config{ptrsize} == 8;
- return;
+ use Config;
+
+ # was $Config{archname} =~ /x64/;
+ return 1 if $Config{ptrsize} == 8;
+ return;
}
sub compiler_name () {
- use Config;
- my $cc = $Config{ccname};
- if($cc eq 'cl' || $cc eq 'cl.exe')
- {
- $cc = 'cl';
- }
- return($cc);
+ use Config;
+ my $cc = $Config{ccname};
+ if ($cc eq 'cl' || $cc eq 'cl.exe') {
+ $cc = 'cl';
+ }
+ return ($cc);
}
sub compiler_version () {
- use Config;
- my $ver = $Config{ccversion} || 0;
- if( $ver =~ /^(\d+\.\d+)/ )
- {
- $ver = 0 + $1;
- }
- return($ver);
+ use Config;
+ my $ver = $Config{ccversion} || 0;
+ if ($ver =~ /^(\d+\.\d+)/) {
+ $ver = 0 + $1;
+ }
+ return ($ver);
}
#
@@ -40,56 +39,54 @@ sub compiler_version () {
# For example, Cosimo does. For testing, of course.
#
sub compiler_version_from_shell () {
- my $cc = compiler_name();
- my $ver;
- # MSVC
- if($cc eq 'cl')
- {
- my @ver = `$cc 2>&1`; # Interesting output in STDERR
- $ver = join('',@ver);
- #print 'VER:'.$ver.':'."\n";
- if($ver =~ /Version (\d[\d\.]+)/ms )
- {
- $ver = $1;
- }
- }
- # GCC
- elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' )
- {
- $ver = join('', `$cc --version`);
- if($ver =~ /gcc.*(\d[\d+]+)/ms )
- {
- $ver = $1;
- }
- }
- # Borland C
- elsif($cc eq 'bcc32' || $cc eq 'bcc')
- {
- $ver = join('', `$cc 2>&1`);
- if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms )
- {
- $ver = $1;
- }
- }
- return($ver);
+ my $cc = compiler_name();
+ my $ver;
+
+ # MSVC
+ if ($cc eq 'cl') {
+ my @ver = `$cc 2>&1`; # Interesting output in STDERR
+ $ver = join('', @ver);
+
+ #print 'VER:'.$ver.':'."\n";
+ if ($ver =~ /Version (\d[\d\.]+)/ms) {
+ $ver = $1;
+ }
+ }
+
+ # GCC
+ elsif ($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc') {
+ $ver = join('', `$cc --version`);
+ if ($ver =~ /gcc.*(\d[\d+]+)/ms) {
+ $ver = $1;
+ }
+ }
+
+ # Borland C
+ elsif ($cc eq 'bcc32' || $cc eq 'bcc') {
+ $ver = join('', `$cc 2>&1`);
+ if ($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms) {
+ $ver = $1;
+ }
+ }
+ return ($ver);
}
sub find_test_dll {
- require File::Spec;
+ require File::Spec;
- my $default_dll_name = is_perl_64bit()
- ? 'API_test64.dll'
- : 'API_test.dll';
+ my $default_dll_name =
+ is_perl_64bit()
+ ? 'API_test64.dll'
+ : 'API_test.dll';
- my $dll_name = $_[0] || $default_dll_name;
+ my $dll_name = $_[0] || $default_dll_name;
- my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll);
- while(my $path = shift @paths)
- {
- $dll = File::Spec->catfile($path, $dll_name);
- return $dll if -s $dll;
- }
- return(undef);
+ my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll);
+ while (my $path = shift @paths) {
+ $dll = File::Spec->catfile($path, $dll_name);
+ return $dll if -s $dll;
+ }
+ return (undef);
}
1;
View
166 Type.pm
@@ -6,7 +6,7 @@ package Win32::API::Type;
#######################################################################
#
# Win32::API::Type - Perl Win32 API type definitions
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
@@ -17,24 +17,25 @@ $VERSION = '0.62';
use Carp;
use Config;
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
@ISA = qw( Exporter DynaLoader );
use vars qw( %Known %PackSize %Modifier %Pointer );
-sub DEBUG {
- if ($Win32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
return 0;
}
}
-%Known = ();
-%PackSize = ();
-%Modifier = ();
-%Pointer = ();
+%Known = ();
+%PackSize = ();
+%Modifier = ();
+%Pointer = ();
# Initialize data structures at startup.
# Aldo wants to keep the <DATA> approach.
@@ -43,57 +44,64 @@ my $section = 'nothing';
foreach (<DATA>) {
next if /^\s*#/ or /^\s*$/;
chomp;
- if( /\[(.+)\]/) {
+ if (/\[(.+)\]/) {
$section = $1;
next;
}
- if($section eq 'TYPE') {
- my($name, $packing) = split(/\s+/);
+ if ($section eq 'TYPE') {
+ my ($name, $packing) = split(/\s+/);
+
# DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
if ($packing eq '_P') {
$packing = pointer_pack_type();
}
$Known{$name} = $packing;
- } elsif($section eq 'PACKSIZE') {
- my($packing, $size) = split(/\s+/);
+ }
+ elsif ($section eq 'PACKSIZE') {
+ my ($packing, $size) = split(/\s+/);
+
# DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
if ($size eq '_P') {
$size = $Config{ptrsize};
}
$PackSize{$packing} = $size;
- } elsif($section eq 'MODIFIER') {
- my($modifier, $mapto) = split(/\s+/, $_, 2);
+ }
+ elsif ($section eq 'MODIFIER') {
+ my ($modifier, $mapto) = split(/\s+/, $_, 2);
my %maps = ();
foreach my $item (split(/\s+/, $mapto)) {
- my($k, $v) = split(/=/, $item);
+ my ($k, $v) = split(/=/, $item);
$maps{$k} = $v;
- }
+ }
+
# DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n";
- $Modifier{$modifier} = { %maps };
- } elsif($section eq 'POINTER') {
- my($pointer, $pointto) = split(/\s+/);
+ $Modifier{$modifier} = {%maps};
+ }
+ elsif ($section eq 'POINTER') {
+ my ($pointer, $pointto) = split(/\s+/);
+
# DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
$Pointer{$pointer} = $pointto;
}
}
close(DATA);
sub new {
- my $class = shift;
- my($type) = @_;
+ my $class = shift;
+ my ($type) = @_;
my $packing = packing($type);
- my $size = sizeof($type);
- my $self = {
- type => $type,
+ my $size = sizeof($type);
+ my $self = {
+ type => $type,
packing => $packing,
- size => $size,
+ size => $size,
};
return bless $self;
}
sub typedef {
my $class = shift;
- my($name, $type) = @_;
+ my ($name, $type) = @_;
my $packing = packing($type, $name);
DEBUG "(PM)Type::typedef: packing='$packing'\n";
my $size = sizeof($type);
@@ -106,9 +114,10 @@ sub is_known {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
- if(ref($type) =~ /Win32::API::Type/) {
+ if (ref($type) =~ /Win32::API::Type/) {
return 1;
- } else {
+ }
+ else {
return defined packing($type);
}
}
@@ -121,77 +130,92 @@ sub sizeof {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
- if(ref($type) =~ /Win32::API::Type/) {
+ if (ref($type) =~ /Win32::API::Type/) {
return $self->{size};
- } else {
+ }
+ else {
my $packing = packing($type);
- if($packing =~ /(\w)\*(\d+)/) {
- return $PackSize{ $1 } * $2;
- } else {
- return $PackSize{ $packing };
+ if ($packing =~ /(\w)\*(\d+)/) {
+ return $PackSize{$1} * $2;
+ }
+ else {
+ return $PackSize{$packing};
}
- }
+ }
}
sub packing {
- # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
- my $self = shift;
+
+ # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
+ my $self = shift;
my $is_pointer = 0;
- if(ref($self) =~ /Win32::API::Type/) {
- # DEBUG "(PM)Type::packing: got an object\n";
+ if (ref($self) =~ /Win32::API::Type/) {
+
+ # DEBUG "(PM)Type::packing: got an object\n";
return $self->{packing};
}
my $type = ($self eq 'Win32::API::Type') ? shift : $self;
my $name = shift;
-
- # DEBUG "(PM)Type::packing: got '$type', '$name'\n";
- my($modifier, $size, $packing);
- if(exists $Pointer{$type}) {
+
+ # DEBUG "(PM)Type::packing: got '$type', '$name'\n";
+ my ($modifier, $size, $packing);
+ if (exists $Pointer{$type}) {
+
# DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n";
- $type = $Pointer{$type};
+ $type = $Pointer{$type};
$is_pointer = 1;
- } elsif($type =~ /(\w+)\s+(\w+)/) {
+ }
+ elsif ($type =~ /(\w+)\s+(\w+)/) {
$modifier = $1;
- $type = $2;
+ $type = $2;
+
# DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n";
}
-
+
$type =~ s/\*$//;
-
- if(exists $Known{$type}) {
- if(defined $name and $name =~ s/\[(.*)\]$//) {
- $size = $1;
- $packing = $Known{$type}[0]."*".$size;
+
+ if (exists $Known{$type}) {
+ if (defined $name and $name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $Known{$type}[0] . "*" . $size;
+
# DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n";
- } else {
+ }
+ else {
$packing = $Known{$type};
- if($is_pointer and $packing eq 'c') {
- $packing = "p";
+ if ($is_pointer and $packing eq 'c') {
+ $packing = "p";
}
+
# DEBUG "(PM)Type::packing: simple packing: '$packing'\n";
}
- if(defined $modifier and exists $Modifier{$modifier}->{$type}) {
- # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
+ if (defined $modifier and exists $Modifier{$modifier}->{$type}) {
+
+# DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
$packing = $Modifier{$modifier}->{$type};
}
return $packing;
- } else {
+ }
+ else {
+
# DEBUG "(PM)Type::packing: NOT FOUND\n";
return undef;
}
-}
+}
sub is_pointer {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
- if(ref($type) =~ /Win32::API::Type/) {
+ if (ref($type) =~ /Win32::API::Type/) {
return 1;
- } else {
- if($type =~ /\*$/) {
+ }
+ else {
+ if ($type =~ /\*$/) {
return 1;
- } else {
+ }
+ else {
return exists $Pointer{$type};
}
}
@@ -202,7 +226,7 @@ sub Pack {
my $pack_type = packing($type);
- if($pack_type eq 'p') {
+ if ($pack_type eq 'p') {
$pack_type = 'Z*';
}
@@ -216,14 +240,14 @@ sub Unpack {
my $pack_type = packing($type);
- if($pack_type eq 'p') {
+ if ($pack_type eq 'p') {
DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n";
$pack_type = 'Z*';
}
- DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n";
+ DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n";
$arg = unpack($pack_type, $arg);
- DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n";
+ DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n";
return $arg;
}
View
14 samples/GetCursorPos.pl
@@ -1,15 +1,17 @@
use Win32::API;
-Win32::API::Struct->typedef( POINT => qw(
- LONG x;
- LONG y;
-) );
+Win32::API::Struct->typedef(
+ POINT => qw(
+ LONG x;
+ LONG y;
+ )
+);
-Win32::API->Import( 'user32' => 'BOOL GetCursorPos(LPPOINT pt)' );
+Win32::API->Import('user32' => 'BOOL GetCursorPos(LPPOINT pt)');
#### using OO semantics
-my $pt = Win32::API::Struct->new( 'POINT' );
+my $pt = Win32::API::Struct->new('POINT');
GetCursorPos($pt) or die "GetCursorPos failed: $^E";
print "Cursor is at: $pt->{x}, $pt->{y}\n";
View
268 samples/Win32/kernel32.pm
@@ -6,51 +6,53 @@ use Win32::API;
$VERSION = '0.50';
%APIs = (
- Beep => [[N, N], N],
- CopyFile => [[P, P, N], N],
- GetBinaryType => [[P, P], N],
- GetCommandLine => [[], P],
- GetCompressedFileSize => [[P, P], N],
- GetCurrencyFormat => [[N, N, P, P, P, N], N],
- GetDiskFreeSpace => [[P, P, P, P, P], N],
- GetDriveType => [[P], N],
- GetSystemTime => [[P], V],
- GetTempPath => [[N, P], N],
- GetVolumeInformation => [[P, P, N, P, P, P, P, N], N],
- MultiByteToWideChar => [[N, N, P, N, P, N], N],
- QueryDosDevice => [[P, P, N], N],
+ Beep => [[N, N], N],
+ CopyFile => [[P, P, N], N],
+ GetBinaryType => [[P, P], N],
+ GetCommandLine => [[], P],
+ GetCompressedFileSize => [[P, P], N],
+ GetCurrencyFormat => [[N, N, P, P, P, N], N],
+ GetDiskFreeSpace => [[P, P, P, P, P], N],
+ GetDriveType => [[P], N],
+ GetSystemTime => [[P], V],
+ GetTempPath => [[N, P], N],
+ GetVolumeInformation => [[P, P, N, P, P, P, P, N], N],
+ MultiByteToWideChar => [[N, N, P, N, P, N], N],
+ QueryDosDevice => [[P, P, N], N],
QueryPerformanceCounter => [[P], N],
QueryPerformanceFrequency => [[P], N],
- SearchPath => [[P, P, P, N, P, P], N],
- SetLastError => [[N], V],
- Sleep => [[N], V],
- VerLanguageName => [[N, P, N], N],
- WideCharToMultiByte => [[N, N, P, N, P, N, P, P], N],
+ SearchPath => [[P, P, P, N, P, P], N],
+ SetLastError => [[N], V],
+ Sleep => [[N], V],
+ VerLanguageName => [[N, P, N], N],
+ WideCharToMultiByte => [[N, N, P, N, P, N, P, P], N],
);
%SUBs = (
Beep => sub {
- my($freq, $duration) = @_;
+ my ($freq, $duration) = @_;
return $Win32::kernel32::Beep->Call($freq, $duration);
},
CopyFile => sub {
- my($old, $new, $flag) = @_;
+ my ($old, $new, $flag) = @_;
$flag = 1 unless defined($flag);
return $Win32::kernel32::CopyFile->Call($old, $new, $flag);
},
GetBinaryType => sub {
- warn "The Win32::GetBinaryType API works only on Windows NT" unless Win32::IsWinNT();
- my($appname) = @_;
+ warn "The Win32::GetBinaryType API works only on Windows NT"
+ unless Win32::IsWinNT();
+ my ($appname) = @_;
my $type = pack("L", 0);
my $result = $Win32::kernel32::GetBinaryType->Call($appname, $type);
return ($result) ? unpack("L", $type) : undef;
},
GetCompressedFileSize => sub {
- warn "The Win32::GetCompressedFileSize API works only on Windows NT" unless Win32::IsWinNT();
- my($filename) = @_;
+ warn "The Win32::GetCompressedFileSize API works only on Windows NT"
+ unless Win32::IsWinNT();
+ my ($filename) = @_;
my $hiword = pack("L", 0);
my $loword = $Win32::kernel32::GetCompressedFileSize->Call($filename, $hiword);
- return $loword + $hiword * 4*1024**3;
+ return $loword + $hiword * 4 * 1024**3;
},
GetCommandLine => sub {
my $cmdline = $Win32::kernel32::GetCommandLine->Call();
@@ -59,52 +61,47 @@ $VERSION = '0.50';
return $string;
},
GetCurrencyFormat => sub {
- my($number, $locale) = @_;
+ my ($number, $locale) = @_;
$locale = 2048 unless defined($locale);
my $output = "\0" x 1024;
- my $result = $Win32::kernel32::GetCurrencyFormat->Call(
- $locale,
- 0,
- $number,
- 0,
- $output,
- 1024,
- );
- if($result) {
- return substr($output, 0, $result-1);
- } else {
+ my $result =
+ $Win32::kernel32::GetCurrencyFormat->Call($locale, 0, $number, 0, $output,
+ 1024,);
+ if ($result) {
+ return substr($output, 0, $result - 1);
+ }
+ else {
return undef;
}
},
GetDiskFreeSpace => sub {
- my($root) = @_;
+ my ($root) = @_;
$root = 0 unless defined($root);
my $SectorsPerCluster = pack("L", 0);
- my $BytesPerSector = pack("L", 0);
- my $FreeClusters = pack("L", 0);