File Coverage

blib/lib/IPC/Shareable.pm

Criterion	Covered	Total	%
statement	120	537	22.3
branch	31	308	10.0
condition	8	49	16.3
subroutine	26	70	37.1
pod	16	16	100.0
total	201	980	20.5

package IPC::Shareable;

use warnings;
use strict;

require 5.00503;

use Carp qw(croak confess carp);
use Data::Dumper;
use IPC::Semaphore;
use IPC::Shareable::SharedMem;
use IPC::SysV qw(
    IPC_PRIVATE
    IPC_CREAT
    IPC_EXCL
    IPC_NOWAIT
    SEM_UNDO
);
use JSON qw(-convert_blessed_universally);
use Scalar::Util;
use String::CRC32;
use Storable 0.6 qw(freeze thaw);

our $VERSION = '1.11';

use constant {
    LOCK_SH               => 1,
    LOCK_EX               => 2,
    LOCK_NB               => 4,
    LOCK_UN               => 8,

    DEBUGGING             => ($ENV{SHAREABLE_DEBUG} or 0),

    SHM_BUFSIZ            => 65536,
    SEM_MARKER            => 0,
    SHM_EXISTS            => 1,

    SHMMAX_BYTES          => 1073741824, # 1 GB

    # Perl sends in a double as opposed to an integer to shmat(), and on some
    # systems, this causes the IPC system to round down to the maximum integer
    # size of 0x80000000 we correct that when generating keys with CRC32

    MAX_KEY_INT_SIZE      => 0x80000000,

    EXCLUSIVE_CHECK_LIMIT => 10, # Number of times we'll check for existing segs
};

require Exporter;
our @ISA = 'Exporter';
our @EXPORT_OK = qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN);
our %EXPORT_TAGS = (
    all     => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
    lock    => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
    flock   => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
);
Exporter::export_ok_tags('all', 'lock', 'flock');

# Locking scheme copied from IPC::ShareLite -- ltl
my %semop_args = (
    (LOCK_EX),
    [
        1, 0, 0,                        # wait for readers to finish
        2, 0, 0,                        # wait for writers to finish
        2, 1, SEM_UNDO,                 # assert write lock
    ],
    (LOCK_EX|LOCK_NB),
    [
        1, 0, IPC_NOWAIT,               # wait for readers to finish
        2, 0, IPC_NOWAIT,               # wait for writers to finish
        2, 1, (SEM_UNDO | IPC_NOWAIT),  # assert write lock
    ],
    (LOCK_EX|LOCK_UN),
    [
        2, -1, (SEM_UNDO | IPC_NOWAIT),
    ],

    (LOCK_SH),
    [
        2, 0, 0,                        # wait for writers to finish
        1, 1, SEM_UNDO,                 # assert shared read lock
    ],
    (LOCK_SH|LOCK_NB),
    [
        2, 0, IPC_NOWAIT,               # wait for writers to finish
        1, 1, (SEM_UNDO | IPC_NOWAIT),  # assert shared read lock
    ],
    (LOCK_SH|LOCK_UN),
    [
        1, -1, (SEM_UNDO | IPC_NOWAIT), # remove shared read lock
    ],
);

my %default_options = (
    key        => IPC_PRIVATE,
    create     => 0,
    exclusive  => 0,
    destroy    => 0,
    mode       => 0666,
    size       => SHM_BUFSIZ,
    protected  => 0,
    limit      => 1,
    graceful   => 0,
    warn       => 0,
    tidy       => 0,
    serializer => 'storable',
);

my %global_register;
my %process_register;
my %used_ids;

sub _trace;
sub _debug;

# --- "Magic" methods
sub TIESCALAR {
    return _tie('SCALAR', @_);
}
sub TIEARRAY {
    return _tie('ARRAY', @_);
}
sub TIEHASH {
    return _tie('HASH', @_);
}
sub STORE {
    my $knot = shift;

    if (! exists $global_register{$knot->seg->id}) {
        $global_register{$knot->seg->id} = $knot;
    }

    $knot->{_data} = $knot->_decode($knot->seg) unless ($knot->{_lock});

    if ($knot->{_type} eq 'HASH') {
        my ($key, $val) = @_;
        _mg_tie($knot, $val, $key) if $knot->_need_tie($val, $key);
        $knot->{_data}{$key} = $val;
    }
    elsif ($knot->{_type} eq 'ARRAY') {
        my ($i, $val) = @_;
        _mg_tie($knot, $val, $i) if $knot->_need_tie($val, $i);
        $knot->{_data}[$i] = $val;
    }
    elsif ($knot->{_type} eq 'SCALAR') {
        my ($val) = @_;
        _mg_tie($knot, $val) if $knot->_need_tie($val);
        $knot->{_data} = \$val;
    }
    else {
        croak "Variables of type $knot->{_type} not supported";
    }

    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!\n";
        }
    }

    return 1;
}
sub FETCH {
    my $knot = shift;

    if (! exists $global_register{$knot->seg->id}) {
        $global_register{$knot->seg->id} = $knot;
    }

    my $data;
    if ($knot->{_lock} || $knot->{_iterating}) {
        $knot->{_iterating} = 0; # In case we break out
        $data = $knot->{_data};
    } else {
        $data = $knot->_decode($knot->seg);
        $knot->{_data} = $data;
    }

    my $val;

    if ($knot->{_type} eq 'HASH') {
        if (defined $data) {
            my $key = shift;
            $val = $data->{$key};
        } else {
            return;
        }
    }
    elsif ($knot->{_type} eq 'ARRAY') {
        if (defined $data) {
            my $i = shift;
            $val = $data->[$i];
        } else {
            return;
        }
    }
    elsif ($knot->{_type} eq 'SCALAR') {
        if (defined $data) {
            $val = $$data;
        } else {
            return;
        }
    }
    else {
        croak "Variables of type $knot->{_type} not supported";
    }

    if (my $inner = _is_kid($val)) {
        my $s = $inner->seg;
        $inner->{_data} = $knot->_decode($s);
    }
    return $val;

}
sub CLEAR {
    my $knot = shift;

    if ($knot->{_type} eq 'HASH') {
        $knot->{_data} = { };
    }
    elsif ($knot->{_type} eq 'ARRAY') {
        $knot->{_data} = [ ];
    }

    else {
        croak "Attempt to clear non-aggegrate";
    }

    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
}
sub DELETE {
    my $knot = shift;
    my $key  = shift;

    $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
    my $val = delete $knot->{_data}->{$key};
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }

    return $val;
}
sub EXISTS {
    my $knot = shift;
    my $key  = shift;

    $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
    return exists $knot->{_data}->{$key};
}
sub FIRSTKEY {
    my $knot = shift;

    $knot->{_iterating} = 1;
    $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
    my $reset = keys %{$knot->{_data}};
    my $first = each %{$knot->{_data}};
    return $first;
}
sub NEXTKEY {
    my $knot = shift;

    # caveat emptor if hash was changed by another process
    my $next = each %{$knot->{_data}};
    if (not defined $next) {
        $knot->{_iterating} = 0;
        return;
    } else {
        $knot->{_iterating} = 1;
        return $next;
    }
}
sub EXTEND {
    #XXX Noop
}
sub PUSH {
    my $knot = shift;

    if (! exists $global_register{$knot->seg->id}) {
        $global_register{$knot->seg->id} = $knot;
    }

    $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};

    push @{$knot->{_data}}, @_;
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        };
    }
}
sub POP {
    my $knot = shift;

    $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};

    my $val = pop @{$knot->{_data}};
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
    return $val;
}
sub SHIFT {
    my $knot = shift;

    $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
    my $val = shift @{$knot->{_data}};
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
    return $val;
}
sub UNSHIFT {
    my $knot = shift;

    $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
    my $val = unshift @{$knot->{_data}}, @_;
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
    return $val;
}
sub SPLICE {
    my($knot, $off, $n, @av) = @_;

    $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
    my @val = splice @{$knot->{_data}}, $off, $n, @av;
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
    return @val;
}
sub FETCHSIZE {
    my $knot = shift;

    $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
    return scalar(@{$knot->{_data}});
}
sub STORESIZE {
    my $knot = shift;
    my $n    = shift;

    $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
    $#{$knot->{_data}} = $n - 1;
    if ($knot->{_lock} & LOCK_EX) {
        $knot->{_was_changed} = 1;
    } else {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!";
        }
    }
    return $n;
}

# --- Public methods

sub new {
    my ($class, %opts) = @_;

    my $type = $opts{var} || 'HASH';

    if ($type eq 'HASH') {
        my $k = tie my %h, 'IPC::Shareable', \%opts;
        return \%h;
    }
    if ($type eq 'ARRAY') {
        my $k = tie my @a, 'IPC::Shareable', \%opts;
        return \@a;
    }
    if ($type eq 'SCALAR') {
        my $k = tie my $s, 'IPC::Shareable', \%opts;
        return \$s;
    }
}
sub global_register {
     # This is a ridiculous way to do this, but if we don't call Dumper, hashes
    # that are created in a separate process than the parent hash don't
    # show up properly in the global register. t/90

    local $SIG{__WARN__} = sub {
        my ($warning) = @_;
        if ($warning !~ /hash after insertion/) {
            warn $warning;
        }
    };

    Dumper \%global_register;

    return \%global_register;
}
sub process_register {
    return \%process_register;
}

sub attributes {
    my ($knot, $attr) = @_;

    my $attrs = $knot->{attributes};

    if (defined $attr) {
        return $knot->{attributes}{$attr};
    }
    else {
        return $knot->{attributes};
    }
}
sub ipcs {
    my $count = `ipcs -m | wc -l`;
    chomp $count;
    return int($count);
}
sub spawn {
    my ($knot, %opts) = @_;

    croak "spawn() requires a key/glue sent in..." if ! defined $opts{key};

    $opts{mode} = 0666 if ! defined $opts{mode};

    $SIG{CHLD} = 'IGNORE';

    _spawn(
        key     => $opts{key},
        mode    => $opts{mode},
    );
}
sub _spawn {
    my (%opts) = @_;

    my $pid = fork;
    return if $pid;

    if (! $pid) {
        tie my %h, 'IPC::Shareable', {
            key       => $opts{key},
            create    => 1,
            #exclusive => 1,
            destroy   => $opts{destroy},
            mode      => $opts{mode},
        };

        $h{__ipc}->{run} = 1;

        while (1) {
            local $SIG{__WARN__} = sub {};
            last if ! defined $h{__ipc};
            last if ! $h{__ipc}->{run};
        }

        IPC::Shareable->clean_up_all if $opts{destroy};
        exit 0;
    }
}
sub unspawn {
    shift;
    my ($key, $destroy) = @_;

    $destroy ||= 0;

    tie my %h, 'IPC::Shareable', {
        key       => $key,
        destroy   => $destroy,
        mode      => 0666,
    };

    $h{__ipc}->{run} = 0;

    $SIG{CHLD} = undef;

    sleep 1;

    IPC::Shareable->clean_up_all if $destroy;
}
sub lock {
    my ($knot, $flags) = @_;
    $flags = LOCK_EX if ! defined $flags;

    return $knot->unlock if ($flags & LOCK_UN);

    return 1 if ($knot->{_lock} & $flags);

    # If they have a different lock than they want, release it first
    $knot->unlock if ($knot->{_lock});

    my $sem = $knot->sem;
    my $return_val = $sem->op(@{ $semop_args{$flags} });
    if ($return_val) {
        $knot->{_lock} = $flags;
        $knot->{_data} = $knot->_decode($knot->seg),
    }
    return $return_val;
}
sub unlock {
    my $knot = shift;

    return 1 unless $knot->{_lock};
    if ($knot->{_was_changed}) {
        if (! defined $knot->_encode($knot->seg, $knot->{_data})){
            croak "Could not write to shared memory: $!\n";
        }
        $knot->{_was_changed} = 0;
    }
    my $sem = $knot->sem;
    my $flags = $knot->{_lock} | LOCK_UN;
    $flags ^= LOCK_NB if ($flags & LOCK_NB);
    $sem->op(@{ $semop_args{$flags} });

    $knot->{_lock} = 0;

    1;
}
*shlock = \&lock;
*shunlock = \&unlock;

sub clean_up {
    my $class = shift;

    for my $id (keys %process_register) {
        my $s = $process_register{$id};
        next unless $s->attributes('owner') == $$;
        next if $s->attributes('protected');
        remove($s);
    }
}
sub clean_up_all {
    my $class = shift;

    my $global_register = __PACKAGE__->global_register;

    my %deleted = %$global_register;

    for my $id (keys %deleted) {
        my $s = $deleted{$id};
        next if $s->attributes('protected');
        remove($s);
    }
}
sub clean_up_protected {
    my ($knot, $protect_key);

    if (scalar @_ == 2) {
        ($knot, $protect_key) = @_;
    }
    if (scalar @_ == 1) {
        ($protect_key) = @_;
    }

    if (! defined $protect_key) {
        croak "clean_up_protected() requires a \$protect_key param";
    }

    if ($protect_key !~ /^\d+$/) {
        croak
            "clean_up_protected() \$protect_key must be an integer. You sent $protect_key";
    }

    for my $s (values %global_register) {
        my $stored_key = $s->attributes('protected');

        if ($stored_key && $stored_key == $protect_key) {
            remove($s);
        }
    }
}
sub remove {
    my $knot = shift;

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

    $s->remove or warn "Couldn't remove shared memory segment $id: $!";

    $s = $knot->sem;

    $s->remove or warn "Couldn't remove semaphore set $id: $!";

    delete $process_register{$id};
    delete $global_register{$id};
}
sub seg {
    my ($knot) = @_;
    return $knot->{_shm} if defined $knot->{_shm};
}
sub sem {
    my ($knot) = @_;
    return $knot->{_sem} if defined $knot->{_sem};
}
sub singleton {
    my ($class, $glue, $warn) = @_;

    if (! defined $glue) {
        croak "singleton() requires a GLUE parameter";
    }

    $warn = 0 if ! defined $warn;

    tie my $lock, 'IPC::Shareable', {
        key         => $glue,
        create      => 1,
        exclusive   => 1,
        graceful    => 1,
        destroy     => 1,
        warn        => $warn
    };

    return $$;
}

END {
    _end();
}

# --- Private methods below

sub _encode {
    my ($knot, $seg, $data) = @_;

    my $serializer = $knot->attributes('serializer');

    if ($serializer eq 'storable') {
        return _freeze($seg, $data);
    }
    elsif ($serializer eq 'json'){
        return _encode_json($seg, $data);
    }

    return undef;
}
sub _end {
    for my $s (values %process_register) {
        unlock($s);
        next if $s->attributes('protected');
        next if ! $s->attributes('destroy');
        next if $s->attributes('owner') != $$;
        remove($s);
    }
}
sub _decode {
    my ($knot, $seg) = @_;

    my $serializer = $knot->attributes('serializer');

    if ($serializer eq 'storable') {
        return _thaw($seg);
    }
    elsif ($serializer eq 'json'){
        return _decode_json($seg);
    }

    return undef;
}
sub _encode_json {
    my $seg  = shift;
    my $data = shift;

    my $json = encode_json $data;

    if (length($json) > $seg->size) {
        croak "Length of shared data exceeds shared segment size";
    }
    $seg->shmwrite($json);
}
sub _decode_json {
    my $seg = shift;

    my $json = $seg->shmread;

    return if ! $json;

    # Remove \x{0} after end of string (broke JSON)

    $json =~ s/\x00+//;

#    my $tag = substr $json, 0, 14, '';

#    if ($tag eq 'IPC::Shareable') {
        my $data = decode_json $json;
        if (! defined($data)){
            croak "Munged shared memory segment (size exceeded?)";
        }
        return $data;
#    } else {
#        return;
#    }
}
sub _freeze {
    my $seg  = shift;
    my $water = shift;

    my $ice = freeze $water;
    # Could be a large string.  No need to copy it.  substr more efficient
    substr $ice, 0, 0, 'IPC::Shareable';

    if (length($ice) > $seg->size) {
        croak "Length of shared data exceeds shared segment size";
    }
    $seg->shmwrite($ice);
}
sub _thaw {
    my $seg = shift;

    my $ice = $seg->shmread;

    return if ! $ice;

    my $tag = substr $ice, 0, 14, '';

    if ($tag eq 'IPC::Shareable') {
        my $water = thaw $ice;
        if (! defined($water)){
            croak "Munged shared memory segment (size exceeded?)";
        }
        return $water;
    } else {
        return;
    }
}
sub _tie {
    my ($type, $class, $key_str, $opts);

    if (scalar @_ == 4) {
        ($type, $class, $key_str, $opts) = @_;
        $opts->{key} = $key_str;
    }
    else {
        ($type, $class, $opts) = @_;
    }

    $opts  = _parse_args($opts);

    my $knot = bless { attributes => $opts }, $class;

    my $key      = $knot->_shm_key;
    my $flags    = $knot->_shm_flags;
    my $shm_size = $knot->attributes('size');

    if ($knot->attributes('limit') && $shm_size > SHMMAX_BYTES) {
        croak
            "Shared memory segment size '$shm_size' is larger than max size of " .
            SHMMAX_BYTES;
    }

    my $seg;

    if ($knot->attributes('graceful')) {
        my $exclusive = eval {
            $seg = IPC::Shareable::SharedMem->new($key, $shm_size, $flags);
            1;
        };

        if (! defined $exclusive) {
            if ($knot->attributes('warn')) {
                warn "Process ID $$ exited due to exclusive shared memory collision\n";
            }
            exit(0);
        }
    }
    else {
        $seg = IPC::Shareable::SharedMem->new($key, $shm_size, $flags);
    }

    if (! defined $seg) {
        if ($! =~ /Cannot allocate memory/) {
            croak "\nERROR: Could not create shared memory segment: $!\n\n" .
                  "Are you using too large a size?";
        }

        if ($! =~ /No space left on device/) {
            croak "\nERROR: Could not create shared memory segment: $!\n\n" .
                "Are you spawning too many segments in a loop?";
        }

        if (! $knot->attributes('create')) {
            confess "ERROR: Could not acquire shared memory segment... 'create' ".
                  "option is not set, and the segment hasn't been created " .
                  "yet:\n\n $!";
        }
        elsif ($knot->attributes('create') && $knot->attributes('exclusive')){
            croak "ERROR: Could not create shared memory segment. 'create' " .
                  "and 'exclusive' are set. Does the segment already exist? " .
                  "\n\n$!";
        }
        else {
            croak "ERROR: Could not create shared memory segment.\n\n$!";
        }
    }

    my $sem = IPC::Semaphore->new($key, 3, $flags);
    if (! defined $sem){
        croak "Could not create semaphore set: $!\n";
    }

    if (! $sem->op(@{ $semop_args{(LOCK_SH)} }) ) {
        croak "Could not obtain semaphore set lock: $!\n";
    }

    %$knot = (
        %$knot,
        _iterating   => 0,
        _key         => $key,
        _lock        => 0,
        _shm         => $seg,
        _sem         => $sem,
        _type        => $type,
        _was_changed => 0,
    );

    $knot->{_data} = _thaw($seg);

    if ($sem->getval(SEM_MARKER) != SHM_EXISTS) {

        if (! exists $global_register{$knot->seg->id}) {
            $global_register{$knot->seg->id} = $knot;
        }

        $process_register{$knot->seg->id} ||= $knot;
        if (! $sem->setval(SEM_MARKER, SHM_EXISTS)){
            croak "Couldn't set semaphore during object creation: $!";
        }
    }

    $sem->op(@{ $semop_args{(LOCK_SH|LOCK_UN)} });

    return $knot;
}
sub _parse_args {
    my ($opts) = @_;

    $opts  = defined $opts  ? $opts  : { %default_options };

    for my $k (keys %default_options) {
        if (not defined $opts->{$k}) {
            $opts->{$k} = $default_options{$k};
        }
        elsif ($opts->{$k} eq 'no') {
            if ($^W) {
                require Carp;
                Carp::carp("Use of `no' in IPC::Shareable args is obsolete");
            }

            $opts->{$k} = 0;
        }
    }
    $opts->{owner} = ($opts->{owner} or $$);
    $opts->{magic} = ($opts->{magic} or 0);
    return $opts;
}
sub _shm_key {
    # Generates a 32-bit CRC on the key string. The $key_str parameter is used
    # for testing only, for purposes of testing various key strings

    my ($knot, $key_str) = @_;

    $key_str //= ($knot->attributes('key') || '');

    my $key;

    if ($key_str eq '') {
        $key = IPC_PRIVATE;
    }
    elsif ($key_str =~ /^\d+$/) {
        $key = $key_str;
    }
    else {
        $key = crc32($key_str);
    }

    $used_ids{$key}++;

    if ($key > MAX_KEY_INT_SIZE) {
        $key = $key - MAX_KEY_INT_SIZE;

        if ($key == 0) {
            croak "We've calculated a key which equals 0. This is a fatal error";
        }
    }

    return $key;
}
sub _shm_key_rand {
    my $key;

    # Unfortunatly, the only way I know how to check if a segment exists is
    # to actually create it. We must do that here, then remove it just to
    # ensure the slot is available

    my $verified_exclusive = 0;

    my $check_count = 0;

    while (! $verified_exclusive && $check_count < EXCLUSIVE_CHECK_LIMIT) {
        $check_count++;

        $key = _shm_key_rand_int();

        next if $used_ids{$key};

        my $flags;
        $flags |= IPC_CREAT;
        $flags |= IPC_EXCL;

        my $seg;

        my $shm_slot_available = eval {
            $seg = IPC::Shareable::SharedMem->new($key, 1, $flags);
            1;
        };

        if ($shm_slot_available) {
            $verified_exclusive = 1;
            $seg->remove if $seg;
        }
    }

    if (! $verified_exclusive) {
        croak
            "_shm_key_rand() can't get an available key after $check_count tries";
    }

    $used_ids{$key}++;

    return $key;
}
sub _shm_key_rand_int {
    srand();
    return int(rand(1_000_000));
}
sub _shm_flags {
    # --- Parses the anonymous hash passed to constructors; returns a list
    # --- of args suitable for passing to shmget
    my ($knot) = @_;

    my $flags = 0;

    $flags |= IPC_CREAT if $knot->attributes('create');
    $flags |= IPC_EXCL  if $knot->attributes('exclusive');;
    $flags |= ($knot->attributes('mode') or 0666);

    return $flags;
}
sub _mg_tie {
    my ($parent, $val, $identifier) = @_;

    my $key;

    if ($parent->{_key} == IPC_PRIVATE) {
        $key = IPC_PRIVATE;
    }
    else {
        $key = _shm_key_rand();
    }

    my %opts = (
        %{ $parent->attributes },
        key       => $key,
        exclusive => 1,
        create    => 1,
        magic     => 1,
    );

    # XXX I wish I didn't have to take a copy of data here and copy it back in
    # XXX Also, have to peek inside potential objects to see their implementation
    my $child;
    my $type = Scalar::Util::reftype($val) || '';

    if ($type eq "HASH") {
        my %copy = %$val;
        $child = tie %$val, 'IPC::Shareable', $key, { %opts };
        croak "Could not create inner tie" if ! $child;

        _reset_segment($parent, $identifier) if $opts{tidy};

        %$val = %copy;
    }
    elsif ($type eq "ARRAY") {
        my @copy = @$val;
        $child = tie @$val, 'IPC::Shareable', $key, { %opts };
        croak "Could not create inner tie" if ! $child;

        _reset_segment($parent, $identifier) if $opts{tidy};

        @$val = @copy;
    }
    elsif ($type eq "SCALAR") {
        my $copy = $$val;
        $child = tie $$val, 'IPC::Shareable', $key, { %opts };
        croak "Could not create inner tie" if ! $child;

        $$val = $copy;
    }
    else {
        croak "Variables of type $type not implemented";
    }

    return $child;
}
sub _is_kid {
    my $data = shift or return;

    my $type = Scalar::Util::reftype( $data );
    return unless $type;

    my $obj;

    if ($type eq "HASH") {
        $obj = tied %$data;
    }
    elsif ($type eq "ARRAY") {
        $obj = tied @$data;
    }
    elsif ($type eq "SCALAR") {
        $obj = tied $$data;
    }

    if (ref $obj eq 'IPC::Shareable') {
        return $obj;
    }

    return;
}
sub _need_tie {
    my ($knot, $val, $identifier) = @_;

    my $type = Scalar::Util::reftype($val);
    return 0 if ! $type;

    my $need_tie;

    if ($type eq "HASH") {
        $need_tie = !(tied %$val);
    }
    elsif ($type eq "ARRAY") {
        $need_tie = !(tied @$val);
    }
    elsif ($type eq "SCALAR") {
        $need_tie = !(tied $$val);
    }

    return $need_tie ? 1 : 0;
}
sub _reset_segment {
    my ($parent, $id) = @_;

    my $parent_type = Scalar::Util::reftype($parent->{_data}) || '';

    if ($parent_type eq 'HASH') {
        my $data = $parent->{_data};
        if (exists $data->{$id} && keys %{ $data->{$id} } && tied %{ $data->{$id} }) {
            (tied %{ $parent->{_data}{$id} })->remove;
        }
    }
    elsif ($parent_type eq 'ARRAY') {
        my $data = $parent->{_data};
        if (exists $data->[$id] && tied @{ $data->[$id] }) {
            (tied @{ $parent->{_data}[$id] })->remove;
        }
    }
}

sub _trace {
    require Carp;
    require Data::Dumper;
    my $caller = '    ' . (caller(1))[3] . " called with:\n";
    my $i = -1;
    my @msg = map {
        ++$i;
        my $obj;
        if (ref eq 'IPC::Shareable') {
            '        ' . "\$_[$i] = $_: shmid: $_->{_shm}->{_id}; " .
                Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]);
        } else {
            '        ' . Data::Dumper->Dump( [ $_ ] => [ "\_[$i]" ]);
        }
    }  @_;
    Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg;
}
sub _debug {
    require Carp;
    require Data::Dumper;
    local $Data::Dumper::Terse = 1;
    my $caller = '    ' . (caller(1))[3] . " tells us that:\n";
    my @msg = map {
        my $obj;
        if (ref eq 'IPC::Shareable') {
            '        ' . "$_: shmid: $_->{_shm}->{_id}; " .
                Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]);
        }
        else {
            '        ' . Data::Dumper::Dumper($_);
        }
    }  @_;
    Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg;
}
sub _placeholder {}

1;

__END__