File Coverage

lib/Oryx/Class.pm

Criterion	Covered	Total	%
statement	44	176	25.0
branch	10	68	14.7
condition	8	24	33.3
subroutine	11	33	33.3
pod	15	18	83.3
total	88	319	27.5

package Oryx::Class;

use Carp qw(carp croak);
use UNIVERSAL qw(isa can);
use Scalar::Util qw(weaken);
use warnings;
use strict;
no strict 'refs';

use base qw(Class::Data::Inheritable Class::Observable);

=head1 NAME

Oryx::Class - abstract base class for Oryx classes

=head1 SYNOPSIS

 # define a persistent class
 package CMS::Page;
 use base qw(Oryx::Class);

 # ... class meta-data here (see DEFINING CLASS META-DATA below) ...

 1;

 #===========================================================================
 # use a persistent class
 use CMS::Page;

 $page = CMS::Page->create({title => 'Life in the Metaverse'});
 $page = CMS::Page->retrieve($id);

 $page->update;
 $page->delete;

 @pages = CMS::Page->search({author => 'Richard Hun%'}, \@order, $limit, $offset);

 #===========================================================================
 # commit your changes
 $page->dbh->commit; # or simply ...
 $page->commit;

 #===========================================================================
 # attribute mutator
 $page->title('The Metamanic Mechanic');
 $tite = $page->title;

 #===========================================================================
 # reference association mutator
 $template_obj = $page->template;
 $page->template( $template_obj );

 #===========================================================================
 # array association accessor
 $page->paragraphs->[0] = $intro_para;
 $paragraph = $page->paragraphs->[42];

 #===========================================================================
 # array association operators
 $concl = pop   @{$page->paragraphs};
 $intro = shift @{$page->paragraphs};
 push    @{$page->paragraphs}, $concl;
 unshift @{$page->paragraphs}, $new_intro;
 splice  @{$page->paragraphs}, 1, 4, ($summary);

 #===========================================================================
 # hash association accessor
 $image_obj = $page->images->{logo};
 $page->images->{mug_shot} = $my_ugly_mug;
 @keys   = keys   %{$page->images};
 @values = values %{$page->images};

 #===========================================================================
 # support for Class::Observable
 Page->add_observer(sub {
     my ($item, $action) = @_;
     #...
 });
 $page->add_observer(...); # instance

=head1 DESCRIPTION

Abstract base class for Oryx persistent classes.

=head1 ABSTRACT METHODS

These methods are overridden by the implementing Class class, i.e.
L or L, for example, but the
interfaces stay the same, so they are documented here.

=over

=item B

creates a persistent object using C<\%proto> to set up the initial state.

=item B

retrieves an object from storage by its object id

=item B

updates storage to persist and reflect changes in the object

=item B

deletes the object from storage

=item B

searches for objects with fields matching C<\%param>. SQL style
C<%> wildcards are supported. C<\@order>, C<$limit> and C<$offset> are
optional. C<\@order> is a list of columns which are used to sort the
results, C<$limit> is an integer which is used to limit the number of
results, and C<$offset> is used to exclude the first results up to
that number. These last two arguments are useful for paging through
search results.

=item B

commits the transaction if your database supports it and AutoCommit
is disabled, then you must do this.

=back

=head2 Observers

Oryx::Class objects now unherit from L thereby
implementing a publish/subscribe system similar to triggers.

The signals are named according to the 6 interface methods prefixed with
I and I, so the following signals are sent:

=over 4

=item before_create

Handler is passed a hashref as argument with fields: C, the search parameters, and C, the L where clause

=item after_create

Handler is passed a hashref as argument with fields: C, the search parameters, and C, the hashref which will be blessed into an instance of this class (during 'construct')

=item before_retrieve

Handler is passed a hashref as argument with fields: C, the id of the object to fetch, and C, the L where clause

=item after_retrieve

Handler is passed a hashref as argument with fields: C, the hashref which will be blessed into an instance of this class (during 'construct')

=item before_update

Handler is passed a hashref as argument with fields: C, the L where clause.

=item after_update

Handler takes no arguments.

=item before_delete

Handler is passed a hashref as argument with fields: C, the L where clause.

=item after_delete

Handler takes no arguments.

=item before_search

Handler is passed a hashref as argument with fields: C, the L where clause, C, the search parameters, the C and C parameters.

=item after_search

Handler is passed a hashref as argument with fields: C, the L where clause, C, the search parameters, the C and C parameters, and C, an arrayref of objects returned by the search.

=item before_construct

Handler is passed a hashref as argument with fields: C, the hashref which will be blessed into an instance of this class.

=item after_construct

Handler is passed a hashref as argument with fields: C, the persistent object.

=back


=cut

use vars qw($XML_DOM_Lite_Is_Available);

BEGIN {
    __PACKAGE__->mk_classdata("auto_deploy");
    __PACKAGE__->mk_classdata("dont_cache");

    $XML_DOM_Lite_Is_Available = 1;
    eval "use XML::DOM::Lite qw(Parser Node :constants);";
    $XML_DOM_Lite_Is_Available = 0 if $@;
}

our $DEBUG = 0;
our $PARSER;

sub parser {
    $PARSER = Parser->new( whitespace => 'strip' ) unless defined $PARSER;
    $PARSER;
}

our %Orphans;

# Object Cache
our %Live_Objects;

=head1 METHODS

These methods are concrete.

=over

=item init

Initialises the class data (see L)

=cut

sub init {
    my $class = shift;
    $DEBUG && $class->_carp('initializing class data');

    # set up class data accessors :
    $class->mk_classdata("_meta");
    $class->mk_classdata("attributes");
    $class->mk_classdata("associations");
    $class->mk_classdata("methods");
    $class->mk_classdata("parents");

    # DATA section cache
    $class->mk_classdata('dataNode');

    $class->meta({});
    $class->attributes({});
    $class->associations({});
    $class->methods({});
    $class->parents([]);

    ${ $class.'::__initialized' } = 1;
}

=item import

Does the work of constructing the class' meta-instances
(L, L and L
instances) from the C<$shema> class variable or defined
in the DATA section of the module if you have L
installed.

=cut

sub import {
    my $class = shift;
    my %param = @_;

    $DEBUG>1 && $class->_carp("importing...");

    if ($class eq __PACKAGE__ and defined $param{auto_deploy}) {
        $class->auto_deploy($param{auto_deploy});
        return; # not interested in doing anything further
    }
    return if $class eq __PACKAGE__
        or $class eq 'Oryx::MetaClass'
        or $class =~ /Oryx::[^:]+::Class/;

    if (${ $class.'::__initialized' }) {
        $DEBUG>1 && $class->_carp('already initialized, returning');
        return;
    }

    if (can($class, 'storage') and $class->storage) {
	if (%Orphans) {
            foreach (keys %Orphans) {
                $DEBUG>1 && $_->_carp('YAY! I am no longer an Orphan');
	        $class->storage->schema->addClass($_)
            }
	    %Orphans = ();
	}
	$class->storage->schema->addClass($class);
    } else {
        $DEBUG && $class->_carp("no storage available Orphaning");
	$Orphans{$class}++;
        $class->auto_deploy($param{auto_deploy})
            if defined $param{auto_deploy};
        return;
    }

    # initialise class data
    $class->init;
    $DEBUG && $class->_carp("setting up...");

    # first set up parent relationships (this doesn't *have* to be
    # done first, but I believe that the chicken came before the
    # egg... the are, as always, good semantic and performance reasons
    # behind this belief... if not behind this particular fragment of
    # code being here instead of at the bottom of this function).
    foreach (@{$class.'::ISA'}) {
	# only if the superclass is a subclass of Oryx::DBx::Class
	if (isa($_, __PACKAGE__)
        and $_ ne __PACKAGE__
        and $_ !~ /Oryx::[^:]+::Class/) {
	    $class->addParent($_);
	}
    }

    my $schema;
    unless ($schema = ${$class.'::schema'})  {
        my $xmldata = $class->parseDataIO;
        eval(q{use Oryx::Schema::Generator});
        die $@ if $@;
        $schema = Oryx::Schema::Generator->generate($class, $xmldata);
    }
    if ($schema) {
        $class->name($schema->{name}) if defined $schema->{name};
	foreach (@{$schema->{attributes}}) {
	    $class->addAttribute($_);
	}
	foreach (@{$schema->{associations}}) {
	    $class->addAssociation($_);
	}
	foreach (@{$schema->{methods}}) {
	    $class->addMethod($_);
	}
    }
    if ($class->auto_deploy or $param{auto_deploy}) {
	unless ($class->storage->util->table_exists(
        $class->dbh, $class->table)) {
	    $class->storage->deploy_class($class);
	}
    }
    if ($param{dont_cache}) { $class->dont_cache(1) }
}

=item meta

Simple accessor to the class meta data.

=cut

sub meta {
    my $class = shift;
    $class->_meta(shift) if @_;
    $class->_meta;
}

=item construct( $class, $proto )

This is typically called from within the C and C
methods of the implementation class (L or

into C<$class> and then allows each class meta-instance to frobnicate
it in turn if they have any need to, before handing the instance to
you.

=cut

sub construct {
    my ($class, $proto) = @_;

    my $object;
    my $key = $class->_mk_cache_key($proto->{id});
    return $object if ($object = $Live_Objects{$key});

    $class->notify_observers('before_construct', { proto => $proto });
    $object = bless $proto, $class;

    $_->construct($object) foreach $class->members;
    $_->construct($object) foreach @{$class->parents};

    $class->notify_observers('after_construct', { object => $object });
    $DEBUG && $class->_carp("constructing $object id => ".$object->id);

    weaken($Live_Objects{$key} = $object) unless $object->dont_cache;
    return $object;
}

=item addAttribute( $meta )

Creates an Attribute meta-instance and associates it with the class.

=cut

sub addAttribute {
    my ($class, $meta) = @_;
    my $attrib =
        (ref($class->storage).'::Attribute')->new($meta, $class);
    $class->attributes->{$attrib->name} = $attrib;
}

=item addAssociation( $meta )

Creates an Association meta-instance and associates it with the class.

=cut

sub addAssociation {
    my ($class, $meta) = @_;
    my $assoc =
        (ref($class->storage).'::Association')->new($meta, $class);
    $class->associations->{$assoc->role} = $assoc;
}

=item addMethod( $meta )

Does nothing at the moment as I cannot decide what such a method
would be used for exactly.

=cut

sub addMethod {
    my ($class, $meta) = @_;
    my $methd =
        (ref($class->storage).'::Method')->new($meta, $class);
    $class->methods->{$methd->name} = $methd;
}

=item addParent( $super )

Creates a Parent meta-instance and associates it with the class.

=cut

sub addParent {
    my ($class, $super) = @_;
    push @{$class->parents},
        (ref($class->storage).'::Parent')->new($super, $class);
}

=item id

Returns the object id.

=cut

sub id { $_[0]->{id} }

=item is_abstract

True if the class does not define any attributes. This is used
for creating a special table for sharing sequences accross subclasses
and for instantiating the correct subclass instance if C
is called on an abstract class.

=cut

sub is_abstract {
    my $class = shift;
    return not %{$class->attributes};
}

=item table

Returns the table name for this class.

=cut

sub table {
    my $class = shift;
    unless (defined $class->meta->{table}) {
	$class->meta->{table} = $class->schema->prefix.$class->name;
    }
    $class->meta->{table};
}

=item name([ $name ])

Get or set the C meta-attribute for the class.

=cut

sub name {
    my $class = shift;
    my $name  = shift;
    $class->setMetaAttribute("name", $name) if $name;
    unless (defined $class->getMetaAttribute("name")) {
	$class =~ /([^:]+)$/;
	$class->setMetaAttribute("name", lc("$1"));
    }
    $class->getMetaAttribute("name");
}

=item members

Return a list of all meta-instances (Attribute, Association, Method
and Parent instances).

=cut

sub members {
    my $class = shift;
    return (
        values %{$class->attributes},
	values %{$class->associations},
	values %{$class->methods},
        # not really members, but we'll treat the same
	#@{$class->parents},
    );
}

=item commit

calls $self->dbh->commit to commit the trasaction

=cut

sub commit { $_[0]->dbh->commit }

=item schema

shortcut for $self->storage->schema. Read only.

=cut

sub schema { $_[0]->storage->schema }

sub parseDataIO {
    my ($class) = @_;
    unless ($XML_DOM_Lite_Is_Available) {
	$class->_carp('XML DATA schemas are not supported unless'
		      .' you have XML::DOM::Lite installed');
	return undef;
    }
    my $stream = $class->loadDataIO;
    if ($stream) {
        return $class->parser->parse($stream)->documentElement;
    } else {
	return undef;
    }
}

sub loadDataIO {
    my $class = shift;
    my $fh = *{"$class\::DATA"}{IO};
    return undef unless $fh;
    local $/ = undef;
    my $stream = <$fh>;
    return $stream;
}

=item remove_from_cache

Object method to remove it from the memory cache.

=cut

sub remove_from_cache {
    my $self = shift;
    my $key = $self->_mk_cache_key($self->id);
    CORE::delete( $Live_Objects{$key} );
}

sub _mk_cache_key {
    my $class = ref($_[0]) || $_[0];
    my $id = $_[1];
    return join('|', ( $class, $id ));
}

sub _carp {
    my $thing = ref($_[0]) ? ref($_[0]) : $_[0];
    carp("[$thing] $_[1]");
}

sub _croak {
    my $thing = ref($_[0]) ? ref($_[0]) : $_[0];
    croak("[$thing] $_[1]");
}

sub DESTROY { $_[0]->remove_from_cache }

1;
__END__