view release on metacpan or  search on metacpan

t/120-error-message-sweep.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use lib 't/lib';
use TestGit qw( require_git_c );
require_git_c();
use TestKarr qw( run_karr );
use File::Temp qw( tempdir );
use Path::Tiny qw( path );
use Cwd qw( abs_path getcwd );
use IPC::Open3 qw( open3 );
use Symbol qw( gensym );

use App::karr::Role::SyncLifecycle;
use App::karr::Task;

# Ticket #77, the rest of the sweep that t/81-error-messages.t deliberately left
# alone. Every case below was reproduced against the pre-fix tree, and every
# "no source location" assertion here fails against it:
#
#   $ cd /tmp/not-a-repo && karr list
#   Not a git repository. karr requires Git.
#    at /.../lib/App/karr/Role/BoardDiscovery.pm line 124.
#
#   $ karr restore --input /nonexistent/nope.yml --yes
#   Error open (<:unix) on '/nonexistent/nope.yml': No such file or directory
#    at /.../lib/App/karr/Cmd/Restore.pm line 101.
#
#   $ karr backup --output <unwritable>/x.yml
#   Error spew on '...': ... Permission denied at /.../lib/App/karr/Cmd/Backup.pm line 75.
#
#   $ karr context --write-to <unwritable>/ctx.md
#   Error spew on '...': ... Permission denied at /.../lib/App/karr/Cmd/Context.pm line 213.
#
#   $ karr init --claude-skill        # into an unwritable .claude
#   mkpath failed for .../.claude/skills: Permission denied
#    at /.../lib/App/karr/Cmd/Init.pm line 171.
#
#   $ karr-foundation --config <sequence.yml>
#   Config must be a YAML mapping at /.../lib/App/karr/Foundation.pm line 299.
#
# The rule the whole ticket is about: where karr keeps its source is never the
# reader's problem. What IS their problem -- the path they typed, the reason the
# OS gave, the line and column YAML::XS objected at -- has to survive the fix,
# so each case asserts the useful half is still there.

my $ROOT = abs_path('.');

sub run_bin {
    my ( $bin, $cwd, @argv ) = @_;
    my $old = getcwd();
    chdir $cwd or die "chdir $cwd: $!";
    my $errfh = gensym;
    my $pid = open3( my $in, my $outfh, $errfh, $^X, "-I$ROOT/lib", "$ROOT/bin/$bin", @argv );
    close $in;
    my $out = do { local $/; <$outfh> };
    my $err = do { local $/; <$errfh> };
    waitpid( $pid, 0 );
    my $exit = $? >> 8;
    chdir $old or die "chdir $old: $!";
    return {
        exit   => $exit,
        stdout => defined $out ? $out : '',
        stderr => defined $err ? $err : '',
    };
}

sub new_board {
    my $repo = tempdir( CLEANUP => 1 );
    system( 'git', 'init', '-q', $repo ) == 0 or die 'git init failed';
    system( 'git', '-C', $repo, 'config', 'user.email', 'test@example.com' );
    system( 'git', '-C', $repo, 'config', 'user.name',  'Test User' );
    my $r = run_karr( $repo, 'init' );
    die "karr init failed: $r->{stderr}" unless $r->{exit} == 0;
    return $repo;
}

# An unwritable directory inside $parent, or a skip reason.
sub unwritable_dir {
    my ($parent) = @_;
    my $dir = path($parent)->child('locked');
    $dir->mkpath;
    chmod 0500, "$dir" or return;
    return $dir;
}

my $ROOT_USER = ( $> == 0 );

# ---------------------------------------------------------------------------

subtest 'karr outside a git repository says so and nothing else' => sub {
    my $nowhere = tempdir( CLEANUP => 1 );
    my $r = run_karr( $nowhere, 'list' );

    isnt $r->{exit}, 0, 'the command fails';
    like $r->{stderr}, qr/Not a git repository\. karr requires Git\./,
        'and says what is wrong';
    unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no "at FILE line N." suffix'
        or diag "stderr was:\n$r->{stderr}";
    unlike $r->{stderr}, qr/BoardDiscovery\.pm/, 'no karr module path'
        or diag "stderr was:\n$r->{stderr}";
    is scalar( grep { length } split /\n/, $r->{stderr} ), 1,
        'exactly one line of error'
        or diag "stderr was:\n$r->{stderr}";
};

subtest 'karr restore names the --input it could not read' => sub {
    my $repo = new_board();
    my $missing = path($repo)->child('no-such-backup.yml');
    my $r = run_karr( $repo, 'restore', '--yes', '--input', "$missing" );

    isnt $r->{exit}, 0, 'the restore fails';
    like $r->{stderr}, qr/Could not read \Q$missing\E/, 'the path the user typed is named';
    like $r->{stderr}, qr/No such file or directory/,   'the reason from the OS survives';
    unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
        or diag "stderr was:\n$r->{stderr}";
    unlike $r->{stderr}, qr/Restore\.pm/, 'no karr module path'
        or diag "stderr was:\n$r->{stderr}";
};

subtest 'karr backup reports an --output it cannot write' => sub {
    plan skip_all => 'running as root: an unwritable directory is still writable'
        if $ROOT_USER;
    my $repo = new_board();
    my $dir = unwritable_dir($repo) or plan skip_all => "cannot chmod: $!";
    my $target = $dir->child('backup.yml');

    my $r = run_karr( $repo, 'backup', '--output', "$target" );
    chmod 0700, "$dir";

    isnt $r->{exit}, 0, 'the backup fails';
    like $r->{stderr}, qr/Could not write \Q$target\E/, 'the target is named';
    like $r->{stderr}, qr/Permission denied/,           'the reason survives';
    unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
        or diag "stderr was:\n$r->{stderr}";
    unlike $r->{stderr}, qr/Backup\.pm/, 'no karr module path'
        or diag "stderr was:\n$r->{stderr}";
};

subtest 'karr context --write reports an unwritable parent directory' => sub {
    plan skip_all => 'running as root: an unwritable directory is still writable'
        if $ROOT_USER;
    my $repo = new_board();
    my $dir = unwritable_dir($repo) or plan skip_all => "cannot chmod: $!";
    my $target = $dir->child('context.md');

    my $r = run_karr( $repo, 'context', '--write-to', "$target" );
    chmod 0700, "$dir";

    isnt $r->{exit}, 0, 'the write fails';
    like $r->{stderr}, qr/Could not write \Q$target\E/, 'the target is named';
    like $r->{stderr}, qr/Permission denied/,           'the reason survives';
    unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
        or diag "stderr was:\n$r->{stderr}";
    unlike $r->{stderr}, qr/Context\.pm/, 'no karr module path'
        or diag "stderr was:\n$r->{stderr}";
};

subtest 'karr context --write still overwrites a read-only target file' => sub {
    plan skip_all => 'running as root: a read-only file is still writable'
        if $ROOT_USER;
    # Named in ticket #77 as the case that must NOT start failing: spew renames
    # a temp file into place, so the mode of the existing file is irrelevant --
    # only the directory has to be writable. Guarding the write must not turn
    # this into an error.
    my $repo = new_board();
    my $target = path($repo)->child('ctx.md');
    $target->spew_utf8("previous content\n");
    chmod 0400, "$target" or plan skip_all => "cannot chmod: $!";

    my $r = run_karr( $repo, 'context', '--write-to', "$target" );

    is $r->{exit}, 0, 'the write succeeds' or diag "stderr was:\n$r->{stderr}";
    like $target->slurp_utf8, qr/kanban-md context/, 'and the context really landed';
};

subtest 'karr init --claude-skill reports an unwritable .claude' => sub {
    plan skip_all => 'running as root: an unwritable directory is still writable'
        if $ROOT_USER;
    my $repo = tempdir( CLEANUP => 1 );
    system( 'git', 'init', '-q', $repo ) == 0 or die 'git init failed';
    system( 'git', '-C', $repo, 'config', 'user.email', 'test@example.com' );
    system( 'git', '-C', $repo, 'config', 'user.name',  'Test User' );
    my $claude = path($repo)->child('.claude');
    $claude->mkpath;
    chmod 0500, "$claude" or plan skip_all => "cannot chmod: $!";

    my $r = run_karr( $repo, 'init', '--claude-skill' );
    chmod 0700, "$claude";

    isnt $r->{exit}, 0, 'the install fails';