diff --git a/lib/MetamodelX/Red/Model.rakumod b/lib/MetamodelX/Red/Model.rakumod index d014d043..f5a0ceae 100644 --- a/lib/MetamodelX/Red/Model.rakumod +++ b/lib/MetamodelX/Red/Model.rakumod @@ -257,20 +257,21 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}", my \alias = ::?CLASS.new_type(:$name); my role RAlias[Red::Model:U \rtype, Str $rname, \alias, \rel, \base, \join-type, @cols] { + 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(|) { + method join-on($, \a = alias) { my $*RED-INTERNAL = True; 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 { @@ -289,7 +290,7 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}", $filter } default { - .relationship-ast(alias, |(base if $opposite)) + .relationship-ast(a, |(base if $opposite)) } } } @@ -520,8 +521,9 @@ 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 { - die "Cannot call .^create on a defined model." if model.DEFINITE; +multi method create(\mo where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw { + my \model = mo.^orig; + die "Cannot call .^create on a defined model." if mo.DEFINITE; my $RED-DB = get-RED-DB; my $trans = so $*RED-TRANSACTION-RUNNING; $RED-DB .= begin unless $trans; @@ -614,6 +616,29 @@ multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defi } } 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 with $no; return-rw Proxy.new: STORE => -> | { diff --git a/lib/Red/Attr/Relationship.rakumod b/lib/Red/Attr/Relationship.rakumod index 378869c5..d948328d 100644 --- a/lib/Red/Attr/Relationship.rakumod +++ b/lib/Red/Attr/Relationship.rakumod @@ -196,7 +196,7 @@ method !relationship-ast($t1, $t2) { :points-to($_) ).throw unless $_ ~~ Red::Column; - Red::AST::Eq.new: $_, .ref: $t2 + Red::AST::Eq.new: $_, ast-value .ref: $t2 }).reduce: -> $agg, $i? { return $agg without $i; Red::AST::AND.new: $agg, $i diff --git a/lib/Red/Cli.rakumod b/lib/Red/Cli.rakumod index fe3ba234..128dc59c 100644 --- a/lib/Red/Cli.rakumod +++ b/lib/Red/Cli.rakumod @@ -24,7 +24,7 @@ sub gen-stub(:@includes, :@models, :$driver, :%pars) { for @includes.unique { @stub.push: "use $_;" } - @stub.push: "\nred-defaults \"{ $driver }\", { %pars.map(*.perl) };"; + @stub.push: "\nred-defaults \"{ $driver }\", { %pars.map(*.raku) };"; @stub.push: ""; for @models { @stub.push: ".say for { $_ }.^all;" diff --git a/lib/Red/Column.rakumod b/lib/Red/Column.rakumod index 62efb783..f0e49188 100644 --- a/lib/Red/Column.rakumod +++ b/lib/Red/Column.rakumod @@ -71,7 +71,7 @@ multi method perl(::?CLASS:D:) { "{ self.^name }.new({ self.Hash.pairs.sort.map(-> (:$key, :$value) { next if $key eq .one; - "$key.Str() => $value.perl()" + "$key.Str() => $value.raku()" }).join: ", " })" } diff --git a/lib/Red/Driver.rakumod b/lib/Red/Driver.rakumod index e1e28acd..24091a4e 100644 --- a/lib/Red/Driver.rakumod +++ b/lib/Red/Driver.rakumod @@ -122,7 +122,7 @@ method optimize(Red::AST $in --> Red::AST) { $in } multi method debug(@bind) { if $*RED-DEBUG { - note "BIND: @bind.perl()"; + note "BIND: @bind.raku()"; } } @@ -135,6 +135,6 @@ multi method debug($sql) { multi method debug($sql, @binds) { if $*RED-DEBUG { note "SQL : $sql"; - note "BIND: @binds.perl()"; + note "BIND: @binds.raku()"; } } diff --git a/lib/Red/Driver/Mock.rakumod b/lib/Red/Driver/Mock.rakumod index 7dedd083..4de895ca 100644 --- a/lib/Red/Driver/Mock.rakumod +++ b/lib/Red/Driver/Mock.rakumod @@ -132,7 +132,7 @@ method verify { #is test-assertion { for %!when-re.kv -> Regex $re, % (:$counter = 0, :$times, |) { ok ($times == Inf or $counter == $times), - "Query that matches '$re.perl()' should be called $times times and was called $counter time(s)"; + "Query that matches '$re.raku()' should be called $times times and was called $counter time(s)"; } }, "Red Mock verify" } diff --git a/lib/Red/Model.rakumod b/lib/Red/Model.rakumod index 5f0e114a..d1855ff9 100644 --- a/lib/Red/Model.rakumod +++ b/lib/Red/Model.rakumod @@ -12,7 +12,7 @@ multi method perl(::?CLASS:D:) { self.raku } multi method raku(::?CLASS:D:) { my @attrs = self.^attributes.grep({ !.^can("relationship-ast") && .has_accessor}).map: { - "{ .name.substr(2) } => { .get_value(self).perl }" + "{ .name.substr(2) } => { .get_value(self).raku }" } "{ self.^name }.new({ @attrs.join: ", " })" } diff --git a/lib/X/Red/Exceptions.rakumod b/lib/X/Red/Exceptions.rakumod index 5a6cf8d3..1dfb05fd 100644 --- a/lib/X/Red/Exceptions.rakumod +++ b/lib/X/Red/Exceptions.rakumod @@ -89,7 +89,7 @@ class X::Red::Driver::Mapped::UnknownError is X::Red::Driver::Mapped { Unknown Error!!! Please, copy this backtrace and open an issue on https://github.com/FCO/Red/issues/new Driver: { $.driver } - Original error: { $.orig-exception.perl } + Original error: { $.orig-exception.raku } END } } diff --git a/t/35-create.rakutest b/t/35-create.rakutest index 3c7b4399..c8cbecd2 100644 --- a/t/35-create.rakutest +++ b/t/35-create.rakutest @@ -1,6 +1,7 @@ use Test; use Red ; +# ---- Models with STRING references (:model) ---- model Bla { has UInt $.id is serial; has Str $.value is column; @@ -15,13 +16,50 @@ model Ble { has $.bla is relationship(*.bla-id, :model); } +# ---- Models with TYPE references (:model(Type)) ---- +model Blu { ... } +model Blb { + has UInt $.id is serial; + has Str $.value is column; + has Blu @.blus is relationship(*.blb-id, :model(Blu)); + has Blu $.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 $.blb is relationship(*.blb-id, :model(Blb)); +} + +# ---- Model with non-nullable FK (default=0) ---- +model Blz { ... } +model Bly { + has UInt $.id is serial; + has Str $.value is column; + has UInt $.bly-id is referencing(*.id, :model(Bly), :default{ 0 }); + has Blz $.blz is relationship(*.bly-id, :model(Blz)); +} + +model Blz { + has UInt $.id is serial; + has Str $.value is column; + has @.blies is relationship(*.blz-id, :model(Bly)); + has $.one-bly is relationship(*.blz-id, :model(Bly), :has-one); +} + +# ---- Setup ---- my $*RED-DEBUG = $_ with %*ENV; my $*RED-DEBUG-RESPONSE = $_ with %*ENV; my @conf = (%*ENV // "SQLite").split(" "); my $driver = @conf.shift; my $*RED-DB = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => val .[1] } } ); -schema(Bla, Ble).drop.create; +schema(Bla, Ble, Blb, Blu, Bly, Blz).drop.create; + +# ====================================================================== +# Existing tests (unchanged) +# ====================================================================== subtest "Simple create and fk id", { my $bla = Bla.^create: :value; @@ -99,10 +137,145 @@ subtest "Create with has-one", { }; subtest "Create on transaction", { - throws-like { - Bla.^create: :value, :bles[{ :42value }] - }, X::TypeCheck::Assignment, message => rx/value/; - is Bla.^all.grep(*.value eq "trans1").elems, 0 + throws-like { + Bla.^create: :value, :bles[{ :42value }] + }, X::TypeCheck::Assignment, message => rx/value/; + is Bla.^all.grep(*.value eq "trans1").elems, 0 +}; + +# ====================================================================== +# NEW: belongs-to .^create via relationship accessor (string model) +# ====================================================================== + +subtest "belongs-to .^create sets FK automatically (string model)", { + my $ble = Ble.^create: :value; + my $bla = $ble.bla.^create: :value; + is $bla.value, "bla", "Created Bla has correct value"; + is $ble.bla.id, $bla.id, "FK set on Ble without explicit refresh"; + $ble.^refresh; + is $ble.bla.value, "bla", "After refresh, bla is accessible"; + is $ble.bla.id, $bla.id, "After refresh, IDs still match"; +}; + +subtest "belongs-to .^create does not affect other records", { + my $ble1 = Ble.^create: :value; + my $ble2 = Ble.^create: :value; + my $bla = $ble1.bla.^create: :value; + $ble1.^refresh; + $ble2.^refresh; + is $ble1.bla.id, $bla.id, "FK set on correct Ble"; + nok $ble2.bla.defined, "Other Ble not affected"; + is $ble2.bla-id, UInt, "Other Ble FK is still default (0)"; +}; + +subtest "belongs-to .^create with extra attributes", { + my $ble = Ble.^create: :value; + my $bla = $ble.bla.^create: :value, :id(999); + $ble.^refresh; + is $ble.bla.value, "bla-extra", "Extra attrs passed through"; + is $ble.bla.id, 999, "Explicit ID respected"; +}; + +subtest "belongs-to .^create multiple times on same parent", { + my $ble = Ble.^create: :value; + my $bla1 = $ble.bla.^create: :value; + $ble.^refresh; + is $ble.bla.id, $bla1.id, "First create works"; + + # Creating a second Bla should create a new one and update FK + my $bla2 = $ble.bla.^create: :value; + $ble.^refresh; + is $ble.bla.id, $bla2.id, "Second create updates FK"; + isnt $bla1.id, $bla2.id, "Created different records"; + is Bla.^all.elems, 2, "Both Blas exist in DB"; +}; + +subtest "belongs-to .^create on FK that already has a value", { + my $bla1 = Bla.^create: :value; + my $ble = Ble.^create: :value, :bla-id($bla1.id); + is $ble.bla.id, $bla1.id, "FK manually set works"; + + # Now create a NEW Bla via relationship — should replace FK + my $bla2 = $ble.bla.^create: :value; + $ble.^refresh; + is $ble.bla.id, $bla2.id, "FK updated to new Bla"; + isnt $bla1.id, $bla2.id, "Different Bla records"; +}; + +# ====================================================================== +# Type model references (not strings) +# ====================================================================== + +subtest "belongs-to .^create with type model (not string)", { + my $blu = Blu.^create: :value; + my $blb = $blu.blb.^create: :value; + is $blb.value, "blb"; + $blu.^refresh; + is $blu.blb.id, $blb.id, "FK auto-set with type model reference"; + is $blu.blb.value, "blb", "Value accessible after refresh"; +}; + +subtest "belongs-to .^create isolation with type model", { + my $blu1 = Blu.^create: :value; + my $blu2 = Blu.^create: :value; + my $blb = $blu1.blb.^create: :value; + $blu1.^refresh; + $blu2.^refresh; + is $blu1.blb.id, $blb.id, "FK on correct parent"; + nok $blu2.blb.defined, "Other parent not affected"; +}; + +# ====================================================================== +# To-one via relationship (reverse direction: has-one side) +# ====================================================================== + +subtest "has-one .^create via relationship accessor", { + my $bla = Bla.^create: :value; + my $ble = $bla.one-ble.^create: :value; + is $ble.value, "ble-hasone"; + $bla.^refresh; + is $bla.one-ble.id, $ble.id, "FK auto-set on has-one via accessor"; +}; + +# ====================================================================== +# To-many .create (ResultSeq) — already works, just verifying +# ====================================================================== + +subtest "to-many .create via ResultSeq still works", { + my $bla = Bla.^create: :value; + $bla.bles.create: :value; + $bla.bles.create: :value; + $bla.^refresh; + is $bla.bles.elems, 2, "Two Bles created"; + is $bla.bles.map(*.value).sort, , "Correct values"; + is $bla.bles.map(*.bla-id).unique.elems, 1, "All have same FK"; + is $bla.bles.map(*.bla-id).unique.head, $bla.id, "FK matches parent"; +}; + +subtest "to-many with type model .create still works", { + my $blb = Blb.^create: :value; + $blb.blus.create: :value; + $blb.blus.create: :value; + $blb.^refresh; + is $blb.blus.elems, 2; + is $blb.blus.map(*.value).sort, ; +}; + +# ====================================================================== +# Edge cases +# ====================================================================== + +subtest "belongs-to .^create on unsaved parent should fail", { + my $ble = Ble.new: :value; + throws-like { + $ble.bla.^create: :value; + }, Exception, "Cannot .^create on relationship of unsaved object"; +}; + +subtest "Verify Bla is not fetched when FK is 0", { + my $bly = Bly.^create: :value; + # FK default is 0, so no Blz should be fetched + nok $bly.blz.defined, "No Blz when FK is 0"; }; done-testing;