#!/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/ /
/g;
$load = `uptime`;
# Eingeloggte User
if ($load =~ /^.*?(\d+?) users?.*?$/) {
$useron = $1;
}
else {
$useron = "Nicht verf\ü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ügbar';
}
}
else {
$mailloc = "Unter Windows nicht verf\ügbar.";
$dateloc = "Unter Windows nicht verf\ügbar.";
$greploc = "Unter Windows nicht verf\ügbar.";
$userid = "Unter Windows nicht verf\ügbar.";
$updays = '?';
$upstd = '?';
$upmin = '?';
$useron = "Unter Windows nicht verf\ügbar.";
$load1 = "Unter Windows nicht verf\ügbar.";
$load5 = "Unter Windows nicht verf\ügbar.";
$load15 = "Unter Windows nicht verf\ü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(
$perl_debug"); print "\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, 'Server Diagnose', "Skript Debugger"); print "\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 "\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 "\n"; &_table_start('Programm Pfade', 2); &_row_pair(0, 'grep', $greploc); &_row_pair(1, 'date', $dateloc); &_row_pair(0, 'sendmail', @mailloc); print "\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 "\n"; if (scalar @foundmods > 0) { &_table_start('Installierte Module', 3); print '
Automatisch erstellt mit TellMe am $date | \n"; } print<