feat: .^create on belongs-to relationship with auto FK

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 => -> | {

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

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

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 <inflate deflate>.one;
-            "$key.Str() => $value.perl()"
+            "$key.Str() => $value.raku()"
         }).join: ", "
     })"
 }

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()";
     }
 }

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

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: ", " })"
 }

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

t/35-create.rakutest

@@ -1,6 +1,7 @@
 use Test;
 use Red <has-one>;
 
+# ---- Models with STRING references (:model<Name>) ----
 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<Bla>);
 }
 
+# ---- 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<RED_DEBUG>;
 my $*RED-DEBUG-RESPONSE = $_ with %*ENV<RED_DEBUG_RESPONSE>;
 my @conf                = (%*ENV<RED_DATABASE> // "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<test1>;
@@ -99,10 +137,145 @@ subtest "Create with has-one", {
 };
 
 subtest "Create on transaction", {
-	throws-like {
-		Bla.^create: :value<trans1>, :bles[{ :42value }]
-	}, X::TypeCheck::Assignment, message => rx/value/;
-	is Bla.^all.grep(*.value eq "trans1").elems, 0
+    throws-like {
+        Bla.^create: :value<trans1>, :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<ble>;
+    my $bla = $ble.bla.^create: :value<bla>;
+    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<ble1>;
+    my $ble2 = Ble.^create: :value<ble2>;
+    my $bla  = $ble1.bla.^create: :value<bla-for-ble1>;
+    $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<ble-extra>;
+    my $bla = $ble.bla.^create: :value<bla-extra>, :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<ble-reuse>;
+    my $bla1 = $ble.bla.^create: :value<bla-first>;
+    $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<bla-second>;
+    $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<existing-bla>;
+    my $ble  = Ble.^create: :value<ble-with-fk>, :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<new-bla>;
+    $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<blu>;
+    my $blb = $blu.blb.^create: :value<blb>;
+    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<blu1>;
+    my $blu2 = Blu.^create: :value<blu2>;
+    my $blb  = $blu1.blb.^create: :value<blb1>;
+    $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<bla-hasone>;
+    my $ble = $bla.one-ble.^create: :value<ble-hasone>;
+    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-tomany>;
+    $bla.bles.create: :value<ble1>;
+    $bla.bles.create: :value<ble2>;
+    $bla.^refresh;
+    is $bla.bles.elems, 2, "Two Bles created";
+    is $bla.bles.map(*.value).sort, <ble1 ble2>, "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-tomany>;
+    $blb.blus.create: :value<blu1>;
+    $blb.blus.create: :value<blu2>;
+    $blb.^refresh;
+    is $blb.blus.elems, 2;
+    is $blb.blus.map(*.value).sort, <blu1 blu2>;
+};
+
+# ======================================================================
+# Edge cases
+# ======================================================================
+
+subtest "belongs-to .^create on unsaved parent should fail", {
+    my $ble = Ble.new: :value<unsaved>;
+    throws-like {
+        $ble.bla.^create: :value<should-fail>;
+    }, Exception, "Cannot .^create on relationship of unsaved object";
+};
+
+subtest "Verify Bla is not fetched when FK is 0", {
+    my $bly = Bly.^create: :value<bly-no-fk>;
+    # FK default is 0, so no Blz should be fetched
+    nok $bly.blz.defined, "No Blz when FK is 0";
 };
 
 done-testing;