The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

if ($#ARGV == -1) {
	print "Syntax: $0 lib/project/DB/Result/database_table_definition.pm\n";
	exit;
}

for (@ARGV) {
	print "----- $_ ------\n";
	eval {
	open my $fh,'<',$_ or die "$_: $!";

	my $package;
	
	while (<$fh>) {
		next unless /package ([\w\:]+);/;
		$package = $1;
		last;
	}
	die 'No package found' unless defined($package);
	
	$package =~ /^([\w\:]+)\:\:DB\:\:Result\:\:(\w+)$/ or die 'Invalid package syntax: '.$package;
	my $project = $1;
	my $table = $2;
	my $prefix = $project.'::';

	my $obj = $prefix.$table;
	my $output = <<_EOT_;
package $obj;

use 5.006;
use strict;
use warnings;

use YAWF;
use YAWF::Object;

our \$VERSION = '0.01';
our \@ISA = ( 'YAWF::Object', '$package' );

sub TABLE { return '$table'; }

_EOT_

	while(<$fh>) {
		if (/\Q__PACKAGE__->belongs_to(\E/) {
			scalar(<$fh>) =~ /\"(\w+)\",/ and my $col = $1;
			die 'No belogs_to - local - column found' unless defined($col);
			scalar(<$fh>) =~ /\"$project\:\:DB\:\:Result\:\:([\w\:]+)\",/ and my $reftable = $1;
			die 'No referenced table' unless defined($reftable);
			scalar(<$fh>) =~ /\{ (\w+?) \=\> \"(\w+)\" \},/ or die 'No referencing information found';
			my $remote_col = $1;
			my $local_col = $2;
			
			$output .= <<_EOT_
sub $col {
    my \$self = shift;
    
    \$self->{$col} ||= $prefix$reftable->new($remote_col => \$self->get_column('$local_col'));
    
    return \$self->{$col};
}

_EOT_
		}		elsif (/\_\_PACKAGE\_\_\-\>(has_many|might_have)\(/) {
			scalar(<$fh>) =~ /\"(\w+)\",/ and my $col = $1;
			die 'No belogs_to - local - column found' unless defined($col);
			scalar(<$fh>) =~ /\"$project\:\:DB\:\:Result\:\:([\w\:]+)\",/ and my $reftable = $1;
			die 'No referenced table' unless defined($reftable);
			scalar(<$fh>) =~ /\{ "foreign\.(\w+?)" \=\> \"self\.(\w+)\" \},/ or die 'No referencing information found';
			my $remote_col = $1;
			my $local_col = $2;
			
			$output .= <<_EOT_
sub $col {
    my \$self = shift;

    return $prefix$reftable->list( { $remote_col => \$self->get_column('$local_col') } ) if wantarray;
    return [$prefix$reftable->list( { $remote_col => \$self->get_column('$local_col') } )] ;
}

_EOT_
		}
	}
	close $fh;

	$output .= "1;\n";
	
	my $fn = 'lib/'.$project.'/'.$table.'.pm';
	die $fn.' already exists' if -e $fn;
	open my $out_fh,'>',$fn or die 'Unable to create '.$fn.': '.$!;
	print $out_fh $output;
	close $out_fh;
};
print "$@\n" if $@;
}