view release on metacpan or  search on metacpan

lib/Data/Printer/Config.pm  view on Meta::CPAN

    require Cwd;
    my $cwd = Cwd::getcwd();
    # try harder if we can't access the current dir.
    $cwd = Cwd::cwd() unless defined $cwd;
    return $cwd;
}

sub _project_home {
    require Cwd;
    my $path;
    if ($0 eq '-e' || $0 eq '-') {
        my $cwd = _my_cwd();
        $path = Cwd::abs_path($cwd) if defined $cwd;
    }
    else {
        my $script = $0;
        return unless -f $script;
        require File::Spec;
        require File::Basename;
        # we need the full path if we have chdir'd:
        $script = File::Spec->catfile(_my_cwd(), $script)
            unless File::Spec->file_name_is_absolute($script);
        my (undef, $maybe_path) = File::Basename::fileparse($script);
        $path = Cwd::abs_path($maybe_path) if defined $maybe_path;
    }
    return $path;
}

# adapted from File::HomeDir && File::HomeDir::Tiny
sub _my_home {
    my ($testing) = @_;
    if ($testing) {
        require File::Temp;
        require File::Spec;
        my $BASE  = File::Temp::tempdir( CLEANUP => 1 );
        my $home  = File::Spec->catdir( $BASE, 'my_home' );
        $ENV{HOME} = $home;
        mkdir($home, 0755) unless -d $home;
        return $home;
    }
    elsif ($^O eq 'MSWin32' and "$]" < 5.016) {
        return $ENV{HOME} || $ENV{USERPROFILE};
    }
    elsif ($^O eq 'MacOS') {
        my $error = _tryme(sub { require Mac::SystemDirectory; 1 });
        return Mac::SystemDirectory::HomeDirectory() unless $error;
    }
    # this is the most common case, for most breeds of unix, as well as
    # MSWin32 in more recent perls.
    my $home = (<~>)[0];
    return $home if $home;

    # desperate measures that should never be needed.
    if (exists $ENV{LOGDIR} and $ENV{LOGDIR}) {
        $home = $ENV{LOGDIR};
    }
    if (not $home and exists $ENV{HOME} and $ENV{HOME}) {
        $home = $ENV{HOME};
    }
    # Light desperation on any (Unixish) platform
    SCOPE: { $home = (getpwuid($<))[7] if not defined $home }
    if (defined $home and ! -d $home ) {
        $home = undef;
    }
    return $home;
}

sub _file_mode_is_restricted {
    my ($filename) = @_;
    my $mode_raw = (stat($filename))[2];
    return 0 unless defined $mode_raw;
    my $mode = sprintf('%04o', $mode_raw & 07777);
    return (length($mode) == 4 && substr($mode, 2, 2) eq '00') ? 1 : 0;
}

sub _str2data {
    my ($filename, $content) = @_;
    my $config = { _ => {} };
    my $counter = 0;
    my $filter;
    my $can_use_filters;
    my $ns = '_';
    # based on Config::Tiny
    foreach ( split /(?:\015{1,2}\012|\015|\012)/, $content ) {
        $counter++;
        if (defined $filter) {
            if ( /^end filter\s*$/ ) {
                if (!defined $can_use_filters) {
                    $can_use_filters = _file_mode_is_restricted($filename);
                }
                if ($can_use_filters) {
                    my $sub_str = 'sub { my ($obj, $ddp) = @_; '
                                . $filter->{code_str}
                                . '}'
                                ;
                    push @{$config->{$ns}{filters}}, +{ $filter->{name} => eval $sub_str };
                }
                else {
                    Data::Printer::Common::_warn(undef, "ignored filter '$filter->{name}' from rc file '$filename': file is readable/writeable by others");
                }
                $filter = undef;
            }
            elsif ( /^begin\s+filter/ ) {
                Data::Printer::Common::_warn(undef, "error reading rc file '$filename' line $counter: found 'begin filter' inside another filter definition ($filter->{name}). Are you missing an 'end filter' on line " . ($counter - 1) . '?');
                return {};
            }
            else {
                $filter->{code_str} .= $_;
            }
        }
        elsif ( /^\s*(?:\#|\;|$)/ ) {
            next # skip comments and empty lines
        }
        elsif ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) {
            # Create the sub-hash if it doesn't exist.
            # Without this, sections without keys will not
            # appear at all in the completed struct.
            $config->{$ns = $1} ||= {};
        }
        elsif ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
            # Handle properties: