view release on metacpan or  search on metacpan

t/18_object_kv.t  view on Meta::CPAN

subtest 'nats.go-style delete marker reads as missing (no KV-Operation header)' => sub {
    plan tests => 4;
    my $js = MockJS->new;
    my $os = EV::Nats::ObjectStore->new(js => $js, bucket => 'B');
    # A marker exactly as nats.go writes it: deleted:true meta, no headers.
    my $marker = {
        name => 'gone.txt', bucket => 'B', nuid => '',
        size => 0, chunks => 0, digest => '', deleted => JSON::PP::true(),
    };
    my $meta_subj = '$O.B.M.' . EV::Nats::ObjectStore::_encode_name('gone.txt');
    $js->{store}{$meta_subj} =
        { data => encode_base64(JSON::PP::encode_json($marker), ''), seq => ++$js->{seq} };
    push @{ $js->{order} }, $meta_subj;

    my ($got, $inf);
    $os->get('gone.txt', sub { $got = [ @_ ] });
    is $got->[0], undef, 'get returns no data for a deleted:true marker';
    is $got->[1], undef, 'get returns no error';
    $os->info('gone.txt', sub { $inf = [ @_ ] });
    is $inf->[0], undef, 'info returns no meta';
    is $inf->[1], undef, 'info returns no error';
};

subtest 'overwrite purges the previous object chunks' => sub {
    plan tests => 5;
    my $js = MockJS->new;
    my $os = EV::Nats::ObjectStore->new(js => $js, bucket => 'B');
    $os->put('file', 'first', sub { });
    $js->drain;
    my ($meta_subj) = grep { /\.M\./ } keys %{ $js->{store} };
    my $nuid1 = (JSON::PP::decode_json(decode_base64($js->{store}{$meta_subj}{data})))->{nuid};

    $js->{msg_gets} = 0;
    my $info;
    $os->put('file', 'second', sub { $info = [ @_ ] });
    $js->drain;
    is $info->[1], undef, 'second put succeeded';
    ok $js->{msg_gets} >= 1, 'second put looked up the existing meta first';
    my $nuid2 = (JSON::PP::decode_json(decode_base64($js->{store}{$meta_subj}{data})))->{nuid};
    isnt $nuid2, $nuid1, 'overwrite used a fresh nuid';
    ok((grep { $_ eq '$O.B.C.' . $nuid1 } @{ $js->{purges} || [] }),
       'previous nuid chunk subject purged');
    ok !exists $js->{store}{ '$O.B.C.' . $nuid1 }, 'old chunks gone from the store';
};

subtest 'list decodes base64url and legacy names' => sub {
    plan tests => 2;
    my $js = MockJS->new;
    my $os = EV::Nats::ObjectStore->new(js => $js, bucket => 'B');
    $os->put('report.txt', 'x', sub { });
    $js->drain;
    # plus a legacy-encoded name, as 0.05 would have written it
    my $legacy_meta = { name => 'a b.txt', bucket => 'B', nuid => 'N',
                        size => 0, chunks => 0, digest => '' };
    $js->{store}{'$O.B.M.a%20b.txt'} =
        { data => encode_base64(JSON::PP::encode_json($legacy_meta), ''), seq => ++$js->{seq} };
    push @{ $js->{order} }, '$O.B.M.a%20b.txt';
    my $names;
    $os->list(sub { $names = $_[0] });
    ok((grep { $_ eq 'report.txt' } @$names), 'base64url name decoded in list');
    ok((grep { $_ eq 'a b.txt' } @$names), 'legacy %XX name decoded in list');
};

subtest 'get() does not pin the connection' => sub {
    plan tests => 2;
    my $destroyed = 0;
    my $r;
    {
        my $js = MockJS->new;
        my $os = EV::Nats::ObjectStore->new(js => $js, bucket => 'B');
        # rides along inside the $self that get()'s closure captures
        $os->{_guard} = Guard->new(sub { $destroyed = 1 });
        $os->put('g', 'payload', sub { });
        $js->drain;
        $os->get('g', sub { $r = [ @_ ] });
        is $r->[0], 'payload', 'get returned data';
    }
    ok $destroyed, 'ObjectStore freed after get() (callback cycle broken)';
};

subtest 'missing object is a clean miss' => sub {
    plan tests => 2;
    my $js = MockJS->new;
    my $os = EV::Nats::ObjectStore->new(js => $js, bucket => 'B');
    my $got;
    $os->get('nope', sub { $got = [ @_ ] });
    is $got->[0], undef, 'get(missing) returns no data';
    is $got->[1], undef, 'get(missing) returns no error';
};

subtest 'KV key and bucket validation' => sub {
    plan tests => 12;
    my $js = MockJS->new;
    ok !eval { EV::Nats::KV->new(js => $js, bucket => 'bad bucket'); 1 },
       'bucket with a space rejected';
    my $kv = eval { EV::Nats::KV->new(js => $js, bucket => 'good-bucket_1') };
    ok $kv, 'valid bucket accepted';
    for my $bad ('a b', 'a>b', 'a*b', '.lead', 'trail.', "nl\nkey") {
        (my $show = $bad) =~ s/\n/\\n/;
        ok !eval { $kv->get($bad, sub { }); 1 }, "key '$show' rejected";
    }
    for my $good ('a.b.c', 'A_b-c', 'x=1', 'path/to/key') {
        ok eval { $kv->get($good, sub { }); 1 }, "key '$good' accepted"
            or diag $@;
    }
};

done_testing;