view release on metacpan or  search on metacpan

lib/Config/IOD/Base.pm  view on Meta::CPAN

                 \z/x or return ("Invalid syntax in braced hash value");
        my $res; $res = [
            '{', # COL_V_ENCODING
            '', # COL_V_WS1
            $1, # VOL_V_VALUE
            $2, # COL_V_WS2
            $3, # COL_V_COMMENT_CHAR
            $4, # COL_V_COMMENT
        ] if $needs_res;
        my $decode_res = $self->_decode_json("{$1}");
        return ($decode_res->[1]) unless $decode_res->[0] == 200;
        return (undef, $res, $decode_res->[2]);

    } elsif ($val =~ /\A~/ && $self->{enable_tilde}) {

        $val =~ /\A
                 ~(.*)
                 (\s*)
                 (?: ([;#])(.*) )?
                 \z/x or return ("Invalid syntax in path value");
        my $res; $res = [
            '~', # COL_V_ENCODING
            '', # COL_V_WS1
            $1, # VOL_V_VALUE
            $2, # COL_V_WS2
            $3, # COL_V_COMMENT_CHAR
            $4, # COL_V_COMMENT
        ] if $needs_res;

        my $decode_res = $self->_decode_path_or_paths($val, 'path');
        return ($decode_res->[1]) unless $decode_res->[0] == 200;
        return (undef, $res, $decode_res->[2]);

    } else {

        $val =~ /\A
                 (.*?)
                 (\s*)
                 (?: ([#;])(.*) )?
                 \z/x or return ("Invalid syntax in value"); # shouldn't happen, regex should match any string
        my $res; $res = [
            '', # COL_V_ENCODING
            '', # COL_V_WS1
            $1, # VOL_V_VALUE
            $2, # COL_V_WS2
            $3, # COL_V_COMMENT_CHAR
            $4, # COL_V_COMMENT
        ] if $needs_res;
        return (undef, $res, $1);

    }
    # should not be reached
}

sub _get_my_user_name {
    if ($^O eq 'MSWin32') {
        return $ENV{USERNAME};
    } else {
        return $ENV{USER} if $ENV{USER};
        my @pw;
        eval { @pw = getpwuid($>) };
        return $pw[0] if @pw;
    }
}

# borrowed from PERLANCAR::File::HomeDir 0.04
sub _get_my_home_dir {
    if ($^O eq 'MSWin32') {
        # File::HomeDir always uses exists($ENV{x}) first, does it want to avoid
        # accidentally creating env vars?
        return $ENV{HOME} if $ENV{HOME};
        return $ENV{USERPROFILE} if $ENV{USERPROFILE};
        return join($ENV{HOMEDRIVE}, "\\", $ENV{HOMEPATH})
            if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
    } else {
        return $ENV{HOME} if $ENV{HOME};
        my @pw;
        eval { @pw = getpwuid($>) };
        return $pw[7] if @pw;
    }

    die "Can't get home directory";
}

# borrowed from PERLANCAR::File::HomeDir 0.05, with some modifications
sub _get_user_home_dir {
    my ($name) = @_;

    if ($^O eq 'MSWin32') {
        # not yet implemented
        return undef; ## no critic: Subroutines::ProhibitExplicitReturnUndef
    } else {
        # IF and only if we have getpwuid support, and the name of the user is
        # our own, shortcut to my_home. This is needed to handle HOME
        # environment settings.
        if ($name eq getpwuid($<)) {
            return _get_my_home_dir();
        }

      SCOPE: {
            my $home = (getpwnam($name))[7];
            return $home if $home and -d $home;
        }

        return undef; ## no critic: Subroutines::ProhibitExplicitReturnUndef
    }

}

sub _decode_json {
    my ($self, $val) = @_;
    state $json = do {
        if (eval { require Cpanel::JSON::XS; 1 }) {
            Cpanel::JSON::XS->new->allow_nonref;
        } else {
            require JSON::PP;
            JSON::PP->new->allow_nonref;
        }
    };
    my $res;
    eval { $res = $json->decode($val) };
    if ($@) {
        return [500, "Invalid JSON: $@"];
    } else {
        return [200, "OK", $res];
    }
}

sub _decode_path_or_paths {
    my ($self, $val, $which) = @_;

    if ($val =~ m!\A~([^/]+)?(?:/|\z)!) {
        my $home_dir = length($1) ?
            _get_user_home_dir($1) : _get_my_home_dir();
        unless ($home_dir) {
            if (length $1) {
                return [500, "Can't get home directory for user '$1' in path"];
            } else {
                return [500, "Can't get home directory for current user in path"];
            }
        }
        $val =~ s!\A~([^/]+)?!$home_dir!;
    }
    $val =~ s!(?<=.)/\z!!;

    if ($which eq 'path') {
        return [200, "OK", $val];
    } else {
        return [200, "OK", [glob $val]];
    }
}

sub _decode_hex {
    my ($self, $val) = @_;
    [200, "OK", pack("H*", $val)];
}