view release on metacpan or  search on metacpan

lib/Gloom.pm  view on Meta::CPAN

### This module was derived from Gloom - the Great Little OO Module!
### Read `perldoc Gloom` for more information.

use strict; use warnings;
package Gloom;
our $VERSION = '0.25';

use constant XXX_skip => 1;

sub import {
    my ($class, $flag) = @_;
    my ($package, $module) = caller(0);

    strict->import;
    warnings->import;

    if ($class->isa(__PACKAGE__) and
        defined $flag and
        $flag eq '-base'
    ) {
        $class->import_base($package, $module);
    }
    else {
        require Exporter;
        goto &Exporter::import;
    }
}

sub import_base {
    my ($class, $package, $module) = @_;
    no strict 'refs';
    push @{$package . '::ISA'}, $class;
    $class->import_fake($package, $module);
    $class->export_base($package);
}

sub import_fake {
    my ($class, $package, $module) = @_;
    my $inc_module = $package . '.pm';
    $inc_module =~ s/::/\//g;
    return if defined $INC{$inc_module};
    $INC{$inc_module} = $module;
}

sub export_base {
    my ($source, $target) = @_;
    no strict 'refs';
    for my $sub (map {
        /::/ ? $_ : "${source}::$_"
    } $source->EXPORT_BASE()) {
        my $name = $sub;
        $name =~ s/.*:://;
        *{$target . "::$name"} = \&$sub;
    }
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->init(@_);
    return $self;
}

sub init {
    my $self = shift;
    while (my ($property, $value) = splice(@_, 0, 2)) {
        unless ($self->can($property)) {
            my $class = ref $self;
            require Carp;
            Carp::confess("Class '$class' has no property '$property'");
        }
        $self->$property($value);
    }
}