@voxgig/sdkgen 4.2.7 → 4.3.0

package/project/.sdk/tm/perl/t/feature_corpus.t

@@ -0,0 +1,345 @@
+#!perl
+# ProjectName SDK feature corpus test
+#
+# Feature behaviour, driven by the SHARED corpus.
+#
+# The same route t/primary_utility.t takes for the utilities: language-neutral
+# cases in .sdk/test/test.json, executed against THIS generated SDK. The
+# feature is the ordinary package, built by the generated config, installed by
+# the generated constructor, and driven by a real entity operation. Not a
+# miniature of the pipeline, which can only be as right as the miniature.
+#
+# Everything in a case is data. The one piece perl writes for itself is
+# turning scripted responses into a fetcher, through the documented
+# `utility.fetcher` override.
+
+use strict;
+use warnings;
+use Test::More;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use Cwd ();
+use Scalar::Util ();
+
+use ProjectNameSDK;
+
+my $TEST_JSON = Cwd::abs_path("$FindBin::Bin/../../.sdk/test/test.json");
+
+unless (defined $TEST_JSON && -e $TEST_JSON) {
+  plan skip_all => 'test.json corpus not found';
+}
+
+# Features with a corpus section. A name here with no section is a skip, not
+# a failure: an SDK generated without the feature has nothing to run.
+my @FEATURE_CORPUS_NAMES = ('cost');
+
+# The standard operation names, in the order the runner prefers them.
+my @FEATURE_CORPUS_OPS = qw(load list create update remove);
+
+my $CORPUS = do {
+  open my $fh, '<', $TEST_JSON or die "cannot read $TEST_JSON: $!";
+  local $/;
+  my $raw = <$fh>;
+  close $fh;
+  Voxgig::Struct::parse_json($raw);
+};
+
+# A corpus with no `feature` section is a SKIP, not a failure. Each
+# project carries its OWN materialised copy of .sdk/test/test.json, so a
+# project scaffolded before the section existed legitimately has no cases
+# to run - and a hard assertion here turned that into a red suite in every
+# SDK on the fleet, for a corpus the project had simply not re-pulled yet.
+# The strict check belongs where the corpus is CONTROLLED: sdkgen's own
+# end-to-end lane supplies one and requires the cases to actually run.
+unless (defined $CORPUS->{feature}) {
+  plan skip_all => "this project's test.json has no `feature` section - "
+    . 'recompile the corpus (create-sdkgen .sdk/test/feature/) to run these cases';
+}
+ok(defined $CORPUS->{feature}, 'the corpus carries a feature section');
+
+
+# A scripted transport built from a case's `res` list. Responses are consumed
+# in order and the last one repeats, so a case that does not care how many
+# attempts happen need only declare one.
+#
+# Returns the shape the real fetcher returns: a (response, err) PAIR, with the
+# parsed body behind a `json` coderef and `body` as the raw string. A script
+# that only set `body` would look like an empty result, which reads as a
+# feature defect rather than a mis-shaped script.
+sub scripted_fetcher {
+  my ($res) = @_;
+  my $n = -1;
+  return sub {
+    my ($ctx, $fullurl, $fetchdef) = @_;
+    $n++;
+    my $spec = {};
+    if (ref $res eq 'ARRAY' && @$res) {
+      my $i = $n >= scalar(@$res) ? scalar(@$res) - 1 : $n;
+      $spec = $res->[$i] || {};
+    }
+
+    if (($spec->{throw} || 0) eq '1' || (defined $spec->{throw} && $spec->{throw})) {
+      return (undef, 'scripted transport failure');
+    }
+
+    my $status = defined $spec->{status} ? int($spec->{status}) : 200;
+    my $body = defined $spec->{body} ? $spec->{body} : {};
+
+    return ({
+      'status'     => $status,
+      'statusText' => ($status < 400 ? 'OK' : 'ERR'),
+      'headers'    => { %{ $spec->{headers} || {} } },
+      'json'       => sub { $body },
+      'body'       => Voxgig::Struct::stringify($body),
+    }, undef);
+  };
+}
+
+
+# Build a client the way a caller would.
+#
+# The plain constructor, not the test-mode one: the `test` feature is
+# transport: 'base' and REPLACES the transport, so a client in test mode
+# would shadow the script.
+sub build_client {
+  my ($kase) = @_;
+  my $opts = { 'utility' => { 'fetcher' => scripted_fetcher($kase->{res}) } };
+  $opts->{feature} = $kase->{feature} if defined $kase->{feature};
+  return ProjectNameSDK->new($opts);
+}
+
+
+# Every operation this SDK declares, in a stable order.
+#
+# The corpus cannot name an entity - it is shared by SDKs with none in common
+# - so the runner finds them here. An entity accessor is a capitalised client
+# method whose result answers get_name.
+sub candidates {
+  my ($client) = @_;
+  my %found;
+
+  my $pkg = ref $client;
+  no strict 'refs';
+  for my $sym (sort keys %{"${pkg}::"}) {
+    next unless $sym =~ /^[A-Z]/;
+    next unless defined &{"${pkg}::${sym}"};
+    my $ent = eval { $client->$sym() };
+    next unless defined $ent && Scalar::Util::blessed($ent);
+    next unless $ent->can('get_name');
+    my $entname = eval { $ent->get_name };
+    next unless defined $entname && length $entname;
+    $found{$entname} = [$sym, $ent];
+  }
+  use strict 'refs';
+
+  my @out;
+  for my $entname (sort keys %found) {
+    my ($accessor, $ent) = @{ $found{$entname} };
+    for my $opname (@FEATURE_CORPUS_OPS) {
+      next unless $ent->can($opname);
+      push @out, {
+        key      => "$entname.$opname",
+        accessor => $accessor,
+        op       => $opname,
+      };
+    }
+  }
+  return @out;
+}
+
+
+sub invoke {
+  my ($client, $op, $ctrl) = @_;
+  my $acc = $op->{accessor};
+  my $fn  = $op->{op};
+  my $ent = $client->$acc();
+  return $ent->$fn({}, $ctrl);
+}
+
+
+# Pick operations by DRIVING them: an op is usable when it completes against a
+# plain 200 with no feature active. Declared operations are not all callable
+# with no arguments, and a case failing for that reason would read as a
+# feature defect.
+sub usable_ops {
+  my ($want) = @_;
+  my @picked;
+  for my $cand (candidates(build_client({}))) {
+    my $ok = eval { invoke(build_client({}), $cand, {}); 1 };
+    next unless $ok;
+    push @picked, $cand;
+    last if scalar(@picked) >= $want;
+  }
+  return @picked;
+}
+
+
+# Replace #OPn throughout a case, keys included.
+sub resolve {
+  my ($node, $tokens) = @_;
+  if (ref $node eq 'ARRAY') {
+    return [ map { resolve($_, $tokens) } @$node ];
+  }
+  if (ref $node eq 'HASH') {
+    my %out;
+    for my $k (keys %$node) {
+      $out{ resolve($k, $tokens) } = resolve($node->{$k}, $tokens);
+    }
+    return \%out;
+  }
+  if (!ref $node && defined $node) {
+    my $out = $node;
+    for my $tok (keys %$tokens) {
+      my $q = quotemeta $tok;
+      $out =~ s/$q/$tokens->{$tok}/g;
+    }
+    return $out;
+  }
+  return $node;
+}
+
+
+# The highest #OPn a case mentions.
+sub tokens_used {
+  my ($kase) = @_;
+  my $json = Voxgig::Struct::stringify($kase);
+  my $max = 0;
+  while ($json =~ /#OP(\d+)/g) {
+    $max = $1 if $1 > $max;
+  }
+  return $max;
+}
+
+
+sub member {
+  my ($actual, $key) = @_;
+  return (undef, 0) unless defined $actual;
+  if (ref $actual eq 'HASH' || Scalar::Util::blessed($actual)) {
+    return ($actual->{$key}, 1) if exists $actual->{$key};
+  }
+  return (undef, 0);
+}
+
+
+# Assert that `actual` contains `expect`, recursively. Cases assert only the
+# fields they are about, so a full deep comparison would force every case to
+# restate the whole record.
+sub subset {
+  my ($actual, $expect, $path) = @_;
+
+  if (ref $expect eq 'HASH') {
+    for my $k (sort keys %$expect) {
+      my ($got, $found) = member($actual, $k);
+      ok($found, "$path.$k exists") or next;
+      subset($got, $expect->{$k}, "$path.$k");
+    }
+    return;
+  }
+
+  # JSON true/false parse to a blessed Voxgig::Struct::Bool, and perl's own
+  # booleans are a bare 1 or ''. Compare truth, not spelling: stringified,
+  # those two are 'true' and '1' and would never match.
+  if (Voxgig::Struct::is_jbool($expect)) {
+    is(($actual ? 1 : 0), ($expect ? 1 : 0), "$path is $expect");
+    return;
+  }
+
+  if (!ref $expect && defined $expect && Scalar::Util::looks_like_number($expect)) {
+    ok(!ref $actual && defined $actual && Scalar::Util::looks_like_number($actual),
+      "$path is a number") or return;
+    # Money is float arithmetic; compare with a tolerance far below any amount
+    # a case states.
+    ok(abs($actual - $expect) < 1e-9, "$path == $expect (got "
+      . (defined $actual ? $actual : 'undef') . ')');
+    return;
+  }
+
+  is($actual, $expect, $path);
+}
+
+
+sub record {
+  my ($client, $name) = @_;
+  return $client->{"_$name"};
+}
+
+
+my @ops = usable_ops(2);
+
+# At least one operation, or every case would skip and this file would report
+# green having run nothing.
+ok(scalar(@ops) > 0,
+  'this SDK has an operation the corpus can drive') or do {
+  done_testing();
+  exit 0;
+};
+
+for my $name (@FEATURE_CORPUS_NAMES) {
+  my $section = ($CORPUS->{feature} || {})->{$name};
+  next unless defined $section;
+
+  my $cases = (($section->{basic} || {})->{set}) || [];
+  ok(scalar(@$cases) > 0,
+    "corpus section feature.$name has cases (an emptied fixture must fail loudly)")
+    or next;
+
+  # Probed by ACTIVATING it: the feature defaults to inactive, so an idle
+  # client never builds it and its absence says nothing.
+  my $probe = build_client({ feature => [ { name => $name, active => 1 } ] });
+  next unless defined record($probe, $name);
+
+  my %by_key = map { $_->{key} => $_ } @ops;
+
+  my $ran = 0;
+  for my $raw (@$cases) {
+    my $need = tokens_used($raw);
+    next if $need > scalar(@ops);
+
+    my %tokens;
+    for my $i (0 .. $need - 1) {
+      $tokens{ '#OP' . ($i + 1) } = $ops[$i]{key};
+    }
+    my $kase = resolve($raw, \%tokens);
+
+    my $client = build_client($kase);
+    my $label = $kase->{name} || '';
+
+    for my $step (@{ $kase->{op} || [] }) {
+      my $op = $by_key{ $step->{op} };
+      ok(defined $op, "$label: operation $step->{op} is known") or next;
+      my $ctrl = $step->{ctrl} || {};
+      my $wanterr = $step->{err};
+
+      my $ok = eval { invoke($client, $op, $ctrl); 1 };
+      my $err = $@;
+
+      if (!defined $wanterr) {
+        ok($ok, "$label: $step->{op} succeeded")
+          or diag("failed unexpectedly: $err");
+        next;
+      }
+
+      ok(!$ok, "$label: $step->{op} failed as expected") or next;
+
+      if (!ref $wanterr) {
+        # The CODE, not the message: make_error prefixes and humanises the
+        # text, so matching it would pass on any error mentioning the word.
+        my $code = (Scalar::Util::blessed($err) && $err->can('code'))
+          ? $err->code : undef;
+        is($code, $wanterr, "$label: error code");
+      }
+    }
+
+    subset(record($client, $name), $kase->{out}, "$label: _$name");
+    $ran++;
+  }
+
+  ok($ran > 0, "at least one feature.$name case ran");
+  # Say how many ran. A partial run is legitimate (an SDK with one operation
+  # skips the cases needing two) but it should be visible rather than
+  # inferred from a green tick.
+  diag(sprintf('feature.%s: ran %d of %d case(s) against %d operation(s)',
+    $name, $ran, scalar(@$cases), scalar(@ops)));
+}
+
+done_testing();

package/project/.sdk/tm/perl/utility/make_options.pm

@@ -19,10 +19,42 @@ $REGISTRY{make_options} = sub {
   my ($ctx) = @_;
   my $options = $ctx->{options} || {};
 
+  # Merge custom utility overrides.
+  #
+  # A key naming a real utility member REPLACES it; anything else is attached
+  # as a custom extra. This mirrors ts, where the utility is an open object
+  # and one setprop does both.
+  #
+  # Without the replace half this was a no-op: every entry went to
+  # `{utility}{custom}`, which nothing reads, so a caller passing
+  # `utility => { fetcher => $my_transport }` - the documented way to script
+  # the transport, and the seam the shared feature corpus runs on - was
+  # silently ignored while ts and js honoured it.
+  #
+  # Option keys are camelCase, as ts spells them; members here are
+  # snake_case. Converting rather than listing keeps the mapping to one rule,
+  # so a utility added later is overridable without touching this. The
+  # registrar has already populated every member, so `exists` is the test for
+  # "is this a real one" - once the key is known to be a PUBLIC name.
   my $custom_utils = ProjectNameHelpers::gp($options, 'utility');
   if (Voxgig::Struct::ismap($custom_utils) && $ctx->{utility}) {
+    my $utility = $ctx->{utility};
     for my $k (keys %$custom_utils) {
-      $ctx->{utility}{custom}{$k} = $custom_utils->{$k};
+      # Public utility names are camelCase and carry no underscore, so an
+      # underscore means the caller named something of their own - possibly
+      # the INTERNAL spelling of a real member. `make_error` must stay an
+      # extension in `custom`; replacing the pipeline function with it (ts,
+      # js and go all keep it) would break the error path on the next
+      # request, silently.
+      my $public_name = ($k !~ /_/);
+      my $member = $k;
+      $member =~ s/([A-Z])/'_' . lc($1)/ge;
+      if ($public_name && 'custom' ne $member && exists $utility->{$member}) {
+        $utility->{$member} = $custom_utils->{$k};
+      }
+      else {
+        $utility->{custom}{$k} = $custom_utils->{$k};
+      }
     }
   }
 

package/project/.sdk/tm/php/core/Context.php

@@ -52,6 +52,9 @@ class ProjectNameContext
             if (isset($ctrl_raw['explain']) && is_array($ctrl_raw['explain'])) {
                 $this->ctrl->explain = $ctrl_raw['explain'];
             }
+            if (array_key_exists('actor', $ctrl_raw)) {
+                $this->ctrl->actor = $ctrl_raw['actor'];
+            }
         } elseif ($basectx !== null && $basectx->ctrl !== null) {
             $this->ctrl = $basectx->ctrl;
         }

package/project/.sdk/tm/php/core/Control.php

@@ -9,10 +9,23 @@ class ProjectNameControl
     public mixed $err;
     public mixed $explain;
 
+    // Per-call actor, read by the `audit` and `cost` features to attribute an
+    // operation to whoever asked for it.
+    //
+    // Declared, because this class is typed. ts carries it without declaring
+    // it - its control object is open, so a caller-supplied `actor` simply
+    // survives - and both features were written against that, commenting it
+    // as "an optional extension property on the control". Here the property
+    // did not exist, so `$ctx->ctrl->actor ?? null` was always null and every
+    // operation was attributed to 'anonymous' no matter what the caller
+    // passed. The shared feature corpus caught it.
+    public mixed $actor;
+
     public function __construct(array $opts = [])
     {
         $this->throw_err = $opts['throw_err'] ?? null;
         $this->err = null;
         $this->explain = $opts['explain'] ?? null;
+        $this->actor = $opts['actor'] ?? null;
     }
 }

package/project/.sdk/tm/php/core/Error.php

@@ -13,6 +13,17 @@ class ProjectNameError extends \Exception
     public mixed $result;
     public mixed $spec;
 
+    // HTTP status of the response that caused this error, or -1 when the
+    // request never got one. Promoted to the top level so a consumer can
+    // branch on `err->status` / `err->notFound()` instead of reaching into
+    // `err->result`.
+    //
+    // DECLARED, not created on assignment. makeError set it on an undeclared
+    // property, which PHP 8.2 deprecates and PHP 9 makes fatal - so every
+    // error path in this SDK was on course to stop working. ts declares the
+    // same field; php needs it spelled out because the class is typed.
+    public int $status;
+
     public function __construct(string $code = '', string $msg = '', mixed $ctx = null)
     {
         parent::__construct($msg);
@@ -23,6 +34,7 @@ class ProjectNameError extends \Exception
         $this->ctx = $ctx;
         $this->result = null;
         $this->spec = null;
+        $this->status = -1;
     }
 
     public function error(): string