/usr/local/CPAN/UR/UR/Object/Type/DBICModuleWriter.pm
package UR::Object::Type::DBICModuleWriter; # to help the installer
package UR::Object::Type; # hold methods for the class which cover Module Read/Write.
use strict;
use warnings;
sub dbic_resolve_package_name_for_class_name {
my $self = shift;
my @parts = split(/::/, $self->class_name);
shift @parts; # Remove the namespace part of the name
my $ds = UR::Context->resolve_data_sources_for_class_meta_and_rule($self);
unless ($ds) {
$self->error_message("Can't resolve a data source for class ".$self->class_name);
return undef;
}
my $schema_name = $ds->resolve_dbic_schema_name;
return join('::', $schema_name, @parts);
}
our %meta_classes;
our $bootstrapping = 1;
our @partially_defined_classes;
our $pwd_at_compile_time = cwd();
sub dbic_resolve_module_header_source {
my $self = shift;
no strict 'refs';
my @isa = @{ $self->class_name . "::ISA" };
unless (@isa) {
#Carp::cluck("No isa for $self->{class_name}!?");
my @i = UR::Object::Inheritance->get(
class_name => $self->class_name
);
my @parent_class_objects = map { UR::Object::Type->is_loaded(class_name => $_->parent_class_name) } @i;
die "Parent class objects not all loaded for " . $self->class_name unless (@i == @parent_class_objects);
@isa = map { $_->class_name } @parent_class_objects;
}
unless (@isa) {
#Carp::confess("FAILED TO SET ISA FOR $self->{class_name}!?");
my @i = UR::Object::Inheritance->get(
class_name => $self->class_name
);
my @parent_class_objects =
map { UR::Object::Type->is_loaded(class_name => $_->parent_class_name) } @i;
unless (@i and @i == @parent_class_objects) {
$DB::single=1;
Carp::confess("No inheritance meta-data found for ( @i / @parent_class_objects)" . $self->class_name)
}
@isa = map { $_->class_name } @parent_class_objects;
}
use strict;
my $class_name = $self->class_name;
my @parent_classes = $self->parent_class_metas;
my $has_table = $self->has_table;
unless ($has_table) {
Carp::confess("Trying to write a DBIC class for a tableless UR class?");
return;
}
# For getting default values for some of the properties
my $class_meta_meta = UR::Object::Type->get(class_name => 'UR::Object::Type');
my $perl = "# begin autogenerated dbic\nuse base qw/DBIx::Class/;\n\n__PACKAGE__->load_components(qw/PK::Auto Core/);\n";
$perl .= sprintf("__PACKAGE__->table('%s');\n", $self->table_name);
my %properties_seen;
# Regular properties
my @column_data;
foreach my $property ( UR::Object::Property->get(class_name => $class_name)) {
#next if ($properties_seen{$property->property_name}++);
next unless ($property->is_concrete);
next unless ($property->column_name); # FIXME dosen't handle EAVs
my $this_column = { data_type => $property->data_type,
size => (defined $property->data_length) ? $property->data_length : 1,
is_nullable => $property->is_optional,
};
if (lc($property->property_name) ne lc($property->column_name)) {
$this_column->{'accessor'} = $property->property_name;
}
if (defined($property->default_value)) {
$this_column->{'default_value'} = $property->default_value;
}
push(@column_data,
sprintf("%s => { %s }",
lc($property->column_name),
join(', ', map { "$_ => " . ($this_column->{$_} =~ m/\D/ ? sprintf("'%s'", $this_column->{$_}) : $this_column->{$_}) } keys %$this_column)));
}
$perl .= sprintf("__PACKAGE__->add_columns(%s);\n", join(",\n\t", @column_data));
# ID Properties
my @id_columns = map { lc $_->column_name }
map { UR::Object::Property->get(class_name => $_->class_name,
property_name => $_->property_name)
}
UR::Object::Property::ID->get(class_name => $class_name);
$perl .= sprintf("__PACKAGE__->set_primary_key(qw/ %s /);\n",
join(' ', @id_columns));
# Relationships
foreach my $reference (UR::Object::Reference->get(class_name => $class_name)) {
next if ($properties_seen{$reference->delegation_name}++);
my @ref_props = UR::Object::Reference::Property->get(tha_id => $reference->tha_id);
if (@ref_props > 1) {
$perl .= $self->_dbic_make_multi_column_relationship($reference, @ref_props);
next;
}
# Only a single column relationship from here down
my $property = UR::Object::Property->get(class_name => $reference->class_name,
property_name => $ref_props[0]->property_name);
my $r_property = UR::Object::Property->get(class_name => $reference->r_class_name,
property_name => $ref_props[0]->r_property_name);
my $reltype = $self->_dbic_relation_type_for_property($property);
# Wow, there should be a shorter way to get this
my $dbic_r_class_name = $r_property->class_name->__meta__->dbic_resolve_package_name_for_class_name;
$perl .= sprintf("__PACKAGE__->%s('%s','%s','%s');\n",
$reltype,
$reference->delegation_name,
$dbic_r_class_name,
lc($r_property->column_name));
}
$perl .= "# end autogenerated dbic\n";
return $perl;
}
# FIXME Get the distinction between belongs_to, has_many, has_one, might_have, many_to_many right
sub _dbic_relation_type_for_property {
my($self,$property) = @_;
my $reltype;
if ($property->is_many) {
$reltype = 'has_many';
} elsif ($property->is_optional) {
$reltype = 'might_have';
} else {
$reltype = 'belongs_to';
}
return $reltype;
}
sub _dbic_make_multi_column_relationship {
my($self,$reference, @ref_props) = @_;
$DB::single=1;
@ref_props = sort { $a->rank <=> $b->rank } @ref_props;
my @forward_properties = map { UR::Object::Property->get(class_name => $reference->class_name,
property_name => $_->property_name) }
@ref_props;
my @remote_properties = map { UR::Object::Property->get(class_name => $reference->r_class_name,
property_name => $_->r_property_name) }
@ref_props;
# Make sure all the relation types for these properties are the same
my @reltypes = map { $self->_dbic_relation_type_for_property($_) } @forward_properties;
my $reltype = shift @reltypes;
for(my $i = 0; $i < @reltypes; $i++) {
if ($reltype ne $reltypes[$i]) {
$self->error_message(sprintf("Relation types are not compatible for class %s, reference ID %s",
$reference->class_name, $reference->id));
return;
}
}
# Make sure that all the reverse properties point to the same class
my @remote_properties_classes = map { $_->class_name->__meta__->dbic_resolve_package_name_for_class_name }
@remote_properties;
my $dbic_r_class_name = shift @remote_properties_classes;
for (my $i = 0; $i < @remote_properties_classes; $i++) {
if ($dbic_r_class_name ne $remote_properties_classes[$i]) {
$self->error_message("mismatch remote properties for class (fill in more diags here)");
return;
}
}
my $perl = sprintf("__PACKAGE__->%s('%s','%s',\n",
$reltype,
$reference->delegation_name,
$dbic_r_class_name);
for (my $i = 0; $i < @forward_properties; $i++) {
$perl .= sprintf("\t'foreign.%s' => 'self.%s',\n",
lc($remote_properties[$i]->column_name),
lc($forward_properties[$i]->column_name));
}
$perl .= ");\n";
return $perl;
}
sub dbic_module_base_name {
my $file_name = shift->dbic_resolve_package_name_for_class_name;
$file_name =~ s/::/\//g;
$file_name .= ".pm";
return $file_name;
}
sub dbic_module_path {
my $self = shift;
my $base_name = $self->dbic_module_base_name;
my $path = $INC{$base_name};
return _abs_path_relative_to_pwd_at_compile_time($path) if $path;
#warn "Module $base_name is not in \%INC!\n";
my $namespace = $base_name;
$namespace =~ s/\/.*$//;
$namespace .= ".pm";
for my $dir (map { _abs_path_relative_to_pwd_at_compile_time($_) } @INC) {
next unless $dir; # above _abs_path_... returns undef for dirs in @INC that do not exist
if (-e $dir . "/" . $namespace) {
#warn "Found $base_name in $dir...\n";
my $try_path = $dir . '/' . $base_name;
return $try_path;
}
}
Carp::confess("Failed to find a module path for class " . $self->class_name);
}
# sub _abs_path_relative_to_pwd_at_compile_time { # not a method
# my $path = shift;
# if ($path !~ /^[\/\\]/) {
# $path = $pwd_at_compile_time . '/' . $path;
# }
# $path = Cwd::abs_path($path);
# return $path;
# }
sub dbic_module_directory {
my $self = shift;
my $base_name = $self->dbic_module_base_name;
my $path = $self->dbic_module_path;
return unless length($path);
unless ($path =~ s/$base_name$//) {
Carp::confess("Failed to find base name $base_name at the end of path $path!")
}
return $path;
}
#sub singleton_cache_dir {
# my $self = shift;
# my $singleton_cache_dir = $self->singleton_path;
# $singleton_cache_dir =~ s/\.pm$//;
# $singleton_cache_dir .= "/";
# return $singleton_cache_dir;
#}
sub dbic_module_source_lines {
my $self = shift;
my $file_name = $self->dbic_module_path;
my $in = IO::File->new("<$file_name");
unless ($in) {
return (undef,undef,undef);
}
my @module_src = <$in>;
$in->close;
return @module_src
}
sub dbic_module_source {
join("",shift->module_source_lines);
}
sub dbic_module_header_positions {
my $self = shift;
my @module_src = $self->dbic_module_source_lines;
return (undef,undef) unless (@module_src);
my($begin,$end);
for(my $i = 0; $i < @module_src; $i++) {
no warnings 'uninitialized';
if($module_src[$i] =~ m/# begin autogenerated dbic/) {
$begin = $i;
last;
}
}
for(my $i = $#module_src; $i >= 0; $i--) {
no warnings 'uninitialized';
if ($module_src[$i] =~ m/# end autogenerated dbic/) {
$end = $i;
last;
}
}
return ($begin, $end) if (defined $begin && defined $end);
if ($end < $begin) {
$self->error_message("Found 'end autogenerated dbic' earlier in the file than 'begin autogenerated dbic'!?");
}
return (undef, undef);
}
sub dbic_module_header_source_lines {
my $self = shift;
my ($begin,$end) = $self->dbic_module_header_positions;
my @src = $self->dbic_module_source_lines;
return unless $end;
@src[$begin..$end];
}
sub dbic_module_header_source {
join("",shift->dbic_module_header_source_lines);
}
sub dbic_rewrite_module_header {
use strict;
use warnings;
$DB::single=1;
my $self = shift;
my $package = $self->dbic_resolve_package_name_for_class_name;
# generate new class metadata
my $new_meta_src = $self->dbic_resolve_module_header_source;
unless ($new_meta_src) {
die "Failed to generate source code for $package!";
}
my ($begin,$end) = $self->dbic_module_header_positions;
# determine the path to the module
# this may not exist
my $module_file_path = $self->dbic_module_path;
# temp safety hack
if ($module_file_path =~ "/gsc/scripts/lib") {
Carp::confess("attempt to write directly to the app server!");
}
# determine the new source for the module
my @module_src;
my $old_file_data;
if (-e $module_file_path) {
# rewrite the existing module
# find the old positions of the module header
@module_src = $self->dbic_module_source_lines;
if (!grep {$_ =~ m/^use warnings;/} @module_src) {
$new_meta_src = "use warnings;\n" . $new_meta_src;
}
if (!grep {$_ =~ m/^use strict;/} @module_src) {
$new_meta_src = "use strict;\n" . $new_meta_src;
}
# If $begin and $end are undef, then module_header_positions() didn't find any
# old code and we're inserting all brand new stuff. Look for the package declaration
# and insert after that.
my $len;
if (defined $begin || defined $end) {
$len = $end-$begin+1;
} else {
# is there a more fool-proof way to find it?
for ($begin = 0; $begin < $#module_src; ) {
last if ($module_src[$begin++] =~ m/package\s+$package;/);
}
$len = 0;
}
# replace the old lines with the new source
# note that the inserted "row" is multi-line, but joins nicely below...
splice(@module_src,$begin,$len,$new_meta_src);
my $f = IO::File->new($module_file_path);
$old_file_data = join('',$f->getlines);
$f->close();
}
else {
# write new module source
# put =cut marks around it if this is a special metadata class
# the definition at the top is non-functional for bootstrapping reasons
if ($meta_classes{$package}) {
$new_meta_src = "=cut\n\n$new_meta_src\n\n=cut\n\n";
$self->warning_message("Meta package $package");
}
@module_src = join("\n",
"package $package;",
"",
"use strict;",
"use warnings;",
"",
$new_meta_src,
"",
"1;",
""
);
}
$ENV{'HOST'} ||= '';
my $temp = "$module_file_path.$$.$ENV{HOST}";
my $temp_dir = $module_file_path;
$temp_dir =~ s/\/[^\/]+$//;
unless (-d $temp_dir) {
print "mkdir -p $temp_dir\n";
system "mkdir -p $temp_dir";
}
my $out = IO::File->new(">$temp");
unless ($out) {
die "Failed to create temp file $temp!";
}
for (@module_src) { $out->print($_) };
$out->close;
my $rv = system qq(perl -e 'eval `cat $temp`' 2>/dev/null 1>/dev/null);
$rv /= 255;
if ($rv) {
die "Module is not compilable with new source!";
}
else {
unless (rename $temp, $module_file_path) {
die "Error renaming $temp to $module_file_path!";
}
}
UR::Context::Transaction->log_change($self, ref($self), $self->id, 'dbic_rewrite_module_header', Data::Dumper::Dumper{path => $module_file_path, data => $old_file_data});
return 1;
}
1;