File Coverage

blib/lib/Class/Maker/Extension/Schema/Tangram.pm

Criterion	Covered	Total	%
statement	12	54	22.2
branch	0	22	0.0
condition	0	6	0.0
subroutine	4	6	66.6
pod	0	1	0.0
total	16	89	17.9

# Author: Murat Uenalan ([e-mail])
#
# Copyright (c) 2001 Murat Uenalan. All rights reserved.
#
# Note: This program is free software; you can redistribute
#
# it and/or modify it under the same terms as Perl itself.

package Class::Maker::Extension::Schema::Tangram;

require 5.005_62; use strict; use warnings;

use Exporter;

our $VERSION = '0.01_01';

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(schema) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

our $mappings =
{
	ARRAY =>
	{
		hash => 'flat_hash',

		array => 'flat_array',
	}
};

sub _map_to_tangram
{
	my $attribs = shift;

	my $mapping = shift;

		foreach my $type ( keys %$attribs )
		{
			if( my $what = $mappings->{ ref $attribs->{$type} }->{$type} )
			{
				$attribs->{ $what } = $attribs->{ $type };

				delete $attribs->{ $type };
			}
		}

return $attribs;
}

# Preloaded methods go here.

our $classname_separator = '_';

sub schema
{
	my %schema = ();

	print "Gathering schema: ";

	foreach my $this ( @_ )
	{
		print "$this..\n";

		foreach my $class ( @{Class::Maker::Reflection::inheritance_isa( ref($this) || $this )} )
		{
				# main:: and :: prefix should be stripped from package identifier
				#
				# because of a bug in bless

			$class =~ s/^(?:main)?:://;

			print "\tbase $class detected\n" if $Class::Maker::DEBUG;

				# inefficient PROVISIONAL because below i tweak in the original CLASS info, instead of doing
				# it in the schema => but NOW i have not the time...

			my %copy = %{ Class::Maker::Reflection::reflect( $class )->definition };

			print "DUMPER: ";

			use Data::Dumper;

			print Dumper \%copy;

			my $reflex = \%copy;

			my $cfg = $reflex->{persistance};

			next if exists $cfg->{ignore};

			if( exists $cfg->{table} )
			{
				$schema{$class}->{table} = $cfg->{table};
			}
			elsif( 0 ) # $class =~ /::/ )	# because :: may conflict SQL
			{
				$schema{$class}->{table} = $class;

				$schema{$class}->{table} =~ s/::/$classname_separator/g;
			}

			if( exists $cfg->{abstract} )
			{
				$schema{$class}->{abstract} = $cfg->{abstract} if exists $cfg->{abstract};
			}
			else
			{
					# Translate fieldnames to tangram types (see above for Tangram Type Extension Modules 'use')

				foreach my $csection ( qw(public private protected) )
				{
						# look if we had a: type => [qw(eins zwei)]  ...or... type => { eins => 'Object::Eins', ...

					_map_to_tangram( $reflex->{$csection}, $mappings ) if exists $reflex->{$csection};

					$schema{$class}->{fields} = $reflex->{$csection} if exists $reflex->{$csection};

						# look into array and ref fields for classes to be included into the schema

					foreach my $obj_field ( qw(array ref) )
					{
						if( ref( $reflex->{$csection}->{$obj_field} ) eq 'HASH' )
						{
								# cylce to the references classes and if not already in schema -> add it..

							foreach ( values %{ $reflex->{$csection}->{$obj_field} } )
							{
								unless( exists $schema{ $_ } )
								{
										# catch schema of referenced classes

									my %classes = @{ schema( $_ ) };

									foreach my $class_key ( keys %classes )
									{
										$schema{ $class_key }= $classes{$class_key};
									}
								}
							}
						}
					}
				}

				my $isa = $cfg->{bases} || $reflex->{isa};

				$schema{$class}->{bases} = $isa if $isa;
			}
		}
	}

return [ %schema ];
}

1;

__END__