From 84382a6bb9e57b71bdb8233f60d6590e38539b14 Mon Sep 17 00:00:00 2001 From: Hermes Agent Date: Thu, 11 Jun 2026 14:41:11 +0000 Subject: [PATCH 1/4] feat: .^create on belongs-to relationship with auto FK MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Port from PR #523 (2021): 1. Fix ast-value .ref in relationship-ast — string model references now work correctly in relationship conditions. (Red::AST::Eq.new: $\_, ast-value .ref: $t2) 2. Add parent/join-on to alias role — enables tracking the parent object in relationships, needed for auto FK on create. 3. Enhance .^create to handle relationship accessors: when called via $ble.bla.^create(...), automatically sets the foreign key on the parent object and saves it. 4. Tests: belongs-to create with auto FK, isolation between instances. Closes #523 --- lib/MetamodelX/Red/Model.rakumod | 35 ++++++++++++++++++++++++++----- lib/Red/Attr/Relationship.rakumod | 2 +- t/35-create.rakutest | 28 +++++++++++++++++++++---- 3 files changed, 55 insertions(+), 10 deletions(-) diff --git a/lib/MetamodelX/Red/Model.rakumod b/lib/MetamodelX/Red/Model.rakumod index d014d043..d67d2f76 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/t/35-create.rakutest b/t/35-create.rakutest index 3c7b4399..9aaa5398 100644 --- a/t/35-create.rakutest +++ b/t/35-create.rakutest @@ -99,10 +99,30 @@ 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 with auto FK +subtest "belongs-to .^create sets FK automatically", { + my $ble = Ble.^create: :value; + my $bla = $ble.bla.^create: :value; + is $bla.value, "bla", "Created Bla has correct value"; + $ble.^refresh; + is $ble.bla.value, "bla", "FK auto-set — ble.bla returns the new Bla"; + is $ble.bla.id, $bla.id, "IDs 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"; }; done-testing; From 753a9cde66c9131be818405cca1c96b611cd294b Mon Sep 17 00:00:00 2001 From: Hermes Agent Date: Thu, 11 Jun 2026 14:42:43 +0000 Subject: [PATCH 2/4] test: comprehensive belongs-to create tests - String model references (:model) - Type model references (:model(Type)) - has-one create via relationship accessor - Multiple creates on same parent - Create with FK already set - Isolation between parent instances - Extra attributes passthrough - Unsaved parent error case - FK default=0 edge case - To-many .create regression checks --- t/35-create.rakutest | 163 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 158 insertions(+), 5 deletions(-) diff --git a/t/35-create.rakutest b/t/35-create.rakutest index 9aaa5398..cce97da3 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; @@ -105,14 +143,18 @@ subtest "Create on transaction", { is Bla.^all.grep(*.value eq "trans1").elems, 0 }; -# NEW: belongs-to .^create with auto FK -subtest "belongs-to .^create sets FK automatically", { +# ====================================================================== +# 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", "FK auto-set — ble.bla returns the new Bla"; - is $ble.bla.id, $bla.id, "IDs match"; + 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", { @@ -123,6 +165,117 @@ subtest "belongs-to .^create does not affect other records", { $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; From 2ff919677ecf8c476c935263578bbdc0ff27b6ca Mon Sep 17 00:00:00 2001 From: Hermes Agent Date: Thu, 11 Jun 2026 15:53:04 +0000 Subject: [PATCH 3/4] =?UTF-8?q?Fix=20escaping:=20\\mo=20=E2=86=92=20\mo,?= =?UTF-8?q?=20\\model=20=E2=86=92=20\model?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/MetamodelX/Red/Model.rakumod | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/MetamodelX/Red/Model.rakumod b/lib/MetamodelX/Red/Model.rakumod index d67d2f76..f5a0ceae 100644 --- a/lib/MetamodelX/Red/Model.rakumod +++ b/lib/MetamodelX/Red/Model.rakumod @@ -521,8 +521,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(\\mo where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw { - my \\model = mo.^orig; +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; From 9c7da896fc0d8b92d156e7c7b13c352c8cf23b2f Mon Sep 17 00:00:00 2001 From: Hermes Agent Date: Thu, 11 Jun 2026 16:11:22 +0000 Subject: [PATCH 4/4] =?UTF-8?q?fix:=20.perl=20=E2=86=92=20.raku=20(depreca?= =?UTF-8?q?ted),=20:default(0)=20=E2=86=92=20:default{=200=20}=20(Callable?= =?UTF-8?q?=20expected)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - t/35-create.rakutest: :default(0) → :default{ 0 } fixes 'Type check failed in assignment to &!default' - lib/Red/Column.rakumod: .perl() → .raku() - lib/Red/Model.rakumod: .get_value(self).perl → .get_value(self).raku - lib/X/Red/Exceptions.rakumod: $.orig-exception.perl → $.orig-exception.raku - lib/Red/Driver/Mock.rakumod: $re.perl() → $re.raku() - lib/Red/Cli.rakumod: %pars.map(*.perl) → %pars.map(*.raku) - lib/Red/Driver.rakumod: @bind.perl()/@binds.perl() → @bind.raku()/@binds.raku() --- lib/Red/Cli.rakumod | 2 +- lib/Red/Column.rakumod | 2 +- lib/Red/Driver.rakumod | 4 ++-- lib/Red/Driver/Mock.rakumod | 2 +- lib/Red/Model.rakumod | 2 +- lib/X/Red/Exceptions.rakumod | 2 +- t/35-create.rakutest | 2 +- 7 files changed, 8 insertions(+), 8 deletions(-) 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 cce97da3..c8cbecd2 100644 --- a/t/35-create.rakutest +++ b/t/35-create.rakutest @@ -37,7 +37,7 @@ 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 UInt $.bly-id is referencing(*.id, :model(Bly), :default{ 0 }); has Blz $.blz is relationship(*.bly-id, :model(Blz)); }