unless($model && $schema);
Class::MOP::load_class( $base );
Class::MOP::load_class( $schema );
- my $meta = eval { Class::MOP::load_class($model); } ?
- $model->meta : $base->meta->create($model, superclasses => [ $base ]);
+ my $meta = $self->_load_or_create($model, $base);
# sources => undef, #default to qr/./
# sources => [], #default to nothing
};
};
+ implements _class_to_attribute_name => as {
+ my ( $self, $str ) = @_;
+ confess("wrong arguments passed for _class_to_attribute_name") unless $str;
+ return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str))
+ };
implements add_source => as {
my ($self, %opts) = @_;
unless( $reader ){
$reader = $source;
$reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
- $reader = join('_', map lc, split(/::/, $reader)) . "_collection"; #XXX change to not use _collection ?
+ $reader = $self->_class_to_attribute_name($reader) . "_collection";
}
unless( $dm_name ){
my @haystack = $meta->domain_models;
required => 1,
isa => $collection,
reader => $reader,
- predicate => "has_" . join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $name)),
+ predicate => "has_" . $self->_class_to_attribute_name($name) ,
domain_model => $dm_name,
orig_attr_name => $source,
default => sub {
- $collection->new(_source_resultset => shift->$dm_name->resultset($source));
+ $collection->new
+ (
+ _source_resultset => $_[0]->$dm_name->resultset($source),
+ _parent => $_[0],
+ );
},
);
+# my %debug_attr_opts =
+# (
+# lazy => 1,
+# required => 1,
+# isa => $collection,
+# reader => $reader,
+# predicate => "has_" . $self->_class_to_attribute_name($name) ,
+# domain_model => $dm_name,
+# orig_attr_name => $source,
+# default => qq^sub {
+# my \$self = \$_[0];
+# return $collection->new(
+# _source_resultset => \$self->$dm_name->resultset("$source"),
+# _parent => \$self,
+# );
+# }, ^,
+# );
+
+
+
my $make_immutable = $meta->is_immutable;
$meta->make_mutable if $make_immutable;
my $attr = $meta->add_attribute($name, %attr_opts);
);
$self->add_source(
- model_class => $opts{parent_class},
- source_name => $opts{source_name},
- domain_model_name => $opts{parent_domain_model_name},
+ %opts,
+ model_class => delete $opts{parent_class},
+ domain_model_name => delete $opts{parent_domain_model_name},
collection_class => $col_meta->name,
);
};
Class::MOP::load_class( $base );
Class::MOP::load_class( $object );
- my $meta = eval { Class::MOP::load_class($class) } ?
- $class->meta : $base->meta->create( $class, superclasses => [ $base ]);
+ my $meta = $self->_load_or_create($class, $base);
my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
$meta->make_mutable if $meta->is_immutable;
Class::MOP::load_class($schema) if $schema;
Class::MOP::load_class($source_class);
- my $meta = eval { Class::MOP::load_class($class) } ?
- $class->meta : $base->meta->create($class, superclasses => [ $base ]);
+ my $meta = $self->_load_or_create($class, $base);
#create the domain model
$dm_name ||= $self->dm_name_from_source_name($source_name);
#default options. lazy build but no outsider method
my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
clearer => "_clear_${attr_name}",
- predicate => "has_${attr_name}",
+ predicate => {
+ "has_${attr_name}" =>
+ sub { defined(shift->$dm_name->$attr_name) }
+ },
domain_model => $dm_name,
orig_attr_name => $attr_name,
);
$from_attr->type_constraint->name eq 'ArrayRef' ||
$from_attr->type_constraint->is_subtype_of('ArrayRef');
+
+
if( my $rel_info = $source->relationship_info($attr_name) ){
my $rel_accessor = $rel_info->{attrs}->{accessor};
my $rel_moniker = $rel_info->{class}->result_source_instance->source_name;
#type constraint is the foreign IM object, default inflates it
$attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
$attr_opts{default} = sub {
- shift->$dm_name
- ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
+ if (defined(my $o = shift->$dm_name->$attr_name)) {
+ return $attr_opts{isa}->inflate_result($o->result_source, { $o->get_columns });
+ }
+ return undef;
+ #->find_related($attr_name, {},{result_class => $attr_opts{isa}});
};
}
} elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
return $attr_opts{isa}->new(_source_resultset => $rs);
};
+ #} elsif( $constraint_is_ArrayRef ){
+ #test these to see if rel is m2m
+ #my $meth = $attr_name;
+ #if( $source->can("set_${meth}") && $source->can("add_to_${meth}") &&
+ # $source->can("${meth}_rs") && $source->can("remove_from_${meth}") ){
+
+
+ #}
} else {
#no rel
my $reader = $from_attr->get_read_method;
my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
#create the class
- warn $class;
- my $meta = eval { Class::MOP::load_class($class) } ?
- $class->meta : $base->meta->create($class, superclasses => [$base]);
+ my $meta = $self->_load_or_create($class, $base);
my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
$meta->make_mutable if $meta->is_immutable;
my $s_attr = $s_meta->find_attribute_by_name($s_attr_name);
confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
unless defined $s_attr;
- next unless $s_attr->get_write_method; #only rw attributes!
+ next unless $s_attr->get_write_method
+ && $s_attr->get_write_method !~ /^_/; #only rw attributes!
my $attr_params = $self->parameters_for_source_object_action_attribute
(
$source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
+ #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n";
+
confess("${attr_name} is not writeable and can not be reflected")
unless $from_attr->get_write_method;
is => 'rw',
isa => $from_attr->_isa_metadata,
required => $from_attr->is_required,
+ ($from_attr->is_required
+ ? () : (clearer => "clear_${attr_name}")),
predicate => "has_${attr_name}",
);
return \%attr_opts;
};
+ implements _load_or_create => as {
+ my ($self, $class, $base) = @_;
+ my $meta = $self->_maybe_load_class($class) ?
+ $class->meta : $base->meta->create($class, superclasses => [ $base ]);
+ return $meta;
+ };
+
+ implements _maybe_load_class => as {
+ my ($self, $class) = @_;
+ my $file = $class . '.pm';
+ $file =~ s{::}{/}g;
+ my $ret = eval { Class::MOP::load_class($class) };
+ if ($INC{$file} && $@) {
+ confess "Error loading ${class}: $@";
+ }
+ return $ret;
+ };
+
};
1;
projects / catagits/Reaction.git / blobdiff