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