File Coverage

blib/lib/Modern/OpenAPI/Generator/CodeGen/ClientModels.pm

Criterion	Covered	Total	%
statement	145	162	89.5
branch	43	68	63.2
condition	37	76	48.6
subroutine	18	18	100.0
pod	1	1	100.0
total	244	325	75.0

package Modern::OpenAPI::Generator::CodeGen::ClientModels;

use v5.26;
use strict;
use warnings;
use Carp qw(croak);
use Modern::OpenAPI::Generator ();

sub _pathify_dir {
    my ($name) = @_;
    $name =~ s{::}{/}g;
    return $name;
}

sub generate {
    my ( $class, %arg ) = @_;
    my $writer = $arg{writer}   // croak 'writer';
    my $spec   = $arg{spec}     // croak 'spec';
    my $base   = $arg{base}     // croak 'base';

    my $lib = 'lib/' . _pathify_dir($base);
    my $result_pkg = "$base\::Client::Result";
    $writer->write( "$lib/Client/Result.pm", _result_pm( $result_pkg, $spec ) );

    my $schemas = $spec->raw->{components}{schemas} // {};
    return unless ref $schemas eq 'HASH' && %$schemas;

    my $mbase_pkg = "$base\::Model::Base";
    $writer->write( "$lib/Model/Base.pm", _model_base_pm( $mbase_pkg, $spec ) );

    for my $name ( sort keys %$schemas ) {
        my $sch = $schemas->{$name};
        next unless ref $sch eq 'HASH';
        next if _schema_skipped($sch);
        ( my $file_safe = $name ) =~ s/[^A-Za-z0-9._-]/_/g;
        my $pkg = _schema_name_to_pkg( $base, $name );
        my $pm = _one_model_pm( $spec, $base, $mbase_pkg, $name, $pkg, $sch, $schemas );
        $writer->write( "$lib/Model/$file_safe.pm", $pm ) if length $pm;
    }
}

sub _schema_skipped {
    my ($sch) = @_;
    return 1 if $sch->{allOf} || $sch->{oneOf} || $sch->{anyOf};
    return 0 if ( $sch->{type} // '' ) eq 'object' && ref $sch->{properties} eq 'HASH';
    return 1;
}

sub _schema_name_to_pkg {
    my ( $base, $name ) = @_;
    ( my $safe = $name ) =~ s/[^A-Za-z0-9_]/_/g;
    return "$base\::Model::$safe";
}

sub _ref_name {
    my ($ref) = @_;
    return undef unless defined $ref && $ref =~ m{\#/components/schemas/([^/]+)\z};
    return $1;
}

sub _esc {
    my ($s) = @_;
    $s =~ s/'/\\'/g;
    return $s;
}

sub _wrap_req {
    my ( $required, $inner ) = @_;
    return $inner if $required;
    return "Maybe[$inner]";
}

# OpenAPI Generator-style POD: API info in =begin comment (safe for long markdown).
sub _api_pod_preamble {
    my ( $spec, %opt ) = @_;
    my $info = $spec->raw->{info} // {};
    my $title = $info->{title} // 'API';
    my $desc = $info->{description} // '';
    $desc =~ s/\r\n/\n/g;
    $desc =~ s/^=end\s+comment\s*$/[line removed: looked like =end comment]/gim;
    my $ver = $info->{version} // '';
    my $oav = $spec->openapi_version;
    my $gen    = 'Modern::OpenAPI::Generator';
    my $genurl = 'https://metacpan.org/pod/Modern::OpenAPI::Generator';
    my $gver   = $Modern::OpenAPI::Generator::VERSION // '0';

    my $extra = '';
    if ( my $p = $opt{purpose} ) {
        $extra .= "\n$p\n";
    }
    if ( my $sn = $opt{schema_name} ) {
        $extra .= "\nThis module represents OpenAPI C.\n";
    }
    if ( my $sd = $opt{schema_description} ) {
        $sd =~ s/\r\n/\n/g;
        $sd =~ s/^=end\s+comment\s*$/[line removed]/gim;
        $extra .= "\n---\n\nSchema description:\n\n$sd\n";
    }

    return <<"POD";

=begin comment

$title

$desc
$extra

The version of the OpenAPI document: $oav
API version (info.version): $ver

Perl generator ($gen) version: $gver
Generated by: $gen ($genurl)

=end comment

=cut

#
# NOTE: This file is auto generated by $gen.
# Do not edit the class manually.
# Ref: $genurl
#

POD
}

sub _result_pm {
    my ( $pkg, $spec ) = @_;
    my $pod = _api_pod_preamble(
        $spec,
        purpose =>
'Client result object: holds L (C) and response C (JSON or C<::Model::*>).',
    );
    return <<"PM";
$pod
package $pkg;

use v5.26;
use strict;
use warnings;

use Moo;

has tx => (
  is       => 'ro',
  required => 1,
);

has data => (
  is => 'ro',
);

1;
PM
}

sub _model_base_pm {
    my ( $pkg, $spec ) = @_;
    my $pod = _api_pod_preamble(
        $spec,
        purpose => 'Moo::Role included by all generated C<::Model::*> classes.',
    );
    return <<"PM";
$pod
package $pkg;

use v5.26;
use strict;
use warnings;

use Moo::Role;

1;
PM
}

# Expression to read attribute $pname from $self in generated model (handles odd keys).
sub _perl_self_accessor {
    my ($pname) = @_;
    if ( $pname =~ /^[a-zA-Z_]\w*$/a ) {
        return "\$self->$pname";
    }
    ( my $q = $pname ) =~ s/'/\\'/g;
    return "\$self->\${\\'$q\\'}";
}

sub _one_model_pm {
    my ( $spec, $base, $mbase, $schema_name, $pkg, $sch, $all_schemas ) = @_;

    my $props = $sch->{properties} // {};
    return '' unless ref $props eq 'HASH' && %$props;

    my $req = $sch->{required} // [];
    my %req = map { $_ => 1 } @$req;

    my @has;
    my @buildargs;

    for my $pname ( sort keys %$props ) {
        my $ps = $props->{$pname};
        next unless ref $ps eq 'HASH';
        my ( $has_line, $bld ) =
          _prop_type( $base, $schema_name, $pkg, $pname, $ps, $all_schemas,
            $req{$pname} );
        push @has, $has_line;
        push @buildargs, $bld if length $bld;
    }

    my @to_json_lines;
    for my $pname ( sort keys %$props ) {
        my $ps = $props->{$pname};
        next unless ref $ps eq 'HASH';
        push @to_json_lines,
          sprintf q{    '%s' => _to_json_val( %s ),}, _esc($pname),
          _perl_self_accessor($pname);
    }

    my $to_json_block = '';
    if (@to_json_lines) {
        $to_json_block = join "\n",
          'sub TO_JSON {',
          '  my $self = shift;',
          '  return {',
          join( "\n", @to_json_lines ),
          '  };',
          '}',
          '',
          'sub _to_json_val {',
          '  my ($v) = @_;',
          '  return undef unless defined $v;',
          q{  if ( ref $v eq 'ARRAY' ) { return [ map { _to_json_val($_) } @$v ]; }},
          q{  if ( blessed($v) && $v->can('TO_JSON') ) { return $v->TO_JSON; }},
          '  return $v;',
          '}',
          '',
          'sub to_json {',
          '  my $self = shift;',
          '  require Mojo::JSON;',
          '  return Mojo::JSON::encode_json( $self->TO_JSON );',
          '}',
          '';
    }

    my $buildargs_block = '';
    if (@buildargs) {
        $buildargs_block = join "\n",
          'around BUILDARGS => sub {',
          '  my ( $orig, $class, $args ) = @_;',
          '  $args = {} unless ref $args eq \'HASH\';',
          @buildargs,
          '  return $class->$orig($args);',
          '};',
          '';
    }

    my $uses = join "\n",
      'use v5.26;',
      'use strict;',
      'use warnings;',
      "use Moo;",
      "with '$mbase';",
      'use Types::Standard qw( Str Num Int Bool ArrayRef HashRef Maybe Enum );',
      'use Scalar::Util qw(blessed);',
      '';

    my $has_block = join "\n", @has, '';

    my $pod_top = _api_pod_preamble(
        $spec,
        schema_name        => $schema_name,
        schema_description => ( $sch->{description} // '' ),
    );
    my $pod_end = _api_pod_preamble(
        $spec,
        schema_name        => $schema_name,
        schema_description => ( $sch->{description} // '' ),
    );

    return <<"PM";
$pod_top
package $pkg;

$uses
$has_block
$buildargs_block
sub from_json {
  my ( \$class, \$data, \$is_array ) = \@_;
  \$is_array //= 0;
  if (\$is_array) {
    return undef unless defined \$data && ref \$data eq 'ARRAY';
    return [ map { __PACKAGE__->_from_hash(\$_) } \@\$data ];
  }
  return \$class->_from_hash(\$data);
}

sub _from_hash {
  my ( \$class, \$data ) = \@_;
  return undef unless defined \$data && ref \$data eq 'HASH';
  return \$class->new(\%\$data);
}

$to_json_block
$pod_end
1;
PM
}

sub _prop_type {
    my ( $base, $schema_name, $pkg, $pname, $ps, $all_schemas, $required ) = @_;

    my $qe = _esc($pname);

    if ( my $r = _ref_name( $ps->{'$ref'} // '' ) ) {
        my $npkg = _schema_name_to_pkg( $base, $r );
        my $inner =
            ( !$all_schemas->{$r} || _schema_skipped( $all_schemas->{$r} ) )
          ? 'HashRef'
          : ( $r eq $schema_name ? 'HashRef' : "InstanceOf['$npkg']" );
        my $type = _wrap_req( $required, $inner );
        my $has  = "has '$qe' => ( is => 'ro', isa => $type );";
        return ( $has, '' ) if $inner eq 'HashRef';

        my $bld = <
  if ( exists \$args->{'$qe'} && ref \$args->{'$qe'} eq 'HASH' ) {
    \$args->{'$qe'} = ${npkg}->_from_hash( \$args->{'$qe'} );
  }
BUILD
        return ( $has, $bld );
    }

    if ( ( $ps->{type} // '' ) eq 'array' && ref $ps->{items} eq 'HASH' ) {
        my $it = $ps->{items};
        if ( my $r = _ref_name( $it->{'$ref'} // '' ) ) {
            my $npkg = _schema_name_to_pkg( $base, $r );
            my $inner =
                ( !$all_schemas->{$r} || _schema_skipped( $all_schemas->{$r} ) )
              ? 'ArrayRef[HashRef]'
              : (
                $r eq $schema_name
                ? 'ArrayRef[HashRef]'
                : "ArrayRef[InstanceOf['$npkg']]"
              );
            my $type = _wrap_req( $required, $inner );
            my $has  = "has '$qe' => ( is => 'ro', isa => $type );";
            return ( $has, '' ) if $inner eq 'ArrayRef[HashRef]';

            my $bld = <
  if ( exists \$args->{'$qe'} && ref \$args->{'$qe'} eq 'ARRAY' ) {
    \$args->{'$qe'} = [ map { ref \$_ eq 'HASH' ? ${npkg}->_from_hash(\$_) : \$_ } \@{\$args->{'$qe'}} ];
  }
BUILD
            return ( $has, $bld );
        }
        my $inner = 'ArrayRef[Str]';
        if ( ( $it->{type} // '' ) eq 'number' ) {
            $inner = 'ArrayRef[Num]';
        }
        elsif ( ( $it->{type} // '' ) eq 'integer' ) {
            $inner = 'ArrayRef[Int]';
        }
        my $type = _wrap_req( $required, $inner );
        return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
    }

    my $t = $ps->{type} // 'string';
    if ( $t eq 'string' && ref $ps->{enum} eq 'ARRAY' && @{ $ps->{enum} } ) {
        my @q = map { qq{'$_'} } @{ $ps->{enum} };
        my $enum = 'Enum[' . join( ',', @q ) . ']';
        my $type = _wrap_req( $required, $enum );
        return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
    }
    if ( $t eq 'integer' ) {
        my $type = _wrap_req( $required, 'Int' );
        return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
    }
    if ( $t eq 'number' ) {
        my $type = _wrap_req( $required, 'Num' );
        return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
    }
    if ( $t eq 'boolean' ) {
        my $type = _wrap_req( $required, 'Bool' );
        return (
"has '$qe' => ( is => 'ro', isa => $type, coerce => sub { my \$v = shift; \$v ? 1 : 0 } );",
            ''
        );
    }
    if ( $t eq 'object' ) {
        my $type = _wrap_req( $required, 'HashRef' );
        return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
    }

    my $type = _wrap_req( $required, 'Str' );
    return ( "has '$qe' => ( is => 'ro', isa => $type );", '' );
}

1;

__END__