File Coverage

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

linestmtbrancondsubpodtimecode
1package OpenMP::Environment;
2
4
4
4
4
22
11
109
use strict;
3
4
4
4
4
15
4
192
use warnings;
4
5
4
4
4
4
1285
58895
11324
use Validate::Tiny qw/filter is_in/;
6
7our $VERSION = q{1.4.0};
8
9our @_OMP_VARS = (
10    qw/OMP_CANCELLATION OMP_DISPLAY_ENV OMP_DEFAULT_DEVICE OMP_NUM_TEAMS
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      OMP_TEAMS_THREAD_LIMIT OMP_ALLOCATOR OMP_AFFINITY_FORMAT
16      OMP_DISPLAY_AFFINITY/
17);
18
19# capture state of %ENV
20local %ENV = %ENV;
21
22# constructor
23sub new {
24
4
4
1
17
    my $pkg = shift;
25
26    my $validate_rules = {
27        fields  => \@_OMP_VARS,
28        filters => [
29            [qw/OMP_CANCELLATION OMP_NESTED OMP_DISPLAY_AFFINITY OMP_DISPLAY_ENV OMP_TARGET_OFFLOAD OMP_WAIT_POLICY/] => filter('uc'),    # force to upper case for convenience
30        ],
31        checks => [
32            [qw/OMP_DYNAMIC OMP_NESTED/]                                 => is_in( [qw/TRUE true 1 FALSE false 0/],  q{Expected values are: 'true', 1, 'false', or 0} ),
33            [qw/OMP_CANCELLATION OMP_DISPLAY_AFFINITY/]                  => is_in( [qw/TRUE FALSE/],                 q{Expected values are: 'TRUE' or 'FALSE'} ),
34            OMP_DISPLAY_ENV                                              => is_in( [qw/TRUE VERBOSE FALSE/],         q{Expected values are: 'TRUE', 'VERBOSE', or 'FALSE'} ),
35            OMP_TARGET_OFFLOAD                                           => is_in( [qw/MANDATORY DISABLED DEFAULT/], q{Expected values are: 'MANDATORY', 'DISABLED', or 'DEFAULT'} ),
36            OMP_WAIT_POLICY                                              => is_in( [qw/ACTIVE PASSIVE/],             q{Expected values are: 'ACTIVE' or 'PASSIVE'} ),
37            GOMP_DEBUG                                                   => is_in( [qw/0 1/],                        q{Expected values are: 0 or 1} ),
38
868
868
199118
            [qw/OMP_MAX_TASK_PRIORITY OMP_DEFAULT_DEVICE/]               => sub { return _is_ge_if_set( 0, @_ ) },
39
434
434
99906
            OMP_NUM_THREADS                                              => sub { return _is_positive_integer_list_if_set(@_) },
40
868
868
180031
            [qw/OMP_MAX_ACTIVE_LEVELS OMP_THREAD_LIMIT/]                 => sub { return _is_ge_if_set( 1, @_ ) },
41
868
868
87862
            [qw/OMP_NUM_TEAMS OMP_TEAMS_THREAD_LIMIT/]                   => sub { return _is_ge_if_set( 1, @_ ) },
42
43            #-- the following are not current validated due to the complexity of the rules associated with their values
44
4
14
            OMP_ALLOCATOR           => _no_validate(),
45            OMP_AFFINITY_FORMAT     => _no_validate(),
46            OMP_PROC_BIND           => _no_validate(),
47            OMP_PLACES              => _no_validate(),
48            OMP_STACKSIZE           => _no_validate(),
49            OMP_SCHEDULE            => _no_validate(),
50            GOMP_CPU_AFFINITY       => _no_validate(),
51            GOMP_STACKSIZE          => _no_validate(),
52            GOMP_SPINCOUNT          => _no_validate(),
53            GOMP_RTEMS_THREAD_POOLS => _no_validate(),
54        ],
55    };
56
57    sub _is_ge_if_set {
58
2608
2608
2721
        my ( $min, $value ) = @_;
59
2608
100
100
100
3426
        if ( not defined $value ) {
60
2420
2912
            return;
61        }
62        elsif ( $value =~ m/\D/ or $value lt $min ) {
63
32
69
            return q{Value must be an integer great than or equal to 1};
64        }
65
156
238
        return;
66    }
67
68    sub _is_positive_integer_list_if_set {
69
437
437
471
        my ($value) = @_;
70
437
100
725
        return if not defined $value;
71
45
100
270
        return if $value =~ m/\A\s*[1-9]\d*(?:\s*,\s*[1-9]\d*)*\s*\z/;
72
10
20
        return q{Value must be a comma-separated list of positive integers};
73    }
74
75
4
17
    my $self = { _validation_rules => $validate_rules, };
76
4
11
    return bless $self, $pkg;
77}
78
79# returns a list of variables supported (no values)
80sub vars {
81
7
7
1
9
    my $self = shift;
82
7
32
    return @_OMP_VARS;
83}
84
85# returns a list of variables unset (value not set so don't need it)
86sub vars_unset {
87
5
5
1
6
    my $self  = shift;
88
5
6
    my @unset = ();
89
5
6
    foreach my $ev (@_OMP_VARS) {
90
125
100
145
        push @unset, $ev if not $ENV{$ev};
91    }
92
5
19
    return @unset;
93}
94
95# returns a list of all variables that are currently set, and their values
96# as an array of hash references of the form, "$VAR_NAME => $value"
97sub vars_set {
98
25
25
1
25
    my $self = shift;
99
25
26
    my @set  = ();
100
25
36
    foreach my $ev (@_OMP_VARS) {
101
625
100
1054
        push @set, { $ev => $ENV{$ev} } if $ENV{$ev};
102    }
103
25
61
    return @set;
104}
105
106sub print_omp_summary_unset {
107
1
1
1
1
    my $self = shift;
108
1
3
    return print $self->_omp_summary_unset;
109}
110
111sub _omp_summary_unset {
112
3
3
5
    my $self  = shift;
113
3
4
    my @lines = ();
114
3
5
    push @lines, qq{Summary of OpenMP Environmental UNSET variables supported in this module:};
115  ENV:
116
3
4
    foreach my $ev ( $self->vars_unset ) {
117
25
28
        push @lines, sprintf( qq{%s}, $ev );
118    }
119
3
12
    my $ret = join( qq{\n}, @lines );
120
3
6
    $ret .= print qq{\n};
121
3
100
6
    $ret .= print qq{- none\n} if ( @lines == 1 );
122
3
10
    return $ret;
123}
124
125sub print_omp_summary_set {
126
1
1
1
1
    my $self = shift;
127
1
3
    return print $self->_omp_summary_set;
128}
129
130sub _omp_summary_set {
131
3
3
4
    my $self  = shift;
132
3
4
    my @lines = ();
133
3
4
    push @lines, qq{Summary of OpenMP Environmental SET variables supported in this module:};
134  ENV:
135
3
5
    foreach my $ev_ref ( $self->vars_set ) {
136
50
55
        my $ev  = ( keys %$ev_ref )[0];
137
50
57
        my $val = ( values %$ev_ref )[0];
138
50
81
        push @lines, sprintf( qq{%-25s %s}, $ev, $val );
139    }
140
3
16
    my $ret = join( qq{\n}, @lines );
141
3
6
    $ret .= print qq{\n};
142
3
100
5
    $ret .= print qq{- none\n} if ( @lines == 1 );
143
3
13
    return $ret;
144}
145
146sub print_omp_summary {
147
1
1
1
2
    my $self = shift;
148
1
13
    return print $self->_omp_summary;
149}
150
151sub _omp_summary {
152
5
5
8
    my $self = shift;
153
5
7
    my $ret  = qq{Summary of OpenMP Environmental ALL variables supported in this module:\n};
154
5
8
    $ret .= sprintf( qq{%-25s %s\n}, q{Variable}, q{Value} );
155
5
5
    $ret .= sprintf( qq{%-25s %s\n}, q{~~~~~~~~}, q{~~~~~} );
156  ENV:
157
5
8
    foreach my $ev ( $self->vars ) {
158
125
100
151
        my $val = ( defined $ENV{$ev} ) ? $ENV{$ev} : q{<XXunsetXX>};
159
125
182
        $ret .= sprintf( qq{%-25s %s\n}, $ev, $val );
160    }
161
5
27
    return $ret;
162}
163
164# Return a validation-aware lvalue proxy for one environment variable.
165# FETCH reads the current value from %ENV; STORE routes assignment back through
166# the public accessor so lvalue syntax retains the same validation, filtering,
167# and compatibility behavior as traditional setter calls.
168sub _lvalue_for :lvalue {
169
397
397
594
    my ( $self, $ev, $accessor, $has_override, $override ) = @_;
170
397
330
    my $slot;
171
397
831
    tie $slot, q{OpenMP::Environment::_Lvalue},
172      $self, $ev, $accessor, $has_override, $override;
173
397
1340
    $slot;
174}
175
176# OpenMP Environmental Variable setters/getters
177
178sub omp_allocator :lvalue {
179
8
8
1
14
    my ( $self, $value ) = @_;
180
8
11
    my $ev = q{OMP_ALLOCATOR};
181
8
17
    $self->_get_set_assert( $ev, $value );
182
8
18
    $self->_lvalue_for( $ev, q{omp_allocator} );
183}
184
185sub unset_omp_allocator {
186
4
4
1
11
    my ( $self, $value ) = @_;
187
4
5
    my $ev = q{OMP_ALLOCATOR};
188
4
24
    return delete $ENV{$ev};
189}
190
191sub omp_affinity_format :lvalue {
192
11
11
1
19
    my ( $self, $value ) = @_;
193
11
13
    my $ev = q{OMP_AFFINITY_FORMAT};
194
11
25
    $self->_get_set_assert( $ev, $value );
195
11
20
    $self->_lvalue_for( $ev, q{omp_affinity_format} );
196}
197
198sub unset_omp_affinity_format {
199
3
3
1
10
    my ( $self, $value ) = @_;
200
3
5
    my $ev = q{OMP_AFFINITY_FORMAT};
201
3
20
    return delete $ENV{$ev};
202}
203
204sub omp_display_affinity :lvalue {
205
12
12
1
19
    my ( $self, $value ) = @_;
206
12
16
    my $ev = q{OMP_DISPLAY_AFFINITY};
207
12
24
    $self->_get_set_assert( $ev, $value );
208
11
19
    $self->_lvalue_for( $ev, q{omp_display_affinity} );
209}
210
211sub unset_omp_display_affinity {
212
4
4
1
8
    my ( $self, $value ) = @_;
213
4
5
    my $ev = q{OMP_DISPLAY_AFFINITY};
214
4
20
    return delete $ENV{$ev};
215}
216
217sub omp_cancellation :lvalue {
218
12
12
1
23
    my ( $self, $value ) = @_;
219
12
14
    my $ev = q{OMP_CANCELLATION};
220
12
23
    $self->_get_set_assert( $ev, $value );
221
11
24
    $self->_lvalue_for( $ev, q{omp_cancellation} );
222}
223
224sub unset_omp_cancellation {
225
4
4
1
8
    my ( $self, $value ) = @_;
226
4
6
    my $ev = q{OMP_CANCELLATION};
227
4
22
    return delete $ENV{$ev};
228}
229
230sub omp_display_env :lvalue {
231
14
14
1
25
    my ( $self, $value ) = @_;
232
14
14
    my $ev = q{OMP_DISPLAY_ENV};
233
14
29
    $self->_get_set_assert( $ev, $value );
234
13
21
    $self->_lvalue_for( $ev, q{omp_display_env} );
235}
236
237sub unset_omp_display_env {
238
5
5
1
15
    my ( $self, $value ) = @_;
239
5
13
    my $ev = q{OMP_DISPLAY_ENV};
240
5
24
    return delete $ENV{$ev};
241}
242
243sub omp_default_device :lvalue {
244
31
31
1
44
    my ( $self, $value ) = @_;
245
31
33
    my $ev = q{OMP_DEFAULT_DEVICE};
246
31
49
    $self->_get_set_assert( $ev, $value );
247
28
47
    $self->_lvalue_for( $ev, q{omp_default_device} );
248}
249
250sub unset_omp_default_device {
251
24
24
1
36
    my ( $self, $value ) = @_;
252
24
22
    my $ev = q{OMP_DEFAULT_DEVICE};
253
24
97
    return delete $ENV{$ev};
254}
255
256sub omp_dynamic :lvalue {
257
23
23
1
28
    my $self = shift;
258
23
24
    my $ev = q{OMP_DYNAMIC};
259
23
39
    my ( $has_override, $override );
260
261
23
100
41
    if (@_) {
262
16
18
        my $value = shift;
263
16
20
        my $old = $ENV{$ev};
264
16
100
100
63
        if ( not $value or $value eq q{false} or $value eq q{FALSE} ) {
265
6
22
            $self->unset_omp_dynamic();
266
6
5
            $has_override = 1;
267
6
9
            $override = $old;
268        }
269        else {
270
10
38
            $self->_get_set_assert( $ev, $value );
271        }
272    }
273
274
22
42
    $self->_lvalue_for( $ev, q{omp_dynamic}, $has_override, $override );
275}
276
277sub unset_omp_dynamic {
278
12
12
1
19
    my ( $self, $value ) = @_;
279
12
15
    my $ev = q{OMP_DYNAMIC};
280
12
46
    return delete $ENV{$ev};
281}
282
283sub omp_max_active_levels :lvalue {
284
30
30
1
48
    my ( $self, $value ) = @_;
285
30
30
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
286
30
45
    $self->_get_set_assert( $ev, $value );
287
26
42
    $self->_lvalue_for( $ev, q{omp_max_active_levels} );
288}
289
290sub unset_omp_max_active_levels {
291
22
22
1
32
    my ( $self, $value ) = @_;
292
22
24
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
293
22
89
    return delete $ENV{$ev};
294}
295
296sub omp_max_task_priority :lvalue {
297
31
31
1
53
    my ( $self, $value ) = @_;
298
31
32
    my $ev = q{OMP_MAX_TASK_PRIORITY};
299
31
52
    $self->_get_set_assert( $ev, $value );
300
28
51
    $self->_lvalue_for( $ev, q{omp_max_task_priority} );
301}
302
303sub unset_omp_max_task_priority {
304
24
24
1
44
    my ( $self, $value ) = @_;
305
24
22
    my $ev = q{OMP_MAX_TASK_PRIORITY};
306
24
99
    return delete $ENV{$ev};
307}
308
309sub omp_nested :lvalue {
310
23
23
1
32
    my $self = shift;
311
23
21
    my $ev = q{OMP_NESTED};
312
23
28
    my ( $has_override, $override );
313
314
23
100
42
    if (@_) {
315
16
15
        my $value = shift;
316
16
21
        my $old = $ENV{$ev};
317
16
100
100
64
        if ( not $value or $value eq q{false} or $value eq q{FALSE} ) {
318
6
14
            $self->unset_omp_nested();
319
6
7
            $has_override = 1;
320
6
7
            $override = $old;
321        }
322        else {
323
10
17
            $self->_get_set_assert( $ev, $value );
324        }
325    }
326
327
22
39
    $self->_lvalue_for( $ev, q{omp_nested}, $has_override, $override );
328}
329
330sub unset_omp_nested {
331
10
10
1
20
    my ( $self, $value ) = @_;
332
10
13
    my $ev = q{OMP_NESTED};
333
10
35
    return delete $ENV{$ev};
334}
335
336sub omp_num_threads :lvalue {
337
49
49
1
69
    my ( $self, $value ) = @_;
338
49
46
    my $ev = q{OMP_NUM_THREADS};
339
49
76
    $self->_get_set_assert( $ev, $value );
340
41
63
    $self->_lvalue_for( $ev, q{omp_num_threads} );
341}
342
343sub unset_omp_num_threads {
344
26
26
1
44
    my ( $self, $value ) = @_;
345
26
28
    my $ev = q{OMP_NUM_THREADS};
346
26
105
    return delete $ENV{$ev};
347}
348
349sub omp_num_teams :lvalue {
350
30
30
1
47
    my ( $self, $value ) = @_;
351
30
30
    my $ev = q{OMP_NUM_TEAMS};
352
30
47
    $self->_get_set_assert( $ev, $value );
353
26
44
    $self->_lvalue_for( $ev, q{omp_num_teams} );
354}
355
356sub unset_omp_num_teams {
357
22
22
1
33
    my ( $self, $value ) = @_;
358
22
23
    my $ev = q{OMP_NUM_TEAMS};
359
22
87
    return delete $ENV{$ev};
360}
361
362sub omp_proc_bind :lvalue {
363
9
9
1
14
    my ( $self, $value ) = @_;
364
9
12
    my $ev = q{OMP_PROC_BIND};
365
9
17
    $self->_get_set_assert( $ev, $value );
366
9
19
    $self->_lvalue_for( $ev, q{omp_proc_bind} );
367}
368
369sub unset_omp_proc_bind {
370
5
5
1
25
    my ( $self, $value ) = @_;
371
5
5
    my $ev = q{OMP_PROC_BIND};
372
5
26
    return delete $ENV{$ev};
373}
374
375sub omp_places :lvalue {
376
7
7
1
12
    my ( $self, $value ) = @_;
377
7
9
    my $ev = q{OMP_PLACES};
378
7
16
    $self->_get_set_assert( $ev, $value );
379
7
13
    $self->_lvalue_for( $ev, q{omp_places} );
380}
381
382sub unset_omp_places {
383
3
3
1
8
    my ( $self, $value ) = @_;
384
3
5
    my $ev = q{OMP_PLACES};
385
3
16
    return delete $ENV{$ev};
386}
387
388sub omp_stacksize :lvalue {
389
8
8
1
13
    my ( $self, $value ) = @_;
390
8
8
    my $ev = q{OMP_STACKSIZE};
391
8
16
    $self->_get_set_assert( $ev, $value );
392
8
17
    $self->_lvalue_for( $ev, q{omp_stacksize} );
393}
394
395sub unset_omp_stacksize {
396
4
4
1
8
    my ( $self, $value ) = @_;
397
4
6
    my $ev = q{OMP_STACKSIZE};
398
4
19
    return delete $ENV{$ev};
399}
400
401sub omp_schedule :lvalue {
402
9
9
1
15
    my ( $self, $value ) = @_;
403
9
11
    my $ev = q{OMP_SCHEDULE};
404
9
17
    $self->_get_set_assert( $ev, $value );
405
9
17
    $self->_lvalue_for( $ev, q{omp_schedule} );
406}
407
408sub unset_omp_schedule {
409
5
5
1
11
    my ( $self, $value ) = @_;
410
5
7
    my $ev = q{OMP_SCHEDULE};
411
5
29
    return delete $ENV{$ev};
412}
413
414sub omp_target_offload :lvalue {
415
14
14
1
22
    my ( $self, $value ) = @_;
416
14
15
    my $ev = q{OMP_TARGET_OFFLOAD};
417
14
23
    $self->_get_set_assert( $ev, $value );
418
13
22
    $self->_lvalue_for( $ev, q{omp_target_offload} );
419}
420
421sub unset_omp_target_offload {
422
5
5
1
11
    my ( $self, $value ) = @_;
423
5
5
    my $ev = q{OMP_TARGET_OFFLOAD};
424
5
26
    return delete $ENV{$ev};
425}
426
427sub omp_thread_limit :lvalue {
428
30
30
1
46
    my ( $self, $value ) = @_;
429
30
29
    my $ev = q{OMP_THREAD_LIMIT};
430
30
53
    $self->_get_set_assert( $ev, $value );
431
26
42
    $self->_lvalue_for( $ev, q{omp_thread_limit} );
432}
433
434sub unset_omp_thread_limit {
435
22
22
1
66
    my ( $self, $value ) = @_;
436
22
20
    my $ev = q{OMP_THREAD_LIMIT};
437
22
97
    return delete $ENV{$ev};
438}
439
440sub omp_teams_thread_limit :lvalue {
441
30
30
1
48
    my ( $self, $value ) = @_;
442
30
30
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
443
30
45
    $self->_get_set_assert( $ev, $value );
444
26
47
    $self->_lvalue_for( $ev, q{omp_teams_thread_limit} );
445}
446
447sub unset_omp_teams_thread_limit {
448
22
22
1
33
    my ( $self, $value ) = @_;
449
22
23
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
450
22
94
    return delete $ENV{$ev};
451}
452
453sub omp_wait_policy :lvalue {
454
12
12
1
19
    my ( $self, $value ) = @_;
455
12
15
    my $ev = q{OMP_WAIT_POLICY};
456
12
49
    $self->_get_set_assert( $ev, $value );
457
11
20
    $self->_lvalue_for( $ev, q{omp_wait_policy} );
458}
459
460sub unset_omp_wait_policy {
461
4
4
1
8
    my ( $self, $value ) = @_;
462
4
6
    my $ev = q{OMP_WAIT_POLICY};
463
4
18
    return delete $ENV{$ev};
464}
465
466sub gomp_cpu_affinity :lvalue {
467
7
7
1
13
    my ( $self, $value ) = @_;
468
7
9
    my $ev = q{GOMP_CPU_AFFINITY};
469
7
12
    $self->_get_set_assert( $ev, $value );
470
7
12
    $self->_lvalue_for( $ev, q{gomp_cpu_affinity} );
471}
472
473sub unset_gomp_cpu_affinity {
474
3
3
1
7
    my ( $self, $value ) = @_;
475
3
4
    my $ev = q{GOMP_CPU_AFFINITY};
476
3
17
    return delete $ENV{$ev};
477}
478
479sub gomp_debug :lvalue {
480
10
10
1
15
    my ( $self, $value ) = @_;
481
10
10
    my $ev = q{GOMP_DEBUG};
482
10
18
    $self->_get_set_assert( $ev, $value );
483
9
15
    $self->_lvalue_for( $ev, q{gomp_debug} );
484}
485
486sub unset_gomp_debug {
487
4
4
1
9
    my ( $self, $value ) = @_;
488
4
4
    my $ev = q{GOMP_DEBUG};
489
4
20
    return delete $ENV{$ev};
490}
491
492sub gomp_stacksize :lvalue {
493
7
7
1
13
    my ( $self, $value ) = @_;
494
7
9
    my $ev = q{GOMP_STACKSIZE};
495
7
15
    $self->_get_set_assert( $ev, $value );
496
7
21
    $self->_lvalue_for( $ev, q{gomp_stacksize} );
497}
498
499sub unset_gomp_stacksize {
500
3
3
1
7
    my ( $self, $value ) = @_;
501
3
6
    my $ev = q{GOMP_STACKSIZE};
502
3
14
    return delete $ENV{$ev};
503}
504
505sub gomp_spincount :lvalue {
506
11
11
1
16
    my ( $self, $value ) = @_;
507
11
14
    my $ev = q{GOMP_SPINCOUNT};
508
11
20
    $self->_get_set_assert( $ev, $value );
509
11
22
    $self->_lvalue_for( $ev, q{gomp_spincount} );
510}
511
512sub unset_gomp_spincount {
513
3
3
1
8
    my ( $self, $value ) = @_;
514
3
3
    my $ev = q{GOMP_SPINCOUNT};
515
3
16
    return delete $ENV{$ev};
516}
517
518sub gomp_rtems_thread_pools :lvalue {
519
7
7
1
11
    my ( $self, $value ) = @_;
520
7
10
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
521
7
14
    $self->_get_set_assert( $ev, $value );
522
7
21
    $self->_lvalue_for( $ev, q{gomp_rtems_thread_pools} );
523}
524
525sub unset_gomp_rtems_thread_pools {
526
3
3
1
8
    my ( $self, $value ) = @_;
527
3
5
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
528
3
17
    return delete $ENV{$ev};
529}
530
531# auxilary validation routines for with Validate::Tiny
532
533# used to assert valid environment, useful if variables are already set externally
534sub assert_omp_environment {
535
20
20
1
24
    my $self = shift;
536  ENV:
537
20
24
    foreach my $ev_ref ( $self->vars_set ) {
538
133
248
        my $ev  = ( keys %$ev_ref )[0];
539
133
183
        my $val = ( values %$ev_ref )[0];
540
133
163
        $self->_get_set_assert( $ev, $val );
541    }
542
5
29
    return 1;
543}
544
545sub _get_set_assert {
546
542
542
692
    my ( $self, $ev, $value ) = @_;
547
542
100
823
    if ( defined $value ) {
548
432
522
        my $filtered_value = $self->_assert_valid( $ev, $value );
549
379
1627
        $ENV{$ev} = $filtered_value;
550    }
551
489
100
909
    return ( exists $ENV{$ev} ) ? $ENV{$ev} : undef;
552}
553
554sub _assert_valid {
555
434
434
456
    my ( $self, $ev, $value ) = @_;
556
434
1091
    my $result = Validate::Tiny::validate( { $ev => $value }, $self->{_validation_rules} );
557
558    # process errors, then die
559
434
69169
    my $err;
560
434
434
411
772
    foreach my $e ( keys %{ $result->{error} } ) {
561
54
70
        my $msg = $result->{error}->{$e};
562
54
64
        my $val = $result->{data}->{$e};
563
54
95
        $err = qq{(fatal) $e="$val": $msg\n};
564    }
565
434
100
1043
    die qq{$err\n} if not $result->{success};
566
567    # if all is okay, return the filtered value (since we're testing what's been passed through 'filters' for some envars
568
380
943
    return $result->{data}->{$ev};
569}
570
571# provides validator that does nothing, a null validator useful as a place holder
572sub _no_validate {
573    return sub {
574
4341
4341
631145
        return undef;
575
41
41
301
    };
576}
577
578package OpenMP::Environment::_Lvalue;
579
580
4
4
4
4
22
5
72
use strict;
581
4
4
4
4
13
10
683
use warnings;
582
583sub TIESCALAR {
584
397
397
569
    my ( $class, $owner, $ev, $accessor, $has_override, $override ) = @_;
585
397
1203
    return bless {
586        owner        => $owner,
587        ev           => $ev,
588        accessor     => $accessor,
589        has_override => $has_override,
590        override     => $override,
591    }, $class;
592}
593
594sub FETCH {
595
323
323
3168
    my $self = shift;
596
323
100
512
    return $self->{override} if $self->{has_override};
597
313
814
    return $ENV{ $self->{ev} };
598}
599
600sub STORE {
601
39
39
58
    my ( $self, $value ) = @_;
602
39
46
    my $owner    = $self->{owner};
603
39
39
    my $accessor = $self->{accessor};
604
39
77
    $owner->$accessor($value);
605
38
77
    return;
606}
607
608package OpenMP::Environment;
609
6101;
611