#!/usr/local/bin/perl
#
# italkwho.pl by Yutaka Oiwa
# (c) 1997 Yutaka Oiwa
#
# $Id: italkwho,v 1.7 1998/12/13 12:54:19 yutaka Exp $
#

&tcp'init; #'

@them = ( 'main.italk.ne.jp' );
$format = 'd';
$add = 0;
$dynamic = 0;
$debug = 0;

while ($ARGV[0] =~ /^-/) {
    $target = shift @ARGV;
    if ($target =~ /^-w([awno])$/) {
	$format = $1;
    } elsif ($target eq '-add') {
	$add = 1;
    } elsif ($target eq '-dynamic') {
	$dynamic = 1;
    } else {
	print STDERR "usage: $0 [-w{awno}] [-add] [-dynamic] [host ...]\n";
	exit 0;
    }
}

$add = 1 if (! scalar(@ARGV));
unshift (@ARGV, @them) if $add;
$allowupdate = 0;
if ($dynamic and scalar(@ARGV) >= 2) {
    die "italkwho: multiple servers are not supported with -dynamic option.\n";
}

foreach $them (@ARGV) {
    $port = '12345'; # italkwho
    
    if($them =~ m@(.*):(\d+)@){
	$them = $1;
	$port = $2;
    }
    
    eval {
	&connect_socket(*S, $them, $port);
    };
    if ($@) {
	print STDERR $@;
	next;
    }
    $mode = '';
    while(<S>){
	s/[\r\n]+$//;
	if (/^# Italk Protocol (\d+).(\d+)/) {
	    $protocol= $1 * 100 + $2;
	    if ($dynamic) {
		print S "/x type=biff\r\n/wa\r\n";
	    } else {
		print S "/x user-agent=italkwho\r\n/wa\r\n";
	    }
	    next;
	}
	if ($protocol >= 100) {
	    $_ = $' if /^\#! /;
;
	}
	print "mode $mode line : <$_>\n" if $debug;
	if ($format eq 'a') {
	    print "$_\n";
	}
	if ($_ eq '</italk>') {
	    &output;
	    last if (!$dynamic);
	    $allow_update = 1;
#ifdef OLD_COMPAT
	} elsif ($_ =~ /^\#\# --/) {
	    last;
	} elsif ($_ =~ /^\d\d\d\d /) {
	    print "$_\n";
	    next;
#endif
	} elsif ($_ eq '<italk>') {
	    &clear_all_entries;
	} elsif ($_ eq '<((new)?user)>') {
	    $mode = $1;
	    ($no, $idle, $handle, $host, $status) = ();
	} elsif (/^<([a-z]+)>$/) {
	    $mode = $1;
	} elsif ($_ eq '</user>') {
	    $mode = '';
	    &register_user($no, $handle, $idle, $host, $status);
	    if ($1 eq 'new') {
		&output;
	    }
	} elsif ($_ eq '</newuser>') {
	    $mode = '';
	    if ($allow_update) {
		&register_user($no, $handle, $idle, $host, $status);
		&output;
	    }
	} elsif ($_ eq '</server>') {
	    $mode = '';
	} elsif ($_ eq "</$mode>") {
	    $mode = '';
	} elsif ($mode eq 'server') {
	    $serverhost = $1 if /^host=(.*)$/;
	    $serverport = $1 if /^port=(.*)$/;
	    $serveradmin = $1 if /^admin=(.*)$/;
	    $serverusers = $1 if /^users=(.*)$/;
	$servercurtime = $1 if /^currenttime=\d+ (.*)$/;
	} elsif ($mode eq 'user' || $mode eq 'newuser') {
	    print "DB: entry $_\n" if $debug;
	    /^userno=(\d+)$/ && ($no = $1);
	    /^idle=(\d+)$/ && ($idle = $1);
	    /^handle=(.*)$/ && ($handle = $1);
	    /^host=(.*)$/ && ($host = $1);
	    /^status=(.*)$/ && ($status = $1);
	} elsif ($allow_update) {
	    if (/^newhandle=(\d+),(.*)$/) {
		$handle{$1} = $2;
		&output;
	    } elsif (/^newstatus=(\d+),(.*)$/) {
		$status{$1} = $2;
		&output;
	    } elsif (/^(logout|disconnect)=(\d+)$/) {
		&delete_user($2);
		&output;
	    }
	}
    }
    if ($protocol >= 100) {
	print S "/q\r\n";
    }
    close(S);
}

exit 0;

sub clear_all_entries {
    %handle = ();
    %idle = ();
    %host = ();
    %status = ();
}

sub register_user {
    local($no) = shift;
    ($handle{$no}, $idle{$no}, $host{$no}, $status{$no}) = @_;
}

sub delete_user {
    local($no) = shift;
    print "DELUSER: $no\n" if $debug;
    delete $handle{$no};
    delete $idle{$no};
    delete $host{$no};
    delete $status{$no};
}

sub output {
    eval "&o_server_$format(\$serverhost, \$serverport, \$serveradmin)";
    foreach $no (sort {$a <=> $b} keys %handle) {
	eval "&o_user_$format(\$no, \$handle{\$no}, \$idle{\$no}, \$host{\$no}, \$status{\$no})";
    }
    print "----\n" if ($dynamic);
}

sub o_server_o {
    local($host, $port) = @_;
    print "# $host:$port\n"
}
sub o_server_w { &o_server_o(@_); }
sub o_server_n { &o_server_o(@_); }

sub o_user_d {
    local($no, $handle, $idle, $host, $status) = @_;
    printf "%04d %-28.28s ", $no, "$handle\@$host";
    if ($status ne '') {
	print "<$status> ";
    }
    print "(\@$serverhost:$serverport)\n";
}

sub o_user_n {
    local($no, $handle, $idle, $host, $status) = @_;
    printf " (%04d) %s %-28.28s", $no, &idlestr($idle), "$handle\@$host";
    print " <$status>" if ($status ne '');
    print "\n";
}

sub o_user_w {
    local($no, $handle, $idle, $host, $status) = @_;
    printf " (%04d) %s %s\n", $no, &idlestr($idle), "$handle\@$host";
    print "              <$status>\n" if ($status ne '');
}

sub o_user_o {
    local($no, $handle, $idle, $host, $status) = @_;
    printf " (%04d) %s\@%s", $no, $handle, $host;
    print " <$status>" if ($status ne '');
    if (!$dynamic && $idle >= 300) {
	printf " [idle %s]", &idlestr($idle);
    }
    print "\n";
}

sub idlestr {
    local ($m) = @_;
    $m = int($m / 60);
    if ($m < 5 || $dynamic) {
	'     ';
    } elsif ($m >= 6000) {
	'--:--';
    } else {
	sprintf ("%02d:%02d", int($m / 60), $m % 60);
    }
}    


#!/usr/local/bin/perl
#
# tcp.pl : Easy TCP Socket Library
#
# This Package Provides:
#
# &connect_socket(Handle *Socket, String host, Int Port,
#                 optional String Situation);
# &set_timeout(Int seconds);
#
# $Id: italkwho,v 1.7 1998/12/13 12:54:19 yutaka Exp $
#

###  connect_socket : make a connection with TCP socket.
 
package tcp;

sub init {
    return if $inited;
    $inited = 1;

# customize values
#    $SOCK_STREAM = 1; # AUTO DETECT
#    $AF_INET = 2;

    &alephlib'init; #'

    $IsWin32 = $main'IsWin32; #'
    $IsPerl5 = $main'IsPerl5; #'
    $Flag_alarm = ! $IsWin32;
    $timeout = 120;
}

sub set_timeout {
    $timeout = @_;
}

sub main'connect_socket { #'
    local(*SOCKET, $host, $port, $situation) = @_;
    local($name, $aliases, $proto, $aliases, $type, $len, $thataddr);
    local($thataddr, $that);
    local(%SIG, $mes);

    if (defined $situation) {
	$mes = " $situation:";
    } else {
	$mes = "";
    }

    # detect AF_INET value

    if (! defined $AF_INET || ! defined $SOCK_STREAM) {
	if ($IsPerl5) {
	    eval "use Socket";	# Perl5
	} else {
	    eval "require 'sys/socket.ph'";   # Perl4
	}
	die $@ if ($@);
	$AF_INET = &AF_INET;
	$SOCK_STREAM = &SOCK_STREAM;
    }

    ($name, $aliases, $proto) = getprotobyname('tcp');
    ($name, $aliases, $port) = getservbyname($port, 'tcp')
	unless $port =~ /^\d+$/;

    if($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){
	$thataddr = pack('c4', $1, $2, $3, $4);
    } else {
	eval {
	    $SIG{'ALRM'} = "tcp'timed_out" if ($Flag_alarm); #'
	    &set_alarm($timeout);

	    ($name, $aliases, $type, $len, $thataddr) =  gethostbyname($host);

	    &set_alarm(0);
	};

	if ($@) {
	    die "connect_socket:$mes address resolver time out.";
	}
    }

    if (! $thataddr) {
	die "connect_socket:$mes Unknown host: $host.";
    }

    $that = pack('S n a4 x8', $AF_INET, $port, $thataddr);

    if (! socket(SOCKET, $AF_INET, $SOCK_STREAM, $proto)) {
	die "socket:$mes $!.";
    }

    $Message = '';

    eval {
	
	$SIG{'ALRM'} = 'timed_out' if ($Flag_alarm);
	&set_alarm($timeout);

	if (! connect(SOCKET, $that)) {
	    &set_alarm(0);
	    $Message = "connect:$mes $! by $host.";
	}
	&set_alarm(0);
    };

    if ($@) {
	$Message = "connect_socket:$mes connection timed out.";
    }
    if ($Message) {
	close (SOCKET);
	die $Message;
    }

    select(SOCKET); $| = 1; binmode(SOCKET); select(STDOUT);

    return 1;
}

sub timed_out {
    die "";
}

sub set_alarm {
    alarm($_[0]) if ($Flag_alarm);
}

&init;
1;

package main;

######################################################################
#
# Aleph's Library: Some Common Perl Routine
#
######################################################################

# this package provides:
#  $HomeDirectory
#  $IsWin32
#  $IsPerl5
#  $CommandName
#  $PerlSpec
#  $OSType

# $Id: italkwho,v 1.7 1998/12/13 12:54:19 yutaka Exp $

package alephlib;

sub init {
    return if $inited;
    $inited = 1;

    &detect_environment;
    $ScriptName = &get_command_name;
    $HomeDirectory = &get_user_vicinity;

    # export value
    $main'HomeDirectory = $alephlib'HomeDirectory;
    $main'ScriptName = $alephlib'ScriptName;
    $main'IsWin32 = $alephlib'IsWin32;
    $main'IsPerl5 = $alephlib'IsPerl5;
    $main'OSType = $alephlib'OSType;
    $main'PerlSpec = $alephlib'PerlSpec;
}

sub yesno {
    $_[0] ? "yes" : "no";
}

sub diagnostics {
    printf "
Alephlib Diagnostics:
  Is This Perl Version5? : %s
  Is This Perl Win32's?  : %s
  OS Type                : %s
  Script name            : %s
  Home Directory         : %s
  Perl Spec String       : %s
", &yesno($IsPerl5), &yesno($IsWin32), $OSType,
      $ScriptName, $HomeDirectory, $PerlSpec;
}

sub get_command_name {
    local($_) = $0;

    s|^..*/||o;
    s|\.[a-z]+$||io;		# extension .pl (.bat in Win32)
    y/A-Z/a-z/;
    
    $_;
}

sub get_user_vicinity {
    if ($IsWin32) {
	$_ = $ENV{'HOME'} || $ENV{'LOGDIR'} || $ENV{'windir'};
	s/\\/\//g;
    } else {
	$_ = $ENV{'HOME'} || $ENV{'LOGDIR'} ||
	    (getpwuid($<))[7];
    }
    $_ || die "$ScriptName: Can't find Home Directory!\n";
}

sub detect_environment {
    local ($@); # Error Trap is Local
    local ($string, $major, $minor, $build, $id, $specstr);
    local ($osname, $nodename, $release, $reldate, $domainname);
    $IsWin32 = 0; #'

    eval q|$_ = &Win32'GetCwd;|;	#'
    $IsWin32 = 1 if (!($@)); 

    $PerlVersion = sprintf ("%g", $] + 0);
    $IsPerl5 = ($PerlVersion > 5.0); 

    if ($IsWin32) {
	# Win32 environ detection
	# I think all "Perl for Win32" are Perl5,
	# but take care.
	eval q|
	    ($string, $major, $minor, $build, $id) = &Win32'GetOSVersion; #'
	|;
	$OSType = ('Win+Win32S', 'Win95', 'WinNT')[$id];
	if ($string eq '') {
	    $OSType = sprintf("%s %d.%02d", $OSType, $major, $minor);
	} else {
	    $string =~ s/\b(\S+)\b +/\u$1/g;
	    $OSType = sprintf("%s %d.%02d-%s", $OSType, $major, $minor, $string);
	}
	if ($@) {
	    $OSType = "Win-Unknown";
	}
	$PerlSpec = "Perl $PerlVersion-Win32, " . &Win32'PerlVersion . #'
	    ", $OSType";
    } else {
	if ($IsPerl5) {
	    eval '
		use POSIX; 
		($osname, $nodename, $release, $reldate, $domainname)
		    = &POSIX::uname;
		$OSType = ucfirst("$osname $release");
	    ';
	    if ($@) {
		eval '
		    use Config; 
		    $OSType = ucfirst($Config{"osname"});
		';
		if ($@) {
		    $OSType = $ENV{'OSTYPE'} || 'Unix';
		    $OSType = "\u$OSType";
		}
	    }
	} else {
	    $OSType = $ENV{'OSTYPE'} || 'Unix';
	    $OSType = "\u$OSType";
	}
	$PerlSpec = "Perl $PerlVersion, $OSType";
    }
}

&init;
1;

package main;
