File Coverage

blib/lib/HTML/Perlinfo/General.pm
Criterion Covered Total %
statement 24 114 21.0
branch 0 50 0.0
condition 0 56 0.0
subroutine 8 15 53.3
pod 0 7 0.0
total 32 242 13.2


line stmt bran cond sub pod time code
1             package HTML::Perlinfo::General;
2            
3 1     1   8 use base qw(Exporter);
  1         2  
  1         127  
4             our @EXPORT = qw(print_httpd print_thesemodules print_config print_variables print_general);
5 1     1   490 use POSIX qw(uname);
  1         6111  
  1         5  
6 1     1   1977 use CGI::Deurl as => 'myparams';
  1         1491  
  1         5  
7 1     1   175 use Config qw(%Config config_sh);
  1         2  
  1         40  
8 1     1   533 use Net::Domain qw(hostname);
  1         8397  
  1         82  
9 1     1   9 use File::Spec;
  1         2  
  1         23  
10 1     1   5 use HTML::Perlinfo::Common;
  1         2  
  1         119  
11 1     1   7 use HTML::Perlinfo::Apache;
  1         2  
  1         1822  
12            
13             # Should search for Get, Post, Cookies, Session, and Environment.
14             sub perl_print_gpcse_array {
15 0     0 0   my $html;
16 0           my($name) = @_;
17 0           my ($gpcse_name, $gpcse_value);
18             #POST names should be param() and get in url_param()
19 0 0 0       if (defined($ENV{'QUERY_STRING'}) && length($ENV{'QUERY_STRING'}) >= 1) {
20 0           foreach(keys %myparams) { $html .= print_table_row(2, "GET[\"$_\"]", $myparams{$_}); }
  0            
21             }
22 0 0         if (defined($ENV{'CONTENT_LENGTH'})) {
23 0           foreach(keys %myparams) { $html .= print_table_row(2, "POST[\"$_\"]", $myparams{$_}); }
  0            
24             }
25 0 0         if (defined($ENV{'HTTP_COOKIE'})) {
26 0           $cookies = $ENV{'HTTP_COOKIE'};
27 0           @cookies = split(';',$cookies);
28 0           foreach (@cookies) {
29 0           ($k,$v) = split('=',$_);
30 0           $html .= print_table_row(2, "COOKIE[\"$k\"]", "$v");
31             }
32             }
33 0           foreach my $key (sort(keys %ENV))
34             {
35 0           $gpcse_name = "$name" . '["' . "$key" . '"]';
36 0 0         if ($ENV{$key}) {
37 0           $gpcse_value = "$ENV{$key}";
38             } else {
39 0           $gpcse_value = "no value";
40             }
41            
42            
43 0           $html .= print_table_row(2, "$gpcse_name", "$gpcse_value");
44             }
45 0           return $html;
46             }
47            
48             sub print_variables {
49            
50             return join '', print_section("Environment"),
51             print_table_start(),
52             print_table_header(2, "Variable", "Value"),
53 0 0   0 0   ((defined($ENV{'SERVER_SOFTWARE'})) ? perl_print_gpcse_array("SERVER") : perl_print_gpcse_array("ENV",)),
54             print_table_end();
55             }
56            
57             sub print_config {
58            
59 0     0 0   return join '', print_section("Perl Core"),
60             print_table_start(),
61             print_table_header(2, "Variable", "Value"),
62             print_config_sh($_[0]),
63             print_table_end();
64             }
65            
66             sub print_config_sh {
67            
68 0     0 0   my @configs = qw/api_versionstring cc ccflags cf_by cf_email cf_time extensions installarchlib installbin installhtmldir installhtmlhelpdir installprefix installprefixexp installprivlib installscript installsitearch installsitebin known_extensions libc libperl libpth libs myarchname optimize osname osvers package perllibs perlpath pm_apiversion prefix prefixexp privlib privlibexp startperl version version_patchlevel_string xs_apiversion/;
69            
70             return ($_[0] eq 'info_all') ?
71 0           join '', map { print_table_row(2, add_link('config',$_), $Config{$_})} @configs
72 0 0         : join '', map { print_table_row(2, map{
73 0 0         if ($_ !~ /^'/) {
  0            
74 0           add_link('config', $_);
75             }
76             else {
77 0 0 0       if ($_ eq "\'\'" || $_ eq "\' \'" ) {
78 0           my $value = "no value";
79 0           $value;
80             }
81             else {
82 0           $_;
83             }
84             }
85             }split/=/,$_ )
86             } split /\n/, config_sh();
87             }
88            
89             sub print_httpd {
90            
91 0 0 0 0 0   return unless (defined $ENV{'SERVER_SOFTWARE'} && $ENV{'SERVER_SOFTWARE'} =~ /apache/i);
92 0           my $a = HTML::Perlinfo::Apache->new();
93            
94 0           my $html .= print_section("Apache");
95 0           $html .= print_table_start();
96 0 0         $html .= $a->print_apache() if $a->has(qw(env));
97 0           $html .= print_table_end();
98            
99 0 0         $html .= $a->print_modperl() if $a->has(qw(mp));
100            
101 0           $html .= print_section("Apache Environment"),
102             $html .= print_table_start();
103 0 0         $html .= print_table_header(2, "Variable", "Value"),
104             $html .= $a->print_apache_environment() if $a->has(qw(env));
105 0           $html .= print_table_end();
106            
107 0           return $html;
108             }
109            
110             sub print_thesemodules {
111 0     0 0   my $opt = shift;
112 0           $m = HTML::Perlinfo::Modules->new();
113 0 0 0       if ($opt eq 'core') {
    0          
    0          
114 0           return $m->print_modules(show_only=>$opt, full_page=>0);
115             }
116             elsif ($opt eq 'all') {
117 0           return $m->print_modules(section=>'All Perl modules', full_page=>0);
118             }
119             elsif ($opt eq 'loaded' && ref $_[0] eq 'ARRAY') {
120 0           return $m->print_modules(section=>'Loaded Modules', files_in=>shift, full_page=>0);
121             }
122             else {
123 0           die "internal function print_thesemodules has invalid arguments: @_";
124             }
125             }
126            
127             sub print_general {
128            
129 0   0 0 0   my $opt = shift || 'full';
130            
131 0           my $html = print_box_start(1);
132 0           $html .= sprintf("

Perl Version %s


Release date: %s", perl_version(), release_date());
133            
134 0           $html .= print_box_end();
135            
136 0           $html .= print_table_start();
137 0           $html .= print_table_row(2, "Currently running on", "@{[ (uname)[0..4] ]}");
  0            
138 0           $html .= print_table_row(2, "Built for", "$Config{archname}");
139 0           $html .= print_table_row(2, "Build date", "$Config{cf_time}");
140 0           $html .= print_table_row(2, "Perl path", "$^X");
141            
142 0           $html .= print_table_row(2, "Additional C Compiler Flags", "$Config{ccflags}");
143 0           $html .= print_table_row(2, "Optimizer/Debugger Flags", "$Config{optimize}");
144            
145 0 0         if (defined($ENV{'SERVER_SOFTWARE'})) {
146 0           $html .= print_table_row(2, "Server API", "$ENV{'SERVER_SOFTWARE'}");
147             }
148 0 0 0       if ($Config{usethreads} && !$Config{useithreads} && !$Config{use5005threads}) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
149 0           $html .= print_table_row(2, "Thread Support", "enabled (threads)");
150             }
151             elsif ($Config{useithreads} && !$Config{usethreads} && !$Config{use5005threads}) {
152 0           $html .= print_table_row(2, "Thread Support", "enabled (ithreads)");
153             }
154             elsif ($Config{use5005threads} && !$Config{usethreads} && !$Config{useithreads}) {
155 0           $html .= print_table_row(2, "Thread Support", "enabled (5005threads)");
156             }
157             elsif ($Config{usethreads} && $Config{useithreads} && !$Config{use5005threads}) {
158 0           $html .= print_table_row(2, "Thread Support", "enabled (threads, ithreads)");
159             }
160             elsif ($Config{usethreads} && $Config{use5005threads} && !$Config{useithreads}) {
161 0           $html .= print_table_row(2, "Thread Support", "enabled (threads, 5005threads)");
162             }
163             elsif ($Config{useithreads} && $Config{use5005threads} && !$Config{usethreads}) {
164 0           $html .= print_table_row(2, "Thread Support", "enabled (ithreads, 5005threads)");
165             }
166             elsif ($Config{usethreads} && $Config{useithreads} && $Config{use5005threads}) {
167 0           $html .= print_table_row(2, "Thread Support", "enabled (threads, ithreads, 5005threads)");
168             }
169             else {
170 0           $html .= print_table_row(2, "Thread Support", "disabled (threads, ithreads, 5005threads)");
171             }
172 0           $html .= print_table_end();
173            
174 0           $html .= print_box_start(0);
175            
176            
177 0           $html .= "This is perl, v$Config{version} built for $Config{archname}
Copyright (c) 1987-@{[ sprintf '%d', (localtime)[5]+1900]}, Larry Wall";
  0            
178 0           $html .= print_box_end();
179            
180 0 0         return $html if $opt eq 'top';
181            
182 0           $html .= print_hr();
183 0           $html .= "

Configuration

\n";
184 0           $html .= print_config('info_all');
185            
186 0           $html .= join '', print_section("Perl utilities"),
187             print_table_start(),
188             print_table_header(2, "Name", "Location"),
189             print_table_row(2, add_link('cpan', 'h2ph'), check_path("h2ph")),
190             print_table_row(2, add_link('cpan', 'h2xs'), check_path("h2xs")),
191             print_table_row(2, add_link('cpan', 'perldoc'), check_path("perldoc")),
192             print_table_row(2, add_link('cpan', 'pod2html'), check_path("pod2html")),
193             print_table_row(2, add_link('cpan', 'pod2latex'), check_path("pod2latex")),
194             print_table_row(2, add_link('cpan', 'pod2man'), check_path("pod2man")),
195             print_table_row(2, add_link('cpan', 'pod2text'), check_path("pod2text")),
196             print_table_row(2, add_link('cpan', 'pod2usage'), check_path("pod2usage")),
197             print_table_row(2, add_link('cpan', 'podchecker'), check_path("podchecker")),
198             print_table_row(2, add_link('cpan', 'podselect'), check_path("podselect")),
199             print_table_end(),
200            
201             print_section("Mail"),
202             print_table_start(),
203             print_table_row(2, 'SMTP', hostname()),
204             print_table_row(2, 'sendmail_path', check_path("sendmail")),
205             print_table_end(),
206            
207             print_httpd(),
208            
209             print_section("HTTP Headers Information"),
210             print_table_start(),
211             print_table_colspan_header(2, "HTTP Request Headers");
212 0 0         if (defined($ENV{'SERVER_SOFTWARE'})) {
213             $html .= join '',
214 0           print_table_row(2, 'HTTP Request', "$ENV{'REQUEST_METHOD'} @{[File::Spec->abs2rel($0)]} $ENV{'SERVER_PROTOCOL'}"),
215             print_table_row(2, 'Host', $ENV{'HTTP_HOST'}),
216             print_table_row(2, 'User-Agent', $ENV{'HTTP_USER_AGENT'}),
217             print_table_row(2, 'Accept', $ENV{'HTTP_ACCEPT_ENCODING'}),
218             print_table_row(2, 'Accept-Language', $ENV{'HTTP_ACCEPT_LANGUAGE'}),
219             print_table_row(2, 'Accept-Charset', $ENV{'HTTP_ACCEPT_CHARSET'}),
220             print_table_row(2, 'Keep-Alive', $ENV{'HTTP_KEEP_ALIVE'}),
221 0           print_table_row(2, 'Connection', $ENV{'HTTP_CONNECTION'});
222             }
223 0           $html .= print_table_end();
224 0           return $html;
225             }
226             1;
227