
package UR::Object::Type::ModuleWriter; # to help the installer

package UR::Object::Type; # hold methods for the class which cover Module Read/Write.

use strict;
use warnings;

our %meta_classes;
our $bootstrapping = 1;
our @partially_defined_classes;
our $pwd_at_compile_time = cwd();

sub resolve_class_description_perl {
    my $self = $_[0];
    
    no strict 'refs';
    my @isa = @{ $self->class_name . "::ISA" };
    use strict;

    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;
    }

    my $class_name = $self->class_name;
    my @parent_classes = $self->parent_class_metas;
    my $has_table = $self->has_table;

    # For getting default values for some of the properties
    my $class_meta_meta = UR::Object::Type->get(class_name => 'UR::Object::Type');
    
    my $perl = '';
    
    unless (@isa == 1 and $isa[0] =~ /^UR::Object|UR::Entity$/ ) {
        $perl .= "    is => " . (@isa == 1 ? "[ '@isa' ],\n" : "[ qw/@isa/ ],\n");
    }
    $perl .= "    type_name => '" . $self->type_name . "',\n" unless $self->type_name eq $class_name;
    $perl .= "    table_name => " . ($self->table_name ? "'" . $self->table_name . "'" : 'undef') . ",\n" if $self->data_source_id;
    $perl .= "    is_abstract => 1,\n" if $self->is_abstract;
    $perl .= "    er_role => '" . $self->er_role . "',\n" if ($self->er_role and ($self->er_role ne $class_meta_meta->property_meta_for_name('er_role')->default_value));

    # Meta-property attributes
    my @property_meta_property_names;
    my @property_meta_property_strings;
    if ($self->{'attributes_have'}) {
        @property_meta_property_names = sort { $self->{'attributes_have'}->{$a}->{'position_in_module_header'}
                                                 <=>
                                               $self->{'attributes_have'}->{$b}->{'position_in_module_header'} }
                                            keys %{$self->{'attributes_have'}};
        foreach my $meta_name ( @property_meta_property_names ) {
            my $this_meta_struct = $self->{'attributes_have'}->{$meta_name};

            # The attributes_have structure gets propogated to subclasses, but it only needs to appear
            # in the class definition of the most-parent class
            my $expected_name = $class_name . '::attributes_have';
            next unless ( $this_meta_struct->{'is_specified_in_module_header'} eq $expected_name);

            # We want these to appear first
            my @this_meta_properties;
            push @this_meta_properties, sprintf("is => '%s'", $this_meta_struct->{'is'}) if (exists $this_meta_struct->{'is'});
            push @this_meta_properties, sprintf("is_optional => %d", $this_meta_struct->{'is_optional'}) if (exists $this_meta_struct->{'is_optional'});

            foreach my $key ( sort keys %$this_meta_struct ) {
                next if grep { $key eq $_ } qw( is is_optional is_specified_in_module_header position_in_module_header );  # skip the ones we've already done
                my $value = $this_meta_struct->{$key};
                
                my $format = $self->_is_number($value) ? "%s => %s" : "%s => '%s'";
                push @this_meta_properties, sprintf($format, $key, $value);
            }
            push @property_meta_property_strings, "$meta_name => { " . join(', ', @this_meta_properties) . " },";
        }
    }
    if (@property_meta_property_strings) {
        $perl .= "    attributes_have => [\n        " . 
                 join("\n        ", @property_meta_property_strings) .
                 "\n    ],\n";
    }

    if (exists $self->{'first_sub_classification_method_name'}) {
        # This gets overridden by UR::Object::Type to cache the value it finds from parent
        # classes in __first_sub_classification_method_name, so we can't just get the
        # property through the normal channels
        $perl .= "    first_sub_classification_method_name => '" . $self->{'first_sub_classification_method_name'} ."',\n";
    }
            
    # These property names are either written in other places in this sub, or shouldn't be written out
    my %addl_property_names = map { $_ => 1 } $self->__meta__->all_property_type_names;
    my @specified = qw/is class_name type_name table_name id_by er_role is_abstract generated data_source_id schema_name doc namespace id first_sub_classification_method_name property_metas pproperty_names id_property_metas reference_metas reference_property_metas meta_class_name/;
    delete @addl_property_names{@specified};
    for my $property_name (sort keys %addl_property_names) {
        my $property_obj = $class_meta_meta->property_meta_for_name($property_name);
        next if ($property_obj->is_calculated or $property_obj->is_delegated);

        my $property_value = $self->$property_name;
        my $default_value = $property_obj && $property_obj->default_value;
        # If the property is set on the class object
        # and both the value and default are numeric and numerically different,
        #     or stringly different than the default
        no warnings qw( numeric uninitialized );
        if ( defined $property_value and
             ( ($property_value + 0 eq $property_value and
                $default_value + 0 eq $default_value and
                $property_value != $default_value) 
               or
                ($property_value ne $default_value)
             )
           ) {
                # then it should show up in the class definition
                $perl .= "    $property_name => '" . $self->$property_name . "',\n";
           }
    }

    my %properties_by_section;
    my %id_property_names = map { $_->property_name => 1 } $self->direct_id_token_metas;
    my @properties = $self->direct_property_metas;
    foreach my $property_meta ( @properties ) {
        my $mentioned_section = $property_meta->is_specified_in_module_header;
        next unless $mentioned_section;  # skip implied properites
        ($mentioned_section) = ($mentioned_section =~ m/::(\w+)$/);
         
        if (($mentioned_section and $mentioned_section eq 'id_implied')
            or $id_property_names{$property_meta->property_name}) {

            push @{$properties_by_section{'id_by'}}, $property_meta;

        } elsif ($mentioned_section) {
            push @{$properties_by_section{$mentioned_section}}, $property_meta;
  
        } else {
            push @{$properties_by_section{'has'}}, $property_meta;
        }
    }

    my %sections_seen;
    foreach my $section ( ( 'id_by', 'has', 'has_many', 'has_optional', keys(%properties_by_section) ) ) {
        next unless ($properties_by_section{$section});
        next if ($sections_seen{$section});
        $sections_seen{$section} = 1;

        # New properites (will have position_in_module_header == undef) should go at the end
        my @properties = sort { my $pos_a = defined($a->{'position_in_module_header'})
                                            ? $a->{'position_in_module_header'}
                                            : 1000000;
                                my $pos_b = defined($b->{'position_in_module_header'})
                                            ? $b->{'position_in_module_header'}
                                            : 1000000;
                                $pos_a <=> $pos_b;
                              }
                              @{$properties_by_section{$section}};
        
        my $section_src = '';
        my $max_name_length = 0;
        foreach my $property_meta ( @properties ) {
            my $name = $property_meta->property_name;
            $max_name_length = length($name) if (length($name) > $max_name_length);
        }
        foreach my $property_meta ( @properties ) {
            my $name = $property_meta->property_name;
            my @fields = $self->_get_display_fields_for_property(
                                        $property_meta,
                                        has_table => $has_table,
                                        section => $section,
                                        attributes_have => \@property_meta_property_names);

            my $line = "        "
                . $name . (" " x ($max_name_length - length($name)))
                . " => { "
                . join(", ", @fields)
                . " },\n";

            $section_src .= $line;
        }

        $perl .= "    $section => [\n$section_src    ],\n";
    }

    if (my @unique_constraint_props = sort { $a->unique_group cmp $b->unique_group }
                                      UR::Object::Property::Unique->get(class_name => $self->class_name)) {
        my %unique_groups;
        for my $uc_prop (@unique_constraint_props) {
            $unique_groups{$uc_prop->unique_group} ||= [];
            push @{ $unique_groups{$uc_prop->unique_group} }, $uc_prop;
        }

        $perl .= "    unique_constraints => [\n";
        for my $unique_group (values %unique_groups) {
            my @property_objects = map { 
                    UR::Object::Property->get(class_name => $self->class_name, property_name => $_->property_name); 
                } @$unique_group;
            #my @property_names = sort map { $_->property_name } @property_objects;
            my @property_names = sort map { $_->property_name } @$unique_group; 
            $perl .= "        { "
                . "properties => [qw/@property_names/], "
                . "sql => '" . $unique_group->[0]->unique_group . "'"
                . " },\n";
        }
        $perl .= "    ],\n";
    }

    $perl .= "    schema_name => '" . $self->schema_name . "',\n" if $self->schema_name;
    $perl .= "    data_source => '" . $self->data_source_id . "',\n" if $self->data_source_id;

    my $doc = $self->doc;
    if (defined($doc)) {
        $doc = Dumper($doc);
        $doc =~ s/\$VAR1 = //;
        $doc =~ s/;\s*$//;
    }
    #$perl .= "    source => '" . $self->source . "',\n" if defined $self->source;
    $perl .= "    doc => $doc,\n" if defined($doc);

#=cut
#
#    do {
#        no warnings;
#        
#        my $new_desc = eval "{ $perl }";
#        die $@ if $@;        
#        
#        my $old_desc = $self; #UR::Util::deep_copy($self);
#        for my $key (keys %$old_desc) {            
#            delete $old_desc->{$key} if $key =~ /^_/;            
#        }
#        for my $has (keys %{ $old_desc->{has} }) {
#            my $p = $old_desc->{has}{$has};
#            if ($p->{implied_by}) {
#                delete $old_desc->{has}{$has};
#            }
#        }
#        delete $old_desc->{db_committed};
#        delete $old_desc->{id};
#        delete $old_desc->{module_header_positions};
#        delete $old_desc->{meta_class_name};        
#        
#        my $new_normalized = __PACKAGE__->_normalize_class_description(class_name => $class_name, %$new_desc);
#        my $old_normalized = __PACKAGE__->_normalize_class_description(%$old_desc);
#        my $old_src = Data::Dumper::Dumper($self);
#        my $new_src = Data::Dumper::Dumper($new_normalized);
#        unless ($old_src eq $new_src) {
#            warn "source for $class_name does not normalize back to the original class!\n";
#            print IO::File->new(">/tmp/old.pm")->print($old_src);
#            print IO::File->new(">/tmp/new.pm")->print($new_src);        
#        }
#    };
#
#=cut

    return $perl;
}

sub resolve_module_header_source {
    my $self = shift;
    my $class_name = $self->class_name;
    my $perl = "class $class_name {\n";
    $perl .= $self->resolve_class_description_perl;
    $perl .= "};\n";
    return $perl;
}

my $next_line_prefix = "\n" . (" " x 25);
my $deep_indent_prefix = "\n" . (" " x 55);

sub _get_display_fields_for_property {
    my $self = shift;
    my $property = shift;
    my %params = @_;
    
    if (not $property->is_specified_in_module_header) {
        # we omit showing implied properties which have no additional data,
        # unless they have their own docs, a specified column, etc.
        return();
    }    
    
    my @fields;    
    my %seen;
    my $property_name = $property->property_name;
    
    my $type = $property->data_type;
    if ($type) {
        push @fields, "is => '$type'" if $type;
        $seen{'is'} = 1;
    }
    
    if (defined($property->data_length) and length($property->data_length)) {
        push @fields, "len => " . $property->data_length;
        $seen{'data_length'} = 1;
    }
    
    #$line .= "references => '???', ";
    if ($property->is_legacy_eav) { 
        # temp hack for entity attribute values
        #push @fields, "delegate => { via => 'eav_" . $property->property_name . "', to => 'value' }";
        push @fields, "is_legacy_eav => 1";                
        $seen{'is_legacy_eav'} = 1;
    }
    elsif ($property->is_delegated) {
        # do nothing
        $seen{'is_delegated'} = 1;
    }
    elsif ($property->is_calculated) {
        my @calc_fields;
        if (my $calc_from = $property->calculate_from) {
            if ($calc_from and @$calc_from == 1) {
                push @calc_fields, "calculate_from => '" . $calc_from->[0] . "'";
            } elsif ($calc_from) {
                push @calc_fields, "calculate_from => [ '" . join("', '", @$calc_from) . "' ]";
            }
        }

        my $calc_source;
        foreach my $calc_type ( qw( calculate calculate_sql calculate_perl calculate_js ) ) {
            if ($property->$calc_type) {
                $calc_source = 1;
                push @calc_fields, "$calc_type => q(" . $property->$calc_type . ")";
            }
        }

        push @calc_fields, 'is_calculated => 1' unless ($calc_source);

        push @fields, join(",$next_line_prefix", @calc_fields);
        $seen{'is_calculated'} = 1;
    } 
    elsif ($params{has_table} && ! $property->is_transient) {
        unless ($property->column_name) {
            die("no column for property on class with table: " . $property->property_name .
                " class: " . $self->class_name . "?");
        }
        if (uc($property->column_name) ne uc($property->property_name)) {
            push @fields,  "column_name => '" . $property->column_name . "'";
        }
        $seen{'column_name'} = 1;
    }

    if (defined($property->default_value)) {
        my $value = $property->default_value;
        if (! $self->_is_number($value)) {
            $value = "'$value'";
        }
        push @fields, "default_value => $value";
        $seen{'default_value'} = 1;
    }
    
    my $implied_property = 0;
    if (defined($property->implied_by) and length($property->implied_by)) { 
        push @fields,  "implied_by => '" . $property->implied_by . "'";
        $implied_property = 1;
        $seen{'implied_by'} = 1;
    }

    if (my @id_by = $property->id_by_property_links) {
        push @fields, "id_by => " 
            . (@id_by > 1 ? '[ ' : '')
            . join(", ", map { "'" . $_->property_name . "'" } @id_by)
            . (@id_by > 1 ? ' ]' : '');
        $seen{'id_by_property_links'} = 1;
    }

    if ($property->via) {
        push @fields, "via => '" . $property->via . "'";
        $seen{'via'} = 1;
        if ($property->to and $property->to ne $property->property_name) {
            push @fields, "to => '" . $property->to . "'";
            $seen{'to'} = 1;
        }
    }
    if ($property->reverse_as) {
        push @fields, "reverse_as => '" . $property->reverse_as . "'";
        $seen{'reverse_as'} = 1;
    }

    if ($property->constraint_name) {
        push @fields, "constraint_name => '" . $property->constraint_name . "'";
        $seen{'constraint_name'} = 1;
    }

    if ($property->where) {
        my %where = @{ $property->where };
        push @fields, 'where => [ ' . join(', ', map { sprintf("%s => '%s'", $_, $where{$_}) } keys %where) . ' ]';
    }

    if (my $values_arrayref = $property->valid_values) {
        $seen{'valid_values'} = 1;
        my $value_string = Data::Dumper->new([$values_arrayref])->Terse(1)->Indent(0)->Useqq(1)->Dump;
        push @fields, "valid_values => $value_string";
    }

    # All the things like is_optional, is_many, etc
    # show only true values, false is default
    # section can be things like 'has', 'has_optional' or 'has_transient_many_optional'
    my $section = $params{'section'};
    $section =~ m/^has_(.*)/;
    my @sections = split('_',$1 || '');
    
    for my $std_field_name (qw/optional abstract transient constant class_wide many deprecated/) {
        $seen{$property_name} = 1;
        next if (grep { $std_field_name eq $_ } @sections); # Don't print is_optional if we're in the has_optional section
        my $property_name = "is_" . $std_field_name;
        push @fields, "$property_name => " . $property->$property_name if $property->$property_name;
    }


    foreach my $meta_property ( @{$params{'attributes_have'}} ) {
        my $value = $property->{$meta_property};
        if (defined $value) {
            my $format = $self->_is_number($value) ? "%s => %s" : "%s => '%s'";
            push @fields, sprintf($format, $meta_property, $value);
        }
    }
    
    my $desc = $property->doc;
    if ($desc && length($desc)) {
        $desc =~ s/([\$\@\%\\\"])/\\$1/g;
        $desc =~ s/\n/\\n/g;
        push @fields,  $next_line_prefix . "doc => '$desc'";
    }
    
    return @fields;
}

sub module_base_name {
    my $file_name = shift->class_name;
    $file_name =~ s/::/\//g;
    $file_name .= ".pm";
    return $file_name;
}

sub module_path {
    my $self = shift;
    my $base_name = $self->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($_) } grep { -d $_ } @INC) {
        if (-e $dir . "/" . $namespace) {
            #warn "Found $base_name in $dir...\n";
            my $try_path = $dir . '/' . $base_name;
            return $try_path;
        }
    }
    return;
    #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;
    } 
    my $path2 = Cwd::abs_path($path);
#    Carp::confess("$path abs is undef?") if not defined $path2;
    return $path2;
}


sub module_directory {
    my $self = shift;
    my $base_name = $self->module_base_name;
    my $path = $self->module_path;
    return unless defined($path) and 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 module_source_lines {
    my $self = shift;
    my $file_name = $self->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 module_source {
    join("",shift->module_source_lines);
}

sub module_header_positions {
    my $self = shift;

    my @module_src = $self->module_source_lines;
    my $namespace = $self->namespace;
    my $class_name = $self->class_name;
    
    unless ($self->namespace) {
        die "No namespace on $self->{class_name}?"
    }    
    
    $namespace = 'UR' if $namespace eq $self->class_name;

    my $state = 'before';
    my ($begin,$end,$use);
    for (my $n = 0; $n < @module_src; $n++) {
        my $line = $module_src[$n];        
        if ($state eq 'before') {
            if ($line and $line =~ /^use $namespace;/) {
                $use = $n;
            }
            if (
                $line and (
                    $line =~ /^define UR::Object::Type$/
                    or $line =~ /^(App|UR)::Object::(Type|Class)->(define|create)\($/
                    or $line =~ /^class\s*$class_name\b/
                )
            ) {
                $begin = $n;
                $state = 'during';
            }
            else {

            }
        }
        elsif ($state eq 'during') {
            my $old_meta_src .= $line;  # FIXME this dosen't appear anywhere else??
            if ($line =~ /^(\)|\}|);\s*$/) {
                $end = $n;
                $state = 'after';
            }
        }
        #elsif ($state eq 'after') {
        #
        #}
    }

    # cache
    $self->{module_header_positions} = [$begin,$end,$use];

    # return
    return ($begin,$end,$use);
}

sub module_header_source_lines {
    my $self = shift;
    my ($begin,$end,$use) = $self->module_header_positions;
    my @src = $self->module_source_lines;
    return unless $end;
    @src[$begin..$end];
}

sub module_header_source {
    join("",shift->module_header_source_lines);
}

sub rewrite_module_header {
    use strict;
    use warnings;

    my $self = shift;
    my $package = $self->class_name;

if ($package->isa("UR::Object::Type")) {
    print Carp::longmess($package);
}

    $DB::single = 1;

    # generate new class metadata
    my $new_meta_src = $self->resolve_module_header_source;
    unless ($new_meta_src) {
        die "Failed to generate source code for $package!";
    }

    my ($begin,$end,$use) = $self->module_header_positions;
    
    my $namespace = $self->namespace;
    $namespace = 'UR' if $namespace eq $self->class_name;
    
    unless ($namespace) {
        ($namespace) = ($package =~ /^(.*?)::/);
    }
    $new_meta_src = "use $namespace;\n" . $new_meta_src unless $use;

    # determine the path to the module
    # this may not exist
    my $module_file_path = $self->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->module_source_lines;

        # cleanup legacy cruft
        unless ($namespace eq 'UR') {
            @module_src = map { ($_ =~ m/^use UR;/?"":$_) } @module_src;
        }

        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 " . $self->class_name . ";",
            "",
            "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, 'rewrite_module_header', Data::Dumper::Dumper{path => $module_file_path, data => $old_file_data});

    return 1;
}


sub _is_number {
    my($self,$value) = @_;
    no warnings 'numeric';
    my $is_number = ($value + 0) eq $value;
    return $is_number;
}


1;
