File Coverage

blib/lib/KinoSearch1/Util/Class.pm

Criterion	Covered	Total	%
statement	83	85	97.6
branch	7	10	70.0
condition	1	3	33.3
subroutine	23	24	95.8
pod	9	9	100.0
total	123	131	93.8

package KinoSearch1::Util::Class;
use strict;
use warnings;
use KinoSearch1::Util::ToolSet;

use KinoSearch1::Util::VerifyArgs qw( verify_args kerror );

sub new {
    my $class = shift;    # leave the rest of @_ intact.

    # find a defaults hash and verify args
    $class = ref($class) || $class;
    my $defaults;
    {
        no strict 'refs';
        $defaults = \%{ $class . '::instance_vars' };
    }
    if ( !verify_args( $defaults, @_ ) ) {
        # if a user-based subclass, find KinoSearch1 parent class and verify.
        my $kinoclass = _traverse_at_isa($class);
        confess kerror() unless $kinoclass;
        {
            no strict 'refs';
            $defaults = \%{ $kinoclass . '::instance_vars' };
        }
        confess kerror() unless verify_args( $defaults, @_ );
    }

    # merge var => val pairs into new object, call customizable init routine
    my $self = bless { %$defaults, @_ }, $class;
    $self->init_instance;

    return $self;
}

# Walk @ISA until a parent class starting with 'KinoSearch1::' is found.
sub _traverse_at_isa {
    my $orig = shift;
    {
        no strict 'refs';
        my $at_isa = \@{ $orig . '::ISA' };
        for my $parent (@$at_isa) {
            return $parent if $parent =~ /^KinoSearch1::/;
            my $grand_parent = _traverse_at_isa($parent);
            return $grand_parent if $grand_parent;
        }
    };
    return '';
}

sub init_instance { }

sub init_instance_vars {
    my $package = shift;

    no strict 'refs';
    no warnings 'once';
    my $first_isa = ${ $package . '::ISA' }[0];
    %{ $package . '::instance_vars' }
        = ( %{ $first_isa . '::instance_vars' }, @_ );
}

sub ready_get_set {
    ready_get(@_);
    ready_set(@_);
}

sub ready_get {
    my $package = shift;
    no strict 'refs';
    for my $member (@_) {
        *{ $package . "::get_$member" } = sub { return $_[0]->{$member} };
    }
}

sub ready_set {
    my $package = shift;
    no strict 'refs';
    for my $member (@_) {
        *{ $package . "::set_$member" } = sub { $_[0]->{$member} = $_[1] };
    }
}

=for Rationale:
KinoSearch1 is not thread-safe.  Among other things, the C-struct-based classes
cause segfaults or bus errors when their data gets double-freed by DESTROY.
Therefore, CLONE dies with a user-friendly error message before that happens.

=cut

sub CLONE {
    my $package = shift;
    die(      "CLONE invoked by package '$package', indicating that threads "
            . "or Win32 fork were initiated, but KinoSearch1 is not thread-safe"
    );
}

sub abstract_death {
    my ( undef, $filename, $line, $methodname ) = caller(1);
    die "ERROR: $methodname', called at $filename line $line, is an "
        . "abstract method and must be defined in a subclass";
}

sub unimplemented_death {
    my ( undef, $filename, $line, $methodname ) = caller(1);
    die "ERROR: $methodname, called at $filename line $line, is "
        . "intentionally unimplemented in KinoSearch1, though it is part "
        . "of Lucene";
}

sub todo_death {
    my ( undef, $filename, $line, $methodname ) = caller(1);
    die "ERROR: $methodname, called at $filename line $line, is not "
        . "implemented yet in KinoSearch1, but is on the todo list";
}

1;

__END__