File Coverage

lib/OpenMP/Environment.pm

Criterion	Covered	Total	%
statement	200	231	86.5
branch	19	26	73.0
condition	14	15	93.3
subroutine	60	66	90.9
pod	52	52	100.0
total	345	390	88.4

package OpenMP::Environment;
use strict;
use warnings;

use Validate::Tiny qw/filter is_in/;

our $VERSION = q{1.2.0};

our @_OMP_VARS = (
    qw/OMP_CANCELLATION OMP_DISPLAY_ENV OMP_DEFAULT_DEVICE OMP_NUM_TEAMS
      OMP_DYNAMIC OMP_MAX_ACTIVE_LEVELS OMP_MAX_TASK_PRIORITY OMP_NESTED
      OMP_NUM_THREADS OMP_PROC_BIND OMP_PLACES OMP_STACKSIZE OMP_SCHEDULE
      OMP_TARGET_OFFLOAD OMP_THREAD_LIMIT OMP_WAIT_POLICY GOMP_CPU_AFFINITY
      GOMP_DEBUG GOMP_STACKSIZE GOMP_SPINCOUNT GOMP_RTEMS_THREAD_POOLS
      OMP_TEAMS_THREAD_LIMIT/
);

# capture state of %ENV
local %ENV = %ENV;

# constructor
sub new {
    my $pkg = shift;

    my $validate_rules = {
        fields  => \@_OMP_VARS,
        filters => [
            [qw/OMP_CANCELLATION OMP_NESTED OMP_DISPLAY_ENV OMP_TARGET_OFFLOAD OMP_WAIT_POLICY/] => filter('uc'),    # force to upper case for convenience
        ],
        checks => [
            [qw/OMP_DYNAMIC OMP_NESTED/]                                 => is_in( [qw/TRUE true 1 FALSE false 0/],  q{Expected values are: 'true', 1, 'false', or 0} ),
            [qw/OMP_CANCELLATION/]                                       => is_in( [qw/TRUE FALSE/],                 q{Expected values are: 'TRUE' or 'FALSE'} ),
            OMP_DISPLAY_ENV                                              => is_in( [qw/TRUE VERBOSE FALSE/],         q{Expected values are: 'TRUE', 'VERBOSE', or 'FALSE'} ),
            OMP_TARGET_OFFLOAD                                           => is_in( [qw/MANDATORY DISABLED DEFAULT/], q{Expected values are: 'MANDATORY', 'DISABLED', or 'DEFAULT'} ),
            OMP_WAIT_POLICY                                              => is_in( [qw/ACTIVE PASSIVE/],             q{Expected values are: 'ACTIVE' or 'PASSIVE'} ),
            GOMP_DEBUG                                                   => is_in( [qw/0 1/],                        q{Expected values are: 0 or 1} ),
            [qw/OMP_MAX_TASK_PRIORITY OMP_DEFAULT_DEVICE/]               => sub { return _is_ge_if_set( 0, @_ ) },
            [qw/OMP_NUM_THREADS OMP_MAX_ACTIVE_LEVELS OMP_THREAD_LIMIT/] => sub { return _is_ge_if_set( 1, @_ ) },
            [qw/OMP_NUM_TEAMS OMP_TEAMS_THREAD_LIMIT/]                   => sub { return _is_ge_if_set( 1, @_ ) },

            #-- the following are not current validated due to the complexity of the rules associated with their values
            OMP_PROC_BIND           => _no_validate(),
            OMP_PLACES              => _no_validate(),
            OMP_STACKSIZE           => _no_validate(),
            OMP_SCHEDULE            => _no_validate(),
            GOMP_CPU_AFFINITY       => _no_validate(),
            GOMP_STACKSIZE          => _no_validate(),
            GOMP_SPINCOUNT          => _no_validate(),
            GOMP_RTEMS_THREAD_POOLS => _no_validate(),
        ],
    };

    sub _is_ge_if_set {
        my ( $min, $value ) = @_;
        if ( not defined $value ) {
            return;
        }
        elsif ( $value =~ m/\D/ or $value lt $min ) {
            return q{Value must be an integer great than or equal to 1};
        }
        return;
    }

    my $self = { _validation_rules => $validate_rules, };
    return bless $self, $pkg;
}

# returns a list of variables supported (no values)
sub vars {
    my $self = shift;
    return @_OMP_VARS;
}

# returns a list of variables unset (value not set so don't need it)
sub vars_unset {
    my $self  = shift;
    my @unset = ();
    foreach my $ev (@_OMP_VARS) {
        push @unset, $ev if not $ENV{$ev};
    }
    return @unset;
}

# returns a list of all variables that are currently set, and their values
# as an array of hash references of the form, "$VAR_NAME => $value"
sub vars_set {
    my $self = shift;
    my @set  = ();
    foreach my $ev (@_OMP_VARS) {
        push @set, { $ev => $ENV{$ev} } if $ENV{$ev};
    }
    return @set;
}

sub print_omp_summary_unset {
    my $self = shift;
    return print $self->_omp_summary_unset;
}

sub _omp_summary_unset {
    my $self  = shift;
    my @lines = ();
    push @lines, qq{Summary of OpenMP Environmental UNSET variables supported in this module:};
  ENV:
    foreach my $ev ( $self->vars_unset ) {
        push @lines, sprintf( qq{%s}, $ev );
    }
    my $ret = join( qq{\n}, @lines );
    $ret .= print qq{\n};
    $ret .= print qq{- none\n} if ( @lines == 1 );
    return $ret;
}

sub print_omp_summary_set {
    my $self = shift;
    return print $self->_omp_summary_set;
}

sub _omp_summary_set {
    my $self  = shift;
    my @lines = ();
    push @lines, qq{Summary of OpenMP Environmental SET variables supported in this module:};
  ENV:
    foreach my $ev_ref ( $self->vars_set ) {
        my $ev  = ( keys %$ev_ref )[0];
        my $val = ( values %$ev_ref )[0];
        push @lines, sprintf( qq{%-25s %s}, $ev, $val );
    }
    my $ret = join( qq{\n}, @lines );
    $ret .= print qq{\n};
    $ret .= print qq{- none\n} if ( @lines == 1 );
    return $ret;
}

sub print_omp_summary {
    my $self = shift;
    return print $self->_omp_summary;
}

sub _omp_summary {
    my $self = shift;
    my $ret  = qq{Summary of OpenMP Environmental ALL variables supported in this module:\n};
    $ret .= sprintf( qq{%-25s %s\n}, q{Variable}, q{Value} );
    $ret .= sprintf( qq{%-25s %s\n}, q{~~~~~~~~}, q{~~~~~} );
  ENV:
    foreach my $ev ( $self->vars ) {
        my $val = ( defined $ENV{$ev} ) ? $ENV{$ev} : q{};
        $ret .= sprintf( qq{%-25s %s\n}, $ev, $val );
    }
    return $ret;
}

# OpenMP Environmental Variable setters/getters

sub omp_cancellation {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_CANCELLATION};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_cancellation {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_CANCELLATION};
    return delete $ENV{$ev};
}

sub omp_display_env {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DISPLAY_ENV};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_display_env {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DISPLAY_ENV};
    return delete $ENV{$ev};
}

sub omp_default_device {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DEFAULT_DEVICE};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_default_device {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DEFAULT_DEVICE};
    return delete $ENV{$ev};
}

sub omp_dynamic {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DYNAMIC};
    my $old = $ENV{OMP_DYNAMIC};
    if (not $value or $value eq q{false} or $value eq q{FALSE}) {
     $self->unset_omp_dynamic();
     return $old;
    }
    else {
      return $self->_get_set_assert( $ev, $value );
    }
}

sub unset_omp_dynamic {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_DYNAMIC};
    return delete $ENV{$ev};
}

sub omp_max_active_levels {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_max_active_levels {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_MAX_ACTIVE_LEVELS};
    return delete $ENV{$ev};
}

sub omp_max_task_priority {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_MAX_TASK_PRIORITY};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_max_task_priority {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_MAX_TASK_PRIORITY};
    return delete $ENV{$ev};
}

sub omp_nested {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NESTED};
    my $old = $ENV{OMP_NESTED};
    if (not $value or $value eq q{false} or $value eq q{FALSE}) {
     $self->unset_omp_nested();
     return $old;
    }
    else {
      return $self->_get_set_assert( $ev, $value );
    }
}

sub unset_omp_nested {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NESTED};
    return delete $ENV{$ev};
}

sub omp_num_threads {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NUM_THREADS};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_num_threads {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NUM_THREADS};
    return delete $ENV{$ev};
}

sub omp_num_teams {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NUM_TEAMS};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_num_teams {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_NUM_TEAMS};
    return delete $ENV{$ev};
}

sub omp_proc_bind {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_PROC_BIND};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_proc_bind {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_PROC_BIND};
    return delete $ENV{$ev};
}

sub omp_places {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_PLACES};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_places {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_PLACES};
    return delete $ENV{$ev};
}

sub omp_stacksize {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_STACKSIZE};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_stacksize {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_STACKSIZE};
    return delete $ENV{$ev};
}

sub omp_schedule {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_SCHEDULE};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_schedule {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_SCHEDULE};
    return delete $ENV{$ev};
}

sub omp_target_offload {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_TARGET_OFFLOAD};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_target_offload {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_TARGET_OFFLOAD};
    return delete $ENV{$ev};
}

sub omp_thread_limit {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_THREAD_LIMIT};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_thread_limit {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_THREAD_LIMIT};
    return delete $ENV{$ev};
}

sub omp_teams_thread_limit {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_teams_thread_limit {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_TEAMS_THREAD_LIMIT};
    return delete $ENV{$ev};
}

sub omp_wait_policy {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_WAIT_POLICY};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_omp_wait_policy {
    my ( $self, $value ) = @_;
    my $ev = q{OMP_WAIT_POLICY};
    return delete $ENV{$ev};
}

sub gomp_cpu_affinity {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_CPU_AFFINITY};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_gomp_cpu_affinity {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_CPU_AFFINITY};
    return delete $ENV{$ev};
}

sub gomp_debug {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_DEBUG};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_gomp_debug {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_DEBUG};
    return delete $ENV{$ev};
}

sub gomp_stacksize {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_STACKSIZE};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_gomp_stacksize {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_STACKSIZE};
    return delete $ENV{$ev};
}

sub gomp_spincount {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_SPINCOUNT};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_gomp_spincount {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_SPINCOUNT};
    return delete $ENV{$ev};
}

sub gomp_rtems_thread_pools {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
    return $self->_get_set_assert( $ev, $value );
}

sub unset_gomp_rtems_thread_pools {
    my ( $self, $value ) = @_;
    my $ev = q{GOMP_RTEMS_THREAD_POOLS};
    return delete $ENV{$ev};
}

# auxilary validation routines for with Validate::Tiny

# used to assert valid environment, useful if variables are already set externally
sub assert_omp_environment {
    my $self  = shift;
    my @lines = ();
  ENV:
    foreach my $ev_ref ( $self->vars_set ) {
        my $ev  = ( keys %$ev_ref )[0];
        my $val = ( values %$ev_ref )[0];
        $self->_get_set_assert( $ev, $ENV{$ev} ) if exists $ENV{$ev};
    }
    return 1;
}

sub _get_set_assert {
    my ( $self, $ev, $value ) = @_;
    if ( defined $value ) {
        my $filtered_value = $self->_assert_valid( $ev, $value );
        $ENV{$ev} = $filtered_value;
    }
    return ( exists $ENV{$ev} ) ? $ENV{$ev} : undef;
}

sub _assert_valid {
    my ( $self, $ev, $value ) = @_;
    my $result = Validate::Tiny::validate( { $ev => $value }, $self->{_validation_rules} );

    # process errors, then die
    my $err;
    foreach my $e ( keys %{ $result->{error} } ) {
        my $msg = $result->{error}->{$e};
        my $val = $result->{data}->{$e};
        $err = qq{(fatal) $e="$val": $msg\n};
    }
    die qq{$err\n} if not $result->{success};

    # if all is okay, return the filtered value (since we're testing what's been passed through 'filters' for some envars
    return $result->{data}->{$ev};
}

# provides validator that does nothing, a null validator useful as a place holder
sub _no_validate {
    return sub {
        return undef;
    };
}

1;

__END__