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__ |