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;
