File Coverage

blib/lib/ORM/Base.pm

Criterion	Covered	Total	%
statement	54	55	98.1
branch	19	30	63.3
condition	2	3	66.6
subroutine	6	6	100.0
pod			n/a
total	81	94	86.1

#
# DESCRIPTION
#   PerlORM - Object relational mapper (ORM) for Perl. PerlORM is Perl
#   library that implements object-relational mapping. Its features are
#   much similar to those of Java's Hibernate library, but interface is
#   much different and easier to use.
#
# AUTHOR
#   Alexey V. Akimov
#
# COPYRIGHT
#   Copyright (C) 2005-2006 Alexey V. Akimov
#
#   This library is free software; you can redistribute it and/or
#   modify it under the terms of the GNU Lesser General Public
#   License as published by the Free Software Foundation; either
#   version 2.1 of the License, or (at your option) any later version.
#
#   This library is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#   Lesser General Public License for more details.
#
#   You should have received a copy of the GNU Lesser General Public
#   License along with this library; if not, write to the Free Software
#   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#

package ORM::Base;

use Carp;

$VERSION = 0.8;

my %require;
my %loaded;
my $active = 0;
my $debug  = 0;

sub import
{
    my $class   = shift;
    my $base    = shift;
    my %arg     = @_;
    my $derived = caller 0;
    my $i_am_active;

    unless( $active )
    {
        print STDERR "***** Start loading *****\n" if( $debug );
        $active      = 1;
        $i_am_active = 1;
    }

    my $eval = "package $derived; use base $base; ";

    if( $arg{i_am_history} )
    {
        $eval .= 'do \'ORM/History.pm\';';
        $arg{history_is_enabled} = 0;
    }

    eval $eval;

    croak "Failed to load package $base\n$@" if( $@ );
    $loaded{$base}    = 1;
    $loaded{$derived} = 1;
    print STDERR "  Loading class $derived\n" if( $debug );

    my @require = $base->_derive( derived_class=>$derived, %arg );
    if( $derived->_history_class && !$loaded{$derived->_history_class} )
    {
        push @require, $derived->_history_class;
    }
    for my $module ( @require )
    {
        if( $loaded{$module} )
        {
            print STDERR "    $derived requested $module (already loaded)\n" if( $debug );
        }
        elsif( $require{$module} )
        {
            print STDERR "    $derived requested $module (already in queue)\n" if( $debug );
        }
        else
        {
            print STDERR "    $derived requested $module (queued)\n" if( $debug );
            $require{$module} = 1;
        }
    }

    if( $i_am_active )
    {
        while( %require )
        {
            my $load;

            for my $module ( keys %require )
            {
                $loaded{$module} = 1;
                $load           .= "require $module; ";
            }

            %require = ();
            print STDERR "Loading queued: $load\n" if( $debug );
            eval $load;
            croak "Failed to load packages: $load\n$@" if( $@ );
        }
        %loaded = ();
        $active = 0;
        print STDERR "***** Finish loading *****\n\n" if( $debug );
    }
}

1;