diff --git a/lib/MetamodelX/Red/Model.pm6 b/lib/MetamodelX/Red/Model.pm6 index 6d4e3463..37833a8e 100644 --- a/lib/MetamodelX/Red/Model.pm6 +++ b/lib/MetamodelX/Red/Model.pm6 @@ -223,19 +223,20 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}", my \alias = ::?CLASS.new_type(:$name); %!alias-cache{$name} := alias; my role RAlias[Red::Model:U \rtype, Str $rname, \alias, \rel, \base, \join-type, @cols] { - method columns(|) { @cols } - method table(|) { rtype.^table } - method as(|) { self.table-formatter: $rname } - method orig(|) { rtype } - method join-type(|) { join-type } - method tables(|) { [ |base.^tables, alias ] } - method join-on(|) { + method parent(|) is rw { $ } + method columns(|) { @cols } + method table(|) { rtype.^table } + method as(|) { self.table-formatter: $rname } + method orig(|) { rtype } + method join-type(|) { join-type } + method tables(|) { [ |base.^tables, alias ] } + method join-on($, \a = alias) { do given rel { when Red::AST { $_ } when Callable { - my $filter = do given what-does-it-do($_, alias) { + my $filter = do given what-does-it-do($_, a) { do if [eqv] .values { .values.head } else { @@ -254,7 +255,7 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}", $filter } default { - .relationship-ast(alias) + .relationship-ast(a) } } @@ -455,7 +456,8 @@ multi method create(Str :$with!, |c) is hidden-from-backtrace { #| Creates a new object and saves it on DB #| It accepts a list os pairs (the same as C<.new>) #| And Lists and/or Hashes for relationships -multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw { +multi method create(\mo where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw { + my \model = mo.^orig; my $RED-DB = get-RED-DB; my $trans = so $*RED-TRANSCTION-RUNNING; $RED-DB .= begin unless $trans; @@ -470,6 +472,8 @@ multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defi my %pars; my %positionals; my %has-one{Mu}; + # TODO: make it before creating transaction + die "Not possible call .^create on a defined model" if mo.defined; for %orig-pars.kv -> $name, $val { my \attr = model.^attributes.first(*.name.substr(2) eq $name); @@ -531,6 +535,29 @@ multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defi $type.^create: |%( |%val, $id-name => $no.^id-values.head ) } self.apply-row-phasers($obj, AfterCreate); + + if mo.HOW.?join-on(mo) && mo.HOW.?parent(mo) { + my $obj; + my $*RED-DB = $RED-DB; + if !$data.elems { + $obj = model.^find: $filter + } else { + $obj = model.^new-from-data($data.elems ?? |$data !! |%orig-pars); + $obj.^saved-on-db; + $obj.^clean-up; + $obj.^populate-ids; + } + my %should-set = |mo.^join-on(mo.^parent).should-set.Hash if mo.HOW.?join-on: mo; + my $p = mo.^parent; + my %attrs = |$p.^columns.map: { .name.substr(2) => .self } + for %should-set.kv -> $name, $value { + $p.^set-attr: $name, $value; + $p.^set-dirty: %attrs{ $name }; + } + $p.^save; + return $obj + } + return-rw Proxy.new: STORE => -> | { die X::Assignment::RO.new(value => $obj) diff --git a/lib/MetamodelX/Red/Relationship.pm6 b/lib/MetamodelX/Red/Relationship.pm6 index fbc1dacf..8ec90ef3 100644 --- a/lib/MetamodelX/Red/Relationship.pm6 +++ b/lib/MetamodelX/Red/Relationship.pm6 @@ -160,7 +160,11 @@ multi method add-relationship(::Type Mu:U $self, Red::Attr::Relationship $attr) } else { $self.^add_multi_method: $name, my method (Mu:D:) is rw { use nqp; - nqp::getattr(self, self.WHAT, $attr.name) + my \value = nqp::getattr(self, self.WHAT, $attr.name); + my $n = $self.WHAT."$name"(); + $n.^parent = self if $n.HOW.^can: "parent"; + return $n unless value; + value } } } diff --git a/lib/Red/Attr/Relationship.pm6 b/lib/Red/Attr/Relationship.pm6 index 62ce2c3f..1152d484 100644 --- a/lib/Red/Attr/Relationship.pm6 +++ b/lib/Red/Attr/Relationship.pm6 @@ -15,7 +15,7 @@ unit role Red::Attr::Relationship[ Red::Model :$model-type, ]; -has Mu:U $!type; +#has Mu:U $!type; has Bool $.has-lazy-relationship = ?$model; @@ -110,8 +110,8 @@ method build-relationship(\instance) is hidden-from-sql-commenting { Red::AST::AND.new: $left, $right })) } - return ret.head if type !~~ Positional || attr.has-one; - ret + return ret.head if type !~~ Positional || attr.has-one; + ret }, STORE => method ($value where type) { die X::Assignment::RO.new(value => attr.type) unless attr.rw; @@ -137,7 +137,7 @@ method relationship-ast($type = Nil) is hidden-from-sql-commenting { my \type = self.relationship-argument-type; my @col1 = |rel1 type; @col1.map({ - Red::AST::Eq.new: $_, .ref: $type + Red::AST::Eq.new: $_, ast-value .ref: $type }).reduce: -> $agg, $i { Red::AST::AND.new: $agg, $i } diff --git a/lib/Red/Column.pm6 b/lib/Red/Column.pm6 index ff354981..9c893ca7 100644 --- a/lib/Red/Column.pm6 +++ b/lib/Red/Column.pm6 @@ -139,7 +139,9 @@ class ReferencesProxy does Callable { } method CALL-ME($alias = Nil) { - if &!references { + do if $alias.DEFINITE { + &!references.($alias) + } elsif &!references { my $model = self.model($alias); my $ret = &!references.($model); if $ret ~~ Red::Column && $ret.class.^name eq '$?CLASS' { diff --git a/lib/Red/PrepareCode.pm6 b/lib/Red/PrepareCode.pm6 index d8d352ca..13a9fd0e 100644 --- a/lib/Red/PrepareCode.pm6 +++ b/lib/Red/PrepareCode.pm6 @@ -93,4 +93,4 @@ sub what-does-it-do(&func, \type --> Hash) is export { %values{hash-to-cond(.[0])} = prepare-response .[1] } %values -} \ No newline at end of file +} diff --git a/t/35-create.t b/t/35-create.t index fc41e4fb..bc54baf5 100644 --- a/t/35-create.t +++ b/t/35-create.t @@ -25,6 +25,63 @@ my $*RED-DB = database $driver, |%( @conf.map: { do given .split: "= schema(Bla, Ble).drop.create; +# TODO: Figure out why this test can't be the last one +subtest "Create on has-one", { + my $ble = Ble.^create(:value); + my $bla = $ble.bla.^create: :value; + is $bla.bles.head.gist, $ble.gist; + is $ble.bla.gist, $bla.gist; +} + +subtest "belogs-to using types", { + model Blo { ... } + model Bli { + has UInt $.id is serial; + has Str $.value is column; + has Blo @.blos is relationship(*.bli-id, :model(Blo)); + has Blo $.one-blo is relationship(*.bli-id, :model(Blo), :has-one); + } + + model Blo { + has UInt $.id is serial; + has Str $.value is column; + has UInt $.bli-id is referencing(*.id, :model(Bli)); + has Bli $.bli is relationship(*.bli-id, :model(Bli)); + } + + schema(Bli, Blo).create; + + my $blo = Blo.^create(:value); + my $bli = $blo.bli.^create: :value; + is $bli.blos.head.gist, $blo.gist; + is $blo.bli.gist, $bli.gist; +} + +# TODO: make this work +#subtest "belogs-to using types not using it on attrs", { +# model Blu { ... } +# model Blb { +# has UInt $.id is serial; +# has Str $.value is column; +# has @.blus is relationship(*.blb-id, :model(Blu)); +# has $.one-blu is relationship(*.blb-id, :model(Blu), :has-one); +# } +# +# model Blu { +# has UInt $.id is serial; +# has Str $.value is column; +# has UInt $.blb-id is referencing(*.id, :model(Blb)); +# has $.blb is relationship(*.blb-id, :model(Blb)); +# } +# +# schema(Blb, Blu).create; +# +# my $blu = Blu.^create(:value); +# my $blb = $blu.blb.^create: :value; +# is $blb.blus.head.gist, $blu.gist; +# is $blu.blb.gist, $blb.gist; +#} + subtest "Simple create and fk id", { my $bla = Bla.^create: :value; my $ble = Ble.^create: :value, :bla-id($bla.id); @@ -79,17 +136,6 @@ subtest "Simple create and calling create on Relationship", { is $bla.bles.map(*.value), ; }; -subtest "Simple create and creating by array", { - my $bla = Bla.^create: :value, :bles[{:value}, {:value}]; - - isa-ok $bla, Bla; - is-deeply $bla, Bla.^load: $bla.id; - - does-ok $bla.bles, Red::ResultSeq; - isa-ok $bla.bles, Ble::ResultSeq; - is $bla.bles.map(*.value), ; -}; - subtest "Create with has-one", { my $bla = Bla.^create: :value, :one-ble{:value}; @@ -107,4 +153,15 @@ subtest "Create on transaction", { is Bla.^all.grep(*.value eq "trans1").elems, 0 }; +subtest "Simple create and creating by array", { + my $bla = Bla.^create: :value, :bles[{:value}, {:value}]; + + isa-ok $bla, Bla; + is-deeply $bla, Bla.^load: $bla.id; + + does-ok $bla.bles, Red::ResultSeq; + isa-ok $bla.bles, Ble::ResultSeq; + is $bla.bles.map(*.value), ; +}; + done-testing;