The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package NetHack::Item::Role::Wearable;
{
  $NetHack::Item::Role::Wearable::VERSION = '0.19';
}
use Moose::Role;

has is_worn => (
    traits    => ['Bool'],
    is        => 'rw',
    isa       => 'Bool',
    default   => 0,
    handles   => {
        wear   => 'set',
        remove => 'unset',
    },
);

with 'NetHack::Item::Role::IncorporatesStats' => {
    attribute => 'is_worn',
    stat      => 'worn',
    bool_stat => 1,
};

around is_worn => sub {
    my $orig = shift;
    my $self = shift;

    return $orig->($self) if !@_; # reader

    my $is_worn = shift;
    my $before = $self->is_worn;

    my $ret = $orig->($self, $is_worn, @_);

    if ($self->has_pool && $is_worn ^ $before) {
        my $slot;

        if ($self->type eq 'armor') {
            $slot = $self->subtype;
        }
        elsif ($self->type eq 'ring') {
            my $hand = $self->hand;

            die "When changing a ring's worn status, you must have the 'hand' attribute set" if !$hand;
            $slot = "${hand}_ring";
        }
        else {
            $slot = $self->type;
        }

        my $equipment = $self->pool->inventory->equipment;
        if ($is_worn) {
            my $existing = $equipment->$slot;
            $existing->is_worn(0) if $existing && $existing != $self;

            $equipment->$slot($self);
        }
        else {
            my $clearer = "clear_$slot";
            $equipment->$clearer;
        }
    }

    return $ret;
};

around can_drop => sub {
    my $orig = shift;
    my $self = shift;
    my %args = @_;

    return 0 if $self->is_worn && !$args{ignore_is_worn};
    return $orig->($self, @_);
};

no Moose::Role;

1;