#!/usr/bin/perl
# tell client na stary aj novy protokol ( may be ) made
# by (c) Kozo (jvajda@elf.stuba.sk)
# =======================================================================
# modification history :
# ----------
# version 0.0.1		Thu Sep 26 16:24:49 MESZ 1996
# toto bol uplny zaciatok a ledva vedelo otvorit socket
# ----------
# version 0.5		Fri Oct 04 11:31:08 MESZ 1996
# podporuje oba protokoly heh ..
# ----------
# version 0.6		Fri Oct 11 14:18:06 MESZ 1996
# podporuje aliasy
# ----------
# version 0.7		Fri Oct 11 17:20:06 MESZ 1996
# podporuje .tellrc file
# ----------
# version 0.8		Sat Oct 12 11:01:02 MESZ 1996
# vracia vlastne chybove hlasky .. nespolieha sa na server
# caf gildir :-{))
# ----------
# version 0.9		Thu Nov 07 17:00:13 MEZ 1996
# podporuje novu strukturu .tellrc : <config> </config> 
# aj ked nie uplne inteligentne
# ----------
# version 0.9.5		Tue Nov 19 17:31:58 MEZ 1996
# prepracovane spracovavanie rc file
# ----------
# version 1.013		Thu Apr 17 19:13:15 MET DST 1997
# nic nove .. len gildir zmenil trochu protokol a 
# daemon tvrdi, ze vsetko pod 1.0 s nim nemoze komunikovat
#
# uvidime co z toho vznikne .. zatial je to ftakovina ...
# ale zacina byt ciastocne kompati(de)bilna s c-ckovou verziou
# =======================================================================

# ak chcem debugovat treba odhashovat :-{))
  $DEBUG = "YES";

# version ID
   $VERSION = "1.013";

# testovanie poctu parametrov
if ( $#ARGV < 1 ) {
  print "Tell client based on perl by Kozo (jvajda\@elf.stuba.sk)\n";
  print "Version: $VERSION\n";
  print "Usage: tell <name[\@host[:port]]> <msg> [<tty>]\n";
exit(-1);
}


if ( $DEBUG ) {
  print "\nDEBUG INFORMATIONS about tell.pl\n\n";
}

# default port
$DEFAULT_PORT = '4224';

# definicia DEFAULT_RC file a nalezitosti v nom ...
$PWD = (getpwuid($<))[7];
$DEFAULT_RC = "$PWD/.tellrc";
%RC = ('aliasfile',"$PWD/.elm/aliases.text");

# osahanie RC_FILE
$RC_FILE = $ENV{'TELLRC'} || $DEFAULT_RC ;
if ( -r $RC_FILE ){
    open(RC,"$RC_FILE") || die "Can't write $arg: $!\n";
  if ( $DEBUG ) {
    print "opening rc file $RC_FILE\n";
  }

  while ( $_ = <RC>) {
    chop;
    
    # za toto sa sice hanbim, ale funguje to ... mozno to bude niekedy lepsie 
    # berie do uvahy konfiguraciu medzi prvymi vyskytmi <config></config>
    
    if ( $_ =~ /^<config/ && $IS_CONFIG ne "NO" ) {
      $IS_CONFIG = "YES";
      next;
    } 
    if ( $_ =~ /^<\/config/ ) {
      $IS_CONFIG = "NO";
    }
    next if ( $IS_CONFIG ne "YES" || $IS_CONFIG eq "NO" || $_ =~ /^#/);
    
    # a tu uz nacitavam konfiguraciu ...
    # do pola RC
    ($name,$value) = split(/ = /,$_);
    $value = (split(/ |\t/,$value))[0];
    $RC{$name} = $value;

  }
}

if ( $DEBUG ) {
  print "Config file:\n";
  foreach $key (keys %RC) {
    print "     $key\t=\t$RC{$key}\n";   
  }
}

# nacitanie spravy 
  $MSG = $ARGV[1];
# nacitanie tty
  $TTY = $ARGV[2];
# nacitanie a rozkodovanie adresy
  @add = split(":",$ARGV[0]);
  @to = split("@",$add[0]);
  $SERVER = $to[1] || 'localhost';
  $REM_NAME = $to[0] || die "Missing remote name\n";
  $PORT = $add[1] || $DEFAULT_PORT;
# urcenie mena na localnom serveri
  $LOC_NAME = (getpwuid($<))[0];

# testovanie aliasov
  if ( $RC{'aliasfile'} !~ /^\// ) { 
    $RC{'aliasfile'} = "$PWD/$RC{'aliasfile'}";
  } 

if ( -r $RC{'aliasfile'} && $SERVER eq "localhost" ){
  open(ALIAS,"$RC{'aliasfile'}") || die "Can't write $arg: $!\n";
  if ( $DEBUG ) {
    print "opening alias file $RC{'aliasfile'}\n";
  }
  while (<ALIAS>) {
    @line = split(" = ",$_);
    if ( $line[0] eq $REM_NAME ) {
      @alias = split("@",$line[2]);
      $REM_NAME = $alias[0];
      $SERVER = $alias[1];
      if ( $DEBUG ) {
        print "alias = @line\n";
      }
    }
  }
}

if ( $DEBUG ) {
  print " loc_name = $LOC_NAME\n";
  print " rem_name = $REM_NAME\n";
  print " address  = $SERVER\n";
  print " port     = $PORT\n";
  print " tty      = $TTY\n";
  print " msg      = $MSG\n";
}

print "telling to $REM_NAME@$SERVER\n";

  $SOCKADDR = 'S n a4 x8';
  $AF_INET = 2;
  $SOCK_STREAM = 1;
  select(stdout); $|=1;

  # urcenie protokolu, adries, otvorenie socketov a tcp connections .. etc ..
  $proto = (getprotobyname('tcp'))[2];
  $thisaddr = (gethostbyname(''))[4];
  $thataddr = (gethostbyname($SERVER))[4];
  $this = pack($SOCKADDR,$AF_INET,0,$thisaddr);
  $that = pack($SOCKADDR,$AF_INET,$PORT,$thataddr);
  socket(S,$AF_INET,$SOCK_STREAM,$proto) || die "socket: $!\n"; 
  bind(S,$this) || die "bind: $!\n";
  connect(S,$that) || die "connect: $!\n";
  select(S); $| = 1; select(STDOUT);

  # tu sa zacina samotny client 
  # tu sa bude rozhodovat o tom aky protokol pouzit 
  print S "HELO $LOC_NAME $VERSION perl client\n";
  read(S,$inp,256);
  @co = split(/\s+/,$inp);
  if ( $DEBUG ) {
    print " spat = @co\n";
  }
  if ( $co[0] == "101" ) {
  # vymakol som novy protokol  ( caf Gildir )
    if ( $DEBUG ) {
      print "\nNew protocol mode ...\n";
    }
    print S "TELL $REM_NAME $TTY : $MSG\n";
    read(S,$inp,256);
    $spat = &what_from;
    print S "QUIT\n";
    read(S,$inp,256);
  } else {
      if ( $DEBUG ) {
        print "\nOld protocol mode ...\n";
      }
  # stary protokol
    print S "$LOC_NAME:$REM_NAME:$TTY:$MSG\n";
    read(S,$inp,256);
    $spat = &what_from;
  }

close S;
  
# that's all folks  :-{)) 




#############################################################################
# definicia podprogramov

sub what_from
{
  @co = split(/ /,$inp);
  $NUM = $co[0];

# kvazi case na chybove hlasky
  if ( $NUM == 200 ) {
    print "Text sent to tty of $REM_NAME\n";
  }
  if ( $NUM == 201 ) {
    print "Text passed on\n";
  }
  if ( $NUM == 210 ) {
    print "Text saved\n";
  }
  if ( $NUM == 401 ) {
    print "$REM_NAME is not logged on\n";
  }
  if ( $NUM == 402 ) {
    print "$REM_NAME is not on that tty ($TTY)\n";
  }
  if ( $NUM == 403 ) {
    print "$REM_NAME refusing messages\n";
  }
  if ( $NUM == 404 ) {
    print "You are not authorized\n";
  }
  if ( $NUM == 501 ) {
    print "Syntax error\n";
 }

  return($NUM);
}