#!/usr/bin/perl

# TkTemp 0.1
# Copyright (c) 2002 Uiewera Alistair Reuel Ruirarchzatrea.
# All Rights Reserved.
# This program is covered under the BSD Licence. Please see the BSD Licence
# below or in the TkTemp-LICENCE file.

# A simple Tk based tool for converting between centigrade, fahrenheit, and
# kelvin. Features slide rules and entry boxes.

use Tk;
use strict;  
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Ssockets;
use FileHandle;
use IO::File;
$|=1;
my $version="0.1";

my $copyright = "TkTemp Version $version\n By Uiewera Alistair Ruirarchzatrea
Copyright (c) 2002 Uiewera Alistair Ruirarchzatrea
Covered under the BSD Licence. Please consult LICENCE file for
   Detials\n";
print $copyright;

my $bsdlicence = "

/*
 * Copyright (c) 2002 Uiewera Alistair Reuel Ruirarchzatrea.  
 * All rights reserved.
 * 
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer. 
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *    This product includes software developed by Uiewera Ruirarchzatrea and
 *    contributors.
 * 4. Neither the author's name, nor any of the contributors names may be
 *    used to endorse or promote products derived from this software without
 *    specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR `AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  
 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 */
";

my $printed=0;
my @timearray;
$timearray[0]="notready";
$timearray[4]=0;
my ($fscale, $cscale, $kscale) = (0, 0, 0);
my ($kval, $cval, $fval) = (0, 0, 0);
my ($kelvtitle, $centtitle, $fahtitle, $centry, $kentry, $fentry,
$titleframe, $title, $main, $label, $labelcent, $labelkelv, $labelfah,
@localtime, $labelclock, $cscale, $cscalewid, $fscale, $fscalewid, $time, 
$clock, $cframe, $kframe, $fframe, $kscale, $kscalewid);
my ($liwind);
my ($kelvwind, $celwind, $fahwind);
my ($abwinclose, $aboutwind, $aboutwind_close, $aboutwind_button);
# $kscale, $kscalewid,    
my $listensock;
my $start_server=0;
my $start_time=0;
my @time_addr;
my ($uentry, $u2entry, $rtimelabel, $reaumentry, $rentry);
my @serv_addr;
$timearray[6]=0;

main();


sub main {
parse_args();
$main = MainWindow->new();
$main->title("TkTemp $version");
$title = "TkTemp";
$titleframe = $main->Frame() ->pack(side => 'left');
$label =$titleframe -> Label(textvariable => \$title)->pack(side => 'top',
pady => 0);
$label-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*');
$centtitle = "Centigrade:";
$labelcent =$titleframe -> Label(textvariable => \$centtitle)->pack(side => 'top',
pady => 0);
$labelcent-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

my $C_val="C";
my $Centry_val="centry";

$centry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$centry -> bind("<KeyPress-Return>", [\&main_event, $C_val, $Centry_val]);

$kelvtitle ="Kelvin:";
$labelkelv =$titleframe -> Label(textvariable => \$kelvtitle)->pack(side => 'top',
pady => 0);
$labelkelv-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');



$kentry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$kentry -> bind("<KeyPress-Return>", \&kentry_event);


$fahtitle="Fahrenheit:";
$labelfah =$titleframe -> Label(textvariable => \$fahtitle)->pack(side => 'top',
pady => 0);
$labelfah-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

$fentry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$fentry -> bind("<KeyPress-Return>", \&fentry_event);

my $ranktitle="Rankine:";
my $labelrank =$titleframe -> Label(textvariable => \$ranktitle)->pack(side =>
'top', pady => 0);
$labelrank-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

$rentry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$rentry -> bind("<KeyPress-Return>", \&rentry_event);


my $reaumtitle="Reaumur:";
my $labelreaum =$titleframe -> Label(textvariable => \$reaumtitle)->pack(side =>
'top', pady => 0);
$labelreaum-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

$reaumentry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$reaumentry -> bind("<KeyPress-Return>", \&reaum_event);

my $utitle="Uiewera:";
my $labelu =$titleframe -> Label(textvariable =>
\$utitle)->pack(side => 'top', pady => 0);
$labelu-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

$uentry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$uentry -> bind("<KeyPress-Return>", \&uentry_event);

my $u2title="Base360 B:";
my $labelu2 =$titleframe -> Label(textvariable =>
\$u2title)->pack(side => 'top', pady => 0);
$labelu2-> configure (font=>'-*-helvetica-medium-r-*--*-100-*-*-*-*-*');

$u2entry = $titleframe -> Entry(width => 5)->pack(side=> 'top',
pady => 0);
$u2entry -> bind("<KeyPress-Return>", \&u2entry_event);


$time = time();
@localtime=localtime($time);
$clock=  $localtime[2] . ":" . $localtime[1] . ":" . $localtime[0];
$labelclock= $titleframe->Entry(width=> 8, relief=>'flat',borderwidth=>0)->pack(side => 'top',
pady => 0);
$rtimelabel= $titleframe->Entry(width=> 8,
relief=>'flat',borderwidth=>0)->pack(side=>'top',
pady => 0);
$labelclock ->delete(0, 'end');
$labelclock ->insert(0, $clock);
$labelclock ->repeat(1000, \&update_clock);
if ($start_time==1) {

$rtimelabel ->after(10000, \&time_sock_create);
$rtimelabel->repeat(9000000, \&time_sock_create);
}
if ($start_server==1) {
$rtimelabel ->after(20000, \&socket_listen); 
}

my $a_butn_title="About";

my $aboutbutton = $titleframe ->Button(textvariable=> \$a_butn_title,
command => \&about_window)->pack(side=>'top',pady=>5);

my $e_butn_title="Exit";
$aboutbutton = $titleframe ->Button(textvariable=> \$e_butn_title,
command => \&exit)->pack(side=>'top',pady=>5);




$cframe = $main->Frame() ->pack(side => 'left');
$cscalewid = $cframe->Scale(command => \&update_cent,
                        variable => \$cscale,
                        width => 20,
                        length => 400,
                        orient => 'vertical',
                        from => -40,
                        to => 288,
                        resolution => 1,
                        tickinterval => 25,
                        label => ''
                )->pack (side => 'top');
$cframe -> Label(textvariable => \$cscale)->pack(side => 'top',
pady => 0);


my $celsframe = $main->Frame()->pack(side=>'left');

my $cname="Centigrade";
my $cnamelabel=$celsframe->Label(textvariable=>\$cname)->pack(side=>'top'); 
my $cpicframe=$celsframe->Button(command=>\&celsiusinfo)->pack(side=>'top');
my $celsius= $cpicframe->Pixmap(-file=>"pics/celsius.xpm");
$cpicframe->configure(image=>$celsius);


$fframe = $main->Frame() ->pack(side => 'left');
$fscalewid = $fframe->Scale(command => \&update_fah, 
                        variable => \$fscale,
                        width => 20,
                        length => 400,
                        orient => 'vertical',
                        from => -40,
                        to => 288,
                        resolution => 1,
                        tickinterval => 25,
                        label => ''
                )->pack (side => 'top');
$fframe -> Label(textvariable => \$fscale)->pack(side => 'top',
pady => 0);

my $fahframe = $main->Frame()->pack(side=>'left');

my $fname="Fahrenheit";
my $fnamelabel=$fahframe->Label(textvariable=>\$fname)->pack(side=>'top'); 
my $fpicframe=$fahframe->Button(command=>\&fahrenheitinfo)->pack(side=>'top');
my $fahrenheit= $fpicframe->Pixmap(-file=>"pics/fahrenheit3.xpm");
$fpicframe->configure(image=>$fahrenheit);


$kframe = $main->Frame() ->pack(side => 'left');
$kscalewid = $kframe->Scale(command => \&update_kelvin, 
                        variable => \$kscale,
                        width => 20,
                        length => 400,
                        orient => 'vertical',
                        from => 233,
                        to => 561,
                        resolution => 1,
                        tickinterval => 25,
                        label => ''
                )->pack (side => 'top');
$kframe -> Label(textvariable => \$kscale)->pack(side => 'top',
pady => 0);

my $kelvframe = $main->Frame()->pack(side=>'left');

my $kname="Kelvin";
my $knamelabel=$kelvframe->Label(textvariable=>\$kname)->pack(side=>'top'); 
my $kpicframe=$kelvframe->Button(command=>\&kelvininfo)->pack(side=>'top');
my $kelvin= $kpicframe->Pixmap(-file=>"pics/kelvin.xpm");
$kpicframe->configure(image=>$kelvin);



MainLoop();
}

sub parse_args { #1
my @parseargs=@ARGV;
my $count=0;
my $check=1;
my $correct=1;
my @results;

my $arrsizeval=scalar @parseargs;
my $arrsize=$arrsizeval-1;
if ($arrsizeval==0) { #2
print "No arguments to parse\n";
return;
} #e2
while ($check==1) { #2
my $argcount=0;
foreach my $in (@parseargs) {
print "Argument $argcount $parseargs[$argcount]\n";
++$argcount;
} #e2

if ($parseargs[$count] eq "-s") { #3
print "argument -s: Server enabled\n";
$start_server=1;
my @argarray=get_args($count);
my $anyargs=shift @argarray;

if ($anyargs==0) { #4
#none
# return;
} #e4

elsif($anyargs==1) { #4
my $s_count=0;
my $argarray_len=scalar(@argarray);
# if ($argarray[0]==1) {#4.5
#return;

print "-s options $argarray_len\n";
foreach my $in (@argarray) { #5
print "-s arg $s_count: $argarray[$s_count]\n";
++$s_count;

print "IP Address: $in\n";
my @serv_addr=split(":", $in);

my $servarr_len=scalar(@serv_addr);
if ($servarr_len>3) { #6
$correct=0;
push(@results, "Too many arguments on -s");
} #e6
if ($serv_addr[0] !~ m/[\d]+\.[\d]+\.[\d]+\.[\d]+/) { #6
$correct=0;
push(@results, "IP address improper format: $time_addr[0]");
} #e6
print "Port address: $serv_addr[1]\n";
if ($servarr_len > 1) { #6
if ($serv_addr[1] !~ m/^[\d]+$/) { #7
$correct=0;
print ("port check\n");
push(@results, "Port value not a number: $serv_addr[1] length: $servarr_len");
} #e7
push(@serv_addr, 1);

} #e6 
} #e5
# } #e4.5
} #e4
$start_server=1;
} #e3

elsif ($parseargs[$count] eq "-t") { #3
# -t yes|no [address]
my $start_time1=splice(@parseargs, $count+1, 1);
print "Time Yes/No: $start_time1\n";
$arrsize=$arrsize-1;
if ($start_time1 eq "yes") { #4
$start_time=1;
} #e4

elsif ($start_time1 eq "no") { #4
$start_time=0;
} #e4
else { #4
$correct=0;
push(@results, "Incorrect yes|no value $start_time1");
} #e4

my $firstchar=substr($parseargs[$count+1], 0, 1);
print "Next Argument Char: $firstchar\n";
if ($firstchar ne "-") { #4
my $time_addr1=splice(@parseargs, $count+1, 1);
print "IP Address: $time_addr1\n";
$arrsize=$arrsize-1;
@time_addr=split(":", $time_addr1);

my $timearr_len=scalar(@time_addr);
if ($timearr_len>3) { #5
$correct=0;
push(@results, "Too many arguments on -t");
} #e5
if ($time_addr[0] !~ m/[\d]+\.[\d]+\.[\d]+\.[\d]+/) { #5
$correct=1;
push(@results, "IP address improper format: $time_addr[0]");
} #e5
print "Port address: $time_addr[1]\n";
if ($timearr_len > 1) { #5
if ($time_addr[1] !~ m/^[\d]+$/) { #6
$correct=1;
print ("port check\n");
push(@results, "Port value not a number: $time_addr[1] length: $timearr_len");
} #e6
# unshift (@time_addr, 1);
} #e5
unshift (@time_addr, 1);

} #e4
else { #4
# $correct=0;
} #e4
} #e3

else { #3
$correct=0;
push (@results, "Argument not recognised: $parseargs[$count]");
} #e3

if ($correct==0) { #3
print "Processing error argument: $parseargs[$count]\n";
foreach my $in (@results) { #4
print "$in\n";
} #e4
print "TkTemp $version Command Line Options
-s: Start built in server for telnet temparature conversions
-t: Connect to time server
   -t yes|no [address[:port]]
";
exit;
} #e3
++$count;

if ($count > $arrsize) { #3
$check=0;
} #e3

} #e2

sub get_args { #2
my $gt_check=1;
my @gt_args;
my $loccount=$_[0];
my $gt_count=0;
my $anyargs=1;
my $gt_arrsize=$_[1];
my $it_count=0;
my $parseargs_len=scalar(@parseargs);
if ($parseargs_len<=($loccount+1)) {
$gt_check=0;
}
while ($gt_check==1) { #3

my $gt_firstchar=substr($parseargs[$loccount+1], 0, 1);
print "Next Argument Char: $gt_firstchar\n";

#my $gt_arg=splice(@parseargs, $loccount+($gt_count+1), 1);

if ($gt_firstchar ne "-") { #4
my $gt_arg=splice(@parseargs, $loccount+1, 1);
$arrsize=$arrsize-1;
$gt_count=$gt_count-1;
push(@gt_args, $gt_arg);
} #e4
elsif ($gt_firstchar eq "") { #4
$gt_check=0;
} #e4

else { #4
$gt_check=0;

} #e4
#my $tst_addr=$loccount+1;
#my $tst_arr=$arrsize-1;
print "$arrsize, $loccount\n";
if ($arrsize<=$loccount) { #4
$gt_check=0;
} #e4
if ($arrsize<1) { #4
$gt_check=0;
} #e4

++$gt_count;
++$it_count;
} #e3
my $gtargs_len=scalar(@gt_args);
if ($gtargs_len==0) { #3
$anyargs=0;
} #e3

unshift(@gt_args, $anyargs);
return @gt_args;
} #e2

} #e1



#fahrenheit to centigrade
sub update_fah  {
my $inputtemp = $fscale + 40; 
$inputtemp = $inputtemp / 1.8;
$cscale = $inputtemp - 40;
$kscale=cent_kelv_conv($cscale);
# if ($buttonupdate ==1) {
# $kval=$kscale;
# $cval=$cscale;
# $fval=$fscale;
# }
# update_rr($cscale);
update_boxes($cscale, $kscale, $fscale);
# $buttonupdate=0;
}

sub update_boxes {
my ($incval, $inkval, $infval)= @_;
 $kentry->delete(0, 'end');
 $kentry->insert(0, $inkval);
 $centry->delete(0, 'end');  
 $centry->insert(0, $incval);
 $fentry->delete(0, 'end');  
 $fentry->insert(0, $infval);
update_rr($incval);
#$cscalewid->set($cval);
#$fscalewid->set($fval);
#$kscalewid->set($kval);
}


sub update_cent {
$fscale = cent_fah_conv($cscale);
$kscale=cent_kelv_conv($cscale);
# $fval=$fscale;
# $cval=$cscale;
# $kval=$kscale;
# update_rr($cscale);
update_boxes($cscale, $kscale, $fscale);
}

#centigrade to fahrenhiet
sub cent_fah_conv {    
my $ctemp=$_[0];
my $inputtemp = $ctemp + 40; 
$inputtemp = $inputtemp * 1.8;
my $ftemp = $inputtemp - 40;
return $ftemp;

}
#fahrenheit to centigrade

sub fah_cent_conv {
my $fahintemp=$_[0];
my $inputtemp = $fahintemp + 40; 
$inputtemp = $inputtemp / 1.8;
my $couttemp = $inputtemp - 40;
return $couttemp;
}

#centigrade to kelvin
sub cent_kelv_conv {
my $centtemp=$_[0];
my $kelvtemp=$centtemp + 273.15;
return $kelvtemp;
}

#kelvin to centigrade
sub update_kelvin {
$cscale=$kscale - 273.15;
$fscale =cent_fah_conv($cscale);
# update_rr($cscale);
update_boxes($cscale, $kscale, $fscale);
# $fval=$fscale;
# $cval=$cscale;
# $kval=$kscale;
}

#kelvin to centigrade
sub kelv_cent_conv {
my $celsout=$_[0] - 273.15;
return $celsout;
}

sub main_event {
#print $_[2];
#print $_[0];
##my $tempval=$$_[2] -> get();
#my $tempval=get($$_[2]);

#my $cent=temptocent($tempval, $_[1]);
#update_event($cent);
centry_event();
}

sub centry_event {
# $buttonupdate=1;
my $centry_cval = $centry -> get();
# $cscalewid -> set ($centry_cval);
$cscale=$centry_cval;
my $centry_fval=cent_fah_conv($centry_cval);
my $centry_kval=cent_kelv_conv($centry_cval);
update_boxes($centry_cval, $centry_kval, $centry_fval);
($cscale, $fscale, $kscale)=($centry_cval, $centry_fval, $centry_kval);
# update_cent;
}

sub fentry_event {
# $buttonupdate=1;
my $fscaleentry = $fentry -> get();
# $cscalewid -> set ($cscaleentry);
my $fentry_cval=fah_cent_conv($fscaleentry);
my $fentry_kval=cent_kelv_conv($fentry_cval);
update_boxes($fentry_cval, $fentry_kval, $fscaleentry);
($fscale, $cscale, $kscale)=($fscaleentry, $fentry_cval, $fentry_kval);
# update_fah;
}

sub kentry_event {
# $buttonupdate=1;

my $kscaleentry = $kentry -> get();   
my $kentry_cval=$kscaleentry-273.15;
my $kentry_fval=cent_fah_conv($kentry_cval);
# $cscalewid -> set ($cscaleentry);
update_boxes($kentry_cval, $kscaleentry, $kentry_fval);
($kscale, $cscale, $fscale)=($kscaleentry, $kentry_cval, $kentry_fval);
# update_kelvin;
}

sub rentry_event {
#rankine to fahrenheit
my $rankine = $rentry->get();
my $fahresult=$rankine - 459.67;
my $centval=fah_cent_conv($fahresult);
update_event($centval);
# update_rr($centval);
#$fval
#$kval
#$rval
}

sub reaum_event {
#freezing=0, boiling=80, one degree reaumur =1.25 celsius
#C=R*8/10, R=C*10/8
#C=10/8*R
#R=8/10*C
#to kelvin t=(t*1.25)+273.15
# kelvin to unit t=(t - 273.15)/1.25
# paranthesis, exponents, multiply&divide, add&subtract
# left -> right
# re to kelv
my $incoming=$reaumentry->get();
my $kelvout=($incoming*1.25)+273.15;
# kelv to cent
my $centout=kelv_cent_conv($kelvout);
update_event($centout);
# update_rr($cent);
#$cval=$reaumer*8/10;
#$fval=$

}

sub uentry_event {
# print @_;
my $incoming=$uentry->get();
my $kelvout=($incoming*0.27)+273.15;
# kelv to cent
my $centout = kelv_cent_conv($kelvout);
update_event($centout);
}

sub u2entry_event {
my $incoming=$u2entry->get();
my $uout=$incoming-1011.67;
my $kelvout=($uout*0.27)+273.15;
# kelv to cent
my $centout = kelv_cent_conv($kelvout);
update_event($centout);


}

sub update_event {
my $incoming = $_[0];
# cent to kelv
my $kelvval=cent_kelv_conv($incoming);
# cent to fah
my $fahin=cent_fah_conv($incoming);
# assign slide variables
($kscale, $cscale, $fscale)=($kelvval, $incoming, $fahin);
# update boxes 
# update_rr($incoming);
update_boxes($incoming, $kelvval, $fahin);
}

sub update_rr {
my $incoming=$_[0];
# cent to kelv
my $kelvval=cent_kelv_conv($incoming);

# kelv to reaumur
my $reaumval=($kelvval-273.15)/1.25;
my $uvalue=($kelvval-273.15)/0.27;
my $u2value=$uvalue+1011.67;
# cent to fah
my $fahin=cent_fah_conv($incoming);
# fah to rankine
my $rankval=$fahin +459.67;
# set reaumer box
$reaumentry->delete(0, 'end');
$reaumentry->insert(0, $reaumval);
# set rankine box
$rentry->delete(0, 'end');
$rentry->insert(0, $rankval);
# set uiewera box
$uentry->delete(0, 'end');
$uentry->insert(0, $uvalue);
#set u2 box
$u2entry->delete(0, 'end');
$u2entry->insert(0, $u2value);
}


sub temptocent {
my $ttype = $_[1];
my $incoming = $_[0];
my $outval;
my $result =1;

if ($ttype eq "U2") {
#u2
my $uout=$incoming-1011.67;
my $kelvout=($uout*0.27)+273.15;
# kelv to cent
my $centout = kelv_cent_conv($kelvout);
$outval=$centout;
}

elsif ($ttype eq "U") {

#u
my $kelvout=($incoming*0.27)+273.15;
# kelv to cent
my $centout = kelv_cent_conv($kelvout);
$outval=$centout;
}

elsif ($ttype eq "RE") {
# reaumer
#freezing=0, boiling=80, one degree reaumur =1.25 celsius
#C=R*8/10, R=C*10/8
#C=10/8*R
#R=8/10*C
#to kelvin t=(t*1.25)+273.15
# kelvin to unit t=(t - 273.15)/1.25
# paranthesis, exponents, multiply&divide, add&subtract
# left -> right
# re to kelv
my $kelvout=($incoming*1.25)+273.15;   
# kelv to cent
my $centout=kelv_cent_conv($kelvout);
#$cval=$reaumer*8/10;
#$fval=$ 
$outval=$centout;
}

elsif ($ttype eq "R") {
my $rankine = $incoming;
# rankine
my $fahresult=$rankine - 459.67;
my $centval=fah_cent_conv($fahresult);
$outval=$centval;
}

elsif ($ttype eq "K") {
my $kscaleentry=$incoming;
# kelvin
my $kentry_cval=$kscaleentry-273.15;  
my $kentry_fval=cent_fah_conv($kentry_cval);
$outval=$kentry_cval;
}

elsif ($ttype eq "F") {
my $fscaleentry=$incoming;
# fahrenheit
my $fentry_cval=fah_cent_conv($fscaleentry);
my $fentry_kval=cent_kelv_conv($fentry_cval);
$outval=$fentry_cval;
}

elsif ($ttype eq "C") {
my $centry_cval=$incoming;
# centigrade
my $centry_fval=cent_fah_conv($centry_cval); 
my $centry_kval=cent_kelv_conv($centry_cval);
$outval=$incoming;
}
else {
$result =0;
}

return $result, $outval;
}

sub centtotemp {
my $incoming=$_[1];
my $tscale=$_[0];
# cent to kelv
my $kelvval=cent_kelv_conv($incoming);

# kelv to reaumur
my $reaumval=($kelvval-273.15)/1.25;
my $uvalue=($kelvval-273.15)/0.27;
my $u2value=$uvalue+1011.67;
# cent to fah
my $fahin=cent_fah_conv($incoming);
# fah to rankine
my $rankval=$fahin +459.67;

return ($incoming, $fahin, $kelvval, $reaumval, $rankval, $uvalue,
$u2value);


}

sub update_clock {
my $clockupdate=61;

my $test = 1.434;
#printf($test, '%.2f');
if ($clockupdate > 60) {
$time = time();
$clockupdate=0;
}
else {
++$time;
++$clockupdate;
}
@localtime = localtime($time);
$clock=  $localtime[2] . ":" . $localtime[1] . ":" . $localtime[0];
$clock=sprintf($clock, '%.2f%c%.2f%c%.2f');
$labelclock->delete(0, 'end');
$labelclock->insert(0, $clock);
if ($timearray[0] eq "ready") {
my $timediff=$time - $timearray[1];
my $restime=$timearray[2] + $timediff;
my @rloctime=localtime($restime);
my $locclock=  $rloctime[2] . ":" . $rloctime[1] . ":" . $rloctime[0];

if ($printed < 1) {
my @timeout=localtime($timearray[2]);
print "Local Time: ", $clock, " ";
print "Calculated Time: ", $timeout[2], ":", $timeout[1], ":", $timeout[0];
print " Remote Time: ";
print $locclock, "\n";
++$printed;
}
$rtimelabel->delete(0, 'end');
$rtimelabel->insert(0, $locclock);
}
}

sub calc_remote_time {
my $type = $_[0];
my $mytime=time();
my @outarray;
my @locclock;
if ($timearray[0] eq "ready") {
my $timediff=$mytime - $timearray[1];   
my $restime=$timearray[2] + $timediff;
if ($type eq "time") {
my @rloctime=localtime($restime);
$locclock[0]=  $rloctime[2] . ":" . $rloctime[1] . ":" . $rloctime[0];
}
elsif ($type eq "array") {
@locclock=localtime($restime);
}
elsif ($type eq "string" or $type eq "") {
$locclock[0]=localtime($restime);
}
@outarray=(1, @locclock); 

}
else {
$outarray[0]=0;
}
return @outarray;
}
sub about_window {
my $about_title="About TkTemp";
my $about_text="Copyright (c) 2002 Uiewera Alistair Reuel Ruirarchzatrea.\n
All Rights Reserved.\n
TkTemp is covered under the BSD Licence, please click on Licence below to
read the terms of this licence.\n\n
TkTemp is a simple program to allow temparature scales to be
easily converted from one to another. It features slide rules, and entry
boxes. You may use the entry boxes to enter values, simply enter them and
press enter.";
$abwinclose="Close";
$aboutwind=$main->Toplevel(width=>300, height=>100);
$aboutwind->title("About TkTemp");
my $aboutwind_title=$aboutwind->Label(textvariable=>\$about_title)->pack(side=>'top', pady=>5);
$aboutwind_title-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*');


my $aboutwind_text=$aboutwind->Label(textvariable=>\$about_text)->pack(side=>'top',
pady=>5);

$aboutwind_text-> configure (font=>'-*-helvetica-medium-r-*--*-120-*-*-*-*-*');

my $aboutbframe=$aboutwind -> Frame() -> pack(side=>'top', pady=>5);
$aboutwind_button=$aboutbframe->Button(textvariable=>\$abwinclose,
command=>\&close_about)->pack(side=>'left', pady=>5);
my $ablicence="Licence";
my $aboutwind_licence=$aboutbframe->Button(textvariable=>\$ablicence,
command=>\&licence_window)->pack(side=>'left', pady=>5);
my $abclock="Update Clock";
my $aboutwind_clock=$aboutbframe->Button(textvariable=>\$abclock,
command=>\&time_sock_create)->pack(side=>'left', pady=>5);

}

sub close_about {
$aboutwind->destroy;
}

sub celsiusinfo {
my $cel_title="Anders Celsius";
my $cel_text="Anders Celsius invented the Centigrade/Celsius scale.";
my $celwinclose="Close";
$celwind=$main->Toplevel(width=>300, height=>100);
$celwind->title("Anders Celsius");
my
$celwind_title=$celwind->Label(textvariable=>\$cel_title)->pack(side=>'top');
$celwind_title-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*');


my $celwind_text=$celwind->Label(textvariable=>\$cel_text)->pack(side=>'top',
pady=>5);

$celwind_text-> configure (font=>'-*-helvetica-medium-r-*--*-120-*-*-*-*-*');

my $celbframe=$celwind -> Frame() -> pack(side=>'top', pady=>5);
my $celwind_button=$celbframe->Button(textvariable=>\$celwinclose,  
command=>\&close_cel)->pack(side=>'left', pady=>5);
}

sub close_cel {
$celwind->destroy;
}

sub kelvininfo {
my $kelv_title="Lord Kelvin";
my $kelv_text="Lord Kelvin (Lord William Thomson) invented the kelvin scale";
my $kelvwinclose="Close";
$kelvwind=$main->Toplevel(width=>300, height=>100);
$kelvwind->title("Lord Kelvin");
my
$kelvwind_title=$kelvwind->Label(textvariable=>\$kelv_title)->pack(side=>'top');
$kelvwind_title-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*');


my $kelvwind_text=$kelvwind->Label(textvariable=>\$kelv_text)->pack(side=>'top',
pady=>5);

$kelvwind_text-> configure (font=>'-*-helvetica-medium-r-*--*-120-*-*-*-*-*');

my $kelvbframe=$kelvwind -> Frame() -> pack(side=>'top', pady=>5);
my $kelvwind_button=$kelvbframe->Button(textvariable=>\$kelvwinclose,  
command=>\&close_kelv)->pack(side=>'left', pady=>5);

}

sub close_kelv {   
$kelvwind->destroy;
}


sub fahrenheitinfo {

my $fah_title="Daniel Gabriel  Fahrenheit";
my $fah_text="Daniel Gabriel Fahrenheit invented the Fahrenheit scale.";
my $fahwinclose="Close";
$fahwind=$main->Toplevel(width=>300, height=>100);
$fahwind->title("Daniel Gabriel Fahrenheit");
my $fahwind_title=$fahwind->Label(textvariable=>\$fah_title)->pack(side=>'top');
$fahwind_title-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*');


my
$fahwind_text=$fahwind->Label(textvariable=>\$fah_text)->pack(side=>'top',
pady=>5);

$fahwind_text-> configure (font=>'-*-helvetica-medium-r-*--*-120-*-*-*-*-*');

my $fahbframe=$fahwind -> Frame() -> pack(side=>'top', pady=>5);
my $fahwind_button=$fahbframe->Button(textvariable=>\$fahwinclose,  
command=>\&close_fah)->pack(side=>'left', pady=>5);

}

sub close_fah {
$fahwind->destroy;
}
 

sub licence_window {
my $liwintitle="BSD Licence";
my $liwinclose="Close";
$liwind=$main->Toplevel(width=>300, height=>100);
$liwind->title("TkTemp: BSD Licence");
my $liwind_title=$liwind->Label(textvariable=>\$liwintitle)->pack(side=>'top',
pady=>5);
$liwind_title-> configure (font=>'-*-helvetica-heavy-i-*--*-250-*-*-*-*-*'); 


#my $liwind_text=$liwind->Scrolled('Label(textvariable=>\$bsdlicence)',
#-scrollbars=>'e')->pack(side=>'top',
#pady=>5);
my $liwind_text=$liwind->Scrolled('Text');
tie (*TEXT, 'Tk::Text', $liwind_text);
print TEXT $bsdlicence;
$liwind_text->pack(side=>'top');
#$liwind_text-> configure(font=>'-*-helvetica-medium-r-*--*-120-*-*-*-*-*');


my $liwind_button=$liwind->Button(textvariable=>\$liwinclose,
command=>\&close_licence)->pack(side=>'top', pady=>5);

}

sub close_licence {
$liwind->destroy;
}

sub celsius_info {
print "Celsius";
}

sub time_sock_create { # 1
my ($host, $timeport);
#time protocol port 37 RFC868
$timearray[5]="";
$timearray[0]="notready";
print "Attempting to connect to Time server\n";
if ($timearray[6]==0) {
$timearray[4]==0;
}
if ($timearray[6] == 0) {
if ($timearray[4] == 0) { # 2

$timearray[6]=1;
if ($time_addr[0] == 1) {
if (defined($time_addr[2])) {
$timeport=$time_addr[2];
}
else {
$timeport="time";
}
$host=$time_addr[1];

}
else {
$host = 'time-nw.nist.gov';
$timeport="time";
}
my ($errors, $fh, $fd) =connectsocket(*TIME, $host, $timeport, 'tcp', 'nonblocking');
# print $errors, "\n";
my $testsock=fileno(TIME);
my $sock= \*TIME;
# my $sock=(*TIME);
#my $sock = new IO::Socket::INET (PeerAddr => 'time-nw.nist.gov',
#PeerPort => 37, Proto => 'tcp');
print "fd: ", $sock, "\n";





my $socklen = length($testsock);

if ($socklen > 0) { # 3
print "Connected to $host:$timeport\n";
$timearray[4]=1;
# fcntl $sock, &F_SETFL, O_NONBLOCK;
$rtimelabel->fileevent($sock, 'readable', \&time_sock_event); 
$rtimelabel->fileevent($sock, 'writable', \&time_sock_write);
$timearray[3]=$sock;
#return $sock
} # e 3

else { # 3
print "Time connect failed\n";
$timearray[6]=0;
} # e 3
} #
else {
print "Already connected for update\n";
}
} # e2
else {
print "Already connected for update\n";
}
} # e1

sub time_sock_write {
my $sock=$timearray[3];
print "Socket Writeable\n";
$rtimelabel->fileevent($sock, 'writable', "");
$rtimelabel->fileevent($sock, 'readable', \&time_sock_event);

}

sub time_sock_event { # 1
my $tinbuffer;
my $sock = $timearray[3];
my $result = read($sock, $tinbuffer, 40);
my $tinbufferlen=length($tinbuffer);
if ($tinbufferlen > 0) {
$timearray[5]= $timearray[5] . $tinbuffer;
}
my $tbufferlen=length($timearray[5]);
print "$tinbufferlen byte block recieved.\n";
print "       $tbufferlen total bytes recieved so far\n";
if ($result == 0) { # 2
my $timevaluein=$timearray[5];
print "Disconnecting\n";
$timearray[4]=0;
$timearray[3]="";
$timearray[5]="";

$rtimelabel->fileevent($sock, 'readable', "");
$rtimelabel->fileevent($sock, 'writable', "");
close($sock);
$timearray[6]=0;

if ($tbufferlen==4) { # 3
my $unpackval=unpack("N", $timevaluein);

my $finaltime=$unpackval-2208988800;
$timearray[2]=$finaltime;
$timearray[0]="ready";
print "Time Information Recieved\n";
print "Disconnected\n";
$timearray[6]=0;
} # e 3

} # e 2

elsif ($result == undef) { # 2
} # e 2

else { # 2

if ($tbufferlen > 4) { # 3

# too much data sent


$timearray[4]=0;
$timearray[3]="";
$timearray[5]="";
$rtimelabel->fileevent($sock, 'readable', "");
$rtimelabel->fileevent($sock, 'writable', "");
close($sock);
print "Disconnected\n";
$timearray[6]=0;
} # e 3

elsif ($tbufferlen < 4) { # 3
# too little data, set wait for data
#set time value
$timearray[0]="notready";
$timearray[1]=time();

} # e 3

elsif ($tbufferlen == 4) { # 3
# right amount of data, set recieved condition wait and wait for EOF 
print "Setting local time variable\n";
$timearray[1]=time();

} # e 3


} # e 2
} # e 1

sub set_fh {
my $socket=$_[0];
return $socket;
}

my %sockdb;
my $conncount=0;
my $error;
# my $listensock;

sub socket_listen {
# my $listensock = \*LISTEN;
my $serverport="localhost:8822";
my @errorarray;
my $hostaddr="localhost";

# @errorarray=listensocket($listensock, $serverport, 'tcp', 5);
@errorarray=(1, "Listen created");
if ($serv_addr[0]==1) {
$serverport=$serv_addr[1];
if (defined($serv_addr[2])) {
$serverport="$serverport:" . $serv_addr[2];
}

}
else {
}
$listensock = IO::Socket::INET->new( LocalAddr=>$serverport,
                                    Listen => 5,
                                    Reuse => 1 );

if ($errorarray[0] == 0) {
print "Socket listen create error\n";
print $errorarray[1], "\n";
return;
}
else {
print "Listen socket opened\n";
print $errorarray[1], "\n";

}

fcntl($listensock, &F_SETFL, O_NONBLOCK);
# autoflush $listensock 1;

$rtimelabel->fileevent($listensock, 'readable', [\&listen_event, $listensock]);

}

sub test {
print "worked";
}

sub listen_event { #1
print "Recieved event on socket\n";
my $result;
my @outarray;
my $sock = $_[0];
my $datain;
my $framing = $_[1];
my $protocol = $_[2];
if ($framing eq "") {
  $framing = "newline";
}
if ($protocol eq "") {
  $protocol = "normal";
}
if ($listensock == $sock) { #2
# figure out how to use variables to make filehandle names and references
# figure out how to make objects and references for fd's

++$conncount;
#my $clientsock=\*
#my $clientsock= new FileHandle;
#my $clientsock= new->IO::File;
#my $clientsock= \*{ "CLIENTS0CK" . $conncount };
# my $clientsock= \$clientsockstr;

print "New connection accepting\n";
#print $clientsock, "\n";

#$result=accept($clientsock, $sock);
#if ($result == 0) {
#print "Accept failed\n";
#return;
#}
my $clientsock=$listensock->accept;
fcntl($clientsock, '&F_SETFL', O_NONBLOCK);
# autoflush $clientsock 1;
#$fdnum=fileno($clientsock);
#$clientsock=/$fdnum;
$rtimelabel->fileevent($clientsock, 'readable', [\&listen_event, $clientsock]);
#sockdb format: 
# 0:
# 1:
# 2:
# 3:
# 4:
# 5:
# 6:protocol specific values, embedded array

#userdb format:
#0:

$sockdb{$clientsock}[0]="";
$sockdb{$clientsock}[3]=0;
# $sockdb{$clientsock}[5]=inet_ntoa((unpack_sockaddr_in($result))[1]);
print $sockdb{$clientsock}[5];
sockprint($clientsock, "
\012
TkTemp $version\012
\012
tktemp login>"); 


} #e2

else { #2
print "Read from client socket\n";
$error=sysread($sock, $datain, 40);

if ($error == 0) { #3
#disconnected
print "Socket disconnect\n";
close_sock($sock);
} #e3

elsif ($error == undef) {
#there was an error
print "There was an socket error\n";
}

elsif ($error > 0) { #3
print "Data Recieved\n";
#data in
# print $sock "Echo: ", $datain, "\n";
$sockdb{$sock}[0]=$sockdb{$sock}[0] . $datain;

if ($framing eq "newline") { #4
print "Newline framing\n";
@outarray=split("\n", $sockdb{$sock}[0]);
$sockdb{$sock}[0]="";
my $arrsize = scalar @outarray;
print "Init Array size: $arrsize\n";
if ($arrsize > 0) { #5
my $arrsizeact = $arrsize -1;
#my $lastchar=chomp $outarray[$arrsizeact];
my $len=length($outarray[$arrsizeact]);
my $offset=$len-1;
my $lastchar=substr($outarray[$arrsizeact], $offset, 1);
print "$lastchar\n";
unless ($lastchar eq "\015") { #6
$sockdb{$sock}[0]=$outarray[$arrsizeact];
pop @outarray;
my $arrsize2=scalar @outarray;
print "Final Array size: $arrsize2\n";
} #e6
else {
print "Newline detected\n";
}
} #e5
} #e4

else { #4
#other framing protocol
} #e4

# my $error=0;

foreach my $inval (@outarray) { #4
# chomp $inval;
my $len=length($inval);
my $offset=$len-1;

my $lastchar=substr($inval, $offset, 1);
if ($lastchar eq "\015") {
my $lastchar=substr($inval, $offset, 1, "");

}
proc_protocol($sock, $inval);


} #e4

} #e3
} #e2
} #e1

sub write_event { #1 

my $sock = $_[0];
my $check=0;
my $index=0;
my $arrsize=scalar $sockdb{$sock}[1];
my $error=0;

while ($check==0) { #2

my $inval =${$sockdb{$sock}[1][$index]};
chomp $inval;
my $error=sockprint($sock, $inval);

if ($error==0) { #3
#blocking error, do not remove from queue

#set writeable handler
$error=1;
} #e3

else { #3
#write successful, remove from queu
splice(@{$sockdb{$sock}[1]}, $index, 1);
--$index;
} #e3 

++$index;

if ($index>$arrsize) { #3
$check=1;
} #e3

} #e2
if ($error==1) { #2
# add writeable handler

} #e2
else { #2
# no write errors, queue empty, remove writable handler
$rtimelabel->fileevent($sock, 'writeable', "");
$rtimelabel->fileevent($sock, 'readable', [\&listen_event, $sock]);
} #e2

} #e1

sub sockprint { #1
my $sock=$_[0];
my $inval=$_[1];
my $len=length($_[1]);
my $smyerror=syswrite($_[0], $_[1], $len);
my $messagecode;
my $errorcode;
my $message;

if ($smyerror==0) { #2
#blocking error, add to queue
print "Blocking error\n";
push(@{$sockdb{$sock}[1]}, $inval);
#set writeable handler
$messagecode="BLOCK";
$message="An error occured";
$errorcode=1;
} #e2

else {
$errorcode=0;
}
if ($errorcode==1) { #2
#set writable
$rtimelabel->fileevent($sock, 'writeable', [\&write_event, $sock]);
} #e2
return $errorcode, $messagecode, $message;
} #e1


# my %sockdb;
my %userdb;

sub proc_protocol { #1
#include parsing functions for arguments
my $inval=$_[1];
my $sock=$_[0];
print "Parsing Command: $inval \n";
#remove leading and trailing chars
$inval=~ s/^ +//;
$inval=~ s/ +$//;
if ($sockdb{$sock}[3]==0) { #2
my $len = length($inval);


if (exists($userdb{$inval})) { #3
sockprint $sock, "\015\012This name is already in use. Please enter
another\015\012tktemp login> ";
return;
#new user, look for username
} #e3
elsif ($inval eq "") {
sockprint $sock, "Please enter a username\012tktemp login>";

return;
}

elsif ($inval !~ m/^[\w]+$/) {
sockprint $sock, "Only use alphanumeric characters in usernames\012tktemp
login>";
return;
}

elsif ($len == 20) {
sockprint $sock, "Please choose a name 3 to 20 characters in
length\012tktemp login>";
return;
}

else { #3
# continue
} #e3

sockprint $sock, "Welcome, $inval\015\012";
$sockdb{$sock}[4]=$inval;
$sockdb{$sock}[3]=1;
$userdb{$inval}[0]=$sock;
my $timeval1=time;
my $localtimearr=localtime $timeval1;

sockprint $sock, <<intromsg;




                    TkTemp Information Service
                    Copyright (c) TkTemp 2002 
                       All Rights Reserved

                     $localtimearr





Press enter to continue.
intromsg

sockprint $sock, "tktemp> ";

return;
#} #e3
#return;
} #e2

if ($sockdb{$sock}[6][0] eq "paging") { #2  
print "Processing in paging mode: $inval\n";
pagingmode("existing", $sock, $inval);
return;
} #e2


my $username = $sockdb{$sock}[4];
my @invalarr=split(" ", $inval, 2);
$inval=$invalarr[0];
print $inval, ":\n";
# chomp $inval;
if ($inval eq "/about") {
sockprint $sock, <<endabout;

TkTemp $version

 
endabout
}

elsif ($inval eq "") {
sockprint $sock, <<menu;

1. Time
2. About
3. Quit

Please enter a choice.

menu

}

elsif ($inval eq "/conv") {
#/conv temp tscale
my @inarr=split(" ", $invalarr[1], 2);
my $tscale=$inarr[1];
my $temp=$inarr[0];
my $tscale2="all";

if ($tscale eq "Centigrade") {
$tscale="C";
}
elsif ($tscale eq "Fahrenheit") {
$tscale="F";
}
elsif ($tscale eq "Kelvin") {
$tscale="K";
}
elsif ($tscale eq "Reaumer") {
$tscale="RE";
}
elsif ($tscale eq "Rankine") {
$tscale="R";
}
elsif ($tscale eq "Base360 2") {
$tscale="B2";
}
elsif ($tscale eq "Base360") {
$tscale="B";
}
else {
# continue
}

my ($result, $centtemp)=temptocent($temp, $tscale);
if ($result == 1) {
my @temparr=centtotemp($tscale2, $centtemp);
sockprint $sock, "Temparature conversions for $temp $tscale\012";
my @tnamearr=("Centigrade", "Fahrenheit", "Kelvin", "Reaumer", "Rankine", "U", "U2");
my $count=0;
foreach my $income (@temparr) {
sockprint $sock, "$tnamearr[$count]: $income\012";
++$count;
}
}
else {
sockprint $sock, "Unrecognised temparature scale: $tscale\012";
}
}

elsif ($inval eq "/date") {
#use date function
my $time=time;
my $time=localtime($time);

sockprint $sock, "The date and time are: $time\012";
my @remtimearr=calc_remote_time();
if ($remtimearr[0] == 1) {
sockprint $sock, "The remote date and time are: $remtimearr[1]";
}
else {
sockprint $sock, "The remote date and time are not avialable\012";
}

}

elsif ($inval eq "/users") {
#list users, time connected, hostnames, ports
}

elsif ($inval eq "/quit") {
sockprint $sock, "\015\012Goodbye. Please come back soon.\015\012";
close_sock($sock);

}

elsif ($inval eq "/licence") {
#display BSD licence, paging mode, use paging function
$sockdb{$sock}[6][0]="paging";
print "Entering paging mode\n";
pagingmode("new", $sock, $bsdlicence);
return;
}

elsif ($inval eq "/help") {
my @inarr=split(" ", $invalarr[1]);
my $inarr_len=scalar(@inarr);
my $h_msg;
if ($inarr_len>1) {
sockprint $sock, "/error Too many arguments on /help\012";
}
elsif ($inarr_len==1) {

if ($inarr[0] eq "/licence") {
$h_msg="/licence\012Displays the BSD Licence under which TkTemp is covered\012";
}
elsif($inarr[0] eq "/about") {
$h_msg="/about\012Displays copyright and information about TkTemp\012";
}
elsif($inarr[0] eq "/conv") {
$h_msg="/conv temparature tempscale
Converts from the specified temparature into all 7 supported temparature
scales, fahrenhiet, centigrade, kelvin, rankine, reaumur, Base360, Base360-2
";
}
elsif($inarr[0] eq "/msg") {
$h_msg="/msg touser message
Sends message to specified user on the system
";
}
elsif($inarr[0] eq "/quit") {
$h_msg="/quit
Logs out
";
}
elsif($inarr[0] eq "/date") {
$h_msg="/date
Prints the data, including the time from a time server if available
";
}
elsif($inarr[0] eq "/who") {
$h_msg="/who
Prints a list of users on the system
";
}
else {
$h_msg="Command not recognised: $inarr[0]\012";
}
sockprint $sock, $h_msg;
}
else {
sockprint $sock, "TkTemp $version
$copyright

TkTemp is a program which allows you to convert between 7 different
temparature scales. It is open source and is covered under the BSD Licence.
Please type /licence, or see the TkTemp-LICENCE file for details.

Telnet interface commands:

/about /conv /msg /quit /who /help /licence /date

Please type /help /command for help with these, where command is the command
name you want information on.
";

}

}

elsif ($inval eq "/msg") {
# /msg touser message
print "$invalarr[1]\n";
my @inarr=split(" ", $invalarr[1], 2);
if(exists($userdb{$inarr[0]})) {
my $remsock=$userdb{$inarr[0]}[0];
sockprint $remsock, "\015\012/msgfrom $username $inarr[1]\015\012";
sockprint $remsock, "tktemp> ";
sockprint $sock, "/msg $inarr[1] $inarr[2]\015\012";
}
else {
sockprint $sock, "\015\012/error msg $inarr[1]:Unknown User\015\012";
}

}

elsif ($inval eq "/who") {
my @userarray =keys(%userdb);
foreach my $in (@userarray) {
sockprint $sock, "$in\012";
}
}

else {
sockprint $sock, "\015\012Unrecognised Command\015\012";
}

sockprint $sock, "\015\012tktemp> ";

}

sub proc_framing {

}

sub close_sock { #1
#disconnected
my $sock=$_[0];
if ($sockdb{$sock}[3] == 1) {
my $username=$sockdb{$sock}[4];
delete $userdb{$username};
}
delete $sockdb{$sock};

$rtimelabel->fileevent($sock, 'readable', "");
$rtimelabel->fileevent($sock, 'writeable', "");
close($sock);
} #e1



sub pagingmode { #1
print "Paging mode call\n";
my $inchar=$_[2];
my $pagelen=20;
my $sock=$_[1];
if ($_[0] eq "new") { #2
print "New paging mode call\n";
my ($position, $remaining);
@{$sockdb{$sock}[6][1]} = split_newline($_[2], $pagelen);
my $remain=shift(@{$sockdb{$sock}[6][1]});
if ($remain == 1) { #3
$remaining=pop(@{$sockdb{$sock}[6][1]});
} #e3
$position=1;
print_block($sock, @{$sockdb{$sock}[6][1]}, $position, $pagelen);
sockprint($sock, "Paging mode. Press l to leave, f forward, b back Page 0 R 0\012");
$position=1;
my $pagecount=1;
@{$sockdb{$sock}[6][2]}=($position, $pagecount, $remaining);
return;
} #e2
else { #2
# continue
} #e2
print "Existing paging mode call\n";
my ($position, $pagecount, $remaining)=@{$sockdb{$sock}[6][2]};


if ($inchar eq "f") { #2
my $remainlen=length $remaining;
if ($remainlen==0) { #3
sockprint $sock, "Cannot go further forward\012";
return;
} #e3
++$position;
my $pagecurr = $pagecount;
unless ($position <=  $pagecount) { #3 
my @outarr = split_newline($remaining, 20);
my $remain=shift(@outarr);
if ($remain==1) { #4
$remaining = pop @outarr;
} #e4
++$pagecount;
#++$position;
} #e3
print_block($sock, @{$sockdb{$sock}[6][1]}, $position, $pagelen);
sockprint($sock, "Paging mode. Press l to leave, f forward, b back Page $position R $pagecount\012");
@{$sockdb{$sock}[6][2]}=($position, $pagecount, $remaining);
} #e2



elsif ($inchar eq "r") { #2
print_block($sock, @{$sockdb{$sock}[6][1]}, $position, $pagelen);
sockprint($sock, ">>Paging mode. Press l to leave, f forward, b back , r reprint\012 Page
$position R $pagecount\012");
} #e2

elsif ($inchar eq "b") { #2

if ($position == 0) { #3
sockprint $sock, "cannot go back further Page $position R $pagecount\012";
} #e3
else { #3
$position=$position - 1;
print_block ($sock, @{$sockdb{$sock}[6][1]}, $position, $pagelen);
sockprint($sock, "Paging mode. Press l to leave, f forward, b back Page $position R
$pagecount\012");
@{$sockdb{$sock}[6][2]}=($position, $pagecount, $remaining);

} #e3
} #e2

elsif ($inchar eq "l") { #2
print "Leaving paging mode: $inchar\n";
$sockdb{$sock}[6][0]="normal";
sockprint $sock, "tktemp> \012";
return;
} #e2

else {
sockprint $sock, "Unknown command\012";
sockprint($sock, "Paging mode. Press l to leave, f forward, b back Page $position\012");

}
} #e1



sub print_block { #1

#my $page=pop(@_);
my $pagelen=pop(@_);
my $page=pop(@_);
my $sock=shift(@_);
my $currpage=$page-1;
my $check=1;
my $count=0;
my $pageaddr=$currpage*$pagelen;
my $len=scalar @_;
my $curraddrlen=$pagelen+$pageaddr;
my $effpagelen;
if ($curraddrlen > $len) { #2
my $difference=$curraddrlen-$len;
$effpagelen=$pagelen-$difference;
} #e2
else {   #2
$effpagelen=$pagelen;
} #e2
while ($check==1) { #2
my $currelem=$pageaddr+$count;  
sockprint($sock, "@_[$currelem]\012");
++$count;
if ($count > $effpagelen) { #3
$check=0;
} #e3
} #e2
} #e1


sub split_newline { #1
my $ignorelast;
my $remaining=0;
if (defined($_[1])) { #2
$ignorelast=1;
} #e2
my @splitarr = split("\012", $_[0], $_[1]);
my $count=0;
my $check=1;
my $arrlen=scalar @splitarr;
while($check ==1) { #2
my $len=length @splitarr[$count];
my $lastchar=substr($splitarr[$count], $len-1, 1);
if ($lastchar eq "\015") { #3
chop $splitarr[$count];
} #e3
++$count;
my $fincount;
if ($ignorelast ==1) { #3
$fincount=$count+1;
if ($arrlen>$_[1]) { #4
$remaining=1;
} #e4
} #e3
else { #3
$fincount=$count;
} #e3
if ($fincount > $arrlen) { #3
$check=0;
} #e3
} #e2
return $remaining, @splitarr;
} #e1


sub AUTOLOAD {
my $AUTOLOAD;
print "Unknown subroutine called: $AUTOLOAD\n";
}

