package MPMinus::Info; # $Id: Info.pm 277 2019-05-09 19:53:41Z minus $
use strict;
use utf8;

=encoding utf-8

=head1 NAME

MPMinus::Info - The mpminfo response handler

=head1 VERSION

Version 1.00

=head1 SYNOPSIS

    package MPM::Foo::Info;

    sub record {
        (
            -uri => '/mpminfo',
            -response => sub { shift->mpminfo() },
        )
    }

    1;

=head1 DESCRIPTION

This module provides mpminfo response handler

=head1 METHODS

=over 8

=item B<mpminfo>

    my $rc = $m->mpminfo();

The call in this notation returns info page and returns Apache RC

    my $info_struct = $m->mpminfo( 1 );

The call in notation with the true flag returns info page as perl-structure

=back

=head1 HISTORY

See C<CHANGES> file

=head1 DEPENDENCIES

C<mod_perl2>

=head1 TO DO

See C<TODO> file

=head1 BUGS

* none noted

=head1 SEE ALSO

C<mod_perl2>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<http://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=cut

use vars qw($VERSION);
$VERSION = "1.00";

use Encode;

use Apache2::Const;
use Apache2::RequestRec;
use Apache2::RequestUtil;

use CTK::Util qw/ :FORMAT /;
use Data::Dumper;

use MPMinus::Util qw/getHiTime/;

sub mpminfo {
    my $self = shift;
    my $flag = shift || 0; # true - return as structure (table)
    my $r = $self->r;
    $r->subprocess_env unless exists $ENV{REQUEST_METHOD};

    # GENERAL DATA
    my $config      = $self->get_node('conf') // {};
    my $namespace   = $self->namespace();
    my $project = $config->{project} || "";
    my $name  = $config->{server_name} || "localhost";
    my $port = $config->{server_port} || 80;
    my %rplc = (
            'TITLE'     => sprintf("MPMinus v%s", $self->VERSION),
            'SUBTITLE'  => $project
                ? sprintf("%s (%s)", $project, ($port == 80) ? $name : sprintf("%s:%d", $name, $port))
                : "Oops. Project not found",
        );
    my %general = (
            "Namespace"         => $namespace,
            "LocalCount"        => $self->conf('package')->[1],
            "MPMinus version"   => $self->VERSION,
            "Apache version"    => $self->get_apache_version(),
            "Config file"       => $config->{fileconf},
            "Document root"     => $config->{document_root},
            "Modperl root"      => $config->{modperl_root},
            "Project name"      => $project,
            "Server name"       => $name,
            "Server port"       => $port,
            "Client remote address" => $config->{remote_addr},
        );

    # SUMMARY TABLE
    my %info = (
            general     => {%general},
            env         => {MPMinus::Info::Tools::get_env_info()},
            subproccess_env => {MPMinus::Info::Tools::get_subproccess_env($r)},
            mobject     => Dumper($self),
            ## Config
            controllers => {MPMinus::Info::Tools::get_controllers_info($self->disp())},
            config      => {MPMinus::Info::Tools::get_config_info($config)},
            ## Typeglobs
            typeglobs       => {MPMinus::Info::Tools::get_typeglobs_info($namespace)},
            typeglobs_mpm   => {MPMinus::Info::Tools::get_typeglobs_info("MPM")},
            typeglobs_main  => {MPMinus::Info::Tools::get_typeglobs_info()},
            ## callstack
            callstack   => {MPMinus::Info::Tools::get_callstack_info()},
            ## ISA
            isa_index   => {MPMinus::Info::Tools::get_isa_info($namespace.'::Index')},
            isa_handlers=> {MPMinus::Info::Tools::get_isa_info($namespace.'::Handlers')},
            isa_mpminus => {MPMinus::Info::Tools::get_isa_info('MPMinus')},
        );
    return %info if $flag;

    # RENDER
    my @buffer = ();
    push @buffer, dformat(_render_header(), {%rplc});
    push @buffer, _render_table_std(undef, {%general});
    push @buffer, _render_navbar();

    push @buffer, sprintf("<h2 id=\"ENVIRONMENT\">%s</h2>", "ENVIRONMENT (%ENV)");
    push @buffer, _render_table_std([qw/KEY VALUE/], $info{env});
    push @buffer, sprintf("<h3>%s</h3>", "SUBPROCESS ENVIRONMENT");
    push @buffer, _render_table_std([qw/KEY VALUE/], $info{subproccess_env});
    push @buffer, sprintf("<h2 id=\"MPMINUS\">%s</h2>", 'MPMINUS OBJECT ($m)');
    push @buffer, sprintf("<div class=\"box bg5\"><pre>%s</pre></div>", $info{mobject});

    push @buffer, sprintf("<h2 id=\"CONFIGURATION\">%s</h2>", "CONFIGURATION");
    push @buffer, _render_table_std([qw/KEY VALUE/], $info{config});

    push @buffer, sprintf("<h2 id=\"TYPEGLOBS\">%s</h2>", "TYPEGLOBS");
    push @buffer, _render_table_std(undef, $info{typeglobs});
    push @buffer, sprintf("<h3>%s</h3>", "MPM TYPEGLOBS");
    push @buffer, _render_table_std(undef, $info{typeglobs_mpm});
    push @buffer, sprintf("<h3>%s</h3>", "MAIN TYPEGLOBS");
    push @buffer, _render_table_std(undef, $info{typeglobs_main});

    push @buffer, sprintf("<h2 id=\"CALL-STACK\">%s</h2>", "CALL-STACK");
    push @buffer, _render_table_std([qw/DEPTH STACK/], $info{callstack});

    push @buffer, sprintf("<h2 id=\"ISA\">%s</h2>", "ISA");
    push @buffer, _render_table_std(undef, $info{isa_index});
    push @buffer, sprintf("<h3>%s</h3>", "ISA (Handlers)");
    push @buffer, _render_table_std(undef, $info{isa_handlers});
    push @buffer, sprintf("<h3>%s</h3>", "ISA (MPMinus)");
    push @buffer, _render_table_std(undef, $info{isa_mpminus});

    push @buffer, sprintf("<h2 id=\"LICENSE\">%s</h2>", "LICENSE");
    push @buffer, _render_license();

    push @buffer, sprintf("<p class=\"debug\">Processed in %.4f sec</p>", getHiTime() - $self->conf('hitime'));
    push @buffer, dformat(_render_footer(), {%rplc});

    # OUTPUT
    my $output = join("\n", @buffer);
    $r->content_type('text/html; charset=UTF-8');
    $r->headers_out->set('Content-Length', length(Encode::encode_utf8($output)) || 0);
    $r->print($output);
    $r->rflush();
    return Apache2::Const::OK;
}

sub _render_header {<<'HTML_END';
<!DOCTYPE html>
<html lang="en">
<head>
    <title>[SUBTITLE] | [TITLE]</title>
    <meta charset="utf-8" />
    <link rel="shortcut icon" href="data:image/vnd.microsoft.icon;base64, ">
    <!-- CSS -->
    <style>
        body {
            margin: 0 3rem;
            font-family: sans-serif;
            background-color: white;
        }
        @media (min-width: 60rem) {
            body {
                width: 55rem;
                margin: 0 auto;
            }
        }

        h1, h2, h3, h4 {
            text-align: left;
        }
        .clearfix::after {
            content: "";
            clear: both;
            display: table;
        }
        .header {
            margin-bottom: 1rem;
        }
        .subtitle {
            font-size: 125%;
        }
        .logo {
            display: inline-block;
            float: right;
            width: 4rem;
            height: 4rem;
            border: 0;
        }
        .navbar {
            margin-top: 1rem;
            font-size: 75%;
        }
        .footer {
            text-align: center;
            color: #999;
        }
        .undef {
            font-style: italic;
            color: #666;
        }
        .dig {
            color: #8c1717;
        }
        .debug {
            font-style: italic;
            color: #666;
            font-size: 75%;
            text-align: right;
        }
        pre {
            margin: 0;
            font-family: monospace;
            overflow-x: auto;
        }
        hr {
            background-color: #1b4113; /* bg1 */;
            border: 0;
            height: 1px;
        }

        a {
            color: navy;
            text-decoration: none;
        }
        a:hover {
            text-decoration: underline;
        }

        .bg1 {
            /*background-color: #7981d0;*/
            background-color: #1b4113; /* bg1 */
            color: #eee;
        }
        .bg2 {
            /*background-color: #d1c9ec;*/
            background-color: #3a7a41; /* bg2 */
        }
        .bg3 {
            /*background-color: #f6f4f5;*/
            background-color: #3db157; /* bg3 */
        }
        .bg4 {
            background-color: #abe1b2; /* bg4 */
        }
        .bg5 {
            background-color: #d3f2d5; /* bg5 */
        }

        small {
            font-style: italic;
        }
        small a {
            color: lime;
        }
        .small {
            font-size: 75%;
        }

        table {
            border: 0;
            border-collapse: collapse;
            width: 55rem;
            box-shadow: 1px 2px 3px #ccc;
        }
        th, td {
            border: 1px solid #666;
            vertical-align: baseline;
            padding: 3px 5px;
            max-width: 35rem;
            overflow-x: auto;
            font-size: 75%;
        }
        th {
            background-color: #3db157; /* bg3 */
        }
        td {
            background-color: #d3f2d5; /* bg5 */
        }
        th.w, td.w {
            width: 20rem;
            background-color: #abe1b2; /* bg4 */
        }
        .box {
            border: 1px solid #666;
            box-shadow: 1px 2px 3px #ccc;
            padding: 0.5rem;
            vertical-align: baseline;
        }
        .box::after {
            content: "";
            clear: both;
            display: table;
        }
        .box h1, .box h2, .box h3, .box h4 {
            margin: 0;
            padding: 0;
        }
    </style>
</head>
<body>
    <div class="box bg1 header">
        <a href="https://metacpan.org/release/MPMinus" title="MPMinus on meta::cpan"><img class="logo" alt="MPMinus Logo" src="data:image/svg+xml;base64, " /></a>
        <h1>[TITLE]</h1>
        <div class="subtitle">[SUBTITLE]</div>
    </div>
HTML_END
}
sub _render_navbar {<<'HTML_END';
<div class="box bg5 navbar">
    <a href="#ENVIRONMENT" title="ENVIRONMENT (%ENV)">ENVIRONMENT</a>
    &nbsp;|&nbsp;
    <a href="#MPMINUS" title="MPMINUS OBJECT ($m)">MPMINUS</a>
    &nbsp;|&nbsp;
    <a href="#CONFIGURATION" title="CONFIGURATION">CONFIGURATION</a>
    &nbsp;|&nbsp;
    <a href="#TYPEGLOBS" title="TYPEGLOBS">TYPEGLOBS</a>
    &nbsp;|&nbsp;
    <a href="#CALL-STACK" title="CALL-STACK">CALL-STACK</a>
    &nbsp;|&nbsp;
    <a href="#ISA" title="ISA">ISA</a>
    &nbsp;|&nbsp;
    <a href="#LICENSE" title="LICENSE">LICENSE</a>
</div>
HTML_END
}
sub _render_footer {<<'HTML_END';
    <p>&nbsp;</p>
    <div class="box bg1">
        <div class="footer">
            <small>Copyright &copy; 1998-2019 D&amp;D Corporation. All Rights Reserved</small>
        </div>
    </div>
</body>
</html>
HTML_END
}
sub _render_license {<<'HTML_END';
<div class="box bg5 small">
    <p>
        This program is free software; you can redistribute it and/or
        modify it under the same terms as Perl itself.
    </p>
    <p>
        See <a href="https://dev.perl.org/licenses" title="LICENSE">https://dev.perl.org/licenses</a>
    </p>
</div>
HTML_END
}
sub _render_table_std {
    my ($head, $data) = @_; # Headers-array, Data-hash
    my @tr = ();

    # Headers
    if ($head && ref($head) eq "ARRAY") {
        my @th = ();
        foreach my $h (@$head) {
            push @th, sprintf("<th>%s</th>", tag($h));
        }
        push @tr, sprintf("<tr>\n%s\n</tr>", join("\n", @th));
    }

    # Data
    foreach my $k (sort {$a cmp $b} keys %$data) {
        my ($class, $v);
        if (!defined($data->{$k})) {
            $v = "no value";
            $class = "undef";
        } elsif (ref($data->{$k})) {
            $class = "pre";
            $v = tag(Dumper($data->{$k}));
        } elsif ($data->{$k} =~ /^[+\-]?[0-9.]+$/ ) {
            $class = "dig";
            $v = tag($data->{$k});
        } else {
            $v = tag($data->{$k});
        }
        $v =~ s/\n+/<br \/>/gs;
        my @td = (sprintf("<td class=\"w\">%s</td>", tag($k)));
        if ($class && $class eq "pre") {
            push @td, sprintf("<td><pre>%s</pre></td>", $v);
        } elsif ($class) {
            push @td, sprintf("<td class=\"%s\">%s</td>", $class, $v);
        } else {
            push @td, sprintf("<td>%s</td>", $v);
        }
        push @tr, sprintf("<tr>\n%s\n</tr>", join("\n", @td));
    }

    # Out
    return sprintf("<table>\n%s\n</table>", join("\n", @tr));
}

1;

package MPMinus::Info::Tools;
use strict;

use vars qw($VERSION @EXPORT_OK);
$VERSION = "1.00";

use APR::Table ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Try::Tiny;

use base qw /Exporter/;

@EXPORT_OK = qw/
        get_typeglobs_info
        get_callstack_info
        get_isa_info
        get_env_info
        get_subproccess_env
        get_config_info
        get_controllers_info
    /;

sub get_typeglobs_info {
    my $f = shift || 'main';
    no strict "refs";
    my %outh;

    foreach (sort keys %{"$f\:\:"}) {
        my $k = $_;
        my $v = ${"$f\:\:"}{$_};
        $outh{$k} = $v if defined($v) && $_ =~ /^\w/;
    }

    return %outh
}
sub get_callstack_info {
    my %outh;
    my $j = 0;
    my @args;

    while (@args = caller($j++)) {
        $outh{'#'.$j} = join("\n",map {$_ = defined($_) ? $_ : ''} @args[0..3]);
    }

    return %outh
}
sub get_isa_info {
    my $package = shift || 'main';
    my %outh;
    my $j = 0;
    no strict 'refs';
    foreach (@{"$package\:\:ISA"}) {
        $outh{'#'.(++$j)} = $_;
    }
    return %outh;
}
sub get_env_info {
    my %outh;
    foreach my $key (sort(keys(%ENV))) {
        my $val = $ENV{$key};
        $val =~ s|\n|\\n|g;
        $val =~ s|"|\\"|g;
        $outh{$key} = $val;
    }
    return %outh;
}
sub get_subproccess_env {
    my $r = shift || Apache2::RequestUtil->request;
    my $table = $r->subprocess_env();
    my %outh;
    foreach my $key (keys %{$table}) {
        my $val = $table->{$key};
        $val =~ s|\n|\\n|g;
        $val =~ s|"|\\"|g;
        $outh{$key} = $val;
    }
    return %outh;
}
sub get_config_info {
    my $lconf = shift || return ();
    my %outh;

    my %conf = %$lconf;
    foreach my $k (keys %conf) {
        my $v = $conf{$k};
        if (defined($v) && ref($v) eq "ARRAY") {
            $outh{$k} = "[" . join(", ", @$v) . "]";
        } else {
            $outh{$k} = $v;
        }
    }
    return %outh;
}
sub get_controllers_info {
    my $dispo = shift;
    my $records = $dispo->{records};
    my %ret;
    foreach my $k (grep {$_ ne 'default'} keys %$records) {
        my $rec = $dispo->get($k);
        my $ctp = $rec->{type};
        if ($ctp eq 'location') {
            if ($k eq '/') {
                $ret{'location:root'} = $k;
            } else {
                $ret{'location:'.$k} = $k;
            }
        } else {
            my $params = $rec->{params};
            my $paramsv = $params->{$ctp} ? $params->{$ctp} : 'undefined';
            my $v = $paramsv && ref($paramsv) eq 'ARRAY' ? $paramsv->[0] : $paramsv;
            $ret{lc($ctp.':'.$k)} = ref($v) ? "/$k" : $v;
        }
    }
    return %ret;
}

1;
