File Coverage

lib/OpenMP/Environment.pm
Criterion Covered Total %
statement 179 210 85.2
branch 15 22 68.1
condition 3 3 100.0
subroutine 55 61 90.1
pod 48 48 100.0
total 300 344 87.2


line stmt bran cond sub pod time code
1             package OpenMP::Environment;
2 2     2   1906 use strict;
  2         5  
  2         72  
3 2     2   11 use warnings;
  2         4  
  2         58  
4              
5 2     2   1075 use Validate::Tiny qw/filter is_in/;
  2         36411  
  2         6195  
6              
7             our $VERSION = q{1.1.2};
8              
9             our @_OMP_VARS = (
10             qw/OMP_CANCELLATION OMP_DISPLAY_ENV OMP_DEFAULT_DEVICE
11             OMP_DYNAMIC OMP_MAX_ACTIVE_LEVELS OMP_MAX_TASK_PRIORITY OMP_NESTED
12             OMP_NUM_THREADS OMP_PROC_BIND OMP_PLACES OMP_STACKSIZE OMP_SCHEDULE
13             OMP_TARGET_OFFLOAD OMP_THREAD_LIMIT OMP_WAIT_POLICY GOMP_CPU_AFFINITY
14             GOMP_DEBUG GOMP_STACKSIZE GOMP_SPINCOUNT GOMP_RTEMS_THREAD_POOLS/
15             );
16              
17             # capture state of %ENV
18             local %ENV = %ENV;
19              
20             # constructor
21             sub new {
22 2     2 1 1022 my $pkg = shift;
23              
24             my $validate_rules = {
25             fields => \@_OMP_VARS,
26             filters => [
27             [qw/OMP_CANCELLATION OMP_DYNAMIC OMP_NESTED OMP_DISPLAY_ENV OMP_TARGET_OFFLOAD OMP_WAIT_POLICY/] => filter('uc'), # force to upper case for convenience
28             ],
29             checks => [
30             [qw/OMP_CANCELLATION OMP_DYNAMIC OMP_NESTED/] => is_in( [qw/TRUE FALSE/], q{Expected values are: 'TRUE' or 'FALSE'} ),
31             OMP_DISPLAY_ENV => is_in( [qw/TRUE VERBOSE FALSE/], q{Expected values are: 'TRUE', 'VERBOSE', or 'FALSE'} ),
32             OMP_TARGET_OFFLOAD => is_in( [qw/MANDATORY DISABLED DEFAULT/], q{Expected values are: 'MANDATORY', 'DISABLED', or 'DEFAULT'} ),
33             OMP_WAIT_POLICY => is_in( [qw/ACTIVE PASSIVE/], q{Expected values are: 'ACTIVE' or 'PASSIVE'} ),
34             GOMP_DEBUG => is_in( [qw/0 1/], q{Expected values are: 0 or 1} ),
35 522     522   135158 [qw/OMP_MAX_TASK_PRIORITY OMP_DEFAULT_DEVICE/] => sub { return _is_ge_if_set( 0, @_ ) },
36 783     783   189506 [qw/OMP_NUM_THREADS OMP_MAX_ACTIVE_LEVELS OMP_THREAD_LIMIT/] => sub { return _is_ge_if_set( 1, @_ ) },
37              
38             #-- the following are not current validated due to the complexity of the rules associated with their values
39 2         10 OMP_PROC_BIND => _no_validate(),
40             OMP_PLACES => _no_validate(),
41             OMP_STACKSIZE => _no_validate(),
42             OMP_SCHEDULE => _no_validate(),
43             GOMP_CPU_AFFINITY => _no_validate(),
44             GOMP_STACKSIZE => _no_validate(),
45             GOMP_SPINCOUNT => _no_validate(),
46             GOMP_RTEMS_THREAD_POOLS => _no_validate(),
47             ],
48             };
49              
50             sub _is_ge_if_set {
51 1305     1305   2210 my ( $min, $value ) = @_;
52 1305 100 100     2920 if ( not defined $value ) {
    100          
53 1162         2246 return;
54             }
55             elsif ( $value =~ m/\D/ or $value lt $min ) {
56 23         59 return q{Value must be an integer great than or equal to 1};
57             }
58 120         260 return;
59             }
60              
61 2         8 my $self = { _validation_rules => $validate_rules, };
62 2         9 return bless $self, $pkg;
63             }
64              
65             # returns a list of variables supported (no values)
66             sub vars {
67 2     2 1 3 my $self = shift;
68 2         10 return @_OMP_VARS;
69             }
70              
71             # returns a list of variables unset (value not set so don't need it)
72             sub vars_unset {
73 0     0 1 0 my $self = shift;
74 0         0 my @unset = ();
75 0         0 foreach my $ev (@_OMP_VARS) {
76 0 0       0 push @unset, $ev if not $ENV{$ev};
77             }
78 0         0 return @unset;
79             }
80              
81             # returns a list of all variables that are currently set, and their values
82             # as an array of hash references of the form, "$VAR_NAME => $value"
83             sub vars_set {
84 14     14 1 19 my $self = shift;
85 14         19 my @set = ();
86 14         29 foreach my $ev (@_OMP_VARS) {
87 280 100       734 push @set, { $ev => $ENV{$ev} } if $ENV{$ev};
88             }
89 14         41 return @set;
90             }
91              
92             sub print_omp_summary_unset {
93 0     0 1 0 my $self = shift;
94 0         0 return print $self->_omp_summary_unset;
95             }
96              
97             sub _omp_summary_unset {
98 0     0   0 my $self = shift;
99 0         0 my @lines = ();
100 0         0 push @lines, qq{Summary of OpenMP Environmental UNSET variables supported in this module:};
101             ENV:
102 0         0 foreach my $ev ( $self->vars_unset ) {
103 0         0 push @lines, sprintf( qq{%s}, $ev );
104             }
105 0         0 my $ret = join( qq{\n}, @lines );
106 0         0 $ret .= print qq{\n};
107 0 0       0 $ret .= print qq{- none\n} if ( @lines == 1 );
108 0         0 return $ret;
109             }
110              
111             sub print_omp_summary_set {
112 0     0 1 0 my $self = shift;
113 0         0 return print $self->_omp_summary_set;
114             }
115              
116             sub _omp_summary_set {
117 0     0   0 my $self = shift;
118 0         0 my @lines = ();
119 0         0 push @lines, qq{Summary of OpenMP Environmental SET variables supported in this module:};
120             ENV:
121 0         0 foreach my $ev_ref ( $self->vars_set ) {
122 0         0 my $ev = ( keys %$ev_ref )[0];
123 0         0 my $val = ( values %$ev_ref )[0];
124 0         0 push @lines, sprintf( qq{%-25s %s}, $ev, $val );
125             }
126 0         0 my $ret = join( qq{\n}, @lines );
127 0         0 $ret .= print qq{\n};
128 0 0       0 $ret .= print qq{- none\n} if ( @lines == 1 );
129 0         0 return $ret;
130             }
131              
132             sub print_omp_summary {
133 0     0 1 0 my $self = shift;
134 0         0 return print $self->_omp_summary;
135             }
136              
137             sub _omp_summary {
138 2     2   3 my $self = shift;
139 2         10 my $ret = qq{Summary of OpenMP Environmental ALL variables supported in this module:\n};
140 2         7 $ret .= sprintf( qq{%-25s %s\n}, q{Variable}, q{Value} );
141 2         4 $ret .= sprintf( qq{%-25s %s\n}, q{~~~~~~~~}, q{~~~~~} );
142             ENV:
143 2         5 foreach my $ev ( $self->vars ) {
144 40 100       97 my $val = ( defined $ENV{$ev} ) ? $ENV{$ev} : q{};
145 40         102 $ret .= sprintf( qq{%-25s %s\n}, $ev, $val );
146             }
147 2         13 return $ret;
148             }
149              
150             # OpenMP Environmental Variable setters/getters
151              
152             sub omp_cancellation {
153 6     6 1 1026 my ( $self, $value ) = @_;
154 6         11 my $ev = q{OMP_CANCELLATION};
155 6         14 return $self->_get_set_assert( $ev, $value );
156             }
157              
158             sub unset_omp_cancellation {
159 2     2 1 6 my ( $self, $value ) = @_;
160 2         4 my $ev = q{OMP_CANCELLATION};
161 2         13 return delete $ENV{$ev};
162             }
163              
164             sub omp_display_env {
165 8     8 1 51 my ( $self, $value ) = @_;
166 8         12 my $ev = q{OMP_DISPLAY_ENV};
167 8         21 return $self->_get_set_assert( $ev, $value );
168             }
169              
170             sub unset_omp_display_env {
171 3     3 1 8 my ( $self, $value ) = @_;
172 3         5 my $ev = q{OMP_DISPLAY_ENV};
173 3         29 return delete $ENV{$ev};
174             }
175              
176             sub omp_default_device {
177 25     25 1 5947 my ( $self, $value ) = @_;
178 25         39 my $ev = q{OMP_DEFAULT_DEVICE};
179 25         65 return $self->_get_set_assert( $ev, $value );
180             }
181              
182             sub unset_omp_default_device {
183 22     22 1 50 my ( $self, $value ) = @_;
184 22         33 my $ev = q{OMP_DEFAULT_DEVICE};
185 22         134 return delete $ENV{$ev};
186             }
187              
188             sub omp_dynamic {
189 6     6 1 45 my ( $self, $value ) = @_;
190 6         12 my $ev = q{OMP_DYNAMIC};
191 6         14 return $self->_get_set_assert( $ev, $value );
192             }
193              
194             sub unset_omp_dynamic {
195 2     2 1 6 my ( $self, $value ) = @_;
196 2         3 my $ev = q{OMP_DYNAMIC};
197 2         13 return delete $ENV{$ev};
198             }
199              
200             sub omp_max_active_levels {
201 24     24 1 6883 my ( $self, $value ) = @_;
202 24         39 my $ev = q{OMP_MAX_ACTIVE_LEVELS};
203 24         62 return $self->_get_set_assert( $ev, $value );
204             }
205              
206             sub unset_omp_max_active_levels {
207 20     20 1 43 my ( $self, $value ) = @_;
208 20         33 my $ev = q{OMP_MAX_ACTIVE_LEVELS};
209 20         115 return delete $ENV{$ev};
210             }
211              
212             sub omp_max_task_priority {
213 25     25 1 6478 my ( $self, $value ) = @_;
214 25         44 my $ev = q{OMP_MAX_TASK_PRIORITY};
215 25         80 return $self->_get_set_assert( $ev, $value );
216             }
217              
218             sub unset_omp_max_task_priority {
219 22     22 1 48 my ( $self, $value ) = @_;
220 22         33 my $ev = q{OMP_MAX_TASK_PRIORITY};
221 22         132 return delete $ENV{$ev};
222             }
223              
224             sub omp_nested {
225 6     6 1 44 my ( $self, $value ) = @_;
226 6         10 my $ev = q{OMP_NESTED};
227 6         14 return $self->_get_set_assert( $ev, $value );
228             }
229              
230             sub unset_omp_nested {
231 2     2 1 4 my ( $self, $value ) = @_;
232 2         5 my $ev = q{OMP_NESTED};
233 2         12 return delete $ENV{$ev};
234             }
235              
236             sub omp_num_threads {
237 24     24 1 6808 my ( $self, $value ) = @_;
238 24         39 my $ev = q{OMP_NUM_THREADS};
239 24         59 return $self->_get_set_assert( $ev, $value );
240             }
241              
242             sub unset_omp_num_threads {
243 20     20 1 44 my ( $self, $value ) = @_;
244 20         34 my $ev = q{OMP_NUM_THREADS};
245 20         122 return delete $ENV{$ev};
246             }
247              
248             sub omp_proc_bind {
249 3     3 1 304 my ( $self, $value ) = @_;
250 3         6 my $ev = q{OMP_PROC_BIND};
251 3         9 return $self->_get_set_assert( $ev, $value );
252             }
253              
254             sub unset_omp_proc_bind {
255 3     3 1 10 my ( $self, $value ) = @_;
256 3         5 my $ev = q{OMP_PROC_BIND};
257 3         23 return delete $ENV{$ev};
258             }
259              
260             sub omp_places {
261 1     1 1 4 my ( $self, $value ) = @_;
262 1         3 my $ev = q{OMP_PLACES};
263 1         4 return $self->_get_set_assert( $ev, $value );
264             }
265              
266             sub unset_omp_places {
267 1     1 1 4 my ( $self, $value ) = @_;
268 1         3 my $ev = q{OMP_PLACES};
269 1         8 return delete $ENV{$ev};
270             }
271              
272             sub omp_stacksize {
273 2     2 1 7 my ( $self, $value ) = @_;
274 2         5 my $ev = q{OMP_STACKSIZE};
275 2         6 return $self->_get_set_assert( $ev, $value );
276             }
277              
278             sub unset_omp_stacksize {
279 2     2 1 6 my ( $self, $value ) = @_;
280 2         3 my $ev = q{OMP_STACKSIZE};
281 2         15 return delete $ENV{$ev};
282             }
283              
284             sub omp_schedule {
285 3     3 1 11 my ( $self, $value ) = @_;
286 3         5 my $ev = q{OMP_SCHEDULE};
287 3         9 return $self->_get_set_assert( $ev, $value );
288             }
289              
290             sub unset_omp_schedule {
291 3     3 1 8 my ( $self, $value ) = @_;
292 3         7 my $ev = q{OMP_SCHEDULE};
293 3         22 return delete $ENV{$ev};
294             }
295              
296             sub omp_target_offload {
297 8     8 1 49 my ( $self, $value ) = @_;
298 8         15 my $ev = q{OMP_TARGET_OFFLOAD};
299 8         17 return $self->_get_set_assert( $ev, $value );
300             }
301              
302             sub unset_omp_target_offload {
303 3     3 1 7 my ( $self, $value ) = @_;
304 3         6 my $ev = q{OMP_TARGET_OFFLOAD};
305 3         21 return delete $ENV{$ev};
306             }
307              
308             sub omp_thread_limit {
309 24     24 1 6931 my ( $self, $value ) = @_;
310 24         42 my $ev = q{OMP_THREAD_LIMIT};
311 24         57 return $self->_get_set_assert( $ev, $value );
312             }
313              
314             sub unset_omp_thread_limit {
315 20     20 1 42 my ( $self, $value ) = @_;
316 20         32 my $ev = q{OMP_THREAD_LIMIT};
317 20         138 return delete $ENV{$ev};
318             }
319              
320             sub omp_wait_policy {
321 6     6 1 43 my ( $self, $value ) = @_;
322 6         10 my $ev = q{OMP_WAIT_POLICY};
323 6         15 return $self->_get_set_assert( $ev, $value );
324             }
325              
326             sub unset_omp_wait_policy {
327 2     2 1 4 my ( $self, $value ) = @_;
328 2         4 my $ev = q{OMP_WAIT_POLICY};
329 2         14 return delete $ENV{$ev};
330             }
331              
332             sub gomp_cpu_affinity {
333 1     1 1 5 my ( $self, $value ) = @_;
334 1         3 my $ev = q{GOMP_CPU_AFFINITY};
335 1         4 return $self->_get_set_assert( $ev, $value );
336             }
337              
338             sub unset_gomp_cpu_affinity {
339 1     1 1 4 my ( $self, $value ) = @_;
340 1         2 my $ev = q{GOMP_CPU_AFFINITY};
341 1         8 return delete $ENV{$ev};
342             }
343              
344             sub gomp_debug {
345 4     4 1 38 my ( $self, $value ) = @_;
346 4         6 my $ev = q{GOMP_DEBUG};
347 4         11 return $self->_get_set_assert( $ev, $value );
348             }
349              
350             sub unset_gomp_debug {
351 2     2 1 5 my ( $self, $value ) = @_;
352 2         4 my $ev = q{GOMP_DEBUG};
353 2         12 return delete $ENV{$ev};
354             }
355              
356             sub gomp_stacksize {
357 1     1 1 4 my ( $self, $value ) = @_;
358 1         3 my $ev = q{GOMP_STACKSIZE};
359 1         4 return $self->_get_set_assert( $ev, $value );
360             }
361              
362             sub unset_gomp_stacksize {
363 1     1 1 3 my ( $self, $value ) = @_;
364 1         3 my $ev = q{GOMP_STACKSIZE};
365 1         7 return delete $ENV{$ev};
366             }
367              
368             sub gomp_spincount {
369 1     1 1 4 my ( $self, $value ) = @_;
370 1         2 my $ev = q{GOMP_SPINCOUNT};
371 1         4 return $self->_get_set_assert( $ev, $value );
372             }
373              
374             sub unset_gomp_spincount {
375 1     1 1 4 my ( $self, $value ) = @_;
376 1         2 my $ev = q{GOMP_SPINCOUNT};
377 1         9 return delete $ENV{$ev};
378             }
379              
380             sub gomp_rtems_thread_pools {
381 1     1 1 5 my ( $self, $value ) = @_;
382 1         3 my $ev = q{GOMP_RTEMS_THREAD_POOLS};
383 1         5 return $self->_get_set_assert( $ev, $value );
384             }
385              
386             sub unset_gomp_rtems_thread_pools {
387 1     1 1 4 my ( $self, $value ) = @_;
388 1         3 my $ev = q{GOMP_RTEMS_THREAD_POOLS};
389 1         8 return delete $ENV{$ev};
390             }
391              
392             # auxilary validation routines for with Validate::Tiny
393              
394             # used to assert valid environment, useful if variables are already set externally
395             sub assert_omp_environment {
396 14     14 1 828 my $self = shift;
397 14         25 my @lines = ();
398             ENV:
399 14         33 foreach my $ev_ref ( $self->vars_set ) {
400 89         230 my $ev = ( keys %$ev_ref )[0];
401 89         172 my $val = ( values %$ev_ref )[0];
402 89 50       243 $self->_get_set_assert( $ev, $ENV{$ev} ) if exists $ENV{$ev};
403             }
404 2         11 return 1;
405             }
406              
407             sub _get_set_assert {
408 268     268   538 my ( $self, $ev, $value ) = @_;
409 268 100       621 if ( defined $value ) {
410 261         504 my $filtered_value = $self->_assert_valid( $ev, $value );
411 224         1100 $ENV{$ev} = $filtered_value;
412             }
413 231 100       1237 return ( exists $ENV{$ev} ) ? $ENV{$ev} : undef;
414             }
415              
416             sub _assert_valid {
417 261     261   443 my ( $self, $ev, $value ) = @_;
418 261         1028 my $result = Validate::Tiny::validate( { $ev => $value }, $self->{_validation_rules} );
419              
420             # process errors, then die
421 261         4563 my $err;
422 261         410 foreach my $e ( keys %{ $result->{error} } ) {
  261         682  
423 37         70 my $msg = $result->{error}->{$e};
424 37         59 my $val = $result->{data}->{$e};
425 37         129 $err = qq{(fatal) $e="$val": $msg\n};
426             }
427 261 100       921 die qq{$err\n} if not $result->{success};
428              
429             # if all is okay, return the filtered value (since we're testing what's been passed through 'filters' for some envars
430 224         810 return $result->{data}->{$ev};
431             }
432              
433             # provides validator that does nothing, a null validator useful as a place holder
434             sub _no_validate {
435             return sub {
436 2088     2088   334651 return undef;
437 16     16   169 };
438             }
439              
440             1;
441              
442             __END__