← Index
NYTProf Performance Profile   « line view »
For Makefile.PL
  Run on Sun Mar 1 16:04:44 2015
Reported on Sun Mar 1 16:09:02 2015

FilenameC:/tmp64ng/perl/vendor/lib/Win32/API.pm
StatementsExecuted 139 statements in 0s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11115.6ms15.6msWin32::API::::BEGIN@62 Win32::API::BEGIN@62
1110s0sWin32::API::::BEGIN@17 Win32::API::BEGIN@17
1110s0sWin32::API::::BEGIN@18 Win32::API::BEGIN@18
1110s0sWin32::API::::BEGIN@19 Win32::API::BEGIN@19
1110s0sWin32::API::::BEGIN@20 Win32::API::BEGIN@20
1110s0sWin32::API::::BEGIN@26 Win32::API::BEGIN@26
1110s0sWin32::API::::BEGIN@30 Win32::API::BEGIN@30
1110s0sWin32::API::::BEGIN@36 Win32::API::BEGIN@36
1110s0sWin32::API::::BEGIN@537 Win32::API::BEGIN@537
1110s0sWin32::API::::BEGIN@63 Win32::API::BEGIN@63
1110s0sWin32::API::::BEGIN@64 Win32::API::BEGIN@64
1110s0sWin32::API::::BEGIN@79 Win32::API::BEGIN@79
0000s0sWin32::API::::CLONE Win32::API::CLONE
3210s0sWin32::API::::CORE:match Win32::API::CORE:match (opcode)
1110s0sWin32::API::::CORE:pack Win32::API::CORE:pack (opcode)
2210s0sWin32::API::::CORE:subst Win32::API::CORE:subst (opcode)
7710s0sWin32::API::::DEBUG Win32::API::DEBUG
0000s0sWin32::API::::DESTROY Win32::API::DESTROY
1110s0sWin32::API::::GetMagicSV Win32::API::GetMagicSV (xsub)
1110s0sWin32::API::::GetProcAddress Win32::API::GetProcAddress (xsub)
1110s0sWin32::API::::ISCYG Win32::API::ISCYG (xsub)
1110s0sWin32::API::::Import Win32::API::Import
1110s0sWin32::API::::LoadLibrary Win32::API::LoadLibrary (xsub)
1110s0sWin32::API::More::::BEGIN@397Win32::API::More::BEGIN@397
0000s0sWin32::API::More::::type_to_numWin32::API::More::type_to_num
1110s0sWin32::API::::SetMagicSV Win32::API::SetMagicSV (xsub)
1110s0sWin32::API::::_Align Win32::API::_Align (xsub)
1110s0sWin32::API::::_ImportXS Win32::API::_ImportXS (xsub)
1110s0sWin32::API::::bootstrap Win32::API::bootstrap (xsub)
1110s0sWin32::API::::calltype_to_num Win32::API::calltype_to_num
1110s0sWin32::API::::new Win32::API::new
1110s0sWin32::API::::parse_prototype Win32::API::parse_prototype
2210s0sWin32::API::::type_to_num Win32::API::type_to_num
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# See the bottom of this file for the POD documentation. Search for the
2# string '=head'.
3
4#######################################################################
5#
6# Win32::API - Perl Win32 API Import Facility
7#
8# Author: Aldo Calpini <dada@perl.it>
9# Maintainer: Cosimo Streppone <cosimo@cpan.org>
10#
11# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
12# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
13#
14#######################################################################
15
16package Win32::API;
1720s20s
# spent 0s within Win32::API::BEGIN@17 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 17
use strict;
# spent 0s making 1 call to Win32::API::BEGIN@17 # spent 0s making 1 call to strict::import
1820s20s
# spent 0s within Win32::API::BEGIN@18 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 18
use warnings;
# spent 0s making 1 call to Win32::API::BEGIN@18 # spent 0s making 1 call to warnings::import
1920s20s
# spent 0s within Win32::API::BEGIN@19 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 19
use Config;
# spent 0s making 1 call to Config::import # spent 0s making 1 call to Win32::API::BEGIN@19
20
# spent 0s within Win32::API::BEGIN@20 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 51
BEGIN {
2110s require Exporter; # to export the constants to the main:: space
2210s require DynaLoader; # to dynuhlode the module.
23
24 sub ISCYG ();
2510s eval "sub ISCYG () { ".($^O eq 'cygwin' ? 1 : 0)."}";
2620s20s
# spent 0s within Win32::API::BEGIN@26 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 26
no warnings 'uninitialized';
# spent 0s making 1 call to Win32::API::BEGIN@26 # spent 0s making 1 call to warnings::unimport
2710s10s die "Win32::API on Cygwin requires the cygpath tool on PATH"
# spent 0s making 1 call to Win32::API::ISCYG
28 if ISCYG && index(`cygpath --help`,'Usage: cygpath') == -1;
29
3020s20s
# spent 0s within Win32::API::BEGIN@30 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 30
use vars qw( $DEBUG $sentinal @ISA @EXPORT_OK $VERSION );
# spent 0s making 1 call to Win32::API::BEGIN@30 # spent 0s making 1 call to vars::import
31
3210s @ISA = qw( Exporter DynaLoader );
3310s @EXPORT_OK = qw( ReadMemory IsBadReadPtr MoveMemory
34 WriteMemory SafeReadWideCString ); # symbols to export on request
35
3620s20s
# spent 0s within Win32::API::BEGIN@36 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 36
use Scalar::Util qw( looks_like_number weaken);
# spent 0s making 1 call to Exporter::import # spent 0s making 1 call to Win32::API::BEGIN@36
37
3810s $DEBUG = 0;
39
40 sub ERROR_NOACCESS () { 998 }
41 sub ERROR_NOT_ENOUGH_MEMORY () { 8 }
42 sub ERROR_INVALID_PARAMETER () { 87 }
43 sub APICONTROL_CC_STD () { 0 }
44 sub APICONTROL_CC_C () { 1 }
45 sub APICONTROL_CC_mask () { 0x7 }
46 sub APICONTROL_UseMI64 () { 0x8 }
47 sub APICONTROL_is_more () { 0x10 }
48 sub APICONTROL_has_proto() { 0x20 }
4910s10s eval " *Win32::API::Type::PTRSIZE = *Win32::API::More::PTRSIZE = *PTRSIZE = sub () { ".$Config{ptrsize}." }";
# spent 0s making 1 call to Config::FETCH
# spent 0s executing statements in string eval
5010s10s eval " *Win32::API::Type::IVSIZE = *Win32::API::More::IVSIZE = *IVSIZE = sub () { ".$Config{ivsize}." }";
# spent 0s making 1 call to Config::FETCH
# spent 0s executing statements in string eval
5110s10s}
# spent 0s making 1 call to Win32::API::BEGIN@20
52
53
# spent 0s within Win32::API::DEBUG which was called 7 times, avg 0s/call: # once (0s+0s) by Win32::API::parse_prototype at line 526 # once (0s+0s) by Win32::API::parse_prototype at line 570 # once (0s+0s) by Win32::API::new at line 192 # once (0s+0s) by Win32::API::new at line 114 # once (0s+0s) by Win32::API::parse_prototype at line 525 # once (0s+0s) by Win32::API::parse_prototype at line 583 # once (0s+0s) by Win32::API::new at line 259
sub DEBUG {
5470s if ($Win32::API::DEBUG) {
55 printf @_ if @_ or return 1;
56 }
57 else {
5870s return 0;
59 }
60}
61
6220s215.6ms
# spent 15.6ms within Win32::API::BEGIN@62 which was called: # once (15.6ms+0s) by ExtUtils::MakeMaker::Locale::_init at line 62
use Win32::API::Type;
# spent 15.6ms making 1 call to Win32::API::BEGIN@62 # spent 0s making 1 call to Exporter::import
6320s20s
# spent 0s within Win32::API::BEGIN@63 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 63
use Win32::API::Struct;
# spent 0s making 1 call to Exporter::import # spent 0s making 1 call to Win32::API::BEGIN@63
6420s10s
# spent 0s within Win32::API::BEGIN@64 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 64
use File::Basename ();
# spent 0s making 1 call to Win32::API::BEGIN@64
65
66#######################################################################
67# STATIC OBJECT PROPERTIES
68#
69#### some package-global hash to
70#### keep track of the imported
71#### libraries and procedures
7210smy %Libraries = ();
7310smy %Procedures = ();
74
75
76#######################################################################
77# dynamically load in the API extension module.
78# BEGIN required for constant subs in BOOT:
79
# spent 0s within Win32::API::BEGIN@79 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 82
BEGIN {
8010s $VERSION = '0.79';
8110s10s bootstrap Win32::API;
# spent 0s making 1 call to DynaLoader::bootstrap
8210s10s}
# spent 0s making 1 call to Win32::API::BEGIN@79
83
84#######################################################################
85# PUBLIC METHODS
86#
87
# spent 0s within Win32::API::new which was called: # once (0s+0s) by Win32::API::Import at line 267
sub new {
8810s die "Win32::API/More::new/Import is a class method that takes 2 to 6 parameters, see POD"
89 if @_ < 3 || @_ > 7;
9010s my ($class, $dll, $hproc, $ccnum, $outnum) = (shift, shift);
9110s if(! defined $dll){
92 $hproc = shift;
93 }
9410s my ($proc, $in, $out, $callconvention) = @_;
9510s my ($hdll, $freedll, $proto, $stackunwind) = (0, 0, 0, 0);
9610s my $self = {};
9710s if(! defined $hproc){
98 if (ISCYG() and $dll ne File::Basename::basename($dll)) {
99
100 # need to convert $dll to win32 path
101 # isn't there an API for this?
102 my $newdll = `cygpath -w "$dll"`;
103 chomp $newdll;
104 DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
105 $dll = $newdll;
106 }
107
108 #### avoid loading a library more than once
10910s if (exists($Libraries{$dll})) {
110 DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
111 $hdll = $Libraries{$dll};
112 }
113 else {
11410s10s DEBUG "Win32::API::new: Loading library '$dll'\n";
# spent 0s making 1 call to Win32::API::DEBUG
11510s10s $hdll = Win32::API::LoadLibrary($dll);
# spent 0s making 1 call to Win32::API::LoadLibrary
11610s $freedll = 1;
117 # $Libraries{$dll} = $hdll;
118 }
119
120 #### if the dll can't be loaded, set $! to Win32's GetLastError()
12110s if (!$hdll) {
122 $! = Win32::GetLastError();
123 DEBUG "FAILED Loading library '$dll': $^E\n";
124 return undef;
125 }
126 }
127 else{
128 if(!looks_like_number($hproc) || IsBadReadPtr($hproc, 4)){
129 Win32::SetLastError(ERROR_NOACCESS);
130 DEBUG "FAILED Function pointer '$hproc' is not a valid memory location\n";
131 return undef;
132 }
133 }
134 #### determine if we have a prototype or not, outtype is for future use in XS
13510s if ((not defined $in) and (not defined $out)) {
13610s10s ($proc, $self->{in}, $self->{intypes}, $outnum, $self->{outtype},
# spent 0s making 1 call to Win32::API::parse_prototype
137 $ccnum) = parse_prototype($class, $proc);
13810s if( ! $proc ){
139 Win32::API::FreeLibrary($hdll) if $freedll;
140 Win32::SetLastError(ERROR_INVALID_PARAMETER);
141 return undef;
142 }
14310s $proto = 1;
144 }
145 else {
146 $self->{in} = [];
147 my $self_in = $self->{in}; #avoid hash derefing
148 if (ref($in) eq 'ARRAY') {
149 foreach (@$in) {
150 push(@{$self_in}, $class->type_to_num($_));
151 }
152 }
153 else {
154 my @in = split '', $in;
155 foreach (@in) {
156 push(@{$self_in}, $class->type_to_num($_));
157 }
158 }#'V' must be one and ONLY letter for "in"
159 foreach(@{$self_in}){
160 if($_ == 0){
161 if(@{$self_in} != 1){
162 Win32::API::FreeLibrary($hdll) if $freedll;
163 die "Win32::API 'V' for in prototype must be the only parameter";
164 } else {undef(@{$self_in});} #empty arr, as if in param was ""
165 }
166 }
167 $outnum = $class->type_to_num($out, 1);
168 $ccnum = calltype_to_num($callconvention);
169 }
170
17110s if(!$hproc){ #if not non DLL func
172 #### first try to import the function of given name...
17310s10s $hproc = Win32::API::GetProcAddress($hdll, $proc);
# spent 0s making 1 call to Win32::API::GetProcAddress
174
175 #### ...then try appending either A or W (for ASCII or Unicode)
17610s if (!$hproc) {
177 my $tproc = $proc;
178 $tproc .= (IsUnicode() ? "W" : "A");
179
180 # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
181 $hproc = Win32::API::GetProcAddress($hdll, $tproc);
182 }
183
184 #### ...if all that fails, give up, $! setting is back compat, $! is deprecated
18510s if (!$hproc) {
186 my $err = $! = Win32::GetLastError();
187 DEBUG "FAILED GetProcAddress for Proc '$proc': $^E\n";
188 Win32::API::FreeLibrary($hdll) if $freedll;
189 Win32::SetLastError($err);
190 return undef;
191 }
19210s10s DEBUG "GetProcAddress('$proc') = '$hproc'\n";
# spent 0s making 1 call to Win32::API::DEBUG
193 }
194 else {
195 DEBUG "Using non-DLL function pointer '$hproc' for '$proc'\n";
196 }
197 if(PTRSIZE == 4 && $ccnum == APICONTROL_CC_C) {#fold out on WIN64
198 #calculate add to ESP amount, in units of 4, will be *4ed later
199 $stackunwind += $_ == T_QUAD || $_ == T_DOUBLE ? 2 : 1 for(@{$self->{in}});
200 if($stackunwind > 0xFFFF) {
201 goto too_many_in_params;
202 }
203 }
204 # if a prototype has 8 byte types on 32bit, $stackunwind will be higher than
205 # length of {in} letter array, so 2 different checks need to be done
20610s if($#{$self->{in}} > 0xFFFF) {
207 too_many_in_params:
208 DEBUG "FAILED This function has too many parameters (> ~65535) \n";
209 Win32::API::FreeLibrary($hdll) if $freedll;
210 Win32::SetLastError(ERROR_NOT_ENOUGH_MEMORY);
211 return undef;
212 }
213 #### ok, let's stuff the object
21410s $self->{procname} = $proc;
21510s $self->{dll} = $hdll;
21610s $self->{dllname} = $dll;
217
21810s $outnum &= ~T_FLAG_NUMERIC;
21910s my $control;
22010s $self->{weakapi} = \$control;
22110s10s weaken($self->{weakapi});
# spent 0s making 1 call to Scalar::Util::weaken
222 $control = pack( 'L'
223 .'L'
224 .(PTRSIZE == 8 ? 'Q' : 'L')
225 .(PTRSIZE == 8 ? 'Q' : 'L')
226 .(PTRSIZE == 8 ? 'Q' : 'L')
227 .(PTRSIZE == 8 ? '' : 'L')
228 ,($class eq "Win32::API::More" ? APICONTROL_is_more : 0)
229 | ($proto ? APICONTROL_has_proto : 0)
230 | $ccnum
231 | (PTRSIZE == 8 ? 0 : $stackunwind << 8)
232 | $outnum << 24
23310s10s , scalar(@{$self->{in}}) * PTRSIZE #in param count, in SV * units
# spent 0s making 1 call to Win32::API::CORE:pack
234 , $hproc
235 , \($self->{weakapi})+0 #weak api obj ref
236 , (exists $self->{intypes} ? ($self->{intypes})+0 : 0)
237 , 0); #padding to align to 8 bytes on 32 bit only
238 #align to 16 bytes
23910s $control .= "\x00" x ((((length($control)+ 15) >> 4) << 4)-length($control));
240 #make a APIPARAM template array
24110s my ($i, $arr_end) = (0, scalar(@{$self->{in}}));
24210s for(; $i< $arr_end; $i++) {
243 my $tin = $self->{in}[$i];
244 #unsigned meaningless no sign vs zero extends are done bc uv/iv is
245 #the biggest native integer on the cpu, big to small is truncation
246 #numeric is implemented as T_NUMCHAR for in, keeps asm jumptable clean
247 $tin &= ~(T_FLAG_UNSIGNED|T_FLAG_NUMERIC);
248 $tin--; #T_VOID doesn't exist as in param in XS
249 #put index of param array slice in unused space for croaks, why not?
250 $control .= "\x00" x 8 . pack('CCSSS', $tin, 0, 0, $i, $i+1);
251 }
25210s10s _Align($control, 16); #align the whole PVX to 16 bytes for SSE moves
# spent 0s making 1 call to Win32::API::_Align
253
254 #### keep track of the imported function
25510s if(defined $dll){
25610s $Libraries{$dll} = $hdll;
25710s $Procedures{$dll}++;
258 }
25910s10s DEBUG "Object blessed!\n";
# spent 0s making 1 call to Win32::API::DEBUG
260
26110s my $ref = bless(\$control, $class);
26210s10s SetMagicSV($ref, $self);
# spent 0s making 1 call to Win32::API::SetMagicSV
26310s return $ref;
264}
265
266
# spent 0s within Win32::API::Import which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 30 of ExtUtils/MakeMaker/Locale.pm
sub Import {
26710s10s my $closure = shift->new(@_)
# spent 0s making 1 call to Win32::API::new
268 or return undef;
26910s10s my $procname = ${Win32::API::GetMagicSV($closure)}{procname};
# spent 0s making 1 call to Win32::API::GetMagicSV
270 #dont allow "sub main:: {0;}"
27110s Win32::SetLastError(ERROR_INVALID_PARAMETER), return undef if $procname eq '';
27210s10s _ImportXS($closure, (caller)[0].'::'.$procname);
# spent 0s making 1 call to Win32::API::_ImportXS
27310s return $closure;
274}
275
276#######################################################################
277# PRIVATE METHODS
278#
279sub DESTROY {
280 my ($self) = GetMagicSV($_[0]);
281
282 return if ! defined $self->{dllname};
283 #### decrease this library's procedures reference count
284 $Procedures{$self->{dllname}}--;
285
286 #### once it reaches 0, free it
287 if ($Procedures{$self->{dllname}} == 0) {
288 DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
289 Win32::API::FreeLibrary($Libraries{$self->{dllname}});
290 delete($Libraries{$self->{dllname}});
291 }
292}
293
294# Convert calling convention string (_cdecl|__stdcall)
295# to a C const. Unknown counts as __stdcall
296#
297
# spent 0s within Win32::API::calltype_to_num which was called: # once (0s+0s) by Win32::API::parse_prototype at line 588
sub calltype_to_num {
29810s my $type = shift;
299
30010s if (!$type || $type eq "__stdcall" || $type eq "WINAPI" || $type eq "NTAPI"
301 || $type eq "CALLBACK" ) {
302 return APICONTROL_CC_STD;
303 }
304 elsif ($type eq "_cdecl" || $type eq "__cdecl" || $type eq "WINAPIV") {
305 return APICONTROL_CC_C;
306 }
307 else {
308 warn "unknown calling convention: '$type'";
309 return APICONTROL_CC_STD;
310 }
311}
312
313
314
# spent 0s within Win32::API::type_to_num which was called 2 times, avg 0s/call: # once (0s+0s) by Win32::API::parse_prototype at line 583 # once (0s+0s) by Win32::API::parse_prototype at line 588
sub type_to_num {
31520s die "wrong class" if shift ne "Win32::API";
31620s my $type = shift;
31720s my $out = shift;
31820s my ($num, $numeric);
31920s if(index($type, 'num', 0) == 0){
320 substr($type, 0, length('num'), '');
321 $numeric = 1;
322 }
323 else{
32420s $numeric = 0;
325 }
326
32720s if ( $type eq 'N'
328 or $type eq 'n'
329 or $type eq 'l'
330 or $type eq 'L'
331 or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q'))
332 {
333 $num = T_NUMBER;
334 }
335 elsif ($type eq 'P'
336 or $type eq 'p')
337 {
338 $num = T_POINTER;
339 }
340 elsif ($type eq 'I'
341 or $type eq 'i')
342 {
343 $num = T_INTEGER;
344 }
345 elsif ($type eq 'f'
346 or $type eq 'F')
347 {
348 $num = T_FLOAT;
349 }
350 elsif ($type eq 'D'
351 or $type eq 'd')
352 {
353 $num = T_DOUBLE;
354 }
355 elsif ($type eq 'c'
356 or $type eq 'C')
357 {
358 $num = $numeric ? T_NUMCHAR : T_CHAR;
359 }
360 elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q')
361 {
362 $num = T_QUAD;
363 }
364 elsif($type eq '>'){
365 die "Win32::API does not support pass by copy structs as function arguments";
366 }
367 else {
368 $num = T_VOID; #'V' takes this branch, which is T_VOID in C
369 }#not valid return types of the C func
37020s if(defined $out) {#b/B remains private/undocumented
37120s20s die "Win32::API invalid return type, structs and ".
# spent 0s making 2 calls to Win32::API::CORE:match, avg 0s/call
372 "callbacks as return types not supported"
373 if($type =~ m/^s|S|t|T|b|B|k|K$/);
374 }
375 else {#in type
376 if ($type eq 's' or $type eq 'S' or $type eq 't' or $type eq 'T')
377 {
378 $num = T_STRUCTURE;
379 }
380 elsif ($type eq 'b'
381 or $type eq 'B')
382 {
383 $num = T_POINTERPOINTER;
384 }
385 elsif ($type eq 'k'
386 or $type eq 'K')
387 {
388 $num = T_CODE;
389 }
390 }
39120s $num |= T_FLAG_NUMERIC if $numeric;
39220s return $num;
393}
394
395package Win32::API::More;
396
39720s20s
# spent 0s within Win32::API::More::BEGIN@397 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 397
use vars qw( @ISA );
# spent 0s making 1 call to Win32::API::More::BEGIN@397 # spent 0s making 1 call to vars::import
39810s@ISA = qw ( Win32::API );
399sub type_to_num {
400 die "wrong class" if shift ne "Win32::API::More";
401 my $type = shift;
402 my $out = shift;
403 my ($num, $numeric);
404 if(index($type, 'num', 0) == 0){
405 substr($type, 0, length('num'), '');
406 $numeric = 1;
407 }
408 else{
409 $numeric = 0;
410 }
411
412 if ( $type eq 'N'
413 or $type eq 'n'
414 or $type eq 'l'
415 or $type eq 'L'
416 or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q')
417 or (! $out and # in XS short 'in's are interger/numbers code
418 $type eq 'S'
419 || $type eq 's'))
420 {
421 $num = Win32::API::T_NUMBER;
422 if(defined $out && ($type eq 'N' || $type eq 'L'
423 || $type eq 'S' || $type eq 'Q')){
424 $num |= Win32::API::T_FLAG_UNSIGNED;
425 }
426 }
427 elsif ($type eq 'P'
428 or $type eq 'p')
429 {
430 $num = Win32::API::T_POINTER;
431 }
432 elsif ($type eq 'I'
433 or $type eq 'i')
434 {
435 $num = Win32::API::T_INTEGER;
436 if(defined $out && $type eq 'I'){
437 $num |= Win32::API::T_FLAG_UNSIGNED;
438 }
439 }
440 elsif ($type eq 'f'
441 or $type eq 'F')
442 {
443 $num = Win32::API::T_FLOAT;
444 }
445 elsif ($type eq 'D'
446 or $type eq 'd')
447 {
448 $num = Win32::API::T_DOUBLE;
449 }
450 elsif ($type eq 'c'
451 or $type eq 'C')
452 {
453 $num = $numeric ? Win32::API::T_NUMCHAR : Win32::API::T_CHAR;
454 if(defined $out && $type eq 'C'){
455 $num |= Win32::API::T_FLAG_UNSIGNED;
456 }
457 }
458 elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q')
459 {
460 $num = Win32::API::T_QUAD;
461 if(defined $out && $type eq 'Q'){
462 $num |= Win32::API::T_FLAG_UNSIGNED;
463 }
464 }
465 elsif ($type eq 's') #4 is only used for out params
466 {
467 $num = Win32::API::T_SHORT;
468 }
469 elsif ($type eq 'S')
470 {
471 $num = Win32::API::T_SHORT | Win32::API::T_FLAG_UNSIGNED;
472 }
473 elsif($type eq '>'){
474 die "Win32::API does not support pass by copy structs as function arguments";
475 }
476 else {
477 $num = Win32::API::T_VOID; #'V' takes this branch, which is T_VOID in C
478 } #not valid return types of the C func
479 if(defined $out) {#b/B remains private/undocumented
480 die "Win32::API invalid return type, structs and ".
481 "callbacks as return types not supported"
482 if($type =~ m/^t|T|b|B|k|K$/);
483 }
484 else {#in type
485 if ( $type eq 't'
486 or $type eq 'T')
487 {
488 $num = Win32::API::T_STRUCTURE;
489 }
490 elsif ($type eq 'b'
491 or $type eq 'B')
492 {
493 $num = Win32::API::T_POINTERPOINTER;
494 }
495 elsif ($type eq 'k'
496 or $type eq 'K')
497 {
498 $num = Win32::API::T_CODE;
499 }
500 }
501 $num |= Win32::API::T_FLAG_NUMERIC if $numeric;
502 return $num;
503}
504package Win32::API;
505
506
# spent 0s within Win32::API::parse_prototype which was called: # once (0s+0s) by Win32::API::new at line 136
sub parse_prototype {
50710s my ($class, $proto) = @_;
508
50910s my @in_params = ();
51010s my @in_types = (); #one day create a BNF-ish formal grammer parser here
51110s10s if ($proto =~ /^\s*((?:(?:un|)signed\s+|) #optional signedness
# spent 0s making 1 call to Win32::API::CORE:match
512 \S+)(?:\s*(\*)\s*|\s+) #type and maybe a *
513 (?:(\w+)\s+)? # maybe a calling convention
514 (\S+)\s* #func name
515 \(([^\)]*)\) #param list
516 /x) {
51710s my $ret = $1.(defined($2)?$2:'');
51810s my $callconvention = $3;
51910s my $proc = $4;
52010s my $params = $5;
521
52210s10s $params =~ s/^\s+//;
# spent 0s making 1 call to Win32::API::CORE:subst
52310s10s $params =~ s/\s+$//;
# spent 0s making 1 call to Win32::API::CORE:subst
524
52510s10s DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
# spent 0s making 1 call to Win32::API::DEBUG
52610s10s DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
# spent 0s making 1 call to Win32::API::DEBUG
527
52810s foreach my $param (split(/\s*,\s*/, $params)) {
529 my ($type, $name);
530 #match "in_t* _var" "in_t * _var" "in_t *_var" "in_t _var" "in_t*_var" supported
531 #unsigned or signed or nothing as prefix supported
532 # "in_t ** _var" and "const in_t* var" not supported
533 if ($param =~ /((?:(?:un|)signed\s+|)\w+)(?:\s*(\*)\s*|\s+)(\w+)/) {
534 ($type, $name) = ($1.(defined($2)? $2:''), $3);
535 }
536 {
53720s20s
# spent 0s within Win32::API::BEGIN@537 which was called: # once (0s+0s) by ExtUtils::MakeMaker::Locale::_init at line 537
no warnings 'uninitialized';
# spent 0s making 1 call to Win32::API::BEGIN@537 # spent 0s making 1 call to warnings::unimport
538 if($type eq '') {goto BADPROTO;} #something very wrong, bail out
539 }
540 my $packing = Win32::API::Type::packing($type);
541 if (defined $packing && $packing ne '>') {
542 if (Win32::API::Type::is_pointer($type)) {
543 DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
544 $type,
545 $packing,
546 $class->type_to_num('P');
547 push(@in_params, $class->type_to_num('P'));
548 }
549 else {
550 DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
551 $type,
552 $packing,
553 $class->type_to_num(Win32::API::Type->packing($type, undef, 1));
554 push(@in_params, $class->type_to_num(Win32::API::Type->packing($type, undef, 1)));
555 }
556 }
557 elsif (Win32::API::Struct::is_known($type)) {
558 DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
559 $type, 'T', Win32::API::More->type_to_num('T');
560 push(@in_params, Win32::API::More->type_to_num('T'));
561 }
562 else {
563 warn
564 "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
565 push(@in_params, $class->type_to_num('I'));
566 }
567 push(@in_types, $type);
568
569 }
57010s10s DEBUG "parse_prototype: IN=[ @in_params ]\n";
# spent 0s making 1 call to Win32::API::DEBUG
571
572
57310s10s if (Win32::API::Type::is_known($ret)) {
# spent 0s making 1 call to Win32::API::Type::is_known
57410s10s if (Win32::API::Type::is_pointer($ret)) {
# spent 0s making 1 call to Win32::API::Type::is_pointer
575 DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
576 $ret,
577 Win32::API::Type->packing($ret),
578 $class->type_to_num('P');
579 return ($proc, \@in_params, \@in_types, $class->type_to_num('P', 1),
580 $ret, calltype_to_num($callconvention));
581 }
582 else {
58310s40s DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
# spent 0s making 1 call to Win32::API::DEBUG # spent 0s making 2 calls to Win32::API::Type::packing, avg 0s/call # spent 0s making 1 call to Win32::API::type_to_num
584 $ret,
585 Win32::API::Type->packing($ret),
586 $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1);
587 return (
58810s30s $proc, \@in_params, \@in_types,
# spent 0s making 1 call to Win32::API::Type::packing # spent 0s making 1 call to Win32::API::calltype_to_num # spent 0s making 1 call to Win32::API::type_to_num
589 $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1),
590 $ret, calltype_to_num($callconvention)
591 );
592 }
593 }
594 else {
595 warn
596 "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
597 return ($proc, \@in_params, \@in_types, $class->type_to_num('I', 1),
598 $ret, calltype_to_num($callconvention));
599 }
600
601 }
602 else {
603 BADPROTO:
604 warn "Win32::API::parse_prototype: bad prototype '$proto'";
605 return undef;
606 }
607}
608
609#
610# XXX hack, see the proper implementation in TODO
611# The point here is don't let fork children free the parent's DLLs.
612# CLONE runs on ::API and ::More, that's bad and causes a DLL leak, make sure
613# CLONE dups the DLL handles only once per CLONE
614# GetModuleHandleEx was not used since that is a WinXP and newer function, not Win2K.
615# GetModuleFileName was used to get full DLL pathname incase SxS/multiple DLLs
616# with same file name exist in the process. Even if the dll was loaded as a
617# relative path initially, later SxS can load a DLL with a different full path
618# yet same file name, and then LoadLibrary'ing the original relative path
619# might increase the refcount on the wrong DLL or return a different HMODULE
620sub CLONE {
621 return if $_[0] ne "Win32::API";
622
623 _my_cxt_clone();
624 foreach( keys %Libraries){
625 if($Libraries{$_} != Win32::API::LoadLibrary(Win32::API::GetModuleFileName($Libraries{$_}))){
626 die "Win32::API::CLONE unable to clone DLL \"$Libraries{$_}\" Unicode Problem??";
627 }
628 }
629}
630
63110s1;
632
633__END__
 
# spent 0s within Win32::API::CORE:match which was called 3 times, avg 0s/call: # 2 times (0s+0s) by Win32::API::type_to_num at line 371, avg 0s/call # once (0s+0s) by Win32::API::parse_prototype at line 511
sub Win32::API::CORE:match; # opcode
# spent 0s within Win32::API::CORE:pack which was called: # once (0s+0s) by Win32::API::new at line 233
sub Win32::API::CORE:pack; # opcode
# spent 0s within Win32::API::CORE:subst which was called 2 times, avg 0s/call: # once (0s+0s) by Win32::API::parse_prototype at line 523 # once (0s+0s) by Win32::API::parse_prototype at line 522
sub Win32::API::CORE:subst; # opcode
# spent 0s within Win32::API::GetMagicSV which was called: # once (0s+0s) by Win32::API::Import at line 269
sub Win32::API::GetMagicSV; # xsub
# spent 0s within Win32::API::GetProcAddress which was called: # once (0s+0s) by Win32::API::new at line 173
sub Win32::API::GetProcAddress; # xsub
# spent 0s within Win32::API::ISCYG which was called: # once (0s+0s) by Win32::API::BEGIN@20 at line 27
sub Win32::API::ISCYG; # xsub
# spent 0s within Win32::API::LoadLibrary which was called: # once (0s+0s) by Win32::API::new at line 115
sub Win32::API::LoadLibrary; # xsub
# spent 0s within Win32::API::SetMagicSV which was called: # once (0s+0s) by Win32::API::new at line 262
sub Win32::API::SetMagicSV; # xsub
# spent 0s within Win32::API::_Align which was called: # once (0s+0s) by Win32::API::new at line 252
sub Win32::API::_Align; # xsub
# spent 0s within Win32::API::_ImportXS which was called: # once (0s+0s) by Win32::API::Import at line 272
sub Win32::API::_ImportXS; # xsub
# spent 0s within Win32::API::bootstrap which was called: # once (0s+0s) by DynaLoader::bootstrap at line 216 of DynaLoader.pm
sub Win32::API::bootstrap; # xsub
Report produced by the NYTProf 5.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.