File Coverage

blib/lib/Yaadgom.pm

Criterion	Covered	Total	%
statement	136	157	86.6
branch	21	40	52.5
condition	7	10	70.0
subroutine	20	21	95.2
pod	3	5	60.0
total	187	233	80.2

use strict;

package Yaadgom;
use 5.008_005;
our $VERSION = '0.07';
use Moo;
use Devel::GlobalDestruction;

use Encode qw/decode/;
use JSON::MaybeXS;
use URI;
use Carp;
use Class::Trigger;

has '_json_ed' => (
    is      => 'rw',
    lazy    => 1,
    builder => '_build_json'
);

sub _build_json {
    JSON::MaybeXS->new( utf8 => 1, pretty => 1, canonical => 1 );
}

has 'slash_filename_replacement' => ( is => 'rw', default => sub { '-' } );

has '_results'  => ( is => 'rw', default => sub { +{} } );
has 'file_name' => ( is => 'rw', default => sub { $0 } );

sub process_response {
    my ( $self, %opt ) = @_;

    my $req = $opt{req};
    my $res = $opt{res};

    for my $obj (qw/res req/) {
        for my $func ( qw/as_string/, ( $obj eq 'req' ? qw/uri/ : () ) ) {
            eval { $opt{$obj}->$func };
            croak "Param{$obj}->$func() died, perhaps you forgot to pass an HTTP object: \n$@" if $@;
        }
    }

    my $rep = $self->slash_filename_replacement;

    my $file = exists $opt{file} ? $opt{file} : undef;

    if ($file) {
        $file =~ s/^\///;
        $file =~ s/\/$//;
    }
    else {
        $file = URI->new( $req->uri->path )->path;

        $file =~ s/^\///;
        $file =~ s/\/$//;
        $file =~ s/\//$rep/gio;
        $file =~ s/[0-9]+/*/go;
        $file =~ s/[^a-z$rep*]//gio;

        $self->call_trigger( 'filename_generated', { req => $req, file => $file } );
        my @results = @{ $self->last_trigger_results };
        ($file) = @{ $results[-1] } if $results[-1];
    }

    my $weight = defined $opt{weight} && $opt{weight} =~ /^[0-9]+$/ ? $opt{weight} : 1;

    push @{ $self->_results->{$file}{$weight} },
      {
        extra    => $opt{extra},
        file     => $file,
        folder   => $opt{folder} || 'default',
        markdown => $self->get_markdown(%opt)
      };

}

sub _write_title {
    my ( $self, $title ) = @_;
    "## $title\n\n";
}

sub _write_subtitle {
    my ( $self, $title ) = @_;
    "### $title\n\n";
}

sub _write_line {
    my ( $self, $title ) = @_;
    my $str = "$title\n";
}

sub _write_preformated {
    my ( $self, $str ) = @_;
    "$str\n\n";
}

sub format_body {
    my ( $self, $str ) = @_;
    my ( $header, $body ) = split /\n\n/, $str;
    if ( $header =~ /application\/json/ && $body ) {
        $body = $self->_json_ed->encode( $self->_json_ed->decode($body) );
        $body = decode( 'utf8', $body );
    }

    $self->call_trigger( 'format_body', { response_str => $body } );
    my @results = @{ $self->last_trigger_results };
    ($body) = @{ $results[-1] } if $results[-1];

    return "$header\n$body";
}

sub get_markdown {
    my ( $self, %opt ) = @_;

    my $file_name = $self->file_name;

    my $req = $opt{req};
    my $res = $opt{res};

    my $desc = join ' ', $req->method, $req->uri->path, $opt{extra}{is_fail} ? ' + expected failure' : '';

    do {
        $self->call_trigger( 'format_title', { title => $desc } );
        my @results = @{ $self->last_trigger_results };
        ($desc) = @{ $results[-1] } if $results[-1];
    };

    my $str = join '',
      $self->_write_title($desc),
      ( defined $file_name ? "$file_name\n" : '' ),
      ( exists $opt{extra}{name} ? ( $self->_write_line( '> ' . $opt{extra}{name} . "\n" ) ) : () ),
      $self->_write_subtitle('Request'),
      $self->_write_preformated( $self->format_body( $req->as_string ) ),
      $self->_write_subtitle('Response'),
      $self->_write_preformated( $self->format_body( $res->as_string ) );

    do {
        $self->call_trigger( 'format_before_extras', { str => $str } );
        my @results = @{ $self->last_trigger_results };
        ($str) = @{ $results[-1] } if $results[-1];
    };

    do {
        $self->call_trigger( 'process_extras', %opt );
        my @results = @{ $self->last_trigger_results };
        $str .= join '', $_ for @results;
    };

    if ( exists $opt{extra}{fields} ) {
        $str .= $self->_write_subtitle('Fields details');
        while ( my ( $key, $maybealist ) = each %{ $opt{extra}{fields} } ) {

            $str .= $self->_write_line( '#### ' . $key );
            if ( ref $maybealist eq 'ARRAY' ) {
                $str .= $self->_write_line( '* ' . $_ ) for @$maybealist;
                $str .= "\n";
            }
            else {
                $str .= $self->_write_line( '- ' . $maybealist );
                $str .= "\n";
            }
        }
    }

    do {
        $self->call_trigger( 'format_after_extras', { str => $str } );
        my @results = @{ $self->last_trigger_results };
        ($str) = @{ $results[-1] } if $results[-1];
    };

    return $str;
}

sub export_to_dir {
    my ( $self, %conf ) = @_;

    my $dir = $conf{dir};
    croak "dir ($dir) is not an directory" unless -d $dir;

    $self->map_results(
        sub {
            my (%info) = @_;

            my $str    = $info{str};
            my $folder = $info{folder};
            my $file   = $dir . '/' . $folder . '/' . $info{file} . '.md';

            mkdir $dir . '/' . $folder;

            open my $fh, '>>:utf8', $file or croak "cant open file $file $!";
            print $fh $str;
            close $fh;
        }
    );

    return 1;
}

sub map_results {
    my ( $self, $callback ) = @_;

    my $tests = $self->_results;

    foreach my $endpoint ( keys %$tests ) {

        my @in_order;
        foreach my $num ( sort { $a <=> $b } keys %{ $tests->{$endpoint} } ) {
            push @in_order, @{ $tests->{$endpoint}{$num} };
        }

        my $folders = {};

        foreach (@in_order) {
            push @{ $folders->{ $_->{folder} }{ $_->{file} } }, $_;
        }

        for my $folder ( keys %$folders ) {
            for my $file ( keys %{ $folders->{$folder} } ) {

                my $str = join "\n\n", map { $_->{markdown} } @{ $folders->{$folder}{$file} };

                my $format_time = "\ngenerated at " . gmtime(time) . " GMT\n";
                do {
                    $self->call_trigger( 'format_generated_str', { str => $format_time } );
                    my @results = @{ $self->last_trigger_results };
                    ($format_time) = @{ $results[-1] } if $results[-1];
                };

                $str .= $format_time;

                $callback->(
                    folder => $folder,
                    file   => $file || '_index',
                    str    => $str
                );

            }
        }

    }

}

has 'on_destroy' => ( is => 'rw' );

sub DESTROY {
    my $self = shift;

    if ( ref $self->on_destroy eq 'CODE' ) {
        $self->on_destroy->($self);
    }

}

1;

__END__