view release on metacpan or  search on metacpan

t/85-clean.t  view on Meta::CPAN

    $s->clean_up;

    is shm_cleaned($id), 1, "seg id $id removed after clean_up() ok";

    is keys %$global, 0, "Global register cleaned after clean_up()";
    is keys %$process, 0, "Process register cleaned after clean_up()";
}

# clean_up_all()
{
    my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 , serializer => 'storable' };
    $sv = 'foobar';
    is $sv, 'foobar', "SV set and value is 'foobar'";

    my $id = $s->seg->id;

    my $global = $s->global_register;
    my $process = $s->process_register;

    is keys %$global, 1, "Global register has one entry ok";
    is keys %$process, 1, "Process register has one entry ok";

    is exists $global->{$id}, 1, "ID $id exists in global register";
    is exists $global->{$id}, 1, "ID $id exists in process register";

    $s->clean_up_all;

    is shm_cleaned($id), 1, "seg id $id removed after clean_up_all() ok";

    is keys %$global, 0, "Global register cleaned after clean_up_all()";
    is keys %$process, 0, "Process register cleaned after clean_up_all()";
}

my ($z, $y, $x, $w);

# parent/child
{
    my $awake = 0;
    local $SIG{ALRM} = sub { $awake = 1 };

    my $pid = fork;
    defined $pid or die "Cannot fork : $!";

    if ($pid == 0) {
        # child

        sleep unless $awake;

        my $s = tie(my $sv, 'IPC::Shareable', 'kids', { destroy => 0 , serializer => 'storable' });
        $sv = 'baz';

        is $sv, 'baz', "SV initialized and set to 'baz' ok";

        IPC::Shareable->clean_up;

        my $data = '';
        my $id = $s->seg->id;

        shmread($id, $data, 0, length('IPC::Shareable'));
        is $data, 'IPC::Shareable', "Shared memory alive ok in child";

        $s->clean_up;

        is shm_cleaned($id), 0, "after clean_up(), all is well ok in child, we don't clean up what isn't ours";

        shmread($id, $data, 0, length('IPC::Shareable'));
        is $data, 'IPC::Shareable', "SV doesn't get wiped if in a different proc w/clean_up()";

        exit;
    }
    else {
        # parent

        my $s = tie(my $sv, 'IPC::Shareable', 'kids', { create => 1, destroy => 0 , serializer => 'storable' });

        kill ALRM => $pid;
        my $id = $s->seg->id;
        waitpid($pid, 0);

        is shm_cleaned($id), 0, "ID $id was not cleaned up in the child";

        is keys %{ $s->global_register }, 1, "Global register set before clean_up_all()";
        is keys %{ $s->process_register }, 1, "Process register set before clean_up_all()";

        IPC::Shareable->clean_up_all;

        is keys %{ $s->global_register }, 0, "Global register cleaned with clean_up_all()";
        is keys %{ $s->process_register }, 0, "Process register cleaned with clean_up_all()";
    }
}

IPC::Shareable::_end;

my $segs_after = IPC::Shareable::seg_count();
warn "Segs After: $segs_after\n" if $ENV{PRINT_SEGS};
is $segs_after, $segs_before, "All segs cleaned up ok";
my $sems_after = IPC::Shareable::sem_count();
is $sems_after, $sems_before, "All semaphore sets cleaned up ok";

# remove($key) warns when shmget fails for a non-existent key
{
    my $warnings = [];
    local $SIG{__WARN__} = sub { push @$warnings, @_ };

    IPC::Shareable->remove('0x1B0BFFFE');  # key never created

    is scalar(@$warnings), 1,
        "remove(non-existent key): emits exactly one warning";
    like $warnings->[0], qr/shmget failed/,
        "remove(non-existent key): warning mentions shmget failed";
}

# remove() (object form) warns when sem->remove fails
{
    # destroy => 0: the shm segment is already gone after $k->remove, so no
    # double-remove on scope exit.  Save the semaphore before mocking so we can
    # clean it up manually after the block (mock prevents normal cleanup).
    my $k = tie my %h, 'IPC::Shareable', { key => 'TE', create => 1, destroy => 0 , serializer => 'storable' };
    $h{a} = 1;