File Coverage

File:lib/OpenMP/Environment.pm
Coverage:99.8%

linestmtbrancondsubpodtimecode
1package OpenMP::Environment;
2
7
7
7
7
37
8
210
use strict;
3
7
7
7
7
29
34
319
use warnings;
4
5
7
7
7
7
39
9
343
use Carp qw/croak/;
6
7
7
7
7
2235
4680
361
use Dispatch::Fu qw/dispatch on xdefault/;
7
7
7
7
7
2108
16
134
use OpenMP::Environment::Constants ();
8
7
7
7
7
3263
16
1346
use OpenMP::Environment::Validation ();
9
10our $VERSION = q{1.5.0};
11
12our @_OMP_VARS = OpenMP::Environment::Constants::environment_names();
13
14# capture state of %ENV
15local %ENV = %ENV;
16
17# The DSL is deliberately opt-in.  Constants are installed directly into the
18# caller from OpenMP::Environment::Constants so their names never collide with
19# the identically named accessor methods in this package.
20sub import {
21
14
14
32
    my ( $pkg, @imports ) = @_;
22
14
100
1557
    return if not @imports;
23
24
9
13
    my $caller = caller;
25
9
34
    my %export;
26
9
225
14
245
    my %constant = map { $_ => 1 } OpenMP::Environment::Constants::constant_names();
27
28
9
29
    foreach my $item (@imports) {
29
10
100
100
100
100
100
100
33
        if ( $item eq q{:unset} ) {
30
2
4
            $export{unset} = 1;
31
2
16
            $export{$_} = 1 for keys %constant;
32        }
33        elsif ( $item eq q{:assert} ) {
34
2
4
            $export{assert} = 1;
35
2
19
            $export{$_} = 1 for keys %constant;
36        }
37        elsif ( $item eq q{:dsl} ) {
38
1
7
            $export{unset} = 1;
39
1
2
            $export{assert} = 1;
40
1
8
            $export{$_} = 1 for keys %constant;
41        }
42        elsif ( $item eq q{unset} ) {
43
1
2
            $export{unset} = 1;
44        }
45        elsif ( $item eq q{assert} ) {
46
1
2
            $export{assert} = 1;
47        }
48        elsif ( $constant{$item} ) {
49
2
4
            $export{$item} = 1;
50        }
51        else {
52
1
86
            croak qq{"$item" is not exported by OpenMP::Environment};
53        }
54    }
55
56
7
7
7
7
38
10
213
    no strict q{refs};
57
7
7
7
7
30
9
25950
    no warnings q{redefine};
58
8
4
100
16
15
    *{"${caller}::unset"} = \&unset if $export{unset};
59
8
4
100
16
15
    *{"${caller}::assert"} = \&assert if $export{assert};
60
8
85
    foreach my $name ( sort keys %constant ) {
61
200
100
244
        next if not $export{$name};
62
127
127
246
351
        *{"${caller}::$name"} = OpenMP::Environment::Constants->can($name);
63    }
64
8
3802
    return;
65}
66
67# constructor
68sub new {
69
8
8
1
21
    my $pkg = shift;
70
8
16
    my $self = {
71        _validation_rules => OpenMP::Environment::Validation::validation_rules(),
72    };
73
8
26
    return bless $self, $pkg;
74}
75
76# Backward-compatible private validator helpers retained because older callers
77# and the regression suite may invoke them directly.
78sub _is_ge_if_set {
79
7
7
12
    my ( $min, $value ) = @_;
80
7
100
16
    return if not defined $value;
81
6
100
24
    return q{Value must be an integer great than or equal to 1}
82      if $value =~ m/\D/;
83
4
100
15
    return q{Value must be an integer great than or equal to 1}
84      if $value < $min;
85
2
5
    return;
86}
87
88sub _is_positive_integer_list_if_set {
89
3
3
4
    my ($value) = @_;
90
3
100
16
    return if not defined $value;
91
2
100
14
    return if $value =~ m/\A\s*[1-9]\d*(?:\s*,\s*[1-9]\d*)*\s*\z/;
92
1
4
    return q{Value must be a comma-separated list of positive integers};
93}
94
95sub _no_validate {
96
1
1
1
1
4
4
    return sub { return undef };
97}
98
99sub _is_legacy_false_value {
100
36
36
45
    my ($value) = @_;
101
36
50
59
    return 1 if not defined $value;
102
103    # OpenMP environment values are generally allowed surrounding whitespace.
104    # Preserve the historical false-value-unsets behavior when that standard
105    # spelling is used, including case-insensitive FALSE and numeric zero.
106
36
32
    my $test = $value;
107
36
89
    $test =~ s/\A\s+//;
108
36
64
    $test =~ s/\s+\z//;
109
36
100
58
    return 1 if not $test;
110
32
100
81
    return 1 if lc($test) eq q{false};
111
22
45
    return 0;
112}
113
114# returns a list of variables supported (no values)
115sub vars {
116
7
7
1
9
    my $self = shift;
117
7
30
    return @_OMP_VARS;
118}
119
120# returns a list of variables unset (value not set so don't need it)
121sub vars_unset {
122
5
5
1
6
    my $self  = shift;
123
5
7
    my @unset = ();
124
5
8
    foreach my $ev (@_OMP_VARS) {
125
125
100
177
        push @unset, $ev if not $ENV{$ev};
126    }
127
5
19
    return @unset;
128}
129
130# returns a list of all variables that are currently set, and their values
131# as an array of hash references of the form, "$VAR_NAME => $value"
132sub vars_set {
133
5
5
1
8
    my $self = shift;
134
5
6
    my @set  = ();
135
5
9
    foreach my $ev (@_OMP_VARS) {
136
125
100
233
        push @set, { $ev => $ENV{$ev} } if $ENV{$ev};
137    }
138
5
18
    return @set;
139}
140
141sub print_omp_summary_unset {
142
1
1
1
2
    my $self = shift;
143
1
1
    return print $self->_omp_summary_unset;
144}
145
146sub _omp_summary_unset {
147
3
3
6
    my $self  = shift;
148
3
4
    my @lines = ();
149
3
5
    push @lines, qq{Summary of OpenMP Environmental UNSET variables supported in this module:};
150  ENV:
151
3
6
    foreach my $ev ( $self->vars_unset ) {
152
25
31
        push @lines, sprintf( qq{%s}, $ev );
153    }
154
3
9
    my $ret = join( qq{\n}, @lines );
155
3
5
    $ret .= print qq{\n};
156
3
100
7
    $ret .= print qq{- none\n} if ( @lines == 1 );
157
3
13
    return $ret;
158}
159
160sub print_omp_summary_set {
161
1
1
1
2
    my $self = shift;
162
1
2
    return print $self->_omp_summary_set;
163}
164
165sub _omp_summary_set {
166
3
3
4
    my $self  = shift;
167
3
5
    my @lines = ();
168
3
4
    push @lines, qq{Summary of OpenMP Environmental SET variables supported in this module:};
169  ENV:
170
3
5
    foreach my $ev_ref ( $self->vars_set ) {
171
50
89
        my $ev  = ( keys %$ev_ref )[0];
172
50
68
        my $val = ( values %$ev_ref )[0];
173
50
105
        push @lines, sprintf( qq{%-25s %s}, $ev, $val );
174    }
175
3
25
    my $ret = join( qq{\n}, @lines );
176
3
7
    $ret .= print qq{\n};
177
3
100
7
    $ret .= print qq{- none\n} if ( @lines == 1 );
178
3
16
    return $ret;
179}
180
181sub print_omp_summary {
182
1
1
1
2
    my $self = shift;
183
1
2
    return print $self->_omp_summary;
184}
185
186sub _omp_summary {
187
5
5
8
    my $self = shift;
188
5
5
    my $ret  = qq{Summary of OpenMP Environmental ALL variables supported in this module:\n};
189
5
9
    $ret .= sprintf( qq{%-25s %s\n}, q{Variable}, q{Value} );
190
5
6
    $ret .= sprintf( qq{%-25s %s\n}, q{~~~~~~~~}, q{~~~~~} );
191  ENV:
192
5
8
    foreach my $ev ( $self->vars ) {
193
125
100
165
        my $val = ( defined $ENV{$ev} ) ? $ENV{$ev} : q{<XXunsetXX>};
194
125
171
        $ret .= sprintf( qq{%-25s %s\n}, $ev, $val );
195    }
196
5
32
    return $ret;
197}
198
199# Return a validation-aware lvalue proxy for one environment variable.
200# FETCH reads the current value from %ENV; STORE routes assignment back through
201# the public accessor so lvalue syntax retains the same validation, filtering,
202# and compatibility behavior as traditional setter calls.
203sub _lvalue_for :lvalue {
204
403
403
545
    my ( $self, $ev, $accessor, $has_override, $override ) = @_;
205
403
380
    my $slot;
206
403
830
    tie $slot, q{OpenMP::Environment::_Lvalue},
207      $self, $ev, $accessor, $has_override, $override;
208
403
1282
    $slot;
209}
210
211# OpenMP Environmental Variable setters/getters
212
213sub omp_allocator :lvalue {
214
8
8
1
17
    my ( $self, $value ) = @_;
215
8
11
    my $ev = q{OMP_ALLOCATOR};
216
8
16
    $self->_get_set_assert( $ev, $value );
217
8
13
    $self->_lvalue_for( $ev, q{omp_allocator} );
218}
219
220sub unset_omp_allocator {
221
4
4
1
8
    my ( $self, $value ) = @_;
222
4
7
    my $ev = q{OMP_ALLOCATOR};
223
4
22
    return delete $ENV{$ev};
224}
225
226sub omp_affinity_format :lvalue {
227
11
11
1
18
    my ( $self, $value ) = @_;
228
11
13
    my $ev = q{OMP_AFFINITY_FORMAT};
229
11
18
    $self->_get_set_assert( $ev, $value );
230
11
17
    $self->_lvalue_for( $ev, q{omp_affinity_format} );
231}
232
233sub unset_omp_affinity_format {
234
3
3
1
6
    my ( $self, $value ) = @_;
235
3
5
    my $ev = q{OMP_AFFINITY_FORMAT};
236
3
18
    return delete $ENV{$ev};
237}
238
239sub omp_display_affinity :lvalue {
240
12
12
1
23
    my ( $self, $value ) = @_;
241
12
15
    my $ev = q{OMP_DISPLAY_AFFINITY};
242
12
25
    $self->_get_set_assert( $ev, $value );
243
11
21
    $self->_lvalue_for( $ev, q{omp_display_affinity} );
244}
245
246sub unset_omp_display_affinity {
247
4
4
1
8
    my ( $self, $value ) = @_;
248
4
6
    my $ev = q{OMP_DISPLAY_AFFINITY};
249
4
22
    return delete $ENV{$ev};
250}
251
252sub omp_cancellation :lvalue {
253
12
12
1
24
    my ( $self, $value ) = @_;
254
12
18
    my $ev = q{OMP_CANCELLATION};
255
12
27
    $self->_get_set_assert( $ev, $value );
256
11
17
    $self->_lvalue_for( $ev, q{omp_cancellation} );
257}
258
259sub unset_omp_cancellation {
260
4
4
1
13
    my ( $self, $value ) = @_;
261
4
7
    my $ev = q{OMP_CANCELLATION};
262
4
22
    return delete $ENV{$ev};
263}
264
265sub omp_display_env :lvalue {
266
14
14
1
28
    my ( $self, $value ) = @_;
267
14
16
    my $ev = q{OMP_DISPLAY_ENV};
268
14
26
    $self->_get_set_assert( $ev, $value );
269
13
22
    $self->_lvalue_for( $ev, q{omp_display_env} );
270}
271
272sub unset_omp_display_env {
273
5
5
1
14
    my ( $self, $value ) = @_;
274
5
6
    my $ev = q{OMP_DISPLAY_ENV};
275
5
25
    return delete $ENV{$ev};
276}
277
278sub omp_default_device :lvalue {
279
31
31
1
51
    my ( $self, $value ) = @_;
280
31
27
    my $ev = q{OMP_DEFAULT_DEVICE};
281
31
51
    $self->_get_set_assert( $ev, $value );
282
28
44
    $self->_lvalue_for( $ev, q{omp_default_device} );
283}
284
285sub unset_omp_default_device {
286
24
24
1
36
    my ( $self, $value ) = @_;
287
24
24
    my $ev = q{OMP_DEFAULT_DEVICE};
288
24
103
    return delete $ENV{$ev};
289}
290
291sub omp_dynamic :lvalue {
292
25
25
1
36
    my $self = shift;
293
25
26
    my $ev = q{OMP_DYNAMIC};
294
25
28
    my ( $has_override, $override );
295
296
25
100
49
    if (@_) {
297
18
27
        my $value = shift;
298
18
22
        my $old = $ENV{$ev};
299
18
100
31
        if ( _is_legacy_false_value($value) ) {
300
7
21
            $self->unset_omp_dynamic();
301
7
7
            $has_override = 1;
302
7
14
            $override = $old;
303        }
304        else {
305
11
17
            $self->_get_set_assert( $ev, $value );
306        }
307    }
308
309
24
48
    $self->_lvalue_for( $ev, q{omp_dynamic}, $has_override, $override );
310}
311
312sub unset_omp_dynamic {
313
13
13
1
22
    my ( $self, $value ) = @_;
314
13
53
    my $ev = q{OMP_DYNAMIC};
315
13
57
    return delete $ENV{$ev};
316}
317
318sub omp_max_active_levels :lvalue {
319
30
30
1
40
    my ( $self, $value ) = @_;
320
30
27
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
321
30
51
    $self->_get_set_assert( $ev, $value );
322
26
46
    $self->_lvalue_for( $ev, q{omp_max_active_levels} );
323}
324
325sub unset_omp_max_active_levels {
326
22
22
1
32
    my ( $self, $value ) = @_;
327
22
23
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
328
22
88
    return delete $ENV{$ev};
329}
330
331sub omp_max_task_priority :lvalue {
332
31
31
1
42
    my ( $self, $value ) = @_;
333
31
29
    my $ev = q{OMP_MAX_TASK_PRIORITY};
334
31
53
    $self->_get_set_assert( $ev, $value );
335
28
46
    $self->_lvalue_for( $ev, q{omp_max_task_priority} );
336}
337
338sub unset_omp_max_task_priority {
339
24
24
1
32
    my ( $self, $value ) = @_;
340
24
23
    my $ev = q{OMP_MAX_TASK_PRIORITY};
341
24
96
    return delete $ENV{$ev};
342}
343
344sub omp_nested :lvalue {
345
25
25
1
32
    my $self = shift;
346
25
27
    my $ev = q{OMP_NESTED};
347
25
24
    my ( $has_override, $override );
348
349
25
100
80
    if (@_) {
350
18
24
        my $value = shift;
351
18
21
        my $old = $ENV{$ev};
352
18
100
28
        if ( _is_legacy_false_value($value) ) {
353
7
15
            $self->unset_omp_nested();
354
7
8
            $has_override = 1;
355
7
11
            $override = $old;
356        }
357        else {
358
11
22
            $self->_get_set_assert( $ev, $value );
359        }
360    }
361
362
24
43
    $self->_lvalue_for( $ev, q{omp_nested}, $has_override, $override );
363}
364
365sub unset_omp_nested {
366
11
11
1
17
    my ( $self, $value ) = @_;
367
11
13
    my $ev = q{OMP_NESTED};
368
11
43
    return delete $ENV{$ev};
369}
370
371sub omp_num_threads :lvalue {
372
51
51
1
64
    my ( $self, $value ) = @_;
373
51
50
    my $ev = q{OMP_NUM_THREADS};
374
51
89
    $self->_get_set_assert( $ev, $value );
375
43
67
    $self->_lvalue_for( $ev, q{omp_num_threads} );
376}
377
378sub unset_omp_num_threads {
379
27
27
1
42
    my ( $self, $value ) = @_;
380
27
30
    my $ev = q{OMP_NUM_THREADS};
381
27
105
    return delete $ENV{$ev};
382}
383
384sub omp_num_teams :lvalue {
385
30
30
1
48
    my ( $self, $value ) = @_;
386
30
28
    my $ev = q{OMP_NUM_TEAMS};
387
30
48
    $self->_get_set_assert( $ev, $value );
388
26
40
    $self->_lvalue_for( $ev, q{omp_num_teams} );
389}
390
391sub unset_omp_num_teams {
392
22
22
1
33
    my ( $self, $value ) = @_;
393
22
23
    my $ev = q{OMP_NUM_TEAMS};
394
22
87
    return delete $ENV{$ev};
395}
396
397sub omp_proc_bind :lvalue {
398
9
9
1
13
    my ( $self, $value ) = @_;
399
9
10
    my $ev = q{OMP_PROC_BIND};
400
9
17
    $self->_get_set_assert( $ev, $value );
401
9
15
    $self->_lvalue_for( $ev, q{omp_proc_bind} );
402}
403
404sub unset_omp_proc_bind {
405
5
5
1
8
    my ( $self, $value ) = @_;
406
5
6
    my $ev = q{OMP_PROC_BIND};
407
5
24
    return delete $ENV{$ev};
408}
409
410sub omp_places :lvalue {
411
7
7
1
11
    my ( $self, $value ) = @_;
412
7
9
    my $ev = q{OMP_PLACES};
413
7
13
    $self->_get_set_assert( $ev, $value );
414
7
13
    $self->_lvalue_for( $ev, q{omp_places} );
415}
416
417sub unset_omp_places {
418
3
3
1
8
    my ( $self, $value ) = @_;
419
3
4
    my $ev = q{OMP_PLACES};
420
3
15
    return delete $ENV{$ev};
421}
422
423sub omp_stacksize :lvalue {
424
8
8
1
11
    my ( $self, $value ) = @_;
425
8
11
    my $ev = q{OMP_STACKSIZE};
426
8
14
    $self->_get_set_assert( $ev, $value );
427
8
13
    $self->_lvalue_for( $ev, q{omp_stacksize} );
428}
429
430sub unset_omp_stacksize {
431
4
4
1
8
    my ( $self, $value ) = @_;
432
4
5
    my $ev = q{OMP_STACKSIZE};
433
4
20
    return delete $ENV{$ev};
434}
435
436sub omp_schedule :lvalue {
437
9
9
1
14
    my ( $self, $value ) = @_;
438
9
13
    my $ev = q{OMP_SCHEDULE};
439
9
16
    $self->_get_set_assert( $ev, $value );
440
9
15
    $self->_lvalue_for( $ev, q{omp_schedule} );
441}
442
443sub unset_omp_schedule {
444
5
5
1
11
    my ( $self, $value ) = @_;
445
5
6
    my $ev = q{OMP_SCHEDULE};
446
5
29
    return delete $ENV{$ev};
447}
448
449sub omp_target_offload :lvalue {
450
14
14
1
21
    my ( $self, $value ) = @_;
451
14
15
    my $ev = q{OMP_TARGET_OFFLOAD};
452
14
23
    $self->_get_set_assert( $ev, $value );
453
13
21
    $self->_lvalue_for( $ev, q{omp_target_offload} );
454}
455
456sub unset_omp_target_offload {
457
5
5
1
9
    my ( $self, $value ) = @_;
458
5
6
    my $ev = q{OMP_TARGET_OFFLOAD};
459
5
23
    return delete $ENV{$ev};
460}
461
462sub omp_thread_limit :lvalue {
463
30
30
1
43
    my ( $self, $value ) = @_;
464
30
28
    my $ev = q{OMP_THREAD_LIMIT};
465
30
49
    $self->_get_set_assert( $ev, $value );
466
26
40
    $self->_lvalue_for( $ev, q{omp_thread_limit} );
467}
468
469sub unset_omp_thread_limit {
470
22
22
1
28
    my ( $self, $value ) = @_;
471
22
23
    my $ev = q{OMP_THREAD_LIMIT};
472
22
91
    return delete $ENV{$ev};
473}
474
475sub omp_teams_thread_limit :lvalue {
476
30
30
1
44
    my ( $self, $value ) = @_;
477
30
30
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
478
30
44
    $self->_get_set_assert( $ev, $value );
479
26
45
    $self->_lvalue_for( $ev, q{omp_teams_thread_limit} );
480}
481
482sub unset_omp_teams_thread_limit {
483
22
22
1
33
    my ( $self, $value ) = @_;
484
22
23
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
485
22
92
    return delete $ENV{$ev};
486}
487
488sub omp_wait_policy :lvalue {
489
12
12
1
18
    my ( $self, $value ) = @_;
490
12
11
    my $ev = q{OMP_WAIT_POLICY};
491
12
18
    $self->_get_set_assert( $ev, $value );
492
11
16
    $self->_lvalue_for( $ev, q{omp_wait_policy} );
493}
494
495sub unset_omp_wait_policy {
496
4
4
1
6
    my ( $self, $value ) = @_;
497
4
5
    my $ev = q{OMP_WAIT_POLICY};
498
4
18
    return delete $ENV{$ev};
499}
500
501sub gomp_cpu_affinity :lvalue {
502
7
7
1
11
    my ( $self, $value ) = @_;
503
7
7
    my $ev = q{GOMP_CPU_AFFINITY};
504
7
160
    $self->_get_set_assert( $ev, $value );
505
7
11
    $self->_lvalue_for( $ev, q{gomp_cpu_affinity} );
506}
507
508sub unset_gomp_cpu_affinity {
509
3
3
1
8
    my ( $self, $value ) = @_;
510
3
4
    my $ev = q{GOMP_CPU_AFFINITY};
511
3
15
    return delete $ENV{$ev};
512}
513
514sub gomp_debug :lvalue {
515
10
10
1
15
    my ( $self, $value ) = @_;
516
10
10
    my $ev = q{GOMP_DEBUG};
517
10
17
    $self->_get_set_assert( $ev, $value );
518
9
17
    $self->_lvalue_for( $ev, q{gomp_debug} );
519}
520
521sub unset_gomp_debug {
522
4
4
1
7
    my ( $self, $value ) = @_;
523
4
6
    my $ev = q{GOMP_DEBUG};
524
4
18
    return delete $ENV{$ev};
525}
526
527sub gomp_stacksize :lvalue {
528
7
7
1
9
    my ( $self, $value ) = @_;
529
7
9
    my $ev = q{GOMP_STACKSIZE};
530
7
12
    $self->_get_set_assert( $ev, $value );
531
7
13
    $self->_lvalue_for( $ev, q{gomp_stacksize} );
532}
533
534sub unset_gomp_stacksize {
535
3
3
1
7
    my ( $self, $value ) = @_;
536
3
4
    my $ev = q{GOMP_STACKSIZE};
537
3
15
    return delete $ENV{$ev};
538}
539
540sub gomp_spincount :lvalue {
541
11
11
1
15
    my ( $self, $value ) = @_;
542
11
12
    my $ev = q{GOMP_SPINCOUNT};
543
11
20
    $self->_get_set_assert( $ev, $value );
544
11
19
    $self->_lvalue_for( $ev, q{gomp_spincount} );
545}
546
547sub unset_gomp_spincount {
548
3
3
1
6
    my ( $self, $value ) = @_;
549
3
4
    my $ev = q{GOMP_SPINCOUNT};
550
3
15
    return delete $ENV{$ev};
551}
552
553sub gomp_rtems_thread_pools :lvalue {
554
7
7
1
10
    my ( $self, $value ) = @_;
555
7
9
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
556
7
13
    $self->_get_set_assert( $ev, $value );
557
7
11
    $self->_lvalue_for( $ev, q{gomp_rtems_thread_pools} );
558}
559
560sub unset_gomp_rtems_thread_pools {
561
3
3
1
6
    my ( $self, $value ) = @_;
562
3
4
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
563
3
14
    return delete $ENV{$ev};
564}
565
566# Functional DSL operations.  Dispatch::Fu supplies a static whitelist: an
567# arbitrary environment-variable string cannot be deleted or asserted through
568# these functions unless it is one of the 25 canonical constants.
569sub _unset_case {
570
26
26
1668
    my ($ev) = @_;
571
26
199
    return delete $ENV{$ev};
572}
573
574sub _assert_case {
575
30
30
1858
    my ($ev) = @_;
576
30
53
    return OpenMP::Environment::Validation::assert_variable( \%ENV, $ev );
577}
578
579sub unset($) {
580
27
27
1
39
    my ($ev) = @_;
581    return dispatch {
582
27
27
4392
        xdefault shift;
583    }
584    $ev,
585
1
1
204
      on default                   => sub { croak qq{Unsupported OpenMP/libgomp environment variable "$ev"} },
586
27
161
      on q{OMP_CANCELLATION}       => \&_unset_case,
587      on q{OMP_DISPLAY_ENV}        => \&_unset_case,
588      on q{OMP_DEFAULT_DEVICE}     => \&_unset_case,
589      on q{OMP_NUM_TEAMS}          => \&_unset_case,
590      on q{OMP_DYNAMIC}            => \&_unset_case,
591      on q{OMP_MAX_ACTIVE_LEVELS}  => \&_unset_case,
592      on q{OMP_MAX_TASK_PRIORITY}  => \&_unset_case,
593      on q{OMP_NESTED}             => \&_unset_case,
594      on q{OMP_NUM_THREADS}        => \&_unset_case,
595      on q{OMP_PROC_BIND}          => \&_unset_case,
596      on q{OMP_PLACES}             => \&_unset_case,
597      on q{OMP_STACKSIZE}          => \&_unset_case,
598      on q{OMP_SCHEDULE}           => \&_unset_case,
599      on q{OMP_TARGET_OFFLOAD}     => \&_unset_case,
600      on q{OMP_THREAD_LIMIT}       => \&_unset_case,
601      on q{OMP_WAIT_POLICY}        => \&_unset_case,
602      on q{GOMP_CPU_AFFINITY}      => \&_unset_case,
603      on q{GOMP_DEBUG}             => \&_unset_case,
604      on q{GOMP_STACKSIZE}         => \&_unset_case,
605      on q{GOMP_SPINCOUNT}         => \&_unset_case,
606      on q{GOMP_RTEMS_THREAD_POOLS} => \&_unset_case,
607      on q{OMP_TEAMS_THREAD_LIMIT} => \&_unset_case,
608      on q{OMP_ALLOCATOR}          => \&_unset_case,
609      on q{OMP_AFFINITY_FORMAT}    => \&_unset_case,
610      on q{OMP_DISPLAY_AFFINITY}   => \&_unset_case;
611}
612
613sub assert($) {
614
31
31
1
39
    my ($ev) = @_;
615    return dispatch {
616
31
31
4992
        xdefault shift;
617    }
618    $ev,
619
1
1
191
      on default                   => sub { croak qq{Unsupported OpenMP/libgomp environment variable "$ev"} },
620
31
187
      on q{OMP_CANCELLATION}       => \&_assert_case,
621      on q{OMP_DISPLAY_ENV}        => \&_assert_case,
622      on q{OMP_DEFAULT_DEVICE}     => \&_assert_case,
623      on q{OMP_NUM_TEAMS}          => \&_assert_case,
624      on q{OMP_DYNAMIC}            => \&_assert_case,
625      on q{OMP_MAX_ACTIVE_LEVELS}  => \&_assert_case,
626      on q{OMP_MAX_TASK_PRIORITY}  => \&_assert_case,
627      on q{OMP_NESTED}             => \&_assert_case,
628      on q{OMP_NUM_THREADS}        => \&_assert_case,
629      on q{OMP_PROC_BIND}          => \&_assert_case,
630      on q{OMP_PLACES}             => \&_assert_case,
631      on q{OMP_STACKSIZE}          => \&_assert_case,
632      on q{OMP_SCHEDULE}           => \&_assert_case,
633      on q{OMP_TARGET_OFFLOAD}     => \&_assert_case,
634      on q{OMP_THREAD_LIMIT}       => \&_assert_case,
635      on q{OMP_WAIT_POLICY}        => \&_assert_case,
636      on q{GOMP_CPU_AFFINITY}      => \&_assert_case,
637      on q{GOMP_DEBUG}             => \&_assert_case,
638      on q{GOMP_STACKSIZE}         => \&_assert_case,
639      on q{GOMP_SPINCOUNT}         => \&_assert_case,
640      on q{GOMP_RTEMS_THREAD_POOLS} => \&_assert_case,
641      on q{OMP_TEAMS_THREAD_LIMIT} => \&_assert_case,
642      on q{OMP_ALLOCATOR}          => \&_assert_case,
643      on q{OMP_AFFINITY_FORMAT}    => \&_assert_case,
644      on q{OMP_DISPLAY_AFFINITY}   => \&_assert_case;
645}
646
647# used to assert valid environment, useful if variables are already set externally
648sub assert_omp_environment {
649
22
22
1
43
    return OpenMP::Environment::Validation::assert_environment( \%ENV );
650}
651
652sub _get_set_assert {
653
413
413
503
    my ( $self, $ev, $value ) = @_;
654
413
100
644
    if ( defined $value ) {
655
302
390
        my $filtered_value = $self->_assert_valid( $ev, $value );
656
264
1339
        $ENV{$ev} = $filtered_value;
657    }
658
375
100
749
    return ( exists $ENV{$ev} ) ? $ENV{$ev} : undef;
659}
660
661sub _assert_valid {
662
304
304
322
    my ( $self, $ev, $value ) = @_;
663
304
472
    return OpenMP::Environment::Validation::validate_assignment( $ev, $value );
664}
665
666package OpenMP::Environment::_Lvalue;
667
668
7
7
7
7
44
8
178
use strict;
669
7
7
7
7
33
8
1272
use warnings;
670
671sub TIESCALAR {
672
403
403
592
    my ( $class, $owner, $ev, $accessor, $has_override, $override ) = @_;
673
403
1256
    return bless {
674        owner        => $owner,
675        ev           => $ev,
676        accessor     => $accessor,
677        has_override => $has_override,
678        override     => $override,
679    }, $class;
680}
681
682sub FETCH {
683
323
323
3332
    my $self = shift;
684
323
100
562
    return $self->{override} if $self->{has_override};
685
313
822
    return $ENV{ $self->{ev} };
686}
687
688sub STORE {
689
40
40
49
    my ( $self, $value ) = @_;
690
40
44
    my $owner    = $self->{owner};
691
40
34
    my $accessor = $self->{accessor};
692
40
70
    $owner->$accessor($value);
693
39
70
    return;
694}
695
696package OpenMP::Environment;
697
6981;
699