view release on metacpan or  search on metacpan

lib/DBI/Gofer/Transport/mod_perl.pm  view on Meta::CPAN

                my $is_dupreq = $dup_reqs{ $rr->{request} }++;

                my $request_html = eval {
                    my $request  = $rr->{request_object}
                        || $transport->thaw_request($rr->{request});
                    escape_html( $request->summary_as_text({
                        at => $rr->{_time_received},
                        age => int($time_now-$time_received),
                        idle => $idle,
                        size => length($rr->{request}),
                        ($from) ? (from => $from) : (),
                        ($is_dupreq) ? (is_dup => $is_dupreq) : (),
                    }) );
                } || escape_html("ERROR THAWING REQUEST: $@");

                # bold the word _dup if it's a dup
                $request_html =~ s{\b is_dup \b}{<b>is_dup</b>}x if $is_dupreq;
                push @s, $request_html;
            }
            else {
                push @s, "<i>(no request data)</i>\n";
            }

            my $response_html = eval {
                my $response = $rr->{response_object}
                    || $transport->thaw_response($rr->{response});
                $from{ $from }{errors}++ if $from && $response->err;
                escape_html( $response->summary_as_text({
                    duration => $duration,
                    ($rr->{response}) ? (size => length $rr->{response}) : (),
                }) );
            } || escape_html("ERROR THAWING RESPONSE: $@");
            push @s, $response_html;

            push @s, "\n";

            $idle_total += $idle;
            $dur_total  += $duration;
            ($time_received_prev, $duration_prev) = ($time_received, $duration);
        }
        push @s, "<hr>\n";
        if (@$queue) {
            my $time_span = $dur_total+$idle_total;
            push @s, sprintf "Summary for the %d requests shown above (covering %d seconds for pid $$)...\n",
                scalar @$queue, $time_span;

            my @rr_requ_size = map { length($_->{request}||'') }  @$queue;
            push @s, sprintf "Request  size: min %4d, avg %4d, max %4d (sum %d \@ %dB/sec)\n",
                min(@rr_requ_size), sum(@rr_requ_size)/@rr_requ_size, max(@rr_requ_size),
                sum(@rr_requ_size), sum(@rr_requ_size)/$time_span;

            my @rr_resp_size = map { length($_->{response}||'') } @$queue;
            push @s, sprintf "Response size: min %4d, avg %4d, max %4d (sum %d \@ %dB/sec)\n",
                min(@rr_resp_size), sum(@rr_resp_size)/@rr_resp_size, max(@rr_resp_size),
                sum(@rr_resp_size), sum(@rr_resp_size)/$time_span;

            my @rr_resp_dur = map { $_->{duration} } @$queue;
            push @s, sprintf "Response time: min %.3fs, avg %.3fs, max %.3fs\n",
                min(@rr_resp_dur), sum(@rr_resp_dur)/@rr_resp_dur, max(@rr_resp_dur), sum(@rr_resp_dur);

            push @s, sprintf "Request rate: %.1f/min (occupancy: %.1f%% with %.3fs busy and %.3fs idle)\n",
                    @$queue/($time_span/60),
                    $dur_total/($dur_total+$idle_total)*100, $dur_total, $idle_total
                if $queue_name eq 'recent_requests';

            if ( my @dups = grep { $_ > 1 } values %dup_reqs ) {
                push @s, sprintf "Duplicate requests: %d distinct duplicates, total %d duplicates\n",
                    scalar @dups, sum(@dups);
            }

            if ($show_client_hostname_in_status) { # use DNS lookup
                eval {
                    local $SIG{ALRM} = "TIMEOUT DNS ".__PACKAGE__;
                    alarm(5);
                    for my $from (keys %from) {
                        next unless $from =~ /^\d+\./;
                        my $new = sprintf "%s %s",
                            gethostbyaddr(inet_aton($from),AF_INET) || "?",
                            $from;
                        $from{ $new } = delete $from{ $from };
                    }
                    alarm(0);
                };
                alarm(0);
                warn $@ if $@;
            }
            push @s, sprintf "Recent request distribution from %d sources:\n", scalar keys(%from)
                if keys(%from);
            push @s, sprintf "%-20s: %3d, errors %d\n",
                    $_, $from{$_}{requests}, $from{$_}{errors}||0
                for sort keys %from;
        }
        return \@s;
    }

    push @s, "No Gofer executors cached" unless %executor_cache;
    for my $path (sort keys %executor_cache) {
        my $executor = $executor_cache{$path};
        (my $tag = $path) =~ s/\W/_/g;
        push @s, sprintf qq{<a href="#%s"><b>%s</b></a>\n}, $tag, $path;
    }
    push @s, "<hr>\n";
    $url =~ s/\Q$path_info$//; # remove path_info from $url
    for my $path (sort keys %executor_cache) {
        my $executor = $executor_cache{$path};
        (my $tag = $path) =~ s/\W/_/g;
        my $stats = $executor->{stats};
        local $stats->{recent_requests} = @{$stats->{recent_requests}||[]};
        push @s, sprintf qq{<a name="%s" href="%s"><b>%s</b></a> = }, $tag, "$url$path?$args", $path;
        push @s, escape_html( Data::Dumper::Dumper($executor) );
    }
    return \@s;
}

1;

__END__

=head1 NAME
    
DBI::Gofer::Transport::mod_perl - http mod_perl server-side transport for DBD::Gofer