File Coverage

blib/lib/Class/PObject.pm

Criterion	Covered	Total	%
statement	67	77	87.0
branch	17	26	65.3
condition	6	10	60.0
subroutine	8	8	100.0
pod	0	1	0.0
total	98	122	80.3

package Class::PObject;

# $Id: PObject.pm,v 1.54.2.3 2004/05/20 06:59:14 sherzodr Exp $

use strict;
#use diagnostics;
use Log::Agent;
use vars ('$VERSION', '$revision');

$VERSION  = '2.15_01';
$revision = '$Revision: 1.54.2.3 $';

# configuring Log::Agent
logconfig(-level=>$ENV{POBJECT_DEBUG} || 0,
          -prefix=>'***',
          -caller => [-format => '%-30s->', -info   => "sub"]);

sub import {
    my $class       = shift;
    my $caller_pkg  = (caller)[0];

    unless ( @_ ) {
        no strict 'refs';
        *{ "$caller_pkg\::pobject" } = \&{ "$class\::pobject" };
        return 1
    }
    require Exporter;
    return $class->Exporter::import( @_ )
}

sub pobject {
    my ($class, $props);

    # are we given explicit class name to be created in?
    if ( @_ == 2 ) {
        ($class, $props) = @_;
        logtrc 1, "pobject %s => %s", $class, $props
    }
    # Is class name assumed to be the current caller's package?
    elsif ( $_[0] && (ref($_[0]) eq 'HASH') ) {
        $props = $_[0];
        $class = (caller())[0];
        logtrc 1, "pobject ('%s'), %s", $class, $props
    }
    # otherwise, we throw a usage exception:
    else {
        logcroak "Usage error"
    }
    # should we make sure that current package is not 'main'?
    if ( $class eq 'main' ) {
        logcroak "'main' cannot be the class name"
    }

    # creating the class virtually. Note, that it is different
    # then the way Class::Struct works. Class::Struct literally builds
    # the class contents in a string, and then eval()s them.
    # And we play with symtables. However, I'm not sure how secure this method is.

    no strict 'refs';
    # if the properties have already been created, it means the user
    # is declaring the class with the same name twice. He should be shot!
    if ( ${ "$class\::props" } ) {
        logcroak "are you trying to create the same class two times?"
    }

    # we should have some columns
    unless ( @{$props->{columns}} ) {
        logcroak "class '%s' should have columns!", $class
    }

    # one of the columns should be 'id'. I believe this is a limitation,
    # which should be eliminated in next release
    my $has_id = 0;
    for ( @{$props->{columns}} ) {
        $has_id = ($_ eq 'id') and last
    }
    unless ( $has_id ) {
        logcroak "one of the columns must be 'id'"
    }

    # certain method names are reserved. Making sure they won't get overridden
    my @reserved_methods = qw(
        new load fetch save remove remove_all set get
        pobject_init drop_datasource init_datasource DESTROY
    );
    for my $method ( @reserved_methods ) {
        for my $column ( @{$props->{columns}} ) {
            if ( $method eq $column ) {
                logcroak "method  '%s' is reserved", $method
            }
        }
    }

    for my $colname ( @{$props->{columns}} ) {
        unless ( defined($props->{tmap}) && $props->{tmap}->{$colname} ) {
            if ( $colname eq 'id' ) {
                $props->{tmap}->{$colname} = 'INTEGER', next
            }
            $props->{tmap}->{$colname}   = 'VARCHAR(255)'
        }
    }

    # if no driver was specified, default driver to be used is 'file'
    $props->{driver} ||= 'file';

    # if no serializer set defaulting to 'storable'
    $props->{serializer} ||= 'storable';

    # it's important that we cache all the properties passed to the pobject()
    # as a static data. This lets multiple instances of the pobject to access
    # this data whenever needed
    ${ "$class\::props" }   = $props;

    require Class::PObject::Template;
    # To ensure operator overloading works properly on these
    # objects, let's also set the caller's @ISA array:
    push @{ "$class\::ISA" }, "Class::PObject::Template";

    # creating accessor methods
    for my $colname ( @{ $props->{columns} } ) {
        if ( $class->UNIVERSAL::can($colname) ) {
            logcarp "method '%s' exists in the caller's package", $colname;
            next
        }
        *{ "$class\::$colname" } = sub {
            if ( @_ == 2 ) {
                my $set = \&Class::PObject::Template::set;
                return $set->( $_[0], $colname, $_[1] )
            }
            my $get = \&Class::PObject::Template::get;
            return $get->( $_[0], $colname )
        }
    }
}

logtrc 1, "%s loaded successfully", __PACKAGE__;

1;
__END__