codice:
sub send {
my ($this,$sock,$data,$compr)=@_;
($compr,$sock)=(!$compr,fileno $sock);
if ($this->{Socket}->{$sock}->{Type} eq 'data') {
return undef if ref($data) eq "HASH";
$this->{Socket}->{$sock}->{ToSendBuff}.=$data;
} elsif ($this->{Socket}->{$sock}->{Type} eq 'compdata') {
my $hashato=0;
if (ref($data) eq "HASH") {
return undef unless $data=BinDump::MainDump($data);
$hashato=1;
}
($compr && length($data)>400) ? ($compr =1) : ($compr=0);
$data=compress($data) if $compr;
$this->{Socket}->{$sock}->{ToSendBuff}.="\x9a".pack("ICCI", length($data),$compr,$hashato,crc32($data)).$data;
} else {
croak "cTcp: Unknow type protocol '".$this->{Socket}->{$sock}->{Type}."'";
}
my $dim=length $this->{Socket}->{$sock}->{ToSendBuff};
return undef unless $dim;
if ($this->{Socket}->{$sock}->{BandLimit}) {
unless (exists $this->{tosend}->{Dedicata}->{$sock}) {
$this->{tosend}->{Dedicata}->{$sock}=$this->{Socket}->{$sock}->{BandLimit};
$this->{tosendnum}++;
}
} else {
unless (exists $this->{tosend}->{Comune}->{$sock}) {
$this->{tosend}->{Comune}->{$sock}=1;
$this->{tosendnum}++;
}
}
$this->_RefilBuff();
return $dim;
}
=item recv(socket)
socket sul quale leggere dati.
Torna qualcosa solo se lo socket contiene veramente dei dati, altrimenti torna undef.
Se l'oggetto socket è compdata il valore tornato può essere un riferimento ad un HASH!
Se l'oggetto socket è compdata il pacchetto è disponibile in lettura solo se è stato ricevuto interamente.
=cut
sub recv {
my ($this, $sock,$lung)=@_;
$sock=fileno $sock;
return undef unless exists $this->{Socket}->{$sock};
if ($this->{Socket}->{$sock}->{Type} eq 'data') {
return substr($this->{Socket}->{$sock}->{TmpRecvBuff},0,$lung || length($this->{Socket}->{$sock}->{TmpRecvBuff}),"");
} elsif ($this->{Socket}->{$sock}->{Type} eq 'compdata') {
return shift(@{$this->{Socket}->{$sock}->{RecvBuff}});
}
return undef;
}
=item Remove(socket)
l'oggetto socket specificato non viene più tenuto sotto osservazione.
Eventuali buffer di dati in uscita ed in entrata vengono immediatamente cancellati.
=cut
sub Remove {
my ($this,$sock)=@_;
print "cancellazione $sock\n";
my $socknum=fileno $sock;
delete (%{$this->{Socket}}->{"$socknum"});
$this->{IOS}->{'read'}->remove($sock);
--$this->{tosendnum} if (delete %{$this->{tosend}->{Comune}}->{fileno $sock});
--$this->{tosendnum} if (delete %{$this->{tosend}->{Dedicata}}->{fileno $sock});
}
sub DESTROY {
my $sock=shift;
print "L'oggettone viene distrutto\n";
}
# $this->{Socket}->{fileno $sock}->{BandLimit} Limite di banda per singolo socket
# $this->{tosend}->{$sock} GLi sock con dati nel buffer=>Banda dedicata
# $this->{config}->{BandLimit} Limite di banda generale per tutti gli host
# $this->{Socket}->{$sock}->{ToSendBuff} Dati dello socket da spedire
sub _RefilBuff {
my ($this)=@_;
#1print "ci provo a chiamarlo ".$this->{TimeOut}->{Correct}."\n";
return undef unless $this->{TimeOut}->{Correct}->check();
return undef unless $this->{tosendnum};
my $dedicata=$this->{tosend}->{Dedicata};
my $comune=$this->{tosend}->{Comune};
my $TempoPassato=Time::HiRes::time()-$this->{LastSend};
$this->{LastSend}=Time::HiRes::time();
$TempoPassato=2 if $TempoPassato>2 || $TempoPassato<=0;
my $numero_comuni=scalar(keys(%$comune));
my $socknum;
if ($numero_comuni) {
my $banda_comune_per_host=$this->{config}->{BandLimit}/$numero_comuni*$TempoPassato;
my $resto=0;
foreach $socknum (keys(%$comune)) {
#print "sock num dei comuni $socknum totali $numero_comuni, banda per host $banda_comune_per_host ->".$this->{Socket}->{"$socknum"}->{Sock}."\n";
$resto=_addtobuff($this->{Socket}->{"$socknum"}->{Sock},$banda_comune_per_host+$resto,\$this->{Socket}->{"$socknum"}->{ToSendBuff});
unless (length $this->{Socket}->{$socknum}->{ToSendBuff}) {
#print "un buffer finito di inviare\n";
delete $comune->{$socknum};
$this->{tosendnum}-- if $this->{tosendnum}>0;
_addItem($this->{Return},'EmptyOutBuff',$this->{Socket}->{"$socknum"}->{Sock});
}
}
}
my $numero_dedicati=scalar(keys(%$dedicata));
my ($band);
if ($numero_dedicati) {
while (($socknum,$band)=each(%$dedicata)) {
$band=$band*$TempoPassato if $band>0;
#print "sock num dei dedicati $socknum totali $numero_dedicati, banda $band\n";
_addtobuff($this->{Socket}->{$socknum}->{Sock},$band,\$this->{Socket}->{$socknum}->{ToSendBuff});
unless (length $this->{Socket}->{$socknum}->{ToSendBuff}) {
#print "un buffer finito di inviare\n";
delete $dedicata->{$socknum};
$this->{tosendnum}-- if $this->{tosendnum}>0;
_addItem($this->{Return},'EmptyOutBuff',$this->{Socket}->{"$socknum"}->{Sock});
}
}
}
}
# rimpie il buffer di uno socket e ritorna il numero di byte che non ha spedito.
# Il terzo valore dei parametri (i dati) deve essere passato come reference ad uno scalare.
sub _addtobuff {
my ($sock, $bandlimit, $dati)=@_;
my ($pacchetto);
$bandlimit=int($bandlimit)+1;
#print "refillo $sock\n";
while (_canwrite($sock)) {
($bandlimit>1400) ? ($pacchetto=1400) : (($bandlimit<0) ? ($pacchetto=1400) : ($pacchetto=$bandlimit));
$bandlimit-=$pacchetto;
last unless $pacchetto=substr $$dati,0,$pacchetto,"";
print "spedisco a $sock -> $pacchetto\n";
send $sock,$pacchetto,0;
last if $bandlimit<1;
}
($bandlimit>0) ? (return $bandlimit) : (return 0);
}
sub _canwrite {
my $sock=shift;
my $rin;
vec($rin,fileno($sock),1) = 1;
return select(undef,$rin,undef,0);
}
=head1 SEE ALSO
Portscanner tramite la funzione TryConnect:
require "ctcp.pm";
$ctcp=cTcp->new();
my $port=1;
while (1) {
if ($ref=$ctcp->Select(0.9)) {
foreach $buf (keys(%$ref)) {
print "$buf this socket:\n";
foreach $socket (@{$ref->{$buf}}) {
print "\t$socket:",$socket->peerhost,"-",$socket->peerport,"\n";
# se lo socket non è connesso peerhost e peerport non tornato alcun valore.
}
}
} else {
print "nothing now\n";
}
$ctcp->TryConnect("127.0.0.1",$port,3);
$port++;
$ctcp->TryConnect("127.0.0.1",$port,3);
$port++;
}
=head1 AUTHOR
DanieleG detto anche LordSaga640 °_° e Itami.
=head1 SEE ALSO
L<IO::Socket>, L <IO::Select>
=cut
1;
{
package Cycle; # Fornisce alcune funzione per l'esecuzione di sub a tempi determinati.
use strict;
use Time::HiRes;
# Ad esempio se vogliamo eseguire una funzione solo 3 secondo dopo l'ultima volta che è stata eseguita
# allora si userà questa funzione.
# Le funzioni che fanno uso di questa libreria non contano molto
# sul tempo ma la sfruttao solo per limitare il carico della CPU.
sub new {
my ($package, $cycle)=@_;
my $timer=bless({},$package);
$timer->{last}=Time::HiRes::time();
$timer->{every}=$cycle;
return $timer;
}
sub check {
my $timer=shift;
return undef if Time::HiRes::time()-$timer->{'last'}<$timer->{every};
$timer->{'last'}=Time::HiRes::time();
return 1;
}
}
{
package BinDump;
# Questo package è una mia piccola invenzione.
# Permette di fare il dump di variabili preregistrate o non.
# BinDump 0.01a by Daniele Guiducci
use strict;
# E' la lista delle variabili che si intende registrare.
# Deve essere uguale per tutti i CLIENT che usano questo package.
# Il nome della variabile viene trasformata in numero secondo l'ordine di inserimento.
# Cambiando questo ordine le comunicazione possono essere un po' (TANTO) confuse.
my @RegisterVar= qw();
my %TagName;
{
my ($buf, $cont)=('',0);
foreach $buf (@RegisterVar) {$TagName{$buf}="\x00".pack("C",$cont++);}
}
# $refvar=Riferimento da una variabile (solo HASH)
# $onlyregister= Se Vero fa il dump dei soli valori registrati per gli HASH.
# $subref = Se vero fa il dump dei riferimenti dell'hash (immaginate le sottodirectory).
# Ritorna il pacchetto binario dumpato.
sub MainDump {
my ($refvar,$onlyregister, $subref)=@_;
return undef if ref($refvar) ne "HASH";
return "\x01".HashDump($refvar,$onlyregister, $subref);
}
# Fa L'operazione inmversa di MainDump.
# Come parametro accetta un pacchetto binario.
# Restituisce un puntatore a qualcosa.
sub MainDeDump {
my $pacchetto=shift;
return HashDeDump(\$pacchetto) if substr($pacchetto,0,1,"") eq "\x01";
return undef;
}
# Fa l'operazione inversa di HashDump. Prende la struttura binaria a la scompatta in un HASH.
# Ritorna l'indirizzo dell'hash depaccato.
sub HashDeDump {
my $pacchetto=shift;
my $hash={};
my ($key, $value);
# Controllo il numero delle variabili dell'HASH.
my $num=unpack("I", substr($$pacchetto,0,4,""));
while (length($$pacchetto)>2) {
($key,$value)=(undef,undef);
$key=GetKeyName($pacchetto);
$value=GetValue($pacchetto);
$hash->{$key}=$value if $key && $value
}
return $hash;
}
# data la struttura binaria analizza i primi byte e ne prende il valore
sub GetValue {
my $ref=shift;
my $type=unpack("C",substr($$ref,0,1,""));
if ($type==6) {
my $lung=unpack("I", substr($$ref,0,4,""));
return substr($$ref,0,$lung,"") if $lung;
return "";
}
return unpack("C",substr($$ref,0,1,"")) if $type==1;
return unpack("S",substr($$ref,0,1,"")) if $type==2;
return unpack("I",substr($$ref,0,1,"")) if $type==3;
return substr($$ref,0,16,"") if $type==5;
return HashDeDump($ref) if $type==4;
return undef;
}
# Dato l'indirizzo di uno scalare, tiglie i primi byte e prende il nome della variabile che segue.
# Se il tipo è \x00 allora è una variabile registrata.
# Se è 0x01 allora segue il nome della variabile in formato <Length 1byte><Name>
sub GetKeyName {
my $ref=shift;
my $type= substr($$ref,0,1,"");
my $name;
if ($type eq "\x00") {
my $var=unpack("C", substr($$ref,0,1,""));
return $RegisterVar[$var] if (defined($RegisterVar[$var]));
return undef;
}
if ($type eq "\x01") {
my $lung=unpack("C", substr($$ref,0,1,""));
return substr($$ref,0,$lung,"") if $lung;
}
return undef;
}
# L'HASH viene encodato un un pacchetto binario molto piccolo.
sub HashDump {
my ($refvar,$onlyregister, $subref)=@_;
my ($KeyName,$KeyValue)=('','');
my $Ncoppie=0;
my $struttura="";
WDUMP: while ( my ($key, $value) = each %$refvar ) {
KNAME:
{
$KeyName=$TagName{$key},last KNAME if exists $TagName{$key};
$KeyName="\x01".pack("C/a*",$key),last KNAME unless $onlyregister;
next WDUMP;
}
# 1=Unsigned Char | 2=Unsigned Short | 3=Unsigned Integer | 4=HASH
# 5=HASH 16 BYTE | 6=Stringa
KVALUE:
{
if (ref($value)) { # Se è un riferimento a qualcosa prova a fare il dumping
next WDUMP unless $subref;
$KeyValue="\x04".HashDump($value,$onlyregister,1),last KVALUE if ref($value) eq "HASH";
next WDUMP;
}
if ($value!~ m/\D/ && $value<4294967296) { # Se contiene solo cifre decimali prova a fare il dumping
$KeyValue="\x01".pack("C", $value),last KVALUE if $value<255;
$KeyValue="\x02".pack("S", $value),last KVALUE if $value<65536;
$KeyValue="\x03".pack("I", $value),last KVALUE;
}
$KeyValue="\x05".$value,last KVALUE if length($value)==16;
# Se non è stato individuato un tipo approriato viene encodato come stringa.
# Va bene per qualsiasi tipo di valore.
$KeyValue="\x06".pack ("I/a*", $value);
}
$Ncoppie++;
$struttura.=$KeyName.$KeyValue;
}
return pack("I", $Ncoppie).$struttura;
}
}
1;