#!/usr/bin/perl
#----------------------------------------------------------------------------#
# TellMe Version 1.1              (C) Copyright 2001 HeXaChLoR / perlhelp.de #
# Created: 01/25/01                                  Last Modified: 01/08/05 #
# Contacting the Author:                               hexachlor@perlhelp.de #
# Latest Version at:                     http://www.perlhelp.de/dl/tellme.pl #
#----------------------------------------------------------------------------#
# Upload to your server in ASCII mode and chmod to 755 (-rwxr-xr-x)          #
#----------------------------------------------------------------------------#
# COPYRIGHT NOTICE                                                           #
# Copyright © 2001 HeXaChLoR / perlhelp.de - All Rights Reserved.            #
#                                                                            #
# TellMe may be used and modified free of charge by anyone so long as this   #
# copyright notice and these comments remain intact.                         #
#                                                                            #
# By downloading, installing and using this code you agree to indemnify,     #
# defend, and hold harmless HeXaChLoR and all people who are asociated to    #
# perlhelp.de from any and all liability, penalties, losses, damages, costs, #
# expenses, attorneys' fees, causes of action or claims that caused by or    #
# resulting indirectly from your use of this script which damages either you #
# or any other party or parties without limitation or exception.             #
#                                                                            #
# This indemnification and hold harmless agreement extends to all issues     #
# associated with this script.                                               #
#                                                                            #
# Selling the code for this program without prior written consent is         #
# expressly forbidden. In other words, please ask first before you try and   #
# make money off of our program.                                             #
#                                                                            #
# Even though this code is freeware please obtain permission before re-      #
# distributing this software over the Internet or in any other medium.       #
# In all cases copyright and header must remain intact.                      #
#----------------------------------------------------------------------------#
# CHANGES                                                                    #
# 1.0  ~ Initial Release                                                     #
# 1.01 ~ Beautified output via CSS                                           #
#        Major code cleanup (all sub)                                        #
#        Modified search for sendmail | Thanx to Stefanos stefanos@kknd.de   #
#        Added MIME-type information  | (Stefan Gipper) / http://www.kknd.de #
# 1.1  ~ Fix: Comment lines in MIME info are now removed before output       #
#        Fix: Non fatal require() and import() in BEGIN block instead of     #
#             use() in eval() block to fetch compile time errors             #
#             Doh... What was I thinkin' ???                                 #
#        Add: Script debugging support | Thanx again go to Stefan Gipper for #
#                                      | the inspiration to this add-on      #
#                                      | stefanos@kknd.de/http://www.kknd.de #
#        Code cleanup and extra HTML routines                                #
#----------------------------------------------------------------------------#

# Optical Improvement
# Fonts
$fnt = 'Arial,Helvetica';
# Font color for table headers
$ht_col = 'f0f0f9';
# Background color for table headers
$hb_col = '000060';
# Background color for lighter table cells
$rl_col = 'f0f0f9';
# Background color for darker table cells
$rd_col = 'e0e0ec';
# Font color for normal text
$t_col = '000000';

#####
# S T A R T   M A I N   R O U T I N E
#####

# Get Current Date
@timestamp = localtime(time);
$timestamp[5] += 1900;
$timestamp[4]++;
$date = "$timestamp[3]. $timestamp[4]. $timestamp[5] - $timestamp[2]:$timestamp[1]";

if ($ENV{'QUERY_STRING'} eq 'diag') {
	&get_modules();
	&get_vars();
	&get_databases();
	&get_mimes();
	&show_results();
	exit 0;
}
elsif ($ENV{'QUERY_STRING'} eq 'debform') {
	&show_debform();
}
elsif ($ENV{'QUERY_STRING'} eq 'debug') {
	&get_debug();
	&show_debresult();
}
else {
	&show_choices();
}

#####
# E N D   M A I N   R O U T I N E
#####

#####
# Read misc info
#####
sub get_vars {
	# Datum
	$ltime = localtime;
	$gtime = gmtime;
	# Wenn Unix
	if ($^O !~ /win/i) {
		# sendmail 'erraten'
		@mailtest = ('/bin/sendmail', '/sbin/sendmail',
		'/usr/lib/sendmail', '/usr/bin/sendmail',
		'/usr/share/sendmail', '/usr/sbin/sendmail');
		foreach (@mailtest) {
			push(@mailloc, $_) if (-e $_ && -X _);
		}
		# Pfad zu perl
		$perlloc = `which perl`;
		# Pfad zu grep
		$greploc = `which grep`;
		# Pfad zu date
		$dateloc =`which date`;
		# ID unter der das Skript laeuft
		$userid = `id`;
		$userid =~ s/ /<br>/g;
		$load = `uptime`;
		# Eingeloggte User
		if ($load =~ /^.*?(\d+?) users?.*?$/) {
  			$useron = $1;
		}
		else {
			$useron = "Nicht verf\&uuml;gbar.";
		}
		# Serverlaufzeit
		if ($load =~ m/^.*?up +(\d+?) days?, +(\d+:\d+).+?/) {
  			$updays = $1;
  			$uptime = $2;
			($upstd, $upmin) = split(':', $uptime);
		}
		elsif ($load =~ m/^.*?up +(\d+:\d+).+?/) {
  			$updays = '0';
  			$uptime = $1;
			($upstd, $upmin) = split(':', $uptime);
		}
		else {
  			$updays = '?';
			$upstd = '?';
			$upmin = '?';
		}
		# Last
		if ($load =~ s/^.+?average: +?(\S*? \S*? \S*?)$/$1$2,$3/) {
  			($load1, $load5, $load15) = split(',', $load);
		}
		else {
			$load1 =$load5 = $load15 = 'Nicht verf&uuml;gbar';
		}
	}
	else {
		$mailloc = "Unter Windows nicht verf\&uuml;gbar.";
		$dateloc = "Unter Windows nicht verf\&uuml;gbar.";
		$greploc = "Unter Windows nicht verf\&uuml;gbar.";
		$userid  = "Unter Windows nicht verf\&uuml;gbar.";
		$updays  = '?';
		$upstd   = '?';
		$upmin   = '?';
		$useron  = "Unter Windows nicht verf\&uuml;gbar.";
		$load1   = "Unter Windows nicht verf\&uuml;gbar.";
		$load5   = "Unter Windows nicht verf\&uuml;gbar.";
		$load15  = "Unter Windows nicht verf\&uuml;gbar.";
	}
	# Network Infos
	$netdone = 0;
	if ($mod_sock) {
		if (defined $ENV{'HTTP_HOST'}) {
			($hname, $halias, $haddrtyp, $len, @haddrs) = gethostbyname($ENV{'HTTP_HOST'});
			for ($i = 0; $i < scalar @haddrs; $i++) {
				$hip .= join(".", unpack('C4', $haddrs[$i]));
				$hip .= "\n";
			}
			$netdone = 1;
		}
		elsif ( (defined $ENV{'SERVER_ADDR'}) and ($netdone == 0) ) {
			$lochost = inet_aton("$ENV{'SERVER_ADDR'}"); 
			($hname, $halias, $haddrtyp, $len, @haddrs) = gethostbyaddr($lochost, AF_INET);
			for ($i = 0; $i < scalar @haddrs; $i++) {
				$hip .= join(".", unpack('C4', $haddrs[$i]));
				$hip .= "\n";
			}
		}
		else {
			$hname = $hip = 'HTTP_HOST und SERVER_ADDR nicht gesetzt.';
			$halias = '';
		}
	}
	else {
		$hname = 'Kein Socket Modul vorhanden.';
		$hip = $halias = '';
	}
}

#####
# Search installed modules
#####
sub get_modules {
	my %found;
	if ($mod_file) {
		find(\&_is_module, @INC);
		chomp(@foundmods);
		# Doppelte entfernen
		foreach (@foundmods) {
			if (defined $found{$_}) { $found{$_}++; next;}
			$found{$_} = 1;
		}
		# Case Insensitive Sort
		@foundmods = (sort { lc($a) cmp lc($b)} keys(%found));
		# Wert fuer dreispaltige Formatierung
		$third = scalar @foundmods / 3;
	}
}

#####
# Internal for module search
#####
sub _is_module {
	if ($File::Find::name =~ /\.pm$/){
		open(MODULE,$File::Find::name) || return;
		$pckg = 0;
		while(<MODULE>) {
			if (/^ *package +(\S+);/) {
				push (@foundmods, $1);
				$pckg = 1;
			}
			if (/^.*?VERSION *= *('|")?([\d.]+)('|")? *;/i and $pckg) {
				$modvers{$foundmods[$#foundmods]} = $2;
				last;
			}
		}
		close(MODULE);
	}
}

#####
# Read database infos
#####
sub get_databases {
	
	# Wenn kein DBI Modul
	if ($mod_dbi == 0) {
		$dbi_drivers[0] = 'DBI Modul nicht instaliert';
		$dsn_names{$dbi_drivers[0]}->[0] = 'Keine';
	}
	else {
		# Verfuegbare Treiber auslesen (Case Insensitive Sort)
		@dbi_drivers = sort { lc($a) cmp lc($b)} DBI->available_drivers;
		# Zugehoerige DBs auslesen
		for ($i = 0; $i < scalar @dbi_drivers; $i++) {
			@dsns = ();
			# Datenbanknamen zum Treiber auslesen
			$died_in_eval = 1;
			eval { @dsns = DBI->data_sources($dbi_drivers[$i]); };
			$died_in_eval = 0;
			if ($@) {
				$dsn_names{$dbi_drivers[$i]}->[0] = "<b>Nicht korrekt konfiguriert:</b> $@";
			}
			else {
				if (scalar @dsns) {
					for ($x = 0; $x < scalar @dsns; $x++) {
						$dsnshort = $dsns[$x];
						$dsnshort =~ s/^dbi:[^:]+:(.*)$/$1/i;
						$dsn_names{$dbi_drivers[$i]}->[$x] = $dsnshort;
					}
				}
				else {
					$dsn_names{$dbi_drivers[$i]}->[0] = 'Keine';
				}
			}
		}
	
	}
}

#####
# Mime-Type Infos
#####
sub get_mimes {
	my @raw;
	if ( ($^O !~ /win/i) && (-e "/etc/mime.types") ) {
		open (FILE, "/etc/mime.types");
		@raw = <FILE>;
		close (FILE);
		# Kommentarzeilen loeschen
		@mimes = grep { !/^\s*?#/ } @raw;
		@mimes = sort { lc($a) cmp lc($b) } @mimes;
		$half = int(scalar @mimes / 2);
	}
}

#####
# Debug a script
#####
sub get_debug {
	
	if ($ENV{'REQUEST_METHOD'} eq "POST") {
		read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	}
	else {
		$perl_debug = 'Ungueltiger Skriptaufruf!';
		return;
	}
	@pairs = split(/&/, $buffer);
	#Daten in %INPUT Hash
	foreach (@pairs) {
		($name, $value) = split(/=/, $_);
		$value =~ tr/+/ /;
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		$name =~ tr/+/ /;
		$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		$INPUT{$name} = $value;
	}
	# untaint form data
	if ( (exists $INPUT{'path'}) && (length($INPUT{'path'}) > 0) ) {
		$INPUT{'path'} =~ s/[^-A-Za-z_0-9 \t\/\\\.:]//g;;
	}
	else {
		$perl_debug = 'Kein Pfad angegeben!';
		return;
	}
	if ( (exists $INPUT{'file'}) && (length($INPUT{'file'}) > 0) ) {
		$INPUT{'file'} =~ s/[^-A-Za-z_0-9 \t\/\\\.:]//g;;
	}
	else {
		$perl_debug = 'Kein Skript angegeben!';
		return;
	}
	$script_path = "$INPUT{'path'}/$INPUT{'file'}";
	$script_path =~ s/\\/\//g;
	$script_path =~ s/\/\//\//g;
	if (-e $script_path) {
		@shell = `perl -wc $script_path 2>&1`;
		$perl_debug = join('', @shell);
		$perl_debug = "$script_path syntax OK" if (length($perl_debug) == 0);
	}
	else {
		$perl_debug = 'Angegebenes Skript existiert nicht!';
		return;
	}
}


#####
# Output Choices
#####

sub show_choices {
	&show_head('TellMe V1.1 ~ Server Diagnose / Skript Debugging Tool');

	&_table_start('-- TellMe V1.1 - Server Diagnose / Debugging Tool --', 2);
	&_row_pair(0, "<a href=\"$ENV{SCRIPT_NAME}?diag\">Server Diagnose</a>", "<a href=\"$ENV{SCRIPT_NAME}?debform\">Skript Debugger</a>");
	print "</table></p>\n";

	&show_foot(0);
}

#####
# Output Debug Form
#####

sub show_debform {
	# Get current dir
	$script_path = $0;
	$script_path =~ s/\\/\//g;
	$script_path =~ s/\/\//\//g;
	$script_path = substr($script_path, 0, rindex($script_path, '/'));
	
	&show_head('TellMe V1.1 ~ Skript Debugging Tool');

	&_table_start('-- TellMe V1.1 - Skript Debugging Tool --', 2);
	&_row_pair(0, "<a href=\"$ENV{SCRIPT_NAME}?diag\">Server Diagnose</a>", '<b>Skript Debug</b>');
	print "</table></p>\n";

	print "<form action=\"$ENV{SCRIPT_NAME}?debug\" method=\"POST\">";
	&_table_start('Welches Skript ?', 2);
	&_row_pair(0, 'Pfad:', "<input type=\"text\" name=\"path\" value=\"$script_path\" size=\"40\">");
	&_row_pair(1, 'Skript:', "<input type=\"text\" name=\"file\" size=\"40\">");
	&_row_pair(0, '&nbsp;', "<input type=\"submit\" value=\"Debug starten\">");
	print "</table></p></form>\n";
	&show_foot(0);
}

#####
# Output Debug Result
#####

sub show_debresult {
	&show_head('TellMe V1.1 ~ Skript Debugging Tool');

	&_table_start('-- TellMe V1.1 - Skript Debugging Tool --', 2);
	&_row_pair(0, "<a href=\"$ENV{SCRIPT_NAME}?diag\">Server Diagnose</a>", '<b>Skript Debug</b>');
	print "</table></p>\n";

	print "<form action=\"$ENV{SCRIPT_NAME}?debug\" method=\"POST\">";
	&_table_start('Welches Skript ?', 2);
	&_row_pair(0, 'Pfad:', "<input type=\"text\" name=\"path\" value=\"$INPUT{'path'}\" size=\"40\">");
	&_row_pair(1, 'Skript:', "<input type=\"text\" name=\"file\" value=\"$INPUT{'file'}\" size=\"40\">");
	&_row_pair(0, '&nbsp;', "<input type=\"submit\" value=\"Debug starten\">");
	print "</table></p></form>\n";

	&_table_start('Debug Ausgabe');
	&_row_single(0, "<pre>$perl_debug</pre>");
	print "</table></p>\n";

	&show_foot(1);
}

#####
# Output Diagnostics
#####
sub show_results {
	
	&show_head('TellMe V1.1 ~ Server Diagnose Tool');

	&_table_start('-- TellMe V1.1 - Server Diagnose Tool --', 2);
	&_row_pair(0, '<b>Server Diagnose</b>', "<a href=\"$ENV{SCRIPT_NAME}?debform\">Skript Debugger</a>");
	print "</table></p>\n";

	&_table_start('Server Info', 2);
	&_row_pair(0, 'Hostname(n)', $hname, $halias);
	&_row_pair(1, 'IP Addresse(n)', $hip);
	&_row_pair(0, 'IDs', $userid);
	&_row_pair(1, 'Lokale Uhrzeit', $ltime);
	&_row_pair(0, 'GMT Uhrzeit', $gtime);
	&_row_pair(1, 'Server aktiv seit', "$updays Tage $upstd Std. $upmin Min.");
	&_row_pair(0, 'Eingeloggte User', $useron);
	&_row_single(1, 'Durchschnittl. Serverlast vor', 2);
	&_row_pair(0, '01 Min.', $load1);
	&_row_pair(1, '05 Min.', $load5);
	&_row_pair(0, '15 Min.', $load15);
	print "</table></p>\n";

	&_table_start('Perl Info', 2);
	&_row_pair(0, 'Pfad zu Perl', $perlloc);
	&_row_pair(1, 'Perl Version', $]);
	&_row_pair(0, 'Betriebssystem der Compilierung', $^O);
	&_row_pair(1, 'Modul-Verz. (@INC)', @INC);
	print "</table></p>\n";

	&_table_start('Programm Pfade', 2);
	&_row_pair(0, 'grep', $greploc);
	&_row_pair(1, 'date', $dateloc);
	&_row_pair(0, 'sendmail', @mailloc);
	print "</table></p>\n";

	&_table_start('UmgebungsVariablen (%ENV)', 2);
	my $i = 0;
	foreach (sort keys %ENV) {
		&_row_pair($i, $_, $ENV{$_});
		if ($i == 0) { $i = 1; next; };
		$i = 0 if ($i == 1);
	}
	print "</table></p>\n";

	if (scalar @foundmods > 0) {
		&_table_start('Installierte Module', 3);
		print '<tr>';
		for (0..2) {
			print "<td width=\"203\" valign=\"top\">\n";
			print "<table width=\"100%\" border=\"0\" cellpadding=\"3\">\n";
			&_row_pair(0, '<b>Modul</b>', '<b>Vers.</b>');
			for (1..$third) {
				$i = $_ % 2;
				$mod = shift @foundmods;
				$modvers{$mod} = '?' unless defined $modvers{$mod};
				&_row_pair($i, $mod, $modvers{$mod});
			}
			print "</table></td>\n";
		}
		print "<tr></table></p>\n";
	}
	else {
		&_table_start('Installierte Module');
		&_row_single(0, 'Kann Modul-Info nicht anzeigen.<br>Modul File::Find nicht installiert.');
		print "</table></p>\n";
	}
	
	if (scalar @dbi_drivers > 0) {
		&_table_start('Datenbanken', 2);
		&_row_pair(0, '<b>DB-Treiber</b>', '<b>Datenbanken</b>');
		$i = 1;
		foreach $dbdname (@dbi_drivers) {
			&_row_pair($i, $dbdname, (sort { lc($a) cmp lc($b) } @{$dsn_names{$dbdname}}));
			if ($i == 0) { $i = 1; next; };
			$i = 0 if ($i == 1);
		}
		print "</table></p>\n";
	}
	else {
		&_table_start('Datenbanken');
		&_row_single(0, 'Keine Datenbanken');
		print "</table></p>\n";
	}

	if (scalar @mimes > 0) {
		&_table_start('MIME Typen', 2);
		print '<tr>';
		for (0..1) {
			print "<td width=\"305\" valign=\"top\">\n";
			print "<table width=\"100%\" border=\"0\" cellpadding=\"3\">\n";
			&_row_pair(0, '<b>Typ</b>', '<b>Dateiendung(en)</b>');
			for (1..$half) {
				&_row_pair(($_ % 2), split(' ', shift @mimes));
			}
			print "</table></td>\n";
		}
		print "</table></p>\n";
	}
	else {
		&_table_start('MIME Typen');
		&_row_single(0, 'MIME Information nicht gefunden.');
		print "</table></p>\n";
	}

	&_table_start('Signal Handler (%SIG)', 2);
	$i = 0;
	foreach (sort keys %SIG) {
		&_row_pair($i, $_, $SIG{$_});
		if ($i == 0) { $i = 1; next; };
		$i = 0 if ($i == 1);
	}
	print "</table></p>\n";

	&show_foot(1);
}

#####
# Output HTTP Header + HTML Start
#####
sub show_head {
	my ($title) = @_;
	print<<END_HTML;
Content-type:  text/html

<html>
<head>
<title>$title ~ $hname ~ $date</title>
<style>
body {
	background-color: #fffffc;
}
td {
	font-family: $fnt;
	font-size: 13px;
	font-weight: normal;
	color: #$t_col;
}
.head {
	font-size: 16px;
	font-weight: bold;
	text-align: center;
	color: #$ht_col;
	background-color: #$hb_col; 
}
.light {
	background-color: #$rl_col;
}
.dark {
	background-color: #$rd_col;
}
a {
	font-size: 12px;
	color: #$t_col;
}
.foot {
	font-size: 12px;
	color: #$ht_col;
	background-color: #$hb_col;
}
a.foot {
	font-size: 12px;
	color: #$ht_col;
	background-color: #$hb_col;
}
</style>
</head>
<body>
<div align="center"><center>
END_HTML
}

#####
# Output HTML end
#####
sub show_foot {
	my ($show_date) = @_;
	print "<p><table width=\"610\" cellpadding=\"3\" cellspacing=\"0\" border=\"0\">\n<tr>\n";
	if ($show_date == 1) {
		print "\t<td class=\"foot\">Automatisch erstellt mit TellMe am $date </td>\n";
	}
	print<<END_HTML;
	<td class="foot" align="right">TellMe V1.1  - &copy; 2001 <a href="http://www.perlhelp.de" class="foot" target="_blank"> perlhelp.de</a></td>
</tr>
</table></p>
</center></div>
</body>
</html>
END_HTML
}

#####
# Internals for Output
#####
sub _table_start {
	my ($title, $span) = @_;
	my $plus;
	print '<p><table border="0" width="610" cellpadding="3" cellspacing="1"><tr>';
	print '<td class="head"';
	print " colspan=\"$span\"" if ($span);
	print ">- $title -</td></tr>\n";
}
sub _row_pair {
	my ($style, $title, @vals) = @_;
	print '<tr class="';
	print 'dark' if ($style == 1);
	print 'light' if ($style == 0);
	print "\"><td valign=\"top\"";
	print " rowspan=\"", (scalar @vals), "\"" if (scalar @vals > 1);
	print ">$title</td>";
	if (scalar @vals > 1) {
		$plus = 0;
		for (sort { lc($a) cmp lc($b) } @vals) {
			print '<tr class="' if $plus > 0;
			print 'dark">' if (($plus > 0) && ($style == 1));
			print 'light">' if (($plus > 0) && ($style == 0));
			print '<td>', $_, '</td></tr>';
			$plus++;
		}
	}
	else {
		print '<td valign="top">', $vals[0], '</td></tr>';
	}
	print "\n";
}
sub _row_single {
	my ($style, $title, $span) = @_;
	print '<tr class="';
	print 'dark' if ($style == 1);
	print 'light' if ($style == 0);
	print '"><td';
	print " colspan=\"$span\"" if ($span);
	print ">$title</td></tr>\n";

}


BEGIN {

#####
# Sig-Trap for die() in eval Block
# but not as greedy as CGI::Carp
#####

$SIG{__DIE__} = \&die_if_real_error;

sub die_if_real_error {
	if ($died_in_eval == 1) {
		return;
	}
	my $Error = shift;
	$Error =~ s/\n//;
    my $wm = $ENV{SERVER_ADMIN} ?
		"<a href=\"mailto:$ENV{SERVER_ADMIN}\">Webmaster</a>)" :
		"Webmaster";
	print<<END_OF_TEXT;
Content-type: text/html

<html><body>
<h1>Software Fehler:</h1>
<code>$Error</code>
<p>Bitte senden Sie eine Email an den $wm die den Zeitpunkt
und die obige Fehlermeldung enth&auml;lt.</p>
</body></html>
END_OF_TEXT
#	CORE::die($Error);
	exit();
}

#####
# Require modules without killing the script
#####
eval { $died_in_eval = 1; require File::Find; };
if ($@) {
	$mod_file = 0;
}
else {
	$mod_file = 1;
	import File::Find;
}
eval { $died_in_eval = 1; require Socket; };
if ($@) {
	$mod_sock = 0;
}
else {
	$mod_sock = 1;
	import Socket;
}
eval { $died_in_eval = 1; require DBI; };
if ($@) {
	$mod_dbi = 0;
}
else {
	$mod_dbi = 1;
	import DBI;
}


}  # End of BEGIN Block
