File Coverage

blib/lib/Swagger2/POD.pm

Criterion	Covered	Total	%
statement	190	225	84.4
branch	53	74	71.6
condition	29	56	51.7
subroutine	24	30	80.0
pod	1	1	100.0
total	297	386	76.9

package Swagger2::POD;
use Mojo::Base -base;
use Mojo::JSON 'encode_json';
use Mojo::Message::Response;
use Scalar::Util 'blessed';
use constant NO_DESCRIPTION => 'No description.';

require Swagger2;

my $MOJO_MESSAGE_RESPONSE = Mojo::Message::Response->new;

sub to_string {
  my $self = shift;

  join('',
    $self->_header_to_string, $self->_api_endpoint_to_string,
    $self->_paths_to_string,  $self->_footer_to_string,
  );
}

sub _api_endpoint_to_string {
  my $self    = shift;
  my @schemes = @{$self->{api_spec}->get('/schemes') || []};
  my $url     = $self->{base_url}->clone;
  my $str     = "=head1 BASEURL\n\n";

  unless (@schemes) {
    return $str . "No default URL is defined to this application.\n\n";
  }

  while (my $scheme = shift @schemes) {
    $url->scheme($scheme);
    $str .= sprintf "L<%s>\n\n", $url;
  }

  return $str;
}

sub _footer_to_string {
  my $self    = shift;
  my $contact = $self->{api_spec}->get('/info/contact');
  my $license = $self->{api_spec}->get('/info/license');
  my $str     = '';

  unless ($license->{name}) {
    $license->{name} = 'BSD';
    $license->{url}  = 'http://www.linfo.org/bsdlicense.html';
  }

  $contact->{name} ||= 'Unknown author';

  $str .= sprintf "=head1 COPYRIGHT AND LICENSE\n\n%s", $contact->{name};
  $str .= sprintf " - %s", $contact->{email} || $contact->{url}
    if $contact->{email} || $contact->{url};
  $str .= sprintf "\n\n%s", $license->{name};
  $str .= sprintf " - %s", $license->{url} if $license->{url};
  $str .= "\n\n=cut\n";
  $str;
}

sub _header_to_string {
  my $self = shift;
  my $info = $self->{api_spec}->get('/info');
  my $str  = '';

  $info->{title}       ||= 'Noname API';
  $info->{description} ||= 'This API has no description.';
  $info->{version}     ||= '0.01';

  $str .= sprintf "=head1 NAME\n\n%s\n\n",             $info->{title};
  $str .= sprintf "=head1 VERSION\n\n%s\n\n",          $info->{version};
  $str .= sprintf "=head1 DESCRIPTION\n\n%s\n\n",      $info->{description};
  $str .= sprintf "=head1 TERMS OF SERVICE\n\n%s\n\n", $info->{termsOfService}
    if $info->{termsOfService};
  $str;
}

sub _path_request_to_string {
  my ($self, $info) = @_;
  my @table = ([qw( Name In Type Required Description )]);
  my $str   = '';
  my %body;

  for my $p (@{$info->{parameters} || []}) {
    $p->{description} ||= NO_DESCRIPTION;
    if ($p->{in} eq 'body') {
      %body = (name => 'body', %$p);
      push @table, [$p->{name}, 'body', 'schema', 'Yes', $p->{description}];
    }
    else {
      push @table,
        [
        @$p{qw( name in type )}, Swagger2::_is_true($p->{required}) ? 'Yes' : 'No',
        $p->{description}
        ];
    }
  }

  $str .= sprintf "=head3 Parameters\n\n";
  $str .= (@table == 1) ? "This resource takes no parameters.\n\n" : sprintf "%s\n",
    _ascii_table(\@table, '  ');
  $str .= "  $body{name}:\n\n" . $self->_schema_to_string_dispatch($body{schema}, 0) . "\n"
    if %body;
  $str;
}

sub _path_response_to_string {
  my ($self, $info) = @_;
  my $responses = $info->{responses} || {};
  my $str = '';

  $str .= sprintf "=head3 Responses\n\n";

  for my $code (sort keys %$responses) {
    my $res = $responses->{$code};
    $str .= sprintf "=head4 %s\n\n", _status_code_to_string($code);
    $str .= $self->_summary_and_description($res);
    $str .= $self->_schema_to_string_dispatch($res->{schema}, 0) . "\n";
  }

  return $str;
}

sub _paths_to_string {
  my $self  = shift;
  my $paths = $self->{api_spec}->get('/paths') || {};
  my $str   = "=head1 RESOURCES\n\n";
  my %info;

  for my $path (keys %$paths) {
    for my $method (sort keys %{$paths->{$path}}) {
      next if $method =~ /^x-/;
      my $operationId = $paths->{$path}{$method}{operationId} || join ' ', uc $method, $path;
      $info{$operationId} and die "Overlapping operationId in swagger specification: $operationId";
      $info{$operationId} = {%{$paths->{$path}{$method}}, _path => $path, _method => $method,};
    }
  }

  for my $operationId (sort keys %info) {
    my $url  = $self->{base_url}->clone;
    my $info = $info{$operationId};
    push @{$url->path->parts}, grep { length $_ } split '/', $info->{_path};

    my $ext = $info->{externalDocs};
    my $resource_url;

    $str .= sprintf "=head2 %s\n\n", $operationId;
    $str .= "  THIS RESOURCE IS DEPRECATED!\n\n" if $info->{deprecated};
    $str .= $self->_summary_and_description($info);
    $str .= sprintf "See also L<%s>\n\n", $ext->{url} if $ext;

    next METHOD if $info->{deprecated};
    $url->query(Mojo::Parameters->new);
    $resource_url = $url->to_abs;
    $resource_url =~ s!/%7B([^%]+)%7D!/{$1}!g;

    $str .= sprintf "=head3 Resource URL\n\n";
    $str .= sprintf "  %s %s\n\n", uc $info->{_method}, $resource_url;
    $str .= $self->_path_request_to_string($info);
    $str .= $self->_path_response_to_string($info);
  }

  return $str;
}

sub _schema_anyof_to_string {
  my ($self, $schema, $depth) = @_;
  my $str = "\n" . _sprintf($depth + 1, "// Any of the below:\n");

  for my $s (@{$schema->{anyOf}}) {
    $str .= _sprintf($depth + 1, "");
    $str .= $self->_schema_to_string_dispatch($s, $depth + 1);
  }

  $str;
}

sub _schema_allof_to_string {
  my ($self, $schema, $depth) = @_;
  my $str = "\n" . _sprintf($depth + 1, "// All of the below:\n");

  for my $s (@{$schema->{allOf}}) {
    $str .= _sprintf($depth + 1, "");
    $str .= $self->_schema_to_string_dispatch($s, $depth + 1);
  }

  $str;
}

sub _schema_oneof_to_string {
  my ($self, $schema, $depth) = @_;
  my $str = "\n" . _sprintf($depth + 1, "// One of the below:\n");

  for my $s (@{$schema->{oneOf}}) {
    $str .= _sprintf($depth + 1, "");
    $str .= $self->_schema_to_string_dispatch($s, $depth + 1);
  }

  $str;
}

sub _schema_array_to_string {
  my ($self, $schema, $depth) = @_;
  my $description = _type_description($schema, qw( minItems maxItems multipleOf uniqueItems ));
  my $str = '';

  $description = $description eq NO_DESCRIPTION ? "" : "// $description";

  $str .= _sprintf($depth, "[%s\n", $description);
  $str .= $self->_schema_to_string_dispatch($schema->{items}, $depth + 1);
  $str .= _sprintf($depth + 1, "...\n");
  $str .= _sprintf($depth,     "]\n");
  $str;
}

sub _schema_boolean_to_string {
  my ($self, $schema, $depth) = @_;

  sprintf "%s, // %s\n", 'boolean', _type_description($schema);
}

sub _schema_enum_to_string {
  my ($self, $schema, $depth) = @_;

  sprintf "%s, // %s\n", 'enum', _type_description($schema, qw( enum ));
}

sub _schema_integer_to_string {
  my ($self, $schema, $depth) = @_;

  sprintf "%s, // %s\n", $schema->{format} || 'integer', _type_description($schema, qw( default ));
}

sub _schema_number_to_string {
  my ($self, $schema, $depth) = @_;

  sprintf "%s, // %s\n", $schema->{format} || 'number', _type_description($schema, qw( default ));
}

sub _schema_file_to_string {
  my ($self, $schema, $depth) = @_;
  my $str = $schema->{description} || 'This response contains raw binary or text data.';

  return "  $str\n";
}

sub _schema_object_to_string {
  my ($self, $schema, $depth) = @_;
  my $description = _type_description($schema, qw( minProperties maxProperties ));
  my $str = '';

  $description = $description eq NO_DESCRIPTION ? "" : "// $description";
  $str .= _sprintf($depth, "{%s\n", $description);

  for my $k (sort keys %$schema) {
    $str .= _sprintf($depth + 1, qq("%s": ), $k);
    $str .= $self->_schema_to_string_dispatch($schema->{$k}, $depth + 1)
      if ref $schema->{$k} eq 'HASH';
  }

  $str .= _sprintf($depth, "},\n");
  $str;
}

sub _schema_string_to_string {
  my ($self, $schema, $depth) = @_;

  sprintf "%s, // %s\n", $schema->{format} || 'string',
    _type_description($schema, qw( minLength maxLength pattern default ));
}

sub _schema_to_string_dispatch {
  my ($self, $schema, $depth) = @_;
  my $required = $schema->{required};
  my $method;

  if ($schema->{properties}) {
    $schema = $schema->{properties};
  }
  if ($required and ref $required eq 'ARRAY') {
    $schema->{$_}{required} = 1 for @$required;
  }

  if ($schema->{anyOf}) {
    $method = '_schema_anyof_to_string';
  }
  elsif ($schema->{allOf}) {
    $method = '_schema_allof_to_string';
  }
  elsif ($schema->{oneOf}) {
    $method = '_schema_oneof_to_string';
  }
  elsif (ref $schema->{type} eq 'ARRAY') {
    return sprintf "{%s},\n", join ',', @{$schema->{type}};
  }
  else {
    $method = '_schema_' . ($schema->{type} || 'object') . '_to_string';
  }

  return "Cannot translate '$schema->{type}' into POD." unless $self->can($method);
  return $self->$method($schema, $depth);
}

sub _summary_and_description {
  my ($self, $data) = @_;
  my $str = '';

  $str .= "$data->{summary}\n\n"     if $data->{summary};
  $str .= "$data->{description}\n\n" if $data->{description};
  $str .= NO_DESCRIPTION . "\n\n" unless $data->{summary} or $data->{description};
  $str;
}

# FUNCTIONS
sub _ascii_table {
  my ($rows, $pad) = @_;
  my $width = 1;
  my (@spec, @table);

  $pad //= '';

  for my $row (@$rows) {
    for my $i (0 .. $#$row) {
      $row->[$i] //= '';
      $row->[$i] =~ s/[\r\n]//g;
      my $len = length $row->[$i];
      $spec[$i] = $len if $len >= ($spec[$i] // 0);
    }
  }

  my $format = sprintf '%s| %s |', $pad, join ' | ', map { $width += $_ + 3; "\%-${_}s" } @spec;
  @table = map { sprintf "$format\n", @$_ } @$rows;
  unshift @table, "$pad." . ('-' x ($width - 2)) . ".\n";
  splice @table, 2, 0, "$pad|" . ('-' x ($width - 2)) . "|\n";
  push @table, "$pad'" . ('-' x ($width - 2)) . "'\n";
  return join '', @table;
}

sub _sprintf {
  my ($level, $format, @args) = @_;

  sprintf "%s$format", (" " x (($level + 1) * 2)), @args;
}

sub _status_code_to_string {
  my ($code) = @_;
  my $message = $MOJO_MESSAGE_RESPONSE->code($code)->default_message;

  return sprintf '%s - %s', $code, $message if $message;
  return ucfirst $code;
}

sub _stringify {
  my ($k, $obj) = @_;
  return 'required' if $k eq 'required'   and Swagger2::_is_true($obj->{$k});
  return "$k=true"  if blessed $obj->{$k} and $obj->{$k} eq Mojo::JSON->true;
  return "$k=false" if blessed $obj->{$k} and $obj->{$k} eq Mojo::JSON->false;
  return sprintf '%s=%s', $k, encode_json $obj->{$k} if ref $obj->{$k};
  return sprintf '%s=%s', $k, $obj->{$k};
}

sub _type_description {
  my ($schema) = (shift, shift);
  return $schema->{description} if $schema->{description};
  my @keys = grep { defined $schema->{$_} } 'required', @_;
  my @description = map { _stringify($_, $schema) } @keys;

  return $schema->{title} || NO_DESCRIPTION unless @description;
  return join ', ', @description;
}

1;

=encoding utf8

=head1 NAME

Swagger2::POD - Convert swagger API spec to Perl documentation

=head1 DEPRECATION WARNING

See L.

=head1 DESCRIPTION

L is a module that can convert from L to L.

=head1 SYNOPSIS

  use Swagger2;
  my $swagger = Sswagger2->new("file:///path/to/api-spec.yaml");

  print $swagger->pod->to_string;

=head1 METHODS

=head2 to_string

  $str = $self->to_string;

Will convert swagger API spec to plain old documentation.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014-2015, Jan Henning Thorsen

This program is free software, you can redistribute it and/or modify it under
the terms of the Artistic License version 2.0.

=head1 AUTHOR

Jan Henning Thorsen - C

=cut