view release on metacpan or  search on metacpan

t/07-core-units.t  view on Meta::CPAN

    make_path($young_dir);
    ok( !$branch_keeper->_state_root_is_stale( $young_dir, 3600 ), '_state_root_is_stale keeps roots that are not yet old enough' );
}

{
    my $removal_home = tempdir(CLEANUP => 1);
    my $removal_paths = Developer::Dashboard::PathRegistry->new( home => $removal_home );
    my $removal_keeper = Developer::Dashboard::Housekeeper->new( paths => $removal_paths );
    my $removal_target = File::Spec->catdir( $removal_home, 'remove-me' );
    make_path($removal_target);
    is_deeply(
        $removal_keeper->_remove_tree( $removal_target, 'state-root' ),
        { kind => 'state-root', path => $removal_target },
        '_remove_tree returns a summary payload for successful removals',
    );
    {
        no warnings 'redefine';
        local *Developer::Dashboard::Housekeeper::remove_tree = sub {
            my ( $path, $opts ) = @_;
            ${ $opts->{error} } = [ { $path => 'Permission denied' } ];
            return 0;
        };
        dies_like(
            sub { $removal_keeper->_remove_tree( File::Spec->catdir( $removal_home, 'broken' ), 'state-root' ) },
            qr/Unable to remove stale state-root/,
            '_remove_tree dies when remove_tree reports a non-ENOENT failure',
        );
    }
}

{
    my $ajax_home = tempdir(CLEANUP => 1);
    my $ajax_paths = Developer::Dashboard::PathRegistry->new( home => $ajax_home );
    my $ajax_keeper = Developer::Dashboard::Housekeeper->new( paths => $ajax_paths );

    my ( $cleanup_ajax_fh, $cleanup_ajax_path ) = tempfile( 'developer-dashboard-ajax-XXXXXX', TMPDIR => 1, UNLINK => 0 );
    print {$cleanup_ajax_fh} "ajax payload";
    close $cleanup_ajax_fh or die "Unable to close $cleanup_ajax_path: $!";
    utime time - 7200, time - 7200, $cleanup_ajax_path or die "Unable to age $cleanup_ajax_path: $!";

    my ( $cleanup_result_fh, $cleanup_result_path ) = tempfile( 'dashboard-result-XXXXXX', TMPDIR => 1, UNLINK => 0 );
    print {$cleanup_result_fh} "result payload";
    close $cleanup_result_fh or die "Unable to close $cleanup_result_path: $!";
    utime time - 7200, time - 7200, $cleanup_result_path or die "Unable to age $cleanup_result_path: $!";

    my @removed = $ajax_keeper->_cleanup_temp_files(
        min_age_seconds => 60,
        scanned         => { state_roots => 0, ajax_temp_files => 0, result_temp_files => 0 },
    );
    ok( !-e $cleanup_ajax_path, '_cleanup_temp_files removes old ajax temp files' );
    ok( !-e $cleanup_result_path, '_cleanup_temp_files removes old runtime result temp files' );
    ok(
        grep( { $_->{kind} eq 'ajax-temp-file' && $_->{path} eq $cleanup_ajax_path } @removed ),
        '_cleanup_temp_files reports removed ajax temp files',
    );
    ok(
        grep( { $_->{kind} eq 'result-temp-file' && $_->{path} eq $cleanup_result_path } @removed ),
        '_cleanup_temp_files reports removed runtime result temp files',
    );

    my $blocked_tmp = tempdir( CLEANUP => 1 );
    my ( $ajax_fh, $ajax_path ) = tempfile(
        'developer-dashboard-ajax-FAIL-XXXXXX',
        DIR    => $blocked_tmp,
        UNLINK => 0,
    );
    print {$ajax_fh} "still here";
    close $ajax_fh or die "Unable to close $ajax_path: $!";
    utime time - 7200, time - 7200, $ajax_path or die "Unable to age $ajax_path: $!";
    if ( $> == 0 ) {
        pass('_cleanup_ajax_temp_files unlink-failure branch is skipped under root because root can still remove the temp file despite directory permission tightening');
    }
    else {
        chmod 0555, $blocked_tmp or die "Unable to chmod $blocked_tmp: $!";
        {
            no warnings qw(redefine once);
            local *File::Spec::tmpdir = sub { return $blocked_tmp };
            dies_like(
                sub {
                    $ajax_keeper->_cleanup_temp_files(
                        min_age_seconds => 60,
                        scanned         => { state_roots => 0, ajax_temp_files => 0, result_temp_files => 0 },
                    );
                },
                qr/Unable to remove stale Ajax temp file/,
                '_cleanup_temp_files dies when unlink fails and the temp file still exists',
            );
        }
        chmod 0755, $blocked_tmp or die "Unable to restore $blocked_tmp permissions: $!";
    }
    unlink $ajax_path or die "Unable to remove $ajax_path after ajax unlink failure coverage: $!";
}

dies_like( sub { Developer::Dashboard::UpdateManager->new }, qr/Missing config/, 'update manager requires config' );

{
    package Local::EnvLoader::Functions;

    sub from_env {
        return $ENV{FUNCTION_SOURCE};
    }

    sub blank_value {
        return '';
    }
}

{
    my $env_home = tempdir( CLEANUP => 1 );
    my $previous_cwd = getcwd();
    my $project_root = File::Spec->catdir( $env_home, 'projects', 'env-audit-project' );
    my $child_root = File::Spec->catdir( $project_root, 'child' );
    make_path(
        File::Spec->catdir( $env_home, '.developer-dashboard' ),
        File::Spec->catdir( $project_root, '.git' ),
        File::Spec->catdir( $child_root, '.developer-dashboard' ),
    );
    {
        open my $fh, '>:raw', File::Spec->catfile( $env_home, '.env' ) or die "Unable to write home .env: $!";
        print {$fh} <<'EOF';
ROOT_ONLY=root
SHARED=home
COMPLEX=one=two
# hash comment
// slash comment
/* multi
line
comment */
HOME_REF=~/runtime
SYSTEM_REF=$SYSTEM_ONLY
DEFAULT_REF=${MISSING_VALUE:-fallback}
FUNCTION_REF=${Local::EnvLoader::Functions::from_env():-fallback}
FUNCTION_DEFAULT=${Local::EnvLoader::Functions::blank_value():-fallback-from-function}
CHAIN_REF=$ROOT_ONLY/$SYSTEM_REF
EOF
        close $fh or die "Unable to close home .env: $!";
    }
    {
        open my $fh, '>:raw', File::Spec->catfile( $env_home, '.env.pl' ) or die "Unable to write home .env.pl: $!";
        print {$fh} "\$ENV{ROOT_PL} = \"\$ENV{ROOT_ONLY}-pl\";\n\$ENV{PL_SHARED} = 'home-pl';\n1;\n";
        close $fh or die "Unable to close home .env.pl: $!";
    }
    {
        open my $fh, '>:raw', File::Spec->catfile( $env_home, '.developer-dashboard', '.env' )
          or die "Unable to write home runtime .env: $!";
        print {$fh} "HOME_DD=home-dd\nSHARED=home-dd\n";
        close $fh or die "Unable to close home runtime .env: $!";
    }
    {