1package HTML::Perlinfo::General;
2
3use base qw(Exporter);
4our @EXPORT = qw(print_httpd print_thesemodules print_config print_variables print_general);
5use CGI qw(url_param param);
6use POSIX qw(uname);
7use Config qw(%Config config_sh);
8use Net::Domain qw(hostname);
9use File::Spec;
10use HTML::Perlinfo::Common;
11use HTML::Perlinfo::Apache;
12
13# Should search for Get, Post, Cookies, Session, and Environment.
14sub perl_print_gpcse_array  {
15	  my $html;
16	  my($name) = @_;
17	  my ($gpcse_name, $gpcse_value);
18	  #POST names should be param() and get in url_param()
19	  if (defined($ENV{'QUERY_STRING'}) && length($ENV{'QUERY_STRING'}) >= 1) {
20            foreach(url_param()) { $html .= print_table_row(2, "GET[\"$_\"]", url_param($_)); }
21	  }
22	  if (defined($ENV{'CONTENT_LENGTH'})) {
23             foreach(param()) { $html .= print_table_row(2, "POST[\"$_\"]", param($_)); }
24	  }
25          if (defined($ENV{'HTTP_COOKIE'})) {
26             $cookies = $ENV{'HTTP_COOKIE'};
27             @cookies = split(';',$cookies);
28             foreach (@cookies) {
29	       ($k,$v) = split('=',$_);
30	       $html .= print_table_row(2, "COOKIE[\"$k\"]", "$v");
31	     }
32          }
33	  foreach my $key (sort(keys %ENV))
34	  {
35		  $gpcse_name = "$name" . '["' . "$key" . '"]';
36		  if ($ENV{$key}) {
37			  $gpcse_value = "$ENV{$key}";
38		  } else {
39			  $gpcse_value = "<i>no value</i>";
40		  }
41
42
43		  $html .= print_table_row(2, "$gpcse_name", "$gpcse_value");
44	  }
45	return $html;
46}
47
48sub print_variables {
49
50	return join '', print_section("Environment"),
51		  	print_table_start(),
52		  	print_table_header(2, "Variable", "Value"),
53		  	((defined($ENV{'SERVER_SOFTWARE'})) ?  perl_print_gpcse_array("SERVER") : perl_print_gpcse_array("ENV",)),
54		  	print_table_end();
55}
56
57sub print_config {
58
59	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
66sub print_config_sh {
67
68	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			join '', map { print_table_row(2, add_link('config',$_), $Config{$_})} @configs
72				: join '', map { print_table_row(2, map{
73						if ($_ !~ /^'/) {
74							add_link('config', $_);
75						}
76						else {
77							if ($_ eq "\'\'" || $_ eq "\' \'" ) {
78								my $value = "<i>no value</i>";
79								$value;
80							}
81							else {
82								$_;
83							}
84						}
85								    }split/=/,$_ )
86					    } split /\n/, config_sh();
87}
88
89sub print_httpd {
90
91  return unless (defined $ENV{'SERVER_SOFTWARE'} && $ENV{'SERVER_SOFTWARE'} =~ /apache/i);
92  my $a = HTML::Perlinfo::Apache->new();
93
94  my $html .= print_section("Apache");
95  $html .= print_table_start();
96  $html .= $a->print_apache() if $a->has(qw(env));
97  $html .= print_table_end();
98
99  $html .= $a->print_modperl() if $a->has(qw(mp));
100
101  $html .= print_section("Apache Environment"),
102  $html	.= print_table_start();
103  $html .= print_table_header(2, "Variable", "Value"),
104  $html .= $a->print_apache_environment() if $a->has(qw(env));
105  $html .= print_table_end();
106
107  return $html;
108}
109
110 sub print_thesemodules {
111    my $opt = shift;
112    $m = HTML::Perlinfo::Modules->new();
113    if ($opt eq 'core') {
114    	return $m->print_modules(show_only=>$opt, full_page=>0);
115    }
116    elsif ($opt eq 'all') {
117    	return $m->print_modules(section=>'All Perl modules', full_page=>0);
118    }
119    elsif ($opt eq 'loaded' && ref $_[0] eq 'ARRAY') {
120    	return $m->print_modules(section=>'Loaded Modules', files_in=>shift, full_page=>0);
121    }
122    else {
123	die "internal function print_thesemodules has invalid arguments: @_";
124    }
125 }
126
127sub print_general {
128
129  my $opt = shift || 'full';
130
131  my $html = print_box_start(1);
132  $html .= sprintf("<h1 class=\"p\">Perl Version %s</h1><br style=\"clear:both\" />Release date: %s", perl_version(), release_date());
133
134  $html .= print_box_end();
135
136  $html .= print_table_start();
137  $html .= print_table_row(2, "Currently running on", "@{[ (uname)[0..4] ]}");
138  $html .= print_table_row(2, "Built for",  "$Config{archname}");
139  $html .= print_table_row(2, "Build date",  "$Config{cf_time}");
140  $html .= print_table_row(2, "Perl path", "$^X");
141
142  $html .= print_table_row(2, "Additional C Compiler Flags",  "$Config{ccflags}");
143  $html .= print_table_row(2, "Optimizer/Debugger Flags",  "$Config{optimize}");
144
145  if (defined($ENV{'SERVER_SOFTWARE'})) {
146    $html .= print_table_row(2, "Server API", "$ENV{'SERVER_SOFTWARE'}");
147  }
148 if ($Config{usethreads} && !$Config{useithreads} && !$Config{use5005threads}) {
149    $html .= print_table_row(2, "Thread Support",  "enabled (threads)");
150  }
151  elsif ($Config{useithreads} && !$Config{usethreads} && !$Config{use5005threads}) {
152    $html .= print_table_row(2, "Thread Support",  "enabled (ithreads)");
153  }
154  elsif ($Config{use5005threads} && !$Config{usethreads} && !$Config{useithreads}) {
155    $html .= print_table_row(2, "Thread Support",  "enabled (5005threads)");
156  }
157  elsif ($Config{usethreads} && $Config{useithreads} && !$Config{use5005threads}) {
158    $html .= print_table_row(2, "Thread Support",  "enabled (threads, ithreads)");
159  }
160  elsif ($Config{usethreads} && $Config{use5005threads} && !$Config{useithreads}) {
161    $html .= print_table_row(2, "Thread Support",  "enabled (threads, 5005threads)");
162  }
163  elsif ($Config{useithreads} && $Config{use5005threads} && !$Config{usethreads}) {
164    $html .= print_table_row(2, "Thread Support",  "enabled (ithreads, 5005threads)");
165  }
166  elsif ($Config{usethreads} && $Config{useithreads} &&  $Config{use5005threads}) {
167    $html .= print_table_row(2, "Thread Support",  "enabled (threads, ithreads, 5005threads)");
168  }
169  else {
170    $html .= print_table_row(2, "Thread Support",  "disabled (threads, ithreads, 5005threads)");
171  }
172$html .= print_table_end();
173
174  $html .= print_box_start(0);
175
176
177    $html .= "This is perl, v$Config{version} built for $Config{archname}<br />Copyright (c) 1987-@{[ sprintf '%d', (localtime)[5]+1900]}, Larry Wall";
178    $html .= print_box_end();
179
180    return $html if $opt eq 'top';
181
182  $html .= print_hr();
183  $html .= "<h1>Configuration</h1>\n";
184  $html .= print_config('info_all');
185
186  $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  if (defined($ENV{'SERVER_SOFTWARE'})) {
213    $html .= join '',
214             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	     print_table_row(2, 'Connection', $ENV{'HTTP_CONNECTION'});
222   }
223   $html .= print_table_end();
224   return $html;
225}
2261;
227
228