File Coverage

blib/lib/WWW/Suffit/Plugin/ServerInfo.pm

Criterion	Covered	Total	%
statement	15	144	10.4
branch	0	50	0.0
condition	0	20	0.0
subroutine	5	9	55.5
pod	1	1	100.0
total	21	224	9.3

package WWW::Suffit::Plugin::ServerInfo;
use strict;
use warnings;
use utf8;

=encoding utf8

=head1 NAME

WWW::Suffit::Plugin::ServerInfo - The WWW::Suffit Plugin for show Server and Perl environment data

=head1 SYNOPSIS

    # in your startup
    $self->plugin('WWW::Suffit::Plugin::ServerInfo', {
        route => "/serverinfo",
    });

    ...or:

    # in your startup
    $self->plugin('WWW::Suffit::Plugin::ServerInfo');
    $self->routes->get('/serverinfo1')->to('ServerInfo#info');
    $self->routes->get('/serverinfo2' => sub { shift->serverinfo });

    # Curl Examples:
    curl -H "Accept: text/html" http://localhost:8080/serverinfo
    curl -H "Accept: text/plain" http://localhost:8080/serverinfo
    curl -H "Accept: application/json" http://localhost:8080/serverinfo

=head1 DESCRIPTION

The WWW::Suffit Plugin for show Server and Perl environment data

=head1 OPTIONS

This plugin supports the following options

=head2 debug

    debug => 1,

Switches on the debug mode. This mode performs show log history and dump of config

=head2 route

    route => "/serverinfo",

Sets route name and show server info by it

=head2 template

    template => "suffit_serverinfo",

Sets template for rendering. Default: suffit_serverinfo

=head1 METHODS

Internal methods

=head2 register

Do not use directly. It is called by Mojolicious.

=head1 SEE ALSO

L, L

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L [e-mail]

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C file or L for details

=cut

use Mojo::Base 'Mojolicious::Plugin';

our $VERSION = '1.02';

use Mojo::File qw/ path /;

sub register {
    my ($plugin, $app, $opts) = @_; # $self = $plugin
    $opts //= {};

    # Add classes
    push @{$app->renderer->classes}, __PACKAGE__;
    push @{$app->static->classes},   __PACKAGE__;
    my $ns = 0;
    for (@{$app->routes->namespaces}) { $ns = 1 if $_ eq 'WWW::Suffit::Server' }
    push @{$app->routes->namespaces}, 'WWW::Suffit::Server' unless $ns;

    # Helpers
    $app->helper('serverinfo',    => \&_serverinfo);

    # Set template
    my $template = $opts->{template} || 'suffit_serverinfo';
       $app->{'__suffit_serverinfo_template'} = $template;

    # Set debug mode
    $app->{'__suffit_serverinfo_debug'} = $opts->{debug} ? 1 : 0;

    # Set ANY route to root:
    if (my $route_name = $opts->{routename} || $opts->{route}) { # '/serverinfo'
        #$app->routes->any($route_name => {template => $template} => sub { shift->render } );
        #$app->routes->any($route_name)->to('ServerInfo#info');
        $app->routes->any($route_name => sub { shift->serverinfo });
    }
}
sub _serverinfo {
    my $self = shift;
    my @o = ();

    # Filtered stash snapshot
    my $stash = $self->stash;
    my $snapshot;
    %{$snapshot = {}} = map { $_ => $_ eq 'app' ? 'DUMMY' : $stash->{$_} } grep { !/^mojo\./ and defined $stash->{$_} } keys %$stash;

    my $url = $self->req->url;
    my $params = $self->req->params->to_hash || {};
    my $s = sub {
        my $sec = shift; # sec   - gen, ext, dat
        my $typ = shift; # typ   - str, txt, obj, dmp
        my $key = shift; # key   - Key
        my $val = shift; # val   - Value
        push @o, {
            sec => $sec,
            typ => $typ,
            key => $key,
            val => $val,
        };
    };

    # General
    push @o, "-"x80 . " gen " . "---";
    $s->("gen", "str", 'Request ID' => $self->req->request_id);
    $s->("gen", "str", 'Method'     => $self->req->method);
    $s->("gen", "str", 'Base URL'   => $url->base->to_string);
    $s->("gen", "str", 'URL'        => $url->to_string);
    $s->("gen", "str", 'Router name'=> $self->match->endpoint->name);
    $s->("gen", "str", 'HTTP Version' => $self->req->version);
    $s->("gen", "str", 'Remote IP'  => $self->can('remote_ip') ? $self->remote_ip : $self->tx->remote_address);
    { # Headers
        my @obj;
        foreach my $n (sort @{$self->req->headers->names}) {
            push @obj, [$n, $self->req->headers->header($n)];
        }
        $s->("gen", "obj", 'Request headers', [@obj]);
    }
    { # Parameters
        my @obj;
        foreach my $n (sort keys %$params) {
            push @obj, [$n,  $params->{$n} // ''];
        }
        $s->("gen", "obj", 'Request parameters', [@obj]);
    }
    $s->("gen", "dmp", 'Stash'      => $snapshot);
    $s->("gen", "dmp", 'Session'    => $self->session);

    # Extends
    push @o, "-"x80 . " ext " . "---";
    $s->("ext", "str", 'Perl'           => "$^V ($^O)");
    $s->("ext", "str", 'Mojolicious'    => sprintf("%s (%s)", $Mojolicious::VERSION, $Mojolicious::CODENAME));
    $s->("ext", "str", 'Moniker'        => $self->app->moniker);
    $s->("ext", "str", 'Name'           => $0);
    $s->("ext", "str", 'Executable'     => $^X);
    $s->("ext", "str", 'PID'            => $$);
    $s->("ext", "str", 'Time'           => scalar localtime(time));
    $s->("ext", "str", 'Home'           => $self->app->home->to_string);
    $s->("ext", "str", 'Document root'  => $self->app->documentroot) if $self->app->can('documentroot');
    $s->("ext", "str", 'Data dir'       => $self->app->datadir) if $self->app->can('datadir');
    $s->("ext", "dmp", 'Template paths' => $self->app->renderer->paths);
    $s->("ext", "dmp", 'Template classes'=>$self->app->renderer->classes);
    $s->("ext", "dmp", 'Static paths'   => $self->app->static->paths);
    $s->("ext", "dmp", 'Namespaces'     => $self->app->routes->namespaces);
    $s->("ext", "dmp", 'Include'        => \@INC);
    $s->("ext", "dmp", 'Config'         => $self->app->config) if $self->app->{'__suffit_serverinfo_debug'};

    { # Environment variables
        my @obj;
        foreach my $k (sort keys %ENV) {
            push @obj, [$k, $ENV{$k} // ''];
        }
        $s->("gen", "obj", 'Environment variables', [@obj]);
    }

    { # %INC
        my @obj;
        foreach my $k (sort keys %INC) {
            my $module = $k;
            if ($k =~ /.pm$/) {
                $module =~ s{\/}{::}gsmx;
                $module =~ s/.pm$//g;
            } else {
                $module = path($k)->basename;
            }
            push @obj, [$module, $INC{$k} // ''];
        }
        $s->("gen", "obj", 'Loaded modules', [@obj]);
    }

    # Data
    my $raw_data = $self->req->body // '';
    if (length($raw_data)) {
        push @o, "-"x80 . " dat " . "---";
        $s->("ext", "txt", 'Request data' => $raw_data);
    }

    # Text output
    my @text = ();
    foreach my $r (@o) {
        unless (ref($r) eq 'HASH') {
            push @text, $r, "\n";
            next;
        }
        my $typ = $r->{typ}; # typ   - str, txt, obj
        my $key = $r->{key}; # key   - Key
        my $val = $r->{val}; # val   - Value
        if ($typ eq 'str') {
            push @text, sprintf("%-*s: %s\n", 24, $key, $val);
        } elsif ($typ eq 'txt') {
            push @text, sprintf("%s:\n%s", $key, $val);
        } elsif ($typ eq 'dmp') {
            push @text, sprintf("%s: %s", $key, $self->dumper($val));
        } elsif ($typ eq 'obj' and ref($val) eq 'ARRAY') {
            push @text, sprintf("%s:\n", $key);
            foreach my $p (@$val) {
                push @text, sprintf("  %-*s: %s\n", 22, @$p);
            }
        }
    }

    # Json
    my %json = ();
    foreach my $r (@o) {
        next unless ref($r) eq 'HASH';
        my $key = $r->{key}; # key   - Key
        my $val = $r->{val}; # val   - Value
        $json{$key} = $val;
    }

    # HTML
    my (@html, @headers, @parameters, @environments, @modules) = ();
    foreach my $r (@o) {
        next unless ref($r) eq 'HASH';
        if ($r->{typ} eq 'obj') {
            if ($r->{key} eq 'Request headers') {
                @headers = @{$r->{val}};
            } elsif ($r->{key} eq 'Request parameters') {
                @parameters = @{$r->{val}};
            } elsif ($r->{key} eq 'Environment variables') {
                @environments = @{$r->{val}};
            } elsif ($r->{key} eq 'Loaded modules') {
                @modules = @{$r->{val}};
            }
        } else {
            next if $r->{key} eq 'Include';
            push @html, $r;
        }
    }

    # Render
    return $self->respond_to(
        json    => {
            json    => \%json,
        },
        text    => {
            text    => join("", @text),
        },
        html    => {
            template        => $self->app->{'__suffit_serverinfo_template'},
            general         => \@html,
            headers         => \@headers,
            parameters      => \@parameters,
            environments    => \@environments,
            atinc           => \@INC,
            modules         => \@modules,
        },
        any     => {
            text    => join("", @text),
        },
    );
    #return $self->render(template => $self->app->{'__suffit_serverinfo_template'});
}

1;

__DATA__