summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm266
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Callback.pm91
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Struct.pm429
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Test.pm125
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Type.pm272
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info.pm5
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm2
9 files changed, 644 insertions, 550 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm
index 365ce6b46c5..8a08b01033a 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API.pm
@@ -4,30 +4,29 @@
#######################################################################
#
# Win32::API - Perl Win32 API Import Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
#
-# $Id: API.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
-#
#######################################################################
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;
}
}
@@ -39,12 +38,12 @@ use File::Basename ();
#######################################################################
# STATIC OBJECT PROPERTIES
#
-$VERSION = '0.59';
+$VERSION = '0.68';
-#### 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 = ();
@@ -57,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"`;
@@ -71,41 +71,46 @@ 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);
}
@@ -113,20 +118,21 @@ sub new {
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;
@@ -138,7 +144,7 @@ sub new {
$Libraries{$dll} = $hdll;
$Procedures{$dll}++;
- DEBUG "Object blessed!\n";
+ DEBUG "Object blessed!\n";
#### cast the spell
bless($self, $class);
@@ -146,8 +152,9 @@ sub new {
}
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(\@_); }
@@ -159,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)
@@ -192,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;
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
index df15786591b..46879b4041b 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
@@ -4,28 +4,27 @@
#######################################################################
#
# Win32::API::Callback - Perl Win32 API Import Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
-# $Id: Callback.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
-#
#######################################################################
package Win32::API::Callback;
-$VERSION = '0.59';
+$VERSION = '0.68';
-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;
@@ -39,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 }";
@@ -67,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;
@@ -107,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;
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
index 9f706671a77..3dda7d97e05 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
@@ -1,50 +1,45 @@
-package Win32::API::Struct;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-#######################################################################
#
# Win32::API::Struct - Perl Win32 API struct Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
-# $Id: Struct.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
-#######################################################################
-$VERSION = '0.50';
+package Win32::API::Struct;
-use Win32::API::Type;
+$VERSION = '0.62';
use Carp;
+use Win32::API::Type;
+use Config;
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-@ISA = qw( Exporter DynaLoader );
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter 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;
@@ -53,53 +48,59 @@ sub typedef {
sub recognize {
- my($type, $name) = @_;
- my($size, $packing);
- if(exists $Known{$type}) {
- $packing = ">";
- return $name, $packing, $type;
- } else {
+ my ($type, $name) = @_;
+ my ($size, $packing);
+
+ if (is_known($type)) {
+ $packing = '>';
+ return ($name, $packing, $type);
+ }
+ 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;
- }
+ return ($name, $packing, $type);
+ }
}
sub new {
my $class = shift;
- my($type, $name);
- my $self = {
- typedef => [],
- };
- if($#_ == 0) {
- if(exists $Known{$_[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;
- if($packing eq '>') {
+ next unless defined $name;
+ 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]);
}
}
}
@@ -108,201 +109,215 @@ 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 = undef;
- foreach my $member (@{ $self->{typedef} }) {
- my($name, $packing, $type) = @$member;
-
- if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ my $first = '';
+
+ 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();
- # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align;
- } else {
- if($packing =~ /\w\*(\d+)/) {
+ }
+ else {
+
+ # Member is a simple type (LONG, DWORD, etc...)
+ 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";
- } else {
- $size += Win32::API::Type::sizeof($type);
+ $first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = " . $size
+ . "\n";
+ }
+ 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);
+ $size += $type_size + $type_align;
$first = Win32::API::Type::sizeof($type) unless defined $first;
- $align = Win32::API::Type::sizeof($type)
- if Win32::API::Type::sizeof($type) > $align;
- DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
}
}
}
- DEBUG "(PM)Struct::sizeof first=$first align=$align\n";
- #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align;
- #return $first + (scalar(@{ $self->{typedef} })-1) * $align;
- DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align;
- if(defined $align and $align > 0) {
- return scalar(@{ $self->{typedef} }) * $align;
- } else {
- return $size;
+
+ my $struct_size = $size;
+ if (defined $align && $align > 0) {
+ $struct_size += ($size % $align);
}
- return $size;
+ DEBUG "(PM)Struct::sizeof first=$first totalsize=$struct_size\n";
+ return $struct_size;
}
sub align {
- my $self = shift;
- my $align = shift;
-
- if(not defined $align) {
- return $self->{align} unless $self->{align} eq 'auto';
- $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($type, $name);
- my @items = ();
- my @recipients = ();
-
+ my $self = shift;
+ my $packing = "";
+ my $packed_size = 0;
+ 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) = $self->{$name}->getPack();
-
+ if ($type eq '>') {
+ my ($subpacking, $subitems, $subrecipients, $subpacksize) =
+ $self->{$name}->getPack();
DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
-
- $packing .= $subpacking;
- push(@items, @$subitems);
+ push(@items, @$subitems);
push(@recipients, @$subrecipients);
- } else {
- if($type =~ /\w\*(\d+)/) {
- my $size = $1;
- $type = "a$size";
+ $packing .= $subpacking;
+ $packed_size += $subpacksize;
+ }
+ else {
+ my $repeat = 1;
+ if ($type =~ /\w\*(\d+)/) {
+ $repeat = $1;
+ $type = "a$repeat";
}
-
- DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
-
- if($type eq 'p') {
- $type = "L";
+
+ 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 {
- push(@items, $self->{$name});
}
- $packing .= $type;
-
- if($Win32::API::Type::PackSize{$type} < $align) {
- $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ else {
+ push(@items, $self->{$name});
}
-
push(@recipients, $self);
+ $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 * $repeat ) + $type_align;
}
}
- DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n";
- return($packing, [@items], [@recipients]);
+
+ DEBUG
+ "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n";
+
+ 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) {
- printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
+
+ if (DEBUG) {
+ 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($type, $name);
+ my $self = shift;
+ my $packing = "";
+ my $packed_size = 0;
+ 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) = $self->{$name}->getUnpack();
-
+ if ($type eq '>') {
+ my ($subpacking, $subpacksize, @subitems) = $self->{$name}->getUnpack();
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
$packing .= $subpacking;
-
-
+ $packed_size += $subpacksize;
push(@items, @subitems);
- } else {
- if($type =~ /\w\*(\d+)/) {
- my $size = $1;
- $type = "Z$size";
- }
-
- #if($type eq 'p') {
- # $packing .= 'Z*';
- # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n";
- #} else {
- $packing .= $type;
- DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
- #}
- if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) {
- DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n",
- $type, $Win32::API::Type::PackSize{$type}, $align
- ;
- $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+ else {
+ my $repeat = 1;
+ if ($type =~ /\w\*(\d+)/) {
+ $repeat = $1;
+ $type = "Z$repeat";
}
+ 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 * $repeat ) + $type_align;
push(@items, $name);
}
}
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n";
- return($packing, @items);
+ return ($packing, $packed_size, @items);
}
sub Unpack {
my $self = shift;
- my($packing, @items) = $self->getUnpack();
+ my ($packing, undef, @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";
@@ -311,26 +326,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;
}
@@ -346,42 +363,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;
}
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm
index 0b21ced6927..55bf600b666 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm
@@ -1,30 +1,35 @@
#
# Win32::API::Test - Test helper package for Win32::API
-#
+#
# Cosimo Streppone <cosimo@cpan.org>
#
-# $Id: Test.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
package Win32::API::Test;
+sub is_perl_64bit () {
+ 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);
}
#
@@ -34,50 +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;
- my $dll_name = $_[0];
- 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);
+sub find_test_dll {
+ require File::Spec;
+
+ my $default_dll_name =
+ is_perl_64bit()
+ ? 'API_test64.dll'
+ : 'API_test.dll';
+
+ 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);
}
1;
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm
index 48f0ce1a32f..90e6d1ca0ad 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm
@@ -6,36 +6,36 @@ package Win32::API::Type;
#######################################################################
#
# Win32::API::Type - Perl Win32 API type definitions
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
-# $Id: Type.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
-#
#######################################################################
-$VERSION = '0.59';
+$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.
@@ -44,29 +44,42 @@ 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;
}
@@ -74,21 +87,21 @@ foreach (<DATA>) {
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);
@@ -101,88 +114,108 @@ 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);
}
}
+sub pointer_pack_type {
+ return $Config{ptrsize} == 8 ? 'Q' : 'L';
+}
+
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};
}
}
@@ -193,7 +226,7 @@ sub Pack {
my $pack_type = packing($type);
- if($pack_type eq 'p') {
+ if ($pack_type eq 'p') {
$pack_type = 'Z*';
}
@@ -207,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;
}
@@ -297,42 +330,43 @@ COLORREF L
DWORD L
DWORD32 L
DWORD64 Q
+DWORD_PTR _P
FLOAT f
-HACCEL L
-HANDLE L
-HBITMAP L
-HBRUSH L
-HCOLORSPACE L
-HCONV L
-HCONVLIST L
-HCURSOR L
-HDC L
-HDDEDATA L
-HDESK L
-HDROP L
-HDWP L
-HENHMETAFILE L
-HFILE L
-HFONT L
-HGDIOBJ L
-HGLOBAL L
-HHOOK L
-HICON L
-HIMC L
-HINSTANCE L
-HKEY L
-HKL L
-HLOCAL L
-HMENU L
-HMETAFILE L
-HMODULE L
-HPALETTE L
-HPEN L
-HRGN L
-HRSRC L
-HSZ L
-HWINSTA L
-HWND L
+HACCEL _P
+HANDLE _P
+HBITMAP _P
+HBRUSH _P
+HCOLORSPACE _P
+HCONV _P
+HCONVLIST _P
+HCURSOR _P
+HDC _P
+HDDEDATA _P
+HDESK _P
+HDROP _P
+HDWP _P
+HENHMETAFILE _P
+HFILE _P
+HFONT _P
+HGDIOBJ _P
+HGLOBAL _P
+HHOOK _P
+HICON _P
+HIMC _P
+HINSTANCE _P
+HKEY _P
+HKL _P
+HLOCAL _P
+HMENU _P
+HMETAFILE _P
+HMODULE _P
+HPALETTE _P
+HPEN _P
+HRGN _P
+HRSRC _P
+HSZ _P
+HWINSTA _P
+HWND _P
INT i
INT32 i
INT64 q
@@ -345,20 +379,20 @@ LONG l
LONG32 l
LONG64 q
LONGLONG q
-LPARAM L
-LRESULT L
+LPARAM _P
+LRESULT _P
REGSAM L
-SC_HANDLE L
-SC_LOCK L
-SERVICE_STATUS_HANDLE L
+SC_HANDLE _P
+SC_LOCK _P
+SERVICE_STATUS_HANDLE _P
SHORT s
-SIZE_T L
-SSIZE_T L
+SIZE_T _P
+SSIZE_T _P
TBYTE c
TCHAR C
UCHAR C
UINT I
-UINT_PTR L
+UINT_PTR _P
UINT32 I
UINT64 Q
ULONG L
@@ -368,7 +402,7 @@ ULONGLONG Q
USHORT S
WCHAR S
WORD S
-WPARAM L
+WPARAM _P
VOID c
int i
@@ -396,7 +430,7 @@ q 8
Q 8
s 2
S 2
-p 4
+p _P
[MODIFIER]
unsigned int=I long=L short=S char=C
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
index 6164c18d37b..45cfc373918 100644
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
@@ -70,7 +70,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '1.018';
+our $VERSION = '1.019';
use Carp;
use File::Spec;
@@ -514,7 +514,8 @@ passing any necessary arguments.
{
- my $is_reactos = $^O eq 'MSWin32' && lc $ENV{OS} eq 'reactos';
+ my $is_reactos = $^O eq 'MSWin32' &&
+ defined $ENV{OS} && lc $ENV{OS} eq 'reactos';
sub _isReactOS {
return $is_reactos;
}
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
index 022d1442b33..03f2469d337 100644
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
@@ -75,7 +75,7 @@ return undef; ## no critic (ProhibitExplicitReturnUndef)
use base qw{Win32::Process::Info};
-our $VERSION = '1.018';
+our $VERSION = '1.019';
our $AdjustTokenPrivileges;
our $CloseHandle;
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
index b2b6326b0a4..67bf7562cc9 100644
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
@@ -64,7 +64,7 @@ use strict;
use warnings;
use base qw{Win32::Process::Info};
-our $VERSION = '1.018';
+our $VERSION = '1.019';
use Carp;
use File::Basename;
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
index 3edb3a262f6..06dcea9cfc4 100644
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
@@ -36,7 +36,7 @@ use strict;
use warnings;
use base qw{Win32::Process::Info};
-our $VERSION = '1.018';
+our $VERSION = '1.019';
use vars qw{%mutator};
use Carp;
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 21:19:20 +0000