view release on metacpan or  search on metacpan

lib/Config/Scoped.pm  view on Meta::CPAN

    # now we have baz = {}

    # application validation
    my $valid_value = $thisparser->declaration_validate( %args, tail => $tail );

    # store the current scope in the last $config->{foo}...{baz} = $params
    # use deep copy to break dependencies when config parameters
    # get's changed in the application in different declarations
    return %$tail = %{ dclone( $args{value} ) };
}

sub declaration_validate {
    my $thisparser = shift;
    my %args       = @_;

    Config::Scoped::Error->throw(
        -text => Carp::shortmess("missing parameters") )
      unless ( defined $args{name} && defined $args{value} );

    # warnings for declarations enabled and 'tail' already set?
    if ( $thisparser->warnings_on( name => 'declaration', ) ) {
        Config::Scoped::Error::Validate::Declaration->throw(
            -file => $thisparser->_get_file(%args),
            -line => $thisparser->_get_line(%args),
            -text => "declaration redefinition for '@{$args{name}}'"
          )
          if %{ $args{tail} };
    }

    # return unchanged, subclass methods may do it different
    return $args{value};
}

sub permissions_validate {
    my $thisparser = shift;
    my %args       = @_;

    Config::Scoped::Error->throw(
        -text => Carp::shortmess("missing parameters") )
      unless ( defined $args{handle} || defined $args{file} );

    my $warnings = $thisparser->{local}{warnings};

    # warnings for files enabled?
    return 1
      unless $thisparser->warnings_on(
        name     => 'permissions',
        warnings => $warnings,
      );

    my $fh = $args{handle} || $args{file};

    # mysteriously vaporized
    Config::Scoped::Error::IO->throw(
        -file => $thisparser->_get_file(%args),
        -line => $thisparser->_get_line(%args),
        -text => "'$args{file}' can't stat cfg file/handle: $!"
      )
      unless stat $fh;

    my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);

    # owner is not root and not real uid
    Config::Scoped::Error::Validate::Permissions->throw(
        -file => $thisparser->_get_file(%args),
        -line => $thisparser->_get_line(%args),
        -text => "'$args{file}' is unsafe: owner is not root and not real uid",
      )
      if $uid != 0 && $uid != $<;

    Config::Scoped::Error::Validate::Permissions->throw(
        -file => $thisparser->_get_file(%args),
        -line => $thisparser->_get_line(%args),
        -text => "'$args{file}' is unsafe: writeable by group or others",
      )
      if $mode & 022;

    return 1;
}

# handle quoted strings, expand macro's and interpolate backslash
# patterns like \t, \n, etc. Called as action from within the grammar.
sub _quotelike {
    my $thisparser = shift;
    my %args       = @_;

    Config::Scoped::Error->throw(
        -text => Carp::shortmess("missing parameter") )
      unless defined $args{value};

    my $value = $args{value};

    # accepts only '', "", <<foo, <<'foo', <<"foo" quotes and
    # not q, qq, qx, qw, ..., s///, tr/// etc.
    my %accept = ( single => 1, double => 1, '<<' => 1 );

    # see Text::Balanced::extract_quotelike() to understand this
    # and of course Parse::RecDescent <perl_quotelike> directive
    my $quote_name  = $value->[0];
    my $quote_delim = substr( $value->[1], 0, 1 );
    my $quote_text  = $value->[2];

    # the quote_name isn't set with plain quotes, set it now
    unless ($quote_name) {
        $quote_name = 'double' if $quote_delim eq '"';
        $quote_name = 'single' if $quote_delim eq "'";
    }

    # let the rule fail if not an accepted quote name
    return undef unless $accept{$quote_name};

    # backslash substitution in double quoted strings is
    # done by reval() in the Safe compartment since
    # it's possible to smuggle a subroutine call
    # in a double quoted string.
    #
    $quote_text = $thisparser->_perl_code( expr => "\"$quote_text\"" )
      unless $quote_name eq 'single' || $quote_delim eq "'";

    # macro expansion for double quoted constructs
    $quote_text = $thisparser->_expand_macro( %args, value => $quote_text )