File Coverage

blib/lib/OpenAPI/Modern/Utilities.pm

Criterion	Covered	Total	%
statement	199	199	100.0
branch	34	36	94.4
condition	21	24	87.5
subroutine	47	47	100.0
pod	0	9	0.0
total	301	315	95.5

use strictures 2;
package OpenAPI::Modern::Utilities;
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Internal utilities and common definitions for OpenAPI::Modern

our $VERSION = '0.139';

use 5.020;
use strictures 2;
use stable 0.031 'postderef';
use experimental 'signatures';
no autovivification warn => qw(fetch store exists delete);
use if "$]" >= 5.022, experimental => 're_strict';
no if "$]" >= 5.031009, feature => 'indirect';
no if "$]" >= 5.033001, feature => 'multidimensional';
no if "$]" >= 5.033006, feature => 'bareword_filehandles';
no if "$]" >= 5.041009, feature => 'smartmatch';
no feature 'switch';
use File::ShareDir 'dist_dir';
use List::Util 1.45 'uniqstr';
use Scalar::Util 'looks_like_number';
use Mojo::Util qw(url_unescape url_escape);
use Carp 'croak';
use if "$]" < 5.041010, 'List::Util' => 'any';
use if "$]" >= 5.041010, experimental => 'keyword_any';
use JSON::Schema::Modern::Utilities 0.625 qw(register_schema load_cached_document true false);
use namespace::clean;

use Exporter 'import';

our @EXPORT = qw(
  SUPPORTED_OAD_VERSIONS
  OAS_VERSIONS
  DEFAULT_DIALECT
  DEFAULT_BASE_METASCHEMA
  DEFAULT_METASCHEMA
  STRICT_METASCHEMA
  STRICT_DIALECT
  OAS_VOCABULARY
);

our @EXPORT_OK = qw(
  OAS_SCHEMAS
  add_vocab_and_default_schemas
  uri_decode
  uri_encode
  uri_encode_strict
  intersect_types
  coerce_primitive
  is_cookie_name
  is_cookie_value
  elem
);

our %EXPORT_TAGS = (
  constants => \@EXPORT,
);

# it is likely the case that we can support a version beyond what's stated here -- but we may not,
# so we'll warn to that effect. Every effort will be made to upgrade this implementation to fully
# support the latest point release as soon as possible.
use constant SUPPORTED_OAD_VERSIONS => [ '3.0.4', '3.1.2', '3.2.0' ];

# in most things, e.g. schemas, we only use major.minor as the version number
use constant OAS_VERSIONS => [ map s/^\d+\.\d+\K\.\d+\z//r, SUPPORTED_OAD_VERSIONS->@* ];

# see https://spec.openapis.org/#openapi-specification-schemas for the latest links
# these are updated automatically at build time via 'update-schemas'

# the main OpenAPI document schema, with permissive (unvalidated) JSON Schemas
use constant DEFAULT_METASCHEMA => {
  '3.0' => 'https://spec.openapis.org/oas/3.0/schema/2024-10-18',
  '3.1' => 'https://spec.openapis.org/oas/3.1/schema/2025-11-23',
  '3.2' => 'https://spec.openapis.org/oas/3.2/schema/2025-11-23',
};

# metaschema for JSON Schemas contained within OpenAPI documents:
# standard JSON Schema (presently draft2020-12) + OpenAPI vocabulary
use constant DEFAULT_DIALECT => {
  '3.0' => DEFAULT_METASCHEMA->{'3.0'}.'#/definitions/Schema',
  '3.1' => 'https://spec.openapis.org/oas/3.1/dialect/2024-11-10',
  '3.2' => 'https://spec.openapis.org/oas/3.2/dialect/2025-09-17',
};

# OpenAPI document schema that forces the use of the JSON Schema dialect (no $schema overrides
# permitted)
use constant DEFAULT_BASE_METASCHEMA => {
  '3.0' => 'https://spec.openapis.org/oas/3.0/schema/2024-10-18', # same as standard
  '3.1' => 'https://spec.openapis.org/oas/3.1/schema-base/2025-11-23',
  '3.2' => 'https://spec.openapis.org/oas/3.2/schema-base/2025-11-23',
};

# OpenAPI vocabulary definition
use constant OAS_VOCABULARY => {
  '3.1' => 'https://spec.openapis.org/oas/3.1/meta/2024-11-10',
  '3.2' => 'https://spec.openapis.org/oas/3.2/meta/2025-09-17',
};

# an OpenAPI schema and JSON Schema dialect which prohibit unknown keywords
use constant STRICT_METASCHEMA => {
  '3.1' => 'https://raw.githubusercontent.com/karenetheridge/OpenAPI-Modern/master/share/3.1/strict-schema.json',
  '3.2' => 'https://raw.githubusercontent.com/karenetheridge/OpenAPI-Modern/master/share/3.2/strict-schema.json',
};

use constant STRICT_DIALECT => {
  '3.1' => 'https://raw.githubusercontent.com/karenetheridge/OpenAPI-Modern/master/share/3.1/strict-dialect.json',
  '3.2' => 'https://raw.githubusercontent.com/karenetheridge/OpenAPI-Modern/master/share/3.2/strict-dialect.json',
};

#  =>  (under share/) - for internal use only!
use constant _BUNDLED_SCHEMAS => {
  map +(
    DEFAULT_METASCHEMA->{$_}        => 'oas/'.$_.'/schema.json',
    $_ eq '3.0' ? () : (
      DEFAULT_DIALECT->{$_}         => 'oas/'.$_.'/dialect.json',
      DEFAULT_BASE_METASCHEMA->{$_} => 'oas/'.$_.'/schema-base.json',
      OAS_VOCABULARY->{$_}          => 'oas/'.$_.'/vocabulary.json',
      STRICT_METASCHEMA->{$_}       => $_.'/strict-schema.json',
      STRICT_DIALECT->{$_}          => $_.'/strict-dialect.json',
    )
  ), OAS_VERSIONS->@*
};

# these are all loadable on demand, via JSON::Schema::Modern::load_cached_document,
# and also made available as s//latest/
# {  => [ , , .. ]
use constant OAS_SCHEMAS => {
  map {
    my $version = $_;
    $version => [ grep m{/oas/$version/}, keys _BUNDLED_SCHEMAS->%* ]
  } OAS_VERSIONS->@*
};


sub add_vocab_and_default_schemas ($evaluator, $version = OAS_VERSIONS->[-1]) {
  $evaluator->add_vocabulary('JSON::Schema::Modern::Vocabulary::OpenAPI');

  $evaluator->add_format_validation(int32 => +{
    type => 'number',
    sub => sub ($x) {
      require Math::BigInt; Math::BigInt->VERSION(1.999701);
      $x = Math::BigInt->new($x);
      return if $x->is_nan;
      my $bound = Math::BigInt->new(2) ** 31;
      $x >= -$bound && $x < $bound;
    }
  });

  $evaluator->add_format_validation(int64 => +{
    type => 'number',
    sub => sub ($x) {
      require Math::BigInt; Math::BigInt->VERSION(1.999701);
      $x = Math::BigInt->new($x);
      return if $x->is_nan;
      my $bound = Math::BigInt->new(2) ** 63;
      $x >= -$bound && $x < $bound;
    }
  });

  $evaluator->add_format_validation(float => +{ type => 'number', sub => sub ($x) { 1 } });
  $evaluator->add_format_validation(double => +{ type => 'number', sub => sub ($x) { 1 } });
  $evaluator->add_format_validation(password => +{ type => 'string', sub => sub ($) { 1 } });

  my $OWS = q{[\x09\x20]*};
  my $TOKEN = q{[a-zA-Z0-9!#$%&'*+.^_`|~-]+};
  my $QUOTED_STRING = q{"(?:[\x09\20\x21\x23-\x5B\x5D-\x7E\x80-\xFF]|\x5C[\x09\x20-\x7E\x80-\xFF])*"};
  $evaluator->add_format_validation('media-range' => +{
    type => 'string',
    sub => sub ($x) {
      # see ABNF at RFC9110 Appendix A
      return 0+!!($x =~ m{^$TOKEN/$TOKEN(?:$OWS;$OWS$TOKEN=(?:$TOKEN|$QUOTED_STRING))*\z});
    },
  });

  foreach my $uri (OAS_SCHEMAS->{$version}->@*) {
    my $document = load_cached_document($evaluator, $uri);

    # add "latest" alias for each of these documents, mapping to the same document object
    $evaluator->add_document(($document->canonical_uri =~ s{/\d{4}-\d{2}-\d{2}\z}{}r).'/latest', $document);
  }
}

# url-percent-decode and UTF-8-decode a string
sub uri_decode ($str) {
  Encode::decode('UTF-8', url_unescape($str), Encode::DIE_ON_ERR);
}

# UTF-8-encode and url-percent-encode a string (only encoding characters that MUST be encoded)
sub uri_encode ($str) {
  url_escape(Encode::encode('UTF-8', $str, Encode::DIE_ON_ERR), '^A-Za-z0-9\-._~!$&\'()*+,;=:@');
}

# UTF-8-encode and url-percent-encode a string (encoding all of reserved, gen-delims and sub-delims)
sub uri_encode_strict ($str) {
  url_escape(Encode::encode('UTF-8', $str, Encode::DIE_ON_ERR));
}

# find the intersection of all the lists, number and integer as equivalent
sub intersect_types (@lol) {
  my $count = @lol;
  my %vals;
  while (my $list = shift @lol) {
    ++$vals{$_} foreach uniqstr map +($_ eq 'integer' ? 'number' : $_), @$list;
  }

  return grep $vals{$_} == $count, keys %vals;
}

# Given a reference to a string, coerce it to the best-matching primitive in the allowed list
# other than object and array (which must be deserialized according to style rules first)
# The core types are: (array, object, null, boolean, string, number)
# Returns validity status, allowing the caller to fall back to the string value or generate an error.
sub coerce_primitive ($dataref, $types = []) {
  return if not @$types;            # no type specified; indicate failure
  return if not defined $$dataref;  # null is an error
  return if ref $$dataref;          # booleans, arrays, objects are errors

  my $data = $$dataref; # make copy to avoid unwanted mutation of the original

  $$dataref = undef, return 1 if $data eq '' and elem('null', $types);

  if (elem('boolean', $types)) {
    $$dataref = false, return 1 if $data eq '0' or $data eq 'false' or $data eq '';
    $$dataref = true, return 1 if $data eq '1' or $data eq 'true';
  }

  $$dataref = 0+$$dataref, return 1 if elem('number', $types) and looks_like_number($$dataref);

  $$dataref = ''.$$dataref, return 1 if elem('string', $types);
}

# RFC6265 §3.1 and §4.2.1
# cookie-header = "Cookie:" OWS cookie-string OWS
# cookie-string = cookie-pair *( ";" SP cookie-pair )
# cookie-pair   = cookie-name "=" cookie-value
# cookie-name   = token (defined in RFC2616 §2.2)
# cookie-value  = *cookie-octet / ( DQUOTE *cookie-octet DQUOTE )
# cookie-octet  = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E ; US-ASCII characters excluding
#                                   CTLs, whitespace, DQUOTE, comma, semicolon, and backslash

sub is_cookie_name ($name) {
  !!(defined $name && $name =~ /^[A-Za-z0-9!#\$%&'*+.^_`|~-]+\z/);
}

sub is_cookie_value ($value) {
  !!(defined $value && $value =~ /^("?)[\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*\1\z/);
}

# are any $items a member of $set?
sub elem ($items, $set) {
  croak 'set is not an array' if ref $set ne 'ARRAY';
  $items = [ $items ] if ref $items ne 'ARRAY';

  any {
    my $x = $_;
    any { defined $x ? (defined $_ && $x eq $_) : (!defined $_) } @$items
  }
  @$set;
}

{
  # make all bundled schemas available via JSON::Schema::Modern::load_cached_document
  my $share_dir = dist_dir('OpenAPI-Modern');
  foreach my $uri (keys _BUNDLED_SCHEMAS->%*) {
    register_schema($uri, $share_dir.'/'._BUNDLED_SCHEMAS->{$uri});
  }
}

1;

__END__