File Coverage

blib/lib/Sys/CpuAffinity.pm
Criterion Covered Total %
statement 248 823 30.1
branch 120 518 23.1
condition 25 148 16.8
subroutine 67 79 84.8
pod 3 4 75.0
total 463 1572 29.4


line stmt bran cond sub pod time code
1             package Sys::CpuAffinity;
2 6     6   80984 use Math::BigInt;
  6         169291  
  6         30  
3 6     6   142291 use Carp;
  6         16  
  6         386  
4 6     6   41 use warnings;
  6         12  
  6         180  
5 6     6   33 use strict;
  6         11  
  6         152  
6 6     6   62 use base qw(DynaLoader);
  6         16  
  6         915  
7 6     6   6262 use Data::Dumper;
  6         51426  
  6         51778  
8              
9             ## no critic (ProhibitBacktick,RequireExtendedFormatting)
10             ## no critic (DotMatch,LineBoundary,Sigils,Punctuation,Quotes,Magic,Checked)
11             ## no critic (NamingConventions::Capitalization,BracedFileHandle)
12              
13             our $VERSION = '1.13_03';
14             our $DEBUG = $ENV{DEBUG} || 0;
15             our $XS_LOADED = 0;
16             eval { bootstrap Sys::CpuAffinity $VERSION; $XS_LOADED = 1 };
17              
18 5532     5532 0 4726101 sub TWO () { Math::BigInt->new(2) }
19              
20             # sub import { }
21              
22             #
23             # Development guide:
24             #
25             # when you figure out a new way to perform a task
26             # (in this case, getting cpu affinity), write the method and insert
27             # the call into the chain here.
28             #
29             # Methods should be named _getAffinity_with_XXX, _setAffinity_with_XXX,
30             # or _getNumCpus_from_XXX. The t/inventory.pl file will identify these
31             # methods so they can be included in the tests.
32             #
33             # The new method should return false (0 or '' or undef) whenever it
34             # knows it is the wrong tool for the current system or any other time
35             # that it can't figure out the answer.
36             #
37             # For XS-based solutions, the stub will go in the distributions
38             # contrib/ directory, and will be available if it successfully
39             # compiles during the installation process. See
40             # _getAffinity_with_xs_sched_getaffinity for an example of
41             # how to use a compiled function. All exported XS function names
42             # should begin with "xs_" and all function names, even the ones
43             # that aren't exported to XS, should be unique across the whole
44             # /contrib space.
45             #
46             # Methods that might return with the wrong answer (for example, methods
47             # that make a guess) should go toward the end of the chain. This
48             # probably should include methods that read environment variables
49             # or methods that rely on external commands as these methods are
50             # easier to spoof, even accidentally.
51             #
52              
53             sub getAffinity {
54 49     49 1 27610 my ($pid, %flags) = @_; # %flags reserved for future use
55 49         133 my $wpid = $pid;
56              
57             # 2020-12-18: taskset only returns 32 bits? Give xs_sched more priority
58            
59 49   50     191 my $mask = 0
60             || _getAffinity_with_xs_sched_getaffinity($pid)
61             || _getAffinity_with_xs_pthread_self_getaffinity($pid)
62             || _getAffinity_with_taskset($pid)
63             || _getAffinity_with_BSD_Process_Affinity($pid)
64             || _getAffinity_with_xs_freebsd_getaffinity($pid)
65             || _getAffinity_with_cpuset($pid)
66             || _getAffinity_with_xs_processor_affinity($pid)
67             || _getAffinity_with_pbind($pid)
68             || _getAffinity_with_xs_processor_bind($pid)
69             || _getAffinity_with_psaix($pid)
70             || _getAffinity_with_xs_win32($pid)
71             || _getAffinity_with_xs_irix_sysmp($pid)
72             || _getAffinity_with_Win32Process($wpid)
73             || _getAffinity_with_Win32API($wpid)
74             || 0;
75              
76 49 100       1412 return if $mask == 0;
77 43 50       7206 return wantarray ? _maskToArray($mask) : $mask;
78             }
79              
80             sub _sanitize_set_affinity_args {
81 19     19   52 my ($pid,$mask) = @_;
82              
83 19 50       63 if ($DEBUG) {
84 0         0 print STDERR "sanitize_set_affinity_args: input is ",Dumper(@_),"\n";
85             }
86              
87 19 50       75 return if ! $pid;
88 19 50       87 if (ref $mask eq 'ARRAY') {
89 0         0 $mask = _arrayToMask(@$mask);
90 0 0       0 if ($DEBUG) {
91 0         0 print STDERR "sanitize_set_affinity_args: ",
92             Dumper($_[1])," => $mask\n";
93             }
94             }
95 19         95 my $np = getNumCpus();
96 19 100 66     106 if ($mask == -1 && $np > 0) {
97 4         24 $mask = (TWO ** $np) - 1;
98 4 50       3530 if ($DEBUG) {
99 0         0 print STDERR "sanitize_set_affinity_args: -1 => ",
100             $mask," ",Dumper($mask),"\n";
101             }
102             }
103 19 100       1336 if ($mask <= 0) {
104 2         982 carp "Sys::CpuAffinity: invalid mask $mask in call to setAffinty\n";
105 2         20 return;
106             }
107              
108 17         3004 my $maxmask = TWO ** $np;
109 17 100 66     5304 if ($maxmask > 1 && $mask >= $maxmask) {
110 2         346 my $newmask = $mask & ($maxmask - 1);
111 2 50       1482 if ($newmask == 0) {
112 2         384 carp "Sys::CpuAffinity: mask $mask is not valid for system with ",
113             "$np processors.\n";
114 2         666 return;
115             } else {
116 0         0 carp "Sys::CpuAffinity: mask $mask adjusted to $newmask for ",
117             "system with $np processors\n";
118 0         0 $mask = $newmask;
119             }
120             }
121 15         2593 $_[1] = $mask;
122 15         62 return 1;
123             }
124              
125             sub setAffinity {
126 19     19 1 10388 my ($pid, $mask, %flags) = @_; # %flags reserved for future use
127              
128 19 100       128 return 0 if ! _sanitize_set_affinity_args($pid, $mask);
129              
130 15   50     81 return _setAffinity_with_Win32API($pid,$mask)
131             || _setAffinity_with_xs_win32($pid,$mask)
132             || _setAffinity_with_Win32Process($pid,$mask)
133             || _setAffinity_with_xs_sched_setaffinity($pid,$mask)
134             || _setAffinity_with_taskset($pid,$mask)
135             || _setAffinity_with_BSD_Process_Affinity($pid,$mask)
136             || _setAffinity_with_xs_freebsd_setaffinity($pid,$mask)
137             || _setAffinity_with_xs_processor_affinity($pid,$mask)
138             || _setAffinity_with_pbind($pid,$mask)
139             || _setAffinity_with_xs_processor_bind($pid,$mask)
140             || _setAffinity_with_xs_pthread_self_setaffinity($pid,$mask)
141             || _setAffinity_with_bindprocessor($pid,$mask)
142             || _setAffinity_with_cpuset($pid,$mask)
143             || _setAffinity_with_xs_irix_sysmp($pid,$mask)
144             || 0;
145             }
146              
147             our $_NUM_CPUS_CACHED = 0;
148             sub getNumCpus {
149 22 100   22 1 1744 if ($_NUM_CPUS_CACHED) {
150 18         72 return $_NUM_CPUS_CACHED;
151             }
152 4   0     24 return $_NUM_CPUS_CACHED =
153             _getNumCpus_from_xs_Win32API_System_Info()
154             || _getNumCpus_from_xs_cpusetGetCPUCount()
155             || _getNumCpus_from_proc_cpuinfo()
156             || _getNumCpus_from_proc_stat()
157             || _getNumCpus_from_lsdev()
158             || _getNumCpus_from_bindprocessor()
159             || _getNumCpus_from_BSD_Process_Affinity()
160             || _getNumCpus_from_sysctl_freebsd()
161             || _getNumCpus_from_sysctl()
162             || _getNumCpus_from_dmesg_bsd()
163             || _getNumCpus_from_xs_solaris()
164             || _getNumCpus_from_dmesg_solaris()
165             || _getNumCpus_from_psrinfo()
166             || _getNumCpus_from_hinv()
167             || _getNumCpus_from_hwprefs()
168             || _getNumCpus_from_system_profiler()
169             || _getNumCpus_from_Win32API_System_Info()
170             || _getNumCpus_from_Test_Smoke_SysInfo()
171             || _getNumCpus_from_prtconf() # slower than bindprocessor, lsdev
172             || _getNumCpus_from_ENV()
173             || _getNumCpus_from_taskset()
174             || -1;
175             }
176              
177             ######################################################################
178              
179             # count processors toolbox
180              
181             sub _getNumCpus_from_ENV {
182             # in some OS, the number of processors is part of the default environment
183             # this also makes it easy to spoof the value (is that good or bad?)
184 1 50 33 1   36 if ($^O eq 'MSWin32' || $^O eq 'cygwin') {
185 0 0       0 if (defined $ENV{NUMBER_OF_PROCESSORS}) {
186 0         0 _debug("from Windows ENV: nproc=$ENV{NUMBER_OF_PROCESSORS}");
187 0         0 return $ENV{NUMBER_OF_PROCESSORS};
188             }
189             }
190 1         2 return 0;
191             }
192              
193             our %WIN32_SYSTEM_INFO = ();
194             our %WIN32API = ();
195              
196             sub __is_wow64 {
197             # determines whether this (Windows) program is running the WOW64 emulator
198             # (to let 32-bit apps run on 64-bit architecture)
199              
200             # used in _getNumCpus_from_Win32API_System_Info to decide whether to use
201             # GetSystemInfo or GetNativeSystemInfo in the Windows API.
202              
203 0 0 0 0   0 return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin';
204 0 0       0 return 0 if !_configModule('Win32::API');
205 0 0       0 return $Sys::CpuAffinity::IS_WOW64
206             if $Sys::CpuAffinity::IS_WOW64_INITIALIZED++;
207              
208 0         0 my $hmodule = _win32api('GetModuleHandle', 'kernel32');
209 0 0       0 return 0 if $hmodule == 0;
210              
211 0         0 my $proc = _win32api('GetProcAddress', $hmodule, 'IsWow64Process');
212 0 0       0 return 0 if $proc == 0;
213              
214 0         0 my $current = _win32api('GetCurrentProcess');
215 0 0       0 return 0 if $current == 0; # carp ...
216              
217 0         0 my $bool = 0;
218 0         0 my $result = _win32api('IsWow64Process', $current, $bool);
219 0 0       0 if ($result != 0) {
220 0         0 $Sys::CpuAffinity::IS_WOW64 = $bool;
221             }
222 0         0 $Sys::CpuAffinity::IS_WOW64_INITIALIZED++;
223 0         0 return $Sys::CpuAffinity::IS_WOW64;
224             }
225              
226             sub _getNumCpus_from_Win32API_System_Info {
227 1 50 33 1   111 return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin';
228 0 0       0 return 0 if !_configModule('Win32::API');
229              
230 0 0       0 if (0 == scalar keys %WIN32_SYSTEM_INFO) {
231 0 0       0 if (!defined $WIN32API{'GetSystemInfo'}) {
232 0         0 my $is_wow64 = __is_wow64();
233 0         0 my $lpsysinfo_type_avail
234             = Win32::API::Type::is_known('LPSYSTEM_INFO');
235              
236 0 0       0 my $proto = sprintf 'BOOL %s(%s i)',
    0          
237             $is_wow64 ? 'GetNativeSystemInfo' : 'GetSystemInfo',
238             $lpsysinfo_type_avail ? 'LPSYSTEM_INFO' : 'PCHAR';
239              
240 0         0 $WIN32API{'GetSystemInfo'} = Win32::API->new('kernel32', $proto);
241             }
242              
243             # does this part break on 64-bit machines? Don't think so.
244 0         0 my $buffer = chr(0) x 36;
245 0         0 $WIN32API{'GetSystemInfo'}->Call($buffer);
246             ($WIN32_SYSTEM_INFO{'PageSize'},
247             $WIN32_SYSTEM_INFO{'...'},
248             $WIN32_SYSTEM_INFO{'...'},
249             $WIN32_SYSTEM_INFO{'...'},
250             $WIN32_SYSTEM_INFO{'NumberOfProcessors'},
251             $WIN32_SYSTEM_INFO{'...'},
252             $WIN32_SYSTEM_INFO{'...'},
253             $WIN32_SYSTEM_INFO{'...'},
254 0         0 $WIN32_SYSTEM_INFO{'...'})
255             = unpack 'VVVVVVVvv', substr $buffer,4;
256             }
257 0   0     0 return $WIN32_SYSTEM_INFO{'NumberOfProcessors'} || 0;
258             }
259              
260              
261             sub _getNumCpus_from_xs_cpusetGetCPUCount { # NOT TESTED irix
262 5 50 33 5   86 if ($XS_LOADED && defined &xs_cpusetGetCPUCount) {
263 0         0 return xs_cpusetGetCPUCount();
264             } else {
265 5         30 return 0;
266             }
267             }
268              
269             sub _getNumCpus_from_xs_Win32API_System_Info {
270 5 50   5   59 if (defined &xs_get_numcpus_from_windows_system_info) {
    50          
271 0         0 return xs_get_numcpus_from_windows_system_info();
272             } elsif (defined &xs_get_numcpus_from_windows_system_info_alt) {
273 0         0 return xs_get_numcpus_from_windows_system_info_alt();
274             } else {
275 5         37 return 0;
276             }
277             }
278              
279             sub _getNumCpus_from_proc_cpuinfo {
280              
281             # I'm told this could give the wrong answer with a "non-SMP kernel"
282             # http://www-oss.fnal.gov/fss/hypermail/archives/hyp-linux/0746.html
283              
284 5 50   5   239 return 0 if ! -r '/proc/cpuinfo';
285              
286 5         21 my $num_processors = 0;
287 5         10 my $cpuinfo_fh;
288 5 50       275 if (open $cpuinfo_fh, '<', '/proc/cpuinfo') {
289 5         601 while (<$cpuinfo_fh>) {
290 2160 100       5403 if (/^processor\s/) {
291 80         259 $num_processors++;
292             }
293             }
294 5         74 close $cpuinfo_fh;
295             }
296 5         74 _debug("from /proc/cpuinfo: nproc=$num_processors");
297 5   50     88 return $num_processors || 0;
298             }
299              
300             sub _getNumCpus_from_proc_stat {
301              
302 1 50   1   93 return 0 if ! -r '/proc/stat';
303              
304 1         4 my $num_processors = 0;
305 1         2 my $stat_fh;
306 1 50       40 if (open $stat_fh, '<', '/proc/stat') {
307 1         77 while (<$stat_fh>) {
308 24 100       73 if (/^cpu\d/i) {
309 16         33 $num_processors++;
310             }
311             }
312 1         53 close $stat_fh;
313             }
314 1         14 _debug("from /proc/stat: nproc=$num_processors");
315 1   50     7 return $num_processors || 0;
316             }
317              
318             sub __set_aix_hints {
319 0     0   0 my ($bindprocessor) = @_;
320 0         0 our $AIX_HINTS = { READY => 0 };
321 0 0       0 if (!$bindprocessor) {
322 0         0 $bindprocessor = _configExternalProgram('bindprocessor');
323             }
324 0 0       0 return unless $bindprocessor;
325              
326 0         0 my $vp_output = qx('$bindprocessor' -q 2>/dev/null);
327 0 0       0 if ($vp_output !~ s/The available process\S+ are:\s*//) {
328 0         0 return;
329             }
330 0         0 my @vp = split /\s+/, $vp_output;
331 0         0 @vp = sort { $a <=> $b } @vp;
  0         0  
332 0         0 $AIX_HINTS->{VIRTUAL_PROCESSORS} = \@vp;
333 0         0 my %vp = map {; $_ => -1 } @vp;
  0         0  
334 0         0 my $proc_output = qx('$bindprocessor' -s 0 2>/dev/null);
335 0 0       0 if ($proc_output !~ s/The available process\S+ are:\s*//) {
336 0         0 $AIX_HINTS->{PROCESSORS} = $AIX_HINTS->{VIRTUAL_PROCESSORS};
337 0         0 $AIX_HINTS->{NUM_CORES} = @vp;
338 0         0 return;
339             }
340 0         0 my @procs = split /\s+/, $proc_output;
341 0         0 @procs = sort { $a <=> $b } @procs;
  0         0  
342 0         0 $AIX_HINTS->{PROCESSORS} = \@procs;
343 0         0 $AIX_HINTS->{NUM_CORES} = @procs;
344 0         0 $AIX_HINTS->{READY} = 1;
345 0 0       0 if (@procs == @vp) {
346 0         0 foreach my $proc (@procs) {
347 0         0 $AIX_HINTS->{PROC_MAP}{$_} = $_;
348             }
349             } else {
350 0         0 my $core = -1;
351 0         0 foreach my $proc (@procs) {
352 0         0 $core++;
353 0         0 my $bound_output = qx('$bindprocessor' -b $proc 2>/dev/null);
354 0 0       0 if ($bound_output =~ s/The available process\S+ are:\s*//) {
355 0         0 my @bound_proc = split /\s+/, $bound_output;
356 0         0 foreach my $bound_proc (@bound_proc) {
357 0         0 $AIX_HINTS->{PROC_MAP}{$bound_proc} = $core;
358             }
359             }
360             }
361             }
362             }
363              
364             sub _is_solarisMultiCpuBinding {
365 0     0   0 our $SOLARIS_HINTS;
366 0 0       0 return unless $^O =~ /solaris/i;
367 0 0 0     0 if (!$SOLARIS_HINTS || !$SOLARIS_HINTS->{multicpu}) {
368 0         0 local $?;
369 0         0 my ($maj,$min) = split /[.]/, qx(uname -v);
370 0 0 0     0 if ($? == 0 && ($maj > 11 || ($maj == 11 && $min >= 2))) {
    0 0        
371 0         0 $SOLARIS_HINTS->{multicpu} = 'yes';
372             } elsif (defined &xs_setaffinity_processor_affinity) {
373 0         0 $SOLARIS_HINTS->{multicpu} = 'yes';
374             } else {
375 0         0 $SOLARIS_HINTS->{multicpu} = 'no';
376             }
377             }
378 0         0 return $SOLARIS_HINTS->{multicpu} eq 'yes';
379             }
380              
381             sub _getNumCpus_from_bindprocessor {
382 1 50   1   3640 return 0 if $^O !~ /aix/i;
383 0 0       0 return 0 if !_configExternalProgram('bindprocessor');
384 0         0 my $cmd = _configExternalProgram('bindprocessor');
385 0         0 our $AIX_HINTS;
386 0 0       0 __set_aix_hints($cmd) unless $AIX_HINTS;
387 0   0     0 return $AIX_HINTS->{NUM_CORES} || 0;
388             #my $bindprocessor_output = qx($cmd -s 0 2>/dev/null); # or $cmd -q ?
389 0         0 my $bindprocessor_output = qx($cmd -q 2>/dev/null); # or $cmd -s 0 ?
390 0         0 $bindprocessor_output =~ s/\s+$//;
391 0 0       0 return 0 if !$bindprocessor_output;
392              
393             # Typical output: "The available processors are: 0 1 2 3"
394 0         0 $bindprocessor_output =~ s/.*:\s+//;
395 0         0 my @p = split /\s+/, $bindprocessor_output;
396 0         0 return 0+@p;
397             }
398              
399             sub _getNumCpus_from_lsdev {
400 1 50   1   61 return 0 if $^O !~ /aix/i;
401 0 0       0 return 0 if !_configExternalProgram('lsdev');
402 0         0 my $cmd = _configExternalProgram('lsdev');
403 0         0 my @lsdev_output = qx($cmd -Cc processor 2>/dev/null);
404 0         0 return 0+@lsdev_output;
405             }
406              
407             sub _getNumCpus_from_dmesg_bsd {
408 1 50   1   30 return 0 if $^O !~ /bsd/i;
409              
410 0         0 my @dmesg;
411 0 0 0     0 if (-r '/var/run/dmesg.boot' && open my $fh, '<', '/var/run/dmesg.boot') {
    0          
412 0         0 @dmesg = <$fh>;
413 0         0 close $fh;
414             } elsif (! _configExternalProgram('dmesg')) {
415 0         0 return 0;
416             } else {
417 0         0 my $cmd = _configExternalProgram('dmesg');
418 0         0 @dmesg = qx($cmd 2> /dev/null);
419             }
420             # on the version of FreeBSD that I have to play with
421             # (8.0), dmesg contains this message:
422             #
423             # FreeBSD/SMP: Multiprocessor System Detected: 2 CPUs
424             #
425             # so we'll go with that.
426             #
427             # on NetBSD, the message is:
428             #
429             # cpu3 at mainbus0 apid 3: AMD 686-class, 1975MHz, id 0x100f53
430              
431             # try FreeBSD format
432 0         0 my @d = grep { /Multiprocessor System Detected:/i } @dmesg;
  0         0  
433 0         0 my $ncpus;
434 0 0       0 if (@d > 0) {
435 0         0 _debug("dmesg_bsd contains:\n@d");
436 0         0 ($ncpus) = $d[0] =~ /Detected: (\d+) CPUs/i;
437             }
438              
439             # try NetBSD format. This will also probably work for OpenBSD.
440 0 0       0 if (!$ncpus) {
441             # 1.05 - account for duplicates in @dmesg
442 0         0 my %d = ();
443 0         0 @d = grep { /^cpu\d+ at / } @dmesg;
  0         0  
444 0         0 foreach my $dmesg (@d) {
445 0 0       0 if ($dmesg =~ /^cpu(\d+) at /) {
446 0         0 $d{$1}++;
447             }
448             }
449 0         0 _debug("dmesg_bsd[2] contains:\n",@d);
450 0         0 $ncpus = scalar keys %d;
451             }
452 0 0       0 if (@dmesg < 50) {
453 0         0 _debug("full dmesg log:\n", @dmesg);
454             }
455 0   0     0 return $ncpus || 0;
456             }
457              
458             sub _getNumCpus_from_xs_solaris {
459 1 50   1   51 return 0 if $^O !~ /solaris/i;
460 0 0       0 return 0 if !defined &xs_solaris_numCpus;
461 0         0 my $n = eval { xs_solaris_numCpus() };
  0         0  
462 0   0     0 return $n || 0;
463             }
464              
465             sub _getNumCpus_from_sysctl_freebsd {
466 1 50   1   139 return 0 unless defined &xs_num_cpus_freebsd;
467 0   0     0 return xs_num_cpus_freebsd() || 0;
468             }
469              
470             sub _getNumCpus_from_dmesg_solaris {
471 1 50   1   27 return 0 if $^O !~ /solaris/i;
472 0 0       0 return 0 if !_configExternalProgram('dmesg');
473 0         0 my $cmd = _configExternalProgram('dmesg');
474 0         0 my @dmesg = qx($cmd 2> /dev/null);
475              
476             # a few clues that I see on my system (opensolaris 5.11 i86pc):
477             # ... blah blah is bound to cpu
478             # ^cpu: x86 blah blah
479 0         0 my $ncpus = 0;
480 0         0 foreach my $dmesg (@dmesg) {
481 0 0       0 if ($dmesg =~ /is bound to cpu (\d+)/) {
482 0         0 my $n = $1;
483 0 0       0 if ($ncpus <= $n) {
484 0         0 $ncpus = $n + 1;
485             }
486             }
487 0 0       0 if ($dmesg =~ /^cpu(\d+):/) {
488 0         0 my $n = $1;
489 0 0       0 if ($ncpus <= $n) {
490 0         0 $ncpus = $n + 1;
491             }
492             }
493             }
494              
495             # this doesn't always work
496             # (www.cpantesters.org/cpan/report/35d7685a-70b0-11e0-9552-4df9775ebe45)
497             # what else should we check for in @dmesg ?
498 0 0       0 if ($ncpus == 0) {
499             # ...
500             }
501              
502 0         0 return $ncpus;
503             }
504              
505             sub _getNumCpus_from_sysctl {
506             # sysctl works on a number of systems including MacOS
507 1 50   1   136 return 0 if !_configExternalProgram('sysctl');
508 1         23 my $cmd = _configExternalProgram('sysctl');
509 1         44980 my @sysctl = qx($cmd -a 2> /dev/null);
510 1         52 my @results = grep { /^hw.(?:avail|n)cpu\s*[:=]/ } @sysctl;
  910         1593  
511 1         52 _debug("sysctl output:\n@results");
512 1 50       83 return 0 if @results == 0;
513 0         0 my ($ncpus) = $results[0] =~ /[:=]\s*(\d+)/;
514              
515 0 0       0 if ($ncpus == 0) {
516 0         0 my $result = qx($cmd -n hw.ncpu 2> /dev/null);
517 0         0 _debug("sysctl[2] result: $result");
518 0         0 $ncpus = 0 + $result;
519             }
520 0 0       0 if ($ncpus == 0) {
521 0         0 my $result = qx($cmd -n hw.ncpufound 2> /dev/null);
522 0         0 _debug("sysctl[3] result: $result");
523 0         0 $ncpus = 0 + $result;
524             }
525 0 0       0 if ($ncpus == 0) {
526 0         0 my $result = qx($cmd -n hw.availcpu 2> /dev/null);
527 0         0 _debug("sysctl[4] result: $result");
528 0         0 $ncpus = 0 + $result;
529             }
530              
531              
532 0   0     0 return $ncpus || 0;
533              
534             # there are also sysctl/sysctlbyname system calls
535             }
536              
537             sub _getNumCpus_from_psrinfo {
538 1 50   1   39 return 0 if !_configExternalProgram('psrinfo');
539 0         0 my $cmd = _configExternalProgram('psrinfo');
540 0         0 my @info = qx($cmd 2> /dev/null);
541             # return scalar grep /core/, qx($cmd -t 2>/dev/null);
542 0         0 return scalar @info;
543             }
544              
545             sub _getNumCpus_from_hinv { # NOT TESTED irix
546 1 50   1   30 return 0 if $^O =~ /irix/i;
547 1 50       4 return 0 if !_configExternalProgram('hinv');
548 0         0 my $cmd = _configExternalProgram('hinv');
549              
550             # test debug
551 0 0 0     0 if ($Sys::CpuAffinity::IS_TEST && !$Sys::CpuAffinity::HINV_CALLED++) {
552 0         0 print STDERR "$cmd output:\n";
553 0         0 print STDERR qx($cmd);
554 0         0 print STDERR "\n\n";
555 0         0 print STDERR "$cmd -c processor output:\n";
556 0         0 print STDERR qx($cmd -c processor);
557 0         0 print STDERR "\n\n";
558             }
559              
560             # found this in Test::Smoke::SysInfo v0.042 in Test-Smoke-1.43 module
561 0         0 my @processor = qx($cmd -c processor 2> /dev/null);
562 0         0 _debug('"hinv -c processor" output: ', @processor);
563 0         0 my ($cpu_cnt) = grep { /\d+.+processors?$/i } @processor;
  0         0  
564 0         0 my $ncpu = (split ' ', $cpu_cnt)[0];
565              
566 0 0       0 if ($ncpu == 0) {
567             # there might be output like:
568             # PU 30 at Module 001c35/Slot 0/Slice C: 400 Mhz MIPS R12000 Processor
569 0         0 $ncpu = grep { /^CPU / } @processor;
  0         0  
570             }
571              
572 0         0 return $ncpu;
573             }
574              
575             sub _getNumCpus_from_hwprefs {
576 1 50 33 1   158 return 0 if $^O !~ /darwin/i && $^O !~ /MacOS/i;
577 0 0       0 return 0 if !_configExternalProgram('hwprefs');
578 0         0 my $cmd = _configExternalProgram('hwprefs');
579 0         0 my $result = qx($cmd cpu_count 2> /dev/null);
580 0         0 $result =~ s/\s+$//;
581 0         0 _debug("\"$cmd cpu_count\" output: ", $result);
582 0   0     0 return $result || 0;
583             }
584              
585             sub _getNumCpus_from_system_profiler { # NOT TESTED darwin
586 1 50 33 1   100 return 0 if $^O !~ /darwin/ && $^O !~ /MacOS/i;
587 0 0       0 return 0 if !_configExternalProgram('system_profiler');
588              
589             # with help from Test::Smoke::SysInfo
590 0         0 my $cmd = _configExternalProgram('system_profiler');
591 0         0 my $system_profiler_output
592             = qx($cmd -detailLevel mini SPHardwardDataType 2> /dev/null);
593 0         0 my %system_profiler;
594 0         0 while ($system_profiler_output =~ m/^\s*([\w ]+):\s+(.+)$/gm) {
595 0         0 $system_profiler{uc $1} = $2;
596             }
597              
598 0         0 my $ncpus = $system_profiler{'NUMBER OF CPUS'};
599 0 0       0 if (!defined $ncpus) {
600 0         0 $ncpus = $system_profiler{'TOTAL NUMBER OF CORES'};
601             }
602 0         0 return $ncpus;
603             }
604              
605             sub _getNumCpus_from_prtconf {
606             # solaris has a prtconf command, but I don't think it outputs #cpus.
607 1 50   1   82 return 0 if $^O !~ /aix/i;
608 0 0       0 return 0 if !_configExternalProgram('prtconf');
609 0         0 my $cmd = _configExternalProgram('prtconf');
610              
611             # prtconf can take a long time to run, so cache the result
612 0         0 our $AIX_prtconf_cache;
613 0 0       0 if (!defined($AIX_prtconf_cache)) {
614 0         0 my @result = qx($cmd 2> /dev/null);
615 0         0 my ($result) = grep { /Number Of Processors:/ } @result;
  0         0  
616 0 0       0 return 0 if !$result;
617 0         0 my ($ncpus) = $result =~ /:\s+(\d+)/;
618 0   0     0 $AIX_prtconf_cache = $ncpus || 0;
619             }
620 0         0 return $AIX_prtconf_cache;
621             }
622              
623             sub _getNumCpus_from_Test_Smoke_SysInfo { # NOT TESTED
624 1 50   1   180 return 0 if !_configModule('Test::Smoke::SysInfo');
625 0         0 my $sysinfo = Test::Smoke::SysInfo->new();
626 0 0 0     0 if (defined $sysinfo && defined $sysinfo->{_ncpu}) {
627             # darwin: result might have format "1 [2 cores]", see
628             # www.cpantesters.org/cpan/report/db6067c4-9a66-11e0-91fb-39e97f60f2f7
629 0         0 $sysinfo->{_ncpu} =~ s/\d+ \[(\d+) cores\]/$1/;
630 0         0 return $sysinfo->{_ncpu};
631             }
632 0         0 return;
633             }
634              
635             sub _getNumCpus_from_taskset {
636 1 50   1   50 return 0 if $^O !~ /linux/i;
637 1         18 my $taskset = _configExternalProgram('taskset');
638 1 50       34 return 0 unless $taskset;
639              
640             # neither of these approaches are foolproof
641             # 1. read affinity mask of PID 1
642             # 2. try different affinity settings until it fails
643             #
644             # Will probably undercount if there are >64 cpus!
645              
646 1         4475 my $result = qx($taskset -p 1 2> /dev/null);
647 1         67 my ($mask) = $result =~ /:\s+(\w+)/;
648 1 50       35 if ($mask) {
649 1         37 my $n = 1+__hex($mask);
650 1         45 return int(0.5+log($n)/log(2));
651             }
652              
653 0         0 my $n = 0;
654 0   0     0 do {
655 0         0 my $cmd = sprintf '%s -p %x $$', $taskset, 1<<$n;
656 0         0 my $result = qx($cmd >/dev/null 2>/dev/null);
657 0         0 $n++;
658             } while ($?==0 && $n < 64);
659              
660 0 0       0 if ($n > 1) { # n==1 could be a false positive
661 0         0 return $n;
662             }
663              
664 0         0 $n = 0;
665 0         0 while ( do { qx($taskset -pc $n $$ >/dev/null 2>/dev/null); $?==0 } ) {
  0         0  
  0         0  
666 0         0 $n++;
667 0 0       0 last if $n >= 256;
668             }
669 0         0 return 0;
670             }
671              
672             ######################################################################
673              
674             # get affinity toolbox
675              
676             sub _getAffinity_with_Win32API {
677 7     7   147 my $opid = shift;
678 7 50 33     145 return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin';
679 0 0       0 return 0 if !_configModule('Win32::API');
680              
681 0         0 my $pid = $opid;
682 0 0       0 if ($^O eq 'cygwin') {
683 0         0 $pid = __pid_to_winpid($opid);
684             # return 0 if !defined $pid;
685             }
686 0 0       0 return 0 if !$pid;
687              
688 0 0       0 if ($pid > 0) {
689 0         0 return _getProcessAffinity_with_Win32API($pid);
690             } else { # $pid is a Windows pseudo-process (thread ID)
691 0         0 return _getThreadAffinity_with_Win32API(-$pid);
692             }
693             }
694              
695             sub _getProcessAffinity_with_Win32API {
696 0     0   0 my $pid = shift;
697 0         0 my ($processMask, $systemMask, $processHandle) = (' ' x 16, ' ' x 16);
698              
699             # 0x0400 - PROCESS_QUERY_INFORMATION,
700             # 0x1000 - PROCESS_QUERY_LIMITED_INFORMATION
701 0   0     0 $processHandle = _win32api('OpenProcess',0x0400,0,$pid)
702             || _win32api('OpenProcess',0x1000,0,$pid);
703 0 0       0 return 0 if ! $processHandle;
704 0 0       0 return 0 if ! _win32api('GetProcessAffinityMask', $processHandle,
705             $processMask, $systemMask);
706              
707 0         0 my $mask = _unpack_Win32_mask($processMask);
708 0         0 _debug("affinity with Win32::API: $mask");
709 0         0 return $mask;
710             }
711              
712             sub _getThreadAffinity_with_Win32API {
713 0     0   0 my $thrid = shift;
714 0         0 my ($processMask, $systemMask, $threadHandle) = (' 'x16, ' 'x16);
715              
716             # 0x0020: THREAD_QUERY_INFORMATION
717             # 0x0400: THREAD_QUERY_LIMITED_INFORMATION
718             # 0x0040: THREAD_SET_INFORMATION
719             # 0x0200: THREAD_SET_LIMITED_INFORMATION
720 0   0     0 $threadHandle = _win32api('OpenThread', 0x0060, 0, $thrid)
721             || _win32api('OpenThread', 0x0600, 0, $thrid)
722             || _win32api('OpenThread', 0x0020, 0, $thrid)
723             || _win32api('OpenThread', 0x0400, 0, $thrid);
724 0 0       0 if (! $threadHandle) {
725 0         0 return 0;
726             }
727              
728             # The Win32 API does not have a GetThreadAffinityMask function.
729             # SetThreadAffinityMask will return the previous affinity,
730             # but then you have to call it again to restore the original affinity.
731             # Also, SetThreadAffinityMask won't work if you don't have permission
732             # to change the affinity.
733              
734             # SetThreadAffinityMask argument has to be compatible with
735             # process affinity, so get process affinity.
736              
737             # XXX - this function only works for threads that are contained
738             # by the current process, and that should cover most use
739             # cases of this module. But how would you get the process
740             # id of an arbitrary Win32 thread?
741 0         0 my $cpid = _win32api('GetCurrentProcessId');
742              
743 0   0     0 my $processHandle
744             = _win32api('OpenProcess', 0x0400, 0, $cpid)
745             || _win32api('OpenProcess', 0x1000, 0, $cpid);
746              
747 0         0 local ($!,$^E) = (0,0);
748 0         0 my $result = _win32api('GetProcessAffinityMask',
749             $processHandle, $processMask, $systemMask);
750              
751 0 0       0 if ($result == 0) {
752 0         0 carp 'Could not determine process affinity ',
753             "(required to get thread affinity)\n";
754 0         0 return 0;
755             }
756              
757 0         0 $processMask = _unpack_Win32_mask($processMask);
758 0 0       0 if ($processMask == 0) {
759 0         0 carp 'Process affinity apparently set to zero, ',
760             "will not be able to set/get compatible thread affinity\n";
761 0         0 return 0;
762             }
763              
764 0         0 my $previous_affinity = _win32api('SetThreadAffinityMask',
765             $threadHandle, $processMask);
766              
767 0 0       0 if ($previous_affinity == 0) {
768 0         0 Carp::cluck "Win32::API::SetThreadAffinityMask: $! / $^E\n";
769 0         0 return 0;
770             }
771              
772             # hope we can restore it.
773 0 0       0 if ($previous_affinity != $processMask) {
774 0         0 local $! = 0;
775 0         0 local $^E = 0;
776 0         0 my $new_affinity = _win32api('SetThreadAffinityMask',
777             $threadHandle, $previous_affinity);
778 0 0       0 if ($new_affinity == 0) {
779              
780             # http://msdn.microsoft.com/en-us/library/ms686247(v=vs.85).aspx:
781             #
782             # "If the thread affinity mask requests a processor that is not
783             # selected for the process affinity mask, the last error code
784             # is ERROR_INVALID_PARAMETER." ($! => 87)
785             #
786             # In MSWin32, the result of a fork() is a "pseudo-process",
787             # a Win32 thread that is still contained by its parent.
788             # So on MSWin32 a race condition exists where the parent
789             # process can choose an incompatible set of affinities
790             # during the execution of this function (basically, between
791             # the two calls to SetThreadAffinityMask , above).
792              
793 0         0 carp "Sys::CpuAffinity::_getThreadAffinity_with_Win32API:\n",
794             "set thread $thrid affinity to $processMask ",
795             "in order to retrieve\naffinity, but was unable to ",
796             "restore previous value:\nHandle=$threadHandle, ",
797             "Prev=$previous_affinity, Error=$! / $^E\n";
798             }
799             }
800 0         0 return $previous_affinity;
801             }
802              
803             sub _unpack_Win32_mask {
804             # The Win32 GetProcessAffinityMask function takes
805             # "PDWORD" arguments. We pass (arbitrary) integers for these
806             # arguments, but on return they are changed to 1-4 bytes
807             # representing a packed integer.
808              
809 0     0   0 my $packed = shift;
810 0         0 return unpack "L", substr($packed . "\0\0\0\0", 0, 4);
811             }
812              
813              
814              
815             sub _getAffinity_with_Win32Process {
816 7     7   65 my $pid = shift;
817              
818 7 50 33     139 return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin';
819 0 0       0 return 0 if !_configModule('Win32::Process');
820 0 0       0 return 0 if $pid < 0; # pseudo-process / thread id
821              
822 0 0       0 if ($^O eq 'cygwin') {
823 0         0 $pid = __pid_to_winpid($pid);
824 0 0       0 return 0 if !defined $pid;
825             }
826              
827 0         0 my ($processMask, $systemMask, $result, $processHandle) = (' 'x16, ' 'x16);
828 0 0 0     0 if (! Win32::Process::Open($processHandle, $pid, 0)
829             || ref($processHandle) ne 'Win32::Process') {
830 0         0 return 0;
831             }
832 0 0       0 if (! $processHandle->GetProcessAffinityMask($processMask, $systemMask)) {
833 0         0 return 0;
834             }
835 0         0 _debug("affinity with Win32::Process: $processMask");
836 0         0 return $processMask;
837             }
838              
839             sub _getAffinity_with_taskset {
840 7     7   50 my $pid = shift;
841 7 50       32 return 0 if $^O ne 'linux';
842 7 50       29 return 0 if !_configExternalProgram('taskset');
843 7         56 my $taskset = _configExternalProgram('taskset');
844 7         31254 my $taskset_output = qx($taskset -p $pid 2> /dev/null);
845 7         217 $taskset_output =~ s/\s+$//;
846 7         331 _debug("taskset output: $taskset_output");
847 7 100       352 return 0 if ! $taskset_output;
848 1         16 my ($mask) = $taskset_output =~ /: (\S+)/;
849 1         19 _debug("affinity with taskset: $mask");
850 1         21 return __hex($mask);
851             }
852              
853             sub __hex {
854             # hex() method with better support for input > 0xffffffff
855 2     2   20 my $mask = shift;
856 2 50       18 if (length($mask) > 8) {
857 0         0 my $mask2 = substr($mask,-8);
858 0         0 my $mask1 = substr($mask,0,-8);
859 0         0 return hex($mask2) + (__hex($mask1) << 32);
860             } else {
861 2         34 return hex($mask);
862             }
863             }
864              
865             sub _getAffinity_with_xs_sched_getaffinity {
866 50     50   127 my $pid = shift;
867 50 50       205 return 0 if !defined &xs_sched_getaffinity_get_affinity;
868 50         171 my @mask;
869 50         3545 my $r = xs_sched_getaffinity_get_affinity($pid,\@mask,0);
870 50 100       220 if ($r) {
871 44         214 return _arrayToMask(@mask);
872             }
873 6         84 return;
874             }
875              
876             sub _getAffinity_with_xs_DEBUG_sched_getaffinity {
877             # to debug errors in xs_sched_getaffinity_get_affinity
878             # during t/11-exercise-all.t
879 0     0   0 my $pid = shift;
880 0 0       0 return 0 if !defined &xs_sched_getaffinity_get_affinity;
881 0         0 my @mask;
882 0         0 my $r = xs_sched_getaffinity_get_affinity($pid,\@mask,1);
883 0 0       0 if ($r) {
884 0         0 return _arrayToMask(@mask);
885             }
886 0         0 return;
887             }
888              
889             sub _getAffinity_with_pbind {
890 7     7   67 my ($pid) = @_;
891 7 50       111 return 0 if $^O !~ /solaris/i;
892 0 0       0 return 0 if !_configExternalProgram('pbind');
893 0         0 my $pbind = _configExternalProgram('pbind');
894 0         0 my $cmd = "$pbind -q $pid";
895 0         0 my $pbind_output = qx($cmd 2> /dev/null);
896 0 0 0     0 if ($pbind_output eq '' && $? == 0) {
897              
898             # pid is unbound or pid is invalid?
899 0 0       0 if (kill 'ZERO', $pid) {
900 0         0 $pbind_output = 'not bound';
901             } else {
902 0         0 warn "_getAffinity_with_pbind: could not signal unbound pid $pid";
903 0         0 return;
904             }
905             }
906              
907             # possible output:
908             # process id $pid: $index
909             # process id $pid: not bound
910             # pid \d+ \w+ bound to proccessor(s) \d+ \d+ \d+.
911              
912 0 0       0 if ($pbind_output =~ /not bound/) {
    0          
    0          
913 0         0 my $np = getNumCpus();
914 0 0       0 if ($np > 0) {
915 0         0 return (TWO ** $np) - 1;
916             } else {
917 0         0 carp '_getAffinity_with_pbind: ',
918             "process $pid unbound but can't count processors\n";
919 0         0 return TWO**32 - 1;
920             }
921             } elsif ($pbind_output =~ /: (\d+)/) {
922 0         0 my $bound_processor = $1;
923 0         0 return TWO ** $bound_processor;
924             } elsif ($pbind_output =~ / bound to proces\S+\s+(.+)\.$/) {
925 0         0 my $cpus = $1;
926 0 0       0 if (!defined($cpus)) {
927 0         0 return 0;
928             }
929 0         0 my @cpus = split /\s+/, $1;
930 0         0 return _arrayToMask(@cpus);
931             }
932 0         0 return 0;
933             }
934              
935             sub _getAffinity_with_psaix {
936 7     7   81 my ($pid) = @_;
937 7 50       107 return 0 if $^O !~ /aix/i;
938 0         0 my $pscmd = _configExternalProgram('ps');
939 0 0       0 return 0 if !$pscmd;
940 0         0 our $AIX_HINTS;
941 0 0       0 __set_aix_hints() unless $AIX_HINTS;
942              
943 0         0 my ($header,$data) = qx(ps -o THREAD -p $pid 2>/dev/null);
944 0 0       0 return 0 unless $data;
945 0         0 $header =~ s/^\s+//;
946 0         0 my @h = split /\s+/, $header;
947 0         0 my @d = split /\s+/, $data;
948 0         0 my ($ipid) = grep { $h[$_] eq 'PID' } 0 .. $#h;
  0         0  
949 0         0 my ($ibnd) = grep { $h[$_] eq 'BND' } 0 .. $#h;
  0         0  
950 0 0 0     0 if ($ipid ne '' && $ibnd) {
951 0         0 my $pidd = $d[$ipid];
952 0         0 my $bndd = $d[$ibnd];
953 0 0       0 if ($pidd == $pid) {
954 0         0 $bndd =~ s/^\s+//;
955 0         0 $bndd =~ s/\s+$//;
956 0 0       0 if ($bndd eq '-') { # not bound
957 0         0 return (TWO ** getNumCpus()) - 1;
958             }
959 0 0       0 if ($AIX_HINTS) {
960 0   0     0 $bndd = $AIX_HINTS->{PROC_MAP}{$bndd} || $bndd;
961             }
962 0         0 return TWO ** $bndd;
963             }
964             }
965 0         0 warn "ps\\aix: could not parse result:\n$header$data\n";
966 0         0 return 0;
967             }
968              
969             sub _getAffinity_with_xs_processor_affinity {
970 7     7   107 my ($pid) = @_;
971 7 50       108 return 0 if !defined &xs_getaffinity_processor_affinity;
972 0         0 my @mask = ();
973 0         0 my $ret = xs_getaffinity_processor_affinity($pid,\@mask);
974 0 0       0 if ($ret == 0) {
975 0         0 return 0;
976             }
977 0         0 _debug("affinity with getaffinity_xs_processor_affinity: @mask");
978 0         0 return _arrayToMask(@mask);
979             }
980              
981             sub _getAffinity_with_xs_processor_bind {
982 7     7   83 my ($pid) = @_;
983 7 50       97 return 0 if !defined &xs_getaffinity_processor_bind;
984 0 0       0 return 0 if $^O !~ /solaris/i;
985 0 0       0 return 0 if _is_solarisMultiCpuBinding();
986 0         0 my @mask = ();
987 0         0 my $ret = xs_getaffinity_processor_bind($pid,\@mask);
988 0 0       0 if ($ret == 0) {
989 0         0 return 0;
990             }
991 0         0 _debug("affinity with getaffinity_xs_processor_affinity: @mask");
992 0         0 return _arrayToMask(@mask);
993             }
994              
995             sub _getAffinity_with_BSD_Process_Affinity {
996 7     7   318 my ($pid) = @_;
997 7 50       181 return 0 if $^O !~ /bsd/i;
998 0 0       0 return 0 if !_configModule('BSD::Process::Affinity','0.04');
999              
1000 0         0 my $mask;
1001 0 0       0 if (! eval {
1002 0         0 my $affinity = BSD::Process::Affinity::get_process_mask($pid);
1003 0         0 $mask = $affinity->get;
1004 0         0 1 } ) {
1005             # $MODULE{'BSD::Process::Affinity'} = 0
1006 0         0 _debug("error in _setAffinity_with_BSD_Process_Affinity: $@");
1007 0         0 return 0;
1008             }
1009 0         0 return $mask;
1010             }
1011              
1012             sub _getAffinity_with_cpuset {
1013 7     7   57 my ($pid) = @_;
1014 7 50       112 return 0 if $^O !~ /bsd/i;
1015 0 0       0 return 0 if !_configExternalProgram('cpuset');
1016 0         0 my $cpuset = _configExternalProgram('cpuset');
1017 0         0 my $cmd = "$cpuset -g -p $pid";
1018 0         0 my $cpuset_output = qx($cmd 2> /dev/null);
1019              
1020             # output format:
1021             # pid nnnnn mask: i, j, k, ...
1022              
1023 0         0 $cpuset_output =~ s/.*:\s*//;
1024 0         0 my @cpus = split /\s*,\s*/, $cpuset_output;
1025 0 0       0 if (@cpus > 0) {
1026 0         0 return _arrayToMask(@cpus);
1027             }
1028 0         0 return 0;
1029             }
1030              
1031             sub _getAffinity_with_xs_freebsd_getaffinity {
1032 7     7   91 my $pid = shift;
1033 7 50       85 return 0 if !defined &xs_getaffinity_freebsd;
1034 0         0 my @mask = ();
1035 0         0 my $ret = xs_getaffinity_freebsd($pid,\@mask,0);
1036 0 0       0 if ($ret == 0) {
1037 0         0 return 0;
1038             }
1039 0         0 return _arrayToMask(@mask);
1040             }
1041              
1042             sub _getAffinity_with_xs_freebsd_getaffinity_debug {
1043 0     0   0 my $pid = shift;
1044 0 0       0 if (!defined &xs_getaffinity_freebsd) {
1045 0 0       0 if ($^O =~ /bsd/) {
1046 0         0 warn "\$^O=$^O, xs_getaffinity_freebsd not defined";
1047             }
1048 0         0 return;
1049             }
1050 0         0 my @mask = ();
1051 0         0 my $ret = xs_getaffinity_freebsd($pid,\@mask,1);
1052 0         0 warn "return value from xs_getaffinity_freebsd: $ret";
1053 0 0       0 if ($ret == 0) {
1054 0         0 return 0;
1055             }
1056 0         0 return _arrayToMask(@mask);
1057             }
1058              
1059             sub _getAffinity_with_xs_win32 {
1060 7     7   777 my ($opid) = @_;
1061 7         45 my $pid = $opid;
1062 7 50       28 if ($^O =~ /cygwin/) {
1063 0         0 $pid = __pid_to_winpid($opid);
1064 0 0       0 return 0 if !defined $pid;
1065             }
1066              
1067 7 100       119 if ($pid < 0) {
    100          
    50          
1068 2 50       72 return 0 if !defined &xs_win32_getAffinity_thread;
1069 0         0 return xs_win32_getAffinity_thread(-$pid);
1070             } elsif ($opid == $$) {
1071 1 50       8 if (defined &xs_win32_getAffinity_proc) {
    50          
1072 0         0 return xs_win32_getAffinity_proc($pid);
1073             } elsif (defined &xs_win32_getAffinity_thread) {
1074 0         0 return xs_win32_getAffinity_thread(0);
1075             } else {
1076             }
1077 1         12 return 0;
1078             } elsif (defined &xs_win32_getAffinity_proc) {
1079 0         0 return xs_win32_getAffinity_proc($pid);
1080             }
1081 4         58 return 0;
1082             }
1083              
1084             sub _getAffinity_with_xs_pthread_self_getaffinity {
1085              
1086             # new in 1.00, may only work when run as root
1087              
1088 7     7   51 my ($pid) = @_;
1089 7 50       129 return 0 if $^O !~ /bsd/;
1090              
1091             # this function can only be used on the calling process.
1092 0 0       0 return 0 if $pid != $$;
1093 0 0       0 return 0 if !defined &xs_pthread_self_getaffinity;
1094 0         0 my $z = xs_pthread_self_getaffinity(0);
1095 0 0       0 if ($z == 0) {
1096              
1097             # does $z==0 mean that the current thread is not bound (i.e.,
1098             # bound to all processors)? Or does it mean that the
1099             # pthread_getaffinity_np() call didn't do anything (but still
1100             # returned 0/success?)
1101             # Does pthread_getaffinity_np() always return 0 for normal users
1102             # and return non-zero for the super-user?
1103              
1104             # must use $_NUM_CPUS_CACHED || ... to pass test t/12#2
1105 0   0     0 my $np = $_NUM_CPUS_CACHED || getNumCpus();
1106 0         0 my $maxmask = TWO ** $np - 1;
1107              
1108 0         0 my $y = _setAffinity_with_xs_pthread_self_setaffinity($pid, $maxmask);
1109 0 0       0 if ($y) {
1110 0         0 return $maxmask;
1111             } else {
1112 0         0 return 0;
1113             }
1114             }
1115 0         0 return $z;
1116             }
1117              
1118             sub _getAffinity_with_xs_irix_sysmp {
1119              
1120             # new in 1.00, not tested
1121              
1122 7     7   61 my ($pid) = @_;
1123 7 50       80 return 0 if $^O !~ /irix/i;
1124 0 0       0 return 0 if !defined &xs_irix_sysmp_getaffinity;
1125 0         0 my $result = xs_irix_sysmp_getaffinity($pid);
1126 0 0       0 if ($result < -1) { # error
    0          
1127 0         0 return 0;
1128             } elsif ($result == -1) { # unrestricted
1129 0         0 my $np = getNumCpus();
1130 0         0 return TWO ** $np - 1;
1131             } else { # restricted to a single processor.
1132 0         0 return TWO ** $result;
1133             }
1134             }
1135              
1136             ######################################################################
1137              
1138             # set affinity toolbox
1139              
1140             sub _setAffinity_with_Win32API {
1141 16     16   283 my ($pid, $mask) = @_;
1142 16 50 33     303 return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin';
1143 0 0       0 return 0 if !_configModule('Win32::API');
1144              
1145             # if $^O is 'cygwin', make sure you are passing the Windows pid,
1146             # using Cygwin::pid_to_winpid if necessary!
1147              
1148 0 0       0 if ($^O eq 'cygwin') {
1149 0         0 $pid = __pid_to_winpid($pid);
1150 0 0       0 if ($DEBUG) {
1151 0         0 print STDERR "winpid is $pid ($_[0])\n";
1152             }
1153 0 0       0 return 0 if !defined $pid;
1154             }
1155              
1156 0 0       0 if ($pid > 0) {
1157 0         0 my $processHandle;
1158             # 0x0200 - PROCESS_SET_INFORMATION
1159 0         0 $processHandle = _win32api('OpenProcess', 0x0200,0,$pid);
1160 0 0       0 if ($DEBUG) {
1161 0         0 print STDERR "process handle: $processHandle\n";
1162             }
1163 0 0       0 return 0 if ! $processHandle;
1164 0         0 my $result = _win32api('SetProcessAffinityMask', $processHandle, $mask);
1165 0         0 _debug("set affinity with Win32::API: $result");
1166 0         0 return $result;
1167             } else {
1168             # negative pid indicates Windows "pseudo-process", which should
1169             # use the Thread functions.
1170             # Thread access rights definitions:
1171             # 0x0020: THREAD_QUERY_INFORMATION
1172             # 0x0400: THREAD_QUERY_LIMITED_INFORMATION
1173             # 0x0040: THREAD_SET_INFORMATION
1174             # 0x0200: THREAD_SET_LIMITED_INFORMATION
1175 0         0 my $threadHandle;
1176 0         0 local $! = undef;
1177 0         0 local $^E = 0;
1178 0   0     0 $threadHandle = _win32api('OpenThread', 0x0060, 0, -$pid)
1179             || _win32api('OpenThread', 0x0600, 0, -$pid)
1180             || _win32api('OpenThread', 0x0040, 0, -$pid)
1181             || _win32api('OpenThread', 0x0200, 0, -$pid);
1182 0 0       0 return 0 if ! $threadHandle;
1183 0         0 my $previous_affinity = _win32api('SetThreadAffinityMask',
1184             $threadHandle, $mask);
1185 0 0       0 if ($previous_affinity == 0) {
1186 0         0 carp 'Sys::CpuAffinity::_setAffinity_with_Win32API: ',
1187             "SetThreadAffinityMask call failed: $! / $^E\n";
1188             }
1189 0         0 return $previous_affinity;
1190             }
1191             }
1192              
1193             sub _setAffinity_with_Win32Process {
1194 16     16   255 my ($pid, $mask) = @_;
1195 16 50       167 return 0 if $^O ne 'MSWin32'; # cygwin? can't get it to work reliably
1196 0 0       0 return 0 if !_configModule('Win32::Process');
1197              
1198 0 0       0 if ($^O eq 'cygwin') {
1199 0         0 $pid = __pid_to_winpid($pid);
1200              
1201 0 0       0 if ($DEBUG) {
1202 0         0 print STDERR "cygwin pid $_[0] => winpid $pid\n";
1203             }
1204 0 0       0 return 0 if !defined $pid;
1205             }
1206              
1207 0         0 my $processHandle;
1208 0 0 0     0 if (! Win32::Process::Open($processHandle, $pid, 0)
1209             || ref($processHandle) ne 'Win32::Process') {
1210 0         0 return 0;
1211             }
1212              
1213             # Seg fault on Cygwin? We really prefer not to use it on Cygwin.
1214 0         0 local $SIG{SEGV} = 'IGNORE';
1215              
1216             # SetProcessAffinityMask: "only available on Windows NT"
1217 6     6   78 use Config;
  6         12  
  6         20465  
1218 0         0 my $v = $Config{osvers};
1219 0 0 0     0 if ($^O eq 'MSWin32' && ($v < 3.51 || $v >= 6.0)) {
      0        
1220 0 0       0 if ($DEBUG) {
1221 0         0 print STDERR 'SetProcessAffinityMask ',
1222             "not available on MSWin32 osvers $v?\n";
1223             }
1224 0         0 return 0;
1225             }
1226             # Don't trust Strawberry Perl $Config{osvers}. Win32::GetOSVersion
1227             # is more reliable if it is available.
1228 0 0       0 if (_configModule('Win32')) {
1229 0 0       0 if (!Win32::IsWinNT()) {
1230 0 0       0 if ($DEBUG) {
1231 0         0 print STDERR 'SetProcessorAffinityMask ',
1232             "not available on MSWin32 OS Version $v\n";
1233             }
1234 0         0 return 0;
1235             }
1236             }
1237              
1238 0         0 my $result = $processHandle->SetProcessAffinityMask($mask);
1239 0         0 _debug("set affinity with Win32::Process: $result");
1240 0         0 return $result;
1241             }
1242              
1243             sub _setAffinity_with_taskset {
1244 5     5   230 my ($pid, $mask) = @_;
1245 5 50 33     224 return 0 if $^O ne 'linux' || !_configExternalProgram('taskset');
1246 5         19 my $cmd = sprintf '%s -p %x %d 2>&1',
1247             _configExternalProgram('taskset'), $mask, $pid;
1248              
1249 5         20819 my $taskset_output = qx($cmd 2> /dev/null);
1250 5         320 my $taskset_status = $?;
1251              
1252 5 100       115 if ($taskset_status) {
1253 4         190 _debug("taskset output: $taskset_output");
1254             }
1255              
1256 5         228 return $taskset_status == 0;
1257             }
1258              
1259             sub _setAffinity_with_xs_sched_setaffinity {
1260 16     16   245 my ($pid,$mask,$debug) = @_;
1261 16 50       50 return 0 if !defined &xs_sched_setaffinity_set_affinity;
1262 16         55 my @mask = _maskToArray($mask);
1263 16         1348 return xs_sched_setaffinity_set_affinity($pid,\@mask,0+!!$debug);
1264             }
1265              
1266             sub _setAffinity_with_BSD_Process_Affinity {
1267 5     5   265 my ($pid,$mask) = @_;
1268 5 50       163 return 0 if $^O !~ /bsd/i;
1269 0 0       0 return 0 if !_configModule('BSD::Process::Affinity','0.04');
1270              
1271 0 0       0 if (not eval {
1272 0         0 my $affinity = BSD::Process::Affinity::get_process_mask($pid);
1273 0         0 $affinity->set($mask)->update;
1274 0         0 1}) {
1275 0         0 _debug("error in _setAffinity_with_BSD_Process_Affinity: $@");
1276 0         0 return 0;
1277             }
1278             }
1279              
1280             sub _getNumCpus_from_BSD_Process_Affinity {
1281 1 50   1   35 return 0 if $^O !~ /bsd/i;
1282 0 0       0 return 0 if !_configModule('BSD::Process::Affinity','0.04');
1283 0         0 my $n = BSD::Process::Affinity::current_set()->get;
1284 0         0 $n = log( $n+1.01 ) / log(2);
1285 0         0 return int($n);
1286             }
1287              
1288             sub _setAffinity_with_bindprocessor {
1289 5     5   267 my ($pid,$mask) = @_;
1290 5 50       71 return 0 if $^O !~ /aix/i;
1291 0 0       0 return 0 if $pid < 0;
1292 0 0       0 return 0 if !_configExternalProgram('bindprocessor');
1293 0         0 my $cmd = _configExternalProgram('bindprocessor');
1294 0         0 our $AIX_HINTS;
1295 0 0       0 __set_aix_hints($cmd) unless $AIX_HINTS;
1296              
1297 0         0 my @mask = _maskToArray($mask);
1298 0         0 my @cores = map { $AIX_HINTS->{PROCESSORS}[$_] } @mask;
  0         0  
1299 0 0       0 if (@cores == $AIX_HINTS->{NUM_CORES}) {
    0          
1300 0         0 return system("'$cmd' -u $pid") == 0;
1301             } elsif (@cores > 1) {
1302 0         0 warn "_setAffinity_with_bindprocessor: will only set one core on aix";
1303             }
1304 0         0 return system("'$cmd' $pid $cores[0]") == 0;
1305             }
1306              
1307             sub _setAffinity_with_pbind {
1308 5     5   558 my ($pid,$mask) = @_;
1309 5 50       85 return 0 if $^O !~ /solaris/i;
1310 0 0       0 return 0 if !_configExternalProgram('pbind');
1311 0         0 my $pbind = _configExternalProgram('pbind');
1312 0         0 my @mask = _maskToArray($mask);
1313              
1314 0         0 my $cpus = join ",", @mask;
1315 0         0 my $np = getNumCpus();
1316 0         0 my $c1;
1317 0 0       0 if (@mask == $np) {
1318             # unbind
1319 0         0 $c1 = system("'$pbind' -u $pid > /dev/null 2>&1");
1320             } else {
1321 0         0 $c1 = system("'$pbind' -b -c $cpus -s $pid > /dev/null 2>&1");
1322             }
1323 0         0 return !$c1;
1324             }
1325              
1326             sub _setAffinity_with_xs_processor_affinity {
1327 5     5   232 my ($pid,$mask) = @_;
1328 5 50       67 return 0 if $^O !~ /solaris/i;
1329 0 0       0 return 0 if !defined &xs_setaffinity_processor_affinity;
1330 0         0 my @mask = _maskToArray($mask);
1331 0         0 my $ret = xs_setaffinity_processor_affinity($pid, \@mask);
1332 0 0       0 if ($ret == 0) {
1333 0         0 return 0;
1334             }
1335 0         0 return 1;
1336             }
1337              
1338             sub _setAffinity_with_xs_processor_bind {
1339 5     5   232 my ($pid,$mask) = @_;
1340 5 50       84 return 0 if $^O !~ /solaris/i;
1341 0 0       0 return 0 if !defined &xs_setaffinity_processor_bind;
1342 0 0       0 return 0 if _is_solarisMultiCpuBinding();
1343 0         0 my @mask = _maskToArray($mask);
1344 0         0 my $ret = xs_setaffinity_processor_bind($pid, \@mask);
1345 0 0       0 if ($ret == 0) {
1346 0         0 return 0;
1347             }
1348 0         0 return 1;
1349             }
1350              
1351             sub _setAffinity_with_cpuset {
1352 5     5   227 my ($pid, $mask) = @_;
1353 5 50       39 return 0 if $^O !~ /bsd/i;
1354 0 0       0 return 0 if !_configExternalProgram('cpuset');
1355              
1356 0         0 my $lmask = join ',' => _maskToArray($mask);
1357 0         0 my $cmd = _configExternalProgram('cpuset') . " -l $lmask -p $pid";
1358 0         0 my $c1 = system "$cmd 2> /dev/null";
1359 0         0 return !$c1;
1360             }
1361              
1362             sub _setAffinity_with_xs_freebsd_setaffinity {
1363 5     5   233 my ($pid,$mask) = @_;
1364 5 50       86 return 0 if !defined &xs_setaffinity_freebsd;
1365 0         0 my @mask = _maskToArray($mask);
1366 0         0 return xs_setaffinity_freebsd($pid,\@mask);
1367             }
1368              
1369             sub _setAffinity_with_xs_win32 {
1370 16     16   257 my ($opid, $mask) = @_;
1371              
1372 16         33 my $pid = $opid;
1373 16 50       60 if ($^O =~ /cygwin/) {
1374 0         0 $pid = __pid_to_winpid($opid);
1375 0 0       0 return 0 if !defined $pid;
1376             }
1377              
1378 16 100       98 if ($pid < 0) {
    100          
    50          
1379 2 50       50 if (defined &xs_win32_setAffinity_thread) {
1380 0         0 my $r = xs_win32_setAffinity_thread(-$pid,$mask);
1381 0         0 _debug("xs_win32_setAffinity_thread -$pid,$mask => $r");
1382 0 0       0 return $r if $r;
1383             }
1384 2         46 return 0;
1385             } elsif ($opid == $$) {
1386 12 50       41 if (defined &xs_win32_setAffinity_proc) {
1387 0         0 _debug('xs_win32_setAffinity_proc $$');
1388 0         0 return xs_win32_setAffinity_proc($pid,$mask);
1389             }
1390 12 50 33     46 if ($^O eq 'cygwin' && defined &xs_win32_setAffinity_thread) {
1391 0         0 my $r = xs_win32_setAffinity_thread(0, $mask);
1392 0 0       0 return $r if $r;
1393             }
1394 12         92 return 0;
1395             } elsif (defined &xs_win32_setAffinity_proc) {
1396 0         0 my $r = xs_win32_setAffinity_proc($pid, $mask);
1397 0         0 _debug("xs_win32_setAffinity_proc +$pid,$mask => $r");
1398 0         0 return $r;
1399             }
1400 2         38 return 0;
1401             }
1402              
1403             sub _setAffinity_with_xs_pthread_self_setaffinity {
1404              
1405             # new in 1.00, may only work when run as root
1406              
1407 5     5   214 my ($pid, $mask) = @_;
1408 5 50       74 return 0 if $^O !~ /bsd/i;
1409              
1410             # this function only works with the calling process
1411 0 0       0 return 0 if $$ != $pid;
1412 0 0       0 return 0 if !defined &xs_pthread_self_setaffinity;
1413 0         0 return &xs_pthread_self_setaffinity($mask);
1414             }
1415              
1416             sub _setAffinity_with_xs_irix_sysmp {
1417              
1418             # new in 1.00, not tested
1419              
1420 5     5   232 my ($pid, $mask) = @_;
1421              
1422 5 50       188 return 0 if $^O !~ /irix/i;
1423 0 0       0 return 0 if !defined &xs_irix_sysmp_setaffinity;
1424              
1425             # Like the pbind function in solaris, Irix's sysmp function can only
1426             # * bind a process to a single specific CPU, or
1427             # * bind a process to all CPUs
1428              
1429 0         0 my @mask = _maskToArray($mask);
1430              
1431 0         0 my $np = getNumCpus();
1432 0         0 my $c1;
1433 0 0 0     0 if ($np > 0 && $mask + 1 == TWO ** $np) {
1434 0         0 return xs_irix_sysmp_setaffinity($pid, -1);
1435             } else {
1436 0         0 my $element = 0;
1437 0         0 return xs_irix_sysmp_setaffinity($pid, $mask[$element]);
1438             }
1439             }
1440              
1441             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1442              
1443             sub _maskToArray {
1444 16     16   47 my ($mask) = @_;
1445 16         36 my @mask = ();
1446 16         35 my $i = 0;
1447 16         58 while ($mask > 0) {
1448 215 100       64374 if ($mask & 1) {
1449 148         34975 push @mask, $i;
1450             }
1451 215         16399 $i++;
1452 215         511 $mask >>= 1;
1453             }
1454 16         4451 return @mask;
1455             }
1456              
1457             sub _arrayToMask {
1458 44     44   122 my @procs = @_;
1459 44         292 my $mask = Math::BigInt->new(0);
1460 44         6113 for my $proc (@procs) {
1461 440         147369 $mask |= TWO ** $proc;
1462             }
1463 44         18378 return $mask;
1464             }
1465              
1466             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1467              
1468             sub __pid_to_winpid {
1469 0     0   0 my ($cygwinpid) = @_;
1470 0 0 0     0 if ($] >= 5.008 && defined &Cygwin::pid_to_winpid) {
1471 0         0 return Cygwin::pid_to_winpid($cygwinpid);
1472             } else {
1473 0         0 return __poor_mans_pid_to_winpid($cygwinpid);
1474             }
1475             }
1476              
1477             sub __poor_mans_pid_to_winpid {
1478 0     0   0 my ($cygwinpid) = @_;
1479 0         0 my @psw = qx(/usr/bin/ps -W 2> /dev/null);
1480 0         0 foreach my $psw (@psw) {
1481 0         0 $psw =~ s/^[A-Z\s]+//;
1482 0         0 my ($pid,$ppid,$pgid,$winpid) = split /\s+/, $psw;
1483 0 0       0 next if ! $pid;
1484 0 0       0 if ($pid == $cygwinpid) {
1485 0         0 return $winpid;
1486             }
1487             }
1488 0         0 warn "Could not resolve cygwin pid $cygwinpid into winpid.\n";
1489 0         0 return $cygwinpid;
1490             }
1491              
1492             ######################################################################
1493              
1494             # configuration code
1495              
1496             sub _debug {
1497 31     31   222 my @msg = @_;
1498 31 50       157 return if !$DEBUG;
1499 0         0 print STDERR 'Sys::CpuAffinity: ',@msg,"\n";
1500 0         0 return;
1501             }
1502              
1503             our %MODULE = ();
1504             our %PROGRAM = ();
1505             our %INLINE_CODE = ();
1506              
1507             sub _configModule {
1508 5     5   1377 my $module = shift;
1509 5   50     42 my $version = shift || "";
1510 5 50       35 return $MODULE{$module} if defined $MODULE{$module};
1511              
1512 5 100       508 if (eval "require $module") { ## no critic (StringyEval)
1513 1         40 my $v = eval "\$$module" . "::VERSION";
1514 1 50 33     11 if (!$@ && (!$version || $version <= $v)) {
      33        
1515 1         5 _debug("module $module is available.");
1516 1         5 return $MODULE{$module} = 1;
1517             } else {
1518 0         0 _debug("module $module $version not available ($v)");
1519 0         0 return $MODULE{$module} = 0;
1520             }
1521             } else {
1522 4         37 _debug("module $module $version not available: $@");
1523 4         39 return $MODULE{$module} = 0;
1524             }
1525             }
1526              
1527             our @PATH = ();
1528              
1529             sub _configExternalProgram {
1530 41     41   1133 my $program = shift;
1531 41 100       239 return $PROGRAM{$program} if defined $PROGRAM{$program};
1532 18 50       383 if (-x $program) {
1533 0         0 _debug("Program $program is available in $program");
1534 0         0 return $PROGRAM{$program} = $program;
1535             }
1536              
1537 18 50       250 if ($^O ne 'MSWin32') {
1538 18         90750 my $which = qx(which $program 2> /dev/null);
1539 18         633 $which =~ s/\s+$//;
1540              
1541 18 100 33     1999 if ($which =~ / not in / # negative output on irix
      33        
      66        
1542             || $which =~ /no \Q$program\E in / # negative output on solaris
1543             || $which =~ /Command not found/ # negative output on openbsd
1544             || ! -x $which # not executable, may be junk
1545             ) {
1546              
1547 11         51 $which = '';
1548             }
1549 18 100       179 if ($which) {
1550 7         264 _debug("Program $program is available in $which");
1551 7         263 return $PROGRAM{$program} = $which;
1552             }
1553             }
1554              
1555             # poor man's which
1556 11 100       60 if (@PATH == 0) {
1557 2         59 @PATH = split /:/, $ENV{PATH};
1558 2         36 push @PATH, split /;/, $ENV{PATH};
1559 2         30 push @PATH, '.';
1560 2         21 push @PATH, '/sbin', '/usr/sbin';
1561             }
1562 11         98 foreach my $dir (@PATH) {
1563 143 50       1432 if (-x "$dir/$program") {
1564 0         0 _debug("Program $program is available in $dir/$program");
1565 0         0 return $PROGRAM{$program} = "$dir/$program";
1566             }
1567             }
1568 11         562 return $PROGRAM{$program} = 0;
1569             }
1570              
1571             ######################################################################
1572              
1573             # some Win32::API specific code
1574              
1575             our %WIN32_API_SPECS
1576             = ('GetActiveProcessorCount' => [ 'kernel32',
1577             'DWORD GetActiveProcessorCount(WORD g)' ],
1578             'GetCurrentProcess' => [ 'kernel32',
1579             'HANDLE GetCurrentProcess()' ],
1580             'GetCurrentProcessId' => [ 'kernel32',
1581             'DWORD GetCurrentProcessId()' ],
1582             'GetCurrentThread' => [ 'kernel32',
1583             'HANDLE GetCurrentThread()' ],
1584             'GetCurrentThreadId' => [ 'kernel32',
1585             'int GetCurrentThreadId()' ],
1586             'GetLastError' => [ 'kernel32', 'DWORD GetLastError()' ],
1587             'GetModuleHandle' => [ 'kernel32', 'HMODULE GetModuleHandle(LPCTSTR n)' ],
1588             'GetPriorityClass' => [ 'kernel32',
1589             'DWORD GetPriorityClass(HANDLE h)' ],
1590             'GetProcAddress' => [ 'kernel32',
1591             'DWORD GetProcAddress(HINSTANCE a,LPCTSTR b)' ],
1592             # 'DWORD GetProcAddress(HINSTANCE a,LPCWSTR b)' ],
1593             'GetProcessAffinityMask' => [ 'kernel32',
1594             'BOOL GetProcessAffinityMask(HANDLE h,PDWORD a,PDWORD b)' ],
1595             'GetThreadPriority' => [ 'kernel32',
1596             'int GetThreadPriority(HANDLE h)' ],
1597             'IsWow64Process' => [ 'kernel32', 'BOOL IsWow64Process(HANDLE h,PBOOL b)' ],
1598             'OpenProcess' => [ 'kernel32',
1599             'HANDLE OpenProcess(DWORD a,BOOL b,DWORD c)' ],
1600             'OpenThread' => [ 'kernel32',
1601             'HANDLE OpenThread(DWORD a,BOOL b,DWORD c)' ],
1602             'SetProcessAffinityMask' => [ 'kernel32',
1603             'BOOL SetProcessAffinityMask(HANDLE h,DWORD m)' ],
1604             'SetThreadAffinityMask' => [ 'kernel32',
1605             'DWORD SetThreadAffinityMask(HANDLE h,DWORD d)' ],
1606             'SetThreadPriority' => [ 'kernel32',
1607             'BOOL SetThreadPriority(HANDLE h,int n)' ],
1608             'TerminateThread' => [ 'kernel32',
1609             'BOOL TerminateThread(HANDLE h,DWORD x)' ],
1610             );
1611             our %WIN32_API_SPECS_
1612             = map { $_ => $WIN32_API_SPECS{$_}[1] } keys %WIN32_API_SPECS;
1613              
1614             sub _win32api { ## no critic (RequireArgUnpacking)
1615             ## (we want spooky action-at-a-distance)
1616 0     0     my $function = shift;
1617 0 0         return if !_configModule('Win32::API');
1618 0 0         if (!defined $WIN32API{$function}) {
1619 0           __load_win32api_function($function);
1620             }
1621 0 0 0       return if !defined($WIN32API{$function}) || $WIN32API{$function} == 0;
1622              
1623 0           return $WIN32API{$function}->Call(@_);
1624             }
1625              
1626             sub __load_win32api_function {
1627 0     0     my $function = shift;
1628 0           my $spec = $WIN32_API_SPECS{$function};
1629 0 0         if (!defined $spec) {
1630 0           croak "Sys::CpuAffinity: bad Win32::API function request: $function\n";
1631             }
1632              
1633 0           local ($!, $^E) = (0, 0);
1634              
1635 0           my $spec_ = $WIN32_API_SPECS_{$function};
1636 0           $WIN32API{$function} = Win32::API->new('kernel32',$spec_);
1637              
1638 0 0         if ($!) {
1639 0           carp 'Sys::CpuAffinity: ',
1640             "error initializing Win32::API function $function: $! / $^E\n";
1641 0           $WIN32API{$function} = 0;
1642             }
1643 0           return;
1644             }
1645              
1646             ######################################################################
1647              
1648             1; # End of Sys::CpuAffinity
1649              
1650             __END__