r977 - in packages/libnet-easytcp-perl/trunk: . debian util
Gunnar Wolf
gwolf at costa.debian.org
Sun Jul 17 08:09:13 UTC 2005
Author: gwolf
Date: 2005-05-11 15:21:45 +0000 (Wed, 11 May 2005)
New Revision: 977
Added:
packages/libnet-easytcp-perl/trunk/META.yml
Modified:
packages/libnet-easytcp-perl/trunk/Changes
packages/libnet-easytcp-perl/trunk/EasyTCP.pm
packages/libnet-easytcp-perl/trunk/MANIFEST
packages/libnet-easytcp-perl/trunk/debian/changelog
packages/libnet-easytcp-perl/trunk/debian/control
packages/libnet-easytcp-perl/trunk/debian/copyright
packages/libnet-easytcp-perl/trunk/test.pl
packages/libnet-easytcp-perl/trunk/util/attack.pl
packages/libnet-easytcp-perl/trunk/util/client.pl
packages/libnet-easytcp-perl/trunk/util/server.pl
Log:
Upgraded to upstream version 0.26, registered pkg-perl group as maintainer,
upgraded standards-version to 3.6.1
Modified: packages/libnet-easytcp-perl/trunk/Changes
===================================================================
--- packages/libnet-easytcp-perl/trunk/Changes 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/Changes 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,8 +1,89 @@
-$Header: /cvsroot/Net::EasyTCP/Changes,v 1.28 2002/11/10 17:20:33 mina Exp $
+$Header: /cvsroot/Net::EasyTCP/Changes,v 1.40 2004/03/16 21:19:43 mina Exp $
REVISION HISTORY:
+0.26
+ - Minor bugfix that caused a 1-second responsivity lag on the server
+ - Major bugfix that caused data loss when server bombarded client
+
+
+0.25
+ - Added support for 3 new symmetric encryption modules: Crypt::Twofish2,
+ Crypt::Twofish and Crypt::TEA
+
+
+0.24
+ - Fixed a bug that prevented servers running on machines without any encryption
+ or compression modules installed from negotiating correctly unless donotencrypt
+ or donotcompress was supplied to the constructor.
+ - Better comments in the SYNOPSIS examples of a server and a client
+ - A couple of small documentation changes to clarify the difference between
+ a normal client and a hybrid (server-created) client, and the methods
+ available to each. Thanks to Christian Chapman <secret_hamster at hotmail.com>
+
+
+0.23
+ - Fixed a bug in using Crypt::RSA that completely prevented it from functioning
+ on some systems.
+ - Fixed random negotiation failure while using Crypt::RSA by moving the compatability
+ key length of from 338 to 512 bits. Unfortunately, this means that negotiation
+ will take longer :(
+ - Implemented two new parameters to be passed to the "new" constructor:
+ donotcompresswith, and donotencryptwith. These allow you to selectively disable
+ the use of certain compression/encryption modules.
+ - Much better+graceful error-handling for all Encryption and Compression modules
+ - Minor internal code cleanups
+
+
+0.22
+ - Fixed a bug that prevented versions 0.20 and 0.21 from working correctly when
+ Crypt::RSA was installed.
+
+
+0.21
+ - Fixed a bug that prevented version 0.20 clients to talk to servers in older versions.
+
+
+0.20
+ - No more strict dependency on exact versions match for the Storable module, encryption
+ or compression modules.
+ It used to be that Net::EasyTCP clients and servers insisted that if they use a module
+ mentioned above, that both ends used the same version. This was required because it
+ was observed that different versions of the same module could sometime produce
+ incompatible data (which is a bad thing when you're trying to decrypt an encrypted
+ message you just received).
+ This problem is now fixed. During the negotiation phase, the clients and the servers
+ will test all the modules and decide on which to use on compatability checks and the
+ ability to deal with sample data, as opposed to version checks.
+ - Callback suppplied to the start() method will be given the server object as it's only
+ argument as opposed to no arguments.
+ - Internal code cleanups
+
+
+0.19
+ - Fixed a bug in the testing script that caused the test to fail if you already had a
+ TCP/IP daemon on the machine listening on port 2345
+ - Increased the timeout for a client negotiationg with a server to avoid a race
+ condition of a server and a client launching shortly after each other (as in the
+ case of the test script) while the server takes a bit of time to prepare itself
+ before it's ready for negotiation.
+ - Implemented various minor potential bugfixes and fixed some strict/warning error
+ messages thanks to Michael Krause (VKrauseM at web.de)'s patches
+ - Implemented a "timeout" option that you can supply to the new() constructor
+ while creating a new client object, which you can use to override the default
+ 30 second timeout to establish a TCP/IP socket with the server. Thanks to Michael
+ Krause (VKrauseM at web.de)
+ - Minor code cleanup, with slightly faster encryption key generation time compared
+ to version 0.18
+
+
+0.18
+ - Fixed a bug that caused clients on certain OSes (Noticably SunOS 5.6) to randomly fail
+ logging on to a server giving a "Server rejected supplied password" error
+ - Minor internal code cleanups
+
+
0.17
- Fixed some warnings that might have been generated by use strict/warnings. Thanks to
Michael Krause.
Modified: packages/libnet-easytcp-perl/trunk/EasyTCP.pm
===================================================================
--- packages/libnet-easytcp-perl/trunk/EasyTCP.pm 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/EasyTCP.pm 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,11 +1,11 @@
package Net::EasyTCP;
#
-# $Header: /cvsroot/Net::EasyTCP/EasyTCP.pm,v 1.96 2002/11/10 17:20:33 mina Exp $
+# $Header: /cvsroot/Net::EasyTCP/EasyTCP.pm,v 1.144 2004/03/17 14:14:31 mina Exp $
#
use strict;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $_SERIAL %_COMPRESS_AVAILABLE %_ENCRYPT_AVAILABLE %_MISC_AVAILABLE);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $_SERIAL %_COMPRESS_AVAILABLE %_ENCRYPT_AVAILABLE %_MISC_AVAILABLE $PACKETSIZE);
use IO::Socket;
use IO::Select;
@@ -19,1138 +19,120 @@
my $version;
my $hasCBC;
my @_compress_modules = (
+
#
# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
#
# HIGHEST EVER USED: 2
#
- ['1', 'Compress::Zlib'],
- ['2', 'Compress::LZF'],
- );
+ [ '1', 'Compress::Zlib' ],
+ [ '2', 'Compress::LZF' ],
+ );
my @_encrypt_modules = (
+
#
# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
#
- # HIGHEST EVER USED: B
+ # HIGHEST EVER USED: E
#
- ['B', 'Crypt::RSA', 0, 0],
- ['3', 'Crypt::CBC', 0, 0],
- ['A', 'Crypt::Rijndael', 1, 1],
- ['9', 'Crypt::RC6', 1, 1],
- ['4', 'Crypt::Blowfish', 1, 1],
- ['6', 'Crypt::DES_EDE3', 1, 1],
- ['5', 'Crypt::DES', 1, 1],
- ['2', 'Crypt::CipherSaber', 0, 1],
- );
+ [ 'B', 'Crypt::RSA', 0, 0 ],
+ [ '3', 'Crypt::CBC', 0, 0 ],
+ [ 'A', 'Crypt::Rijndael', 1, 1 ],
+ [ '9', 'Crypt::RC6', 1, 1 ],
+ [ '4', 'Crypt::Blowfish', 1, 1 ],
+ [ '6', 'Crypt::DES_EDE3', 1, 1 ],
+ [ '5', 'Crypt::DES', 1, 1 ],
+ [ 'C', 'Crypt::Twofish2', 1, 1 ],
+ [ 'D', 'Crypt::Twofish', 1, 1 ],
+ [ 'E', 'Crypt::TEA', 1, 1 ],
+ [ '2', 'Crypt::CipherSaber', 0, 1 ],
+ );
my @_misc_modules = (
+
#
# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
# (this is not as necessary as compress and encrypt since it's not transmitted to peers, but just in case...)
#
# HIGHEST EVER USED: 1
#
- ['1', 'Crypt::Random'],
- );
+ [ '1', 'Crypt::Random' ],
+ );
+
#
# Let's reset some variables:
#
- $hasCBC = 0;
+ $hasCBC = 0;
$_COMPRESS_AVAILABLE{_order} = [];
- $_ENCRYPT_AVAILABLE{_order} = [];
- $_MISC_AVAILABLE{_order} = [];
+ $_ENCRYPT_AVAILABLE{_order} = [];
+ $_MISC_AVAILABLE{_order} = [];
+
#
# Now we check the compress array for existing modules
#
foreach (@_compress_modules) {
$@ = undef;
eval {
- eval ("require $_->[1];") || die "$_->[1] not found\n";
- $version = eval ("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
- };
+ eval("require $_->[1];") || die "$_->[1] not found\n";
+ $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
+ };
if (!$@) {
- push (@{$_COMPRESS_AVAILABLE{_order}}, $_->[0]);
- $_COMPRESS_AVAILABLE{$_->[0]}{name} = $_->[1];
- $_COMPRESS_AVAILABLE{$_->[0]}{version} = $version;
- }
+ push(@{ $_COMPRESS_AVAILABLE{_order} }, $_->[0]);
+ $_COMPRESS_AVAILABLE{ $_->[0] }{name} = $_->[1];
+ $_COMPRESS_AVAILABLE{ $_->[0] }{version} = $version;
}
+ }
+
#
# Now we check the encrypt array for existing modules
#
foreach (@_encrypt_modules) {
$@ = undef;
eval {
- eval ("require $_->[1];") || die "$_->[1] not found\n";
- $version = eval ("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
- };
+ eval("require $_->[1];") || die "$_->[1] not found\n";
+ $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
+ };
if (!$@) {
if ($_->[1] eq 'Crypt::CBC') {
$hasCBC = 1;
- }
+ }
elsif (($hasCBC && $_->[2]) || !$_->[2]) {
- push (@{$_ENCRYPT_AVAILABLE{_order}}, $_->[0]);
- $_ENCRYPT_AVAILABLE{$_->[0]}{name} = $_->[1];
- $_ENCRYPT_AVAILABLE{$_->[0]}{cbc} = $_->[2];
- $_ENCRYPT_AVAILABLE{$_->[0]}{mergewithpassword} = $_->[3];
- $_ENCRYPT_AVAILABLE{$_->[0]}{version} = $version;
- }
+ push(@{ $_ENCRYPT_AVAILABLE{_order} }, $_->[0]);
+ $_ENCRYPT_AVAILABLE{ $_->[0] }{name} = $_->[1];
+ $_ENCRYPT_AVAILABLE{ $_->[0] }{cbc} = $_->[2];
+ $_ENCRYPT_AVAILABLE{ $_->[0] }{mergewithpassword} = $_->[3];
+ $_ENCRYPT_AVAILABLE{ $_->[0] }{version} = $version;
}
}
+ }
+
#
# Now we check the misc array for existing modules
#
foreach (@_misc_modules) {
$@ = undef;
eval {
- eval ("require $_->[1];") || die "$_->[1] not found\n";
- $version = eval ("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
- };
+ eval("require $_->[1];") || die "$_->[1] not found\n";
+ $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
+ };
if (!$@) {
- push (@{$_MISC_AVAILABLE{_order}}, $_->[0]);
- $_MISC_AVAILABLE{$_->[0]}{name} = $_->[1];
- $_MISC_AVAILABLE{$_->[0]}{version} = $version;
- }
+ push(@{ $_MISC_AVAILABLE{_order} }, $_->[0]);
+ $_MISC_AVAILABLE{ $_->[0] }{name} = $_->[1];
+ $_MISC_AVAILABLE{ $_->[0] }{version} = $version;
}
}
+}
require Exporter;
-require AutoLoader;
- at ISA = qw(Exporter AutoLoader);
-# Items to export into callers namespace by default. Note: do not export
-# names by default without a very good reason. Use EXPORT_OK instead.
-# Do not simply export all your public functions/methods/constants.
- at EXPORT = qw();
-$VERSION = '0.17';
+ at ISA = qw(Exporter);
+ at EXPORT = qw();
+$VERSION = '0.26';
+$PACKETSIZE = 4096;
-# Preloaded methods go here.
-
#
-# This generates a global keypair and stores it globally
-# Takes the name of a module, returns true or false
+# POD DOCUMENTATION:
#
-sub _generateglobalkeypair() {
- my $module = shift || return undef;
- foreach (keys %_ENCRYPT_AVAILABLE) {
- if ($_ ne "_order" && $_ENCRYPT_AVAILABLE{$_}{name} eq $module) {
- ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = ();
- ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = &_genkey($_) or return undef;
- last;
- }
- }
- return 1;
- }
-#
-# This takes any string and returns it in ascii format
-#
-sub _bin2asc() {
- my $data = shift;
- $data =~ s/(.)/ '%' . sprintf('%02x',ord($1)) /ges;
- $data = uc($data);
- return $data;
- }
-
-#
-# This does the opposite of _bin2asc
-#
-sub _asc2bin() {
- my $data = shift;
- $data =~ s/\%([0-9A-F]{2})/ sprintf("%c",hex($1)) /ges;
- return $data;
- }
-
-#
-# This does very very primitive 2-way encryption & decryption (kinda like ROT13.. works both ways)
-# Takes a client and a string, returns the enc/dec/rypted string
-#
-# This encryption is used to protect the encrypted password and the public key transmitted over the wire
-# It's a last resort of security in case none of the encryption modules were found
-#
-sub _munge() {
- my $client = shift || return undef;
- my $data = shift;
- #
- # Munge's tricky because is existed on and off in different versions
- #
- if (defined $data && ($client->{_version} == 0.07 || $client->{_version} == 0.08 || $client->{_version} >= 0.15)) {
- # Peer supports munge
- my $c;
- my $t;
- for (0..length($data)-1) {
- $c = substr($data, $_, 1);
- $t = vec($c, 0, 4);
- vec($c, 0, 4) = vec($c, 1, 4);
- vec($c, 1, 4) = $t;
- substr($data, $_, 1) = $c;
- }
- $data = reverse($data);
- }
- else {
- # Our peer doesn't munge, so we won't either
- }
- return $data;
- }
-
-#
-# This takes a client object and a callback keyword and calls back the associated sub if possible
-#
-sub _callback() {
- my $client = shift;
- my $type = shift;
- if (!$client->{_negotiating} && $client->{_callbacks}->{$type}) {
- &{$client->{_callbacks}->{$type}}($client);
- }
- }
-
-#
-# This takes in an encryption key id and generates a key(pair) and returns it/them according to the type
-# of encryption specified
-# Returns undef on error
-# If there are already a keypair for the specified module stored globally, it will return that instead of
-# generating new ones.
-#
-sub _genkey() {
- my $modulekey = shift;
- my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
- my $key1 = undef;
- my $key2 = undef;
- my $temp;
- $@ = undef;
- if ($_ENCRYPT_AVAILABLE{$modulekey}{localpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}) {
- $key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey};
- $key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey};
- }
- elsif ($module eq 'Crypt::RSA') {
- $temp = Crypt::RSA->new();
- ($key1, $key2) = $temp->keygen (
- Size => 512,
- Verbosity => 0,
- )
- or $@ = $temp->errstr();
- if ($key1) {
- $key1 = &_bin2asc(nfreeze($key1));
- }
- }
- elsif ($module eq 'Crypt::Rijndael') {
- $key1 = &_genrandstring(32);
- $key2 = $key1;
- }
- elsif ($module eq 'Crypt::RC6') {
- $key1 = &_genrandstring(32);
- $key2 = $key1;
- }
- elsif ($module eq 'Crypt::Blowfish') {
- $key1 = &_genrandstring(56);
- $key2 = $key1;
- }
- elsif ($module eq 'Crypt::DES_EDE3') {
- $key1 = &_genrandstring(24);
- $key2 = $key1;
- }
- elsif ($module eq 'Crypt::DES') {
- $key1 = &_genrandstring(8);
- $key2 = $key1;
- }
- elsif ($module eq 'Crypt::CipherSaber') {
- $key1 = &_genrandstring(32);
- $key2 = $key1;
- }
- else {
- $@ = "Unknown encryption module [$module] modulekey [$modulekey]";
- }
- if (!$key1 || !$key2) {
- $@ = "Could not generate encryption keys. $@";
- }
- return ($key1, $key2);
- }
-
-#
-# This takes client object, and a reference to a scalar
-# And if it can, compresses scalar, modifying the original, via the specified module in the client object
-# Returns true if successful, false if not
-#
-sub _compress() {
- my $client = shift;
- my $rdata = shift;
- my $modulekey = $client->{_compress} || return undef;
- my $module = $_COMPRESS_AVAILABLE{$modulekey}{name};
- if ($module eq 'Compress::Zlib') {
- $$rdata = Compress::Zlib::compress($$rdata);
- return 1;
- }
- elsif ($module eq 'Compress::LZF') {
- $$rdata = Compress::LZF::compress($$rdata);
- return 1;
- }
- return undef;
- }
-
-#
-# This does the opposite of _compress()
-#
-sub _decompress() {
- my $client = shift;
- my $rdata = shift;
- my $modulekey = $client->{_compress};
- my $module = $_COMPRESS_AVAILABLE{$modulekey}{name};
- if ($module eq 'Compress::Zlib') {
- $$rdata = Compress::Zlib::uncompress($$rdata);
- return 1;
- }
- elsif ($module eq 'Compress::LZF') {
- $$rdata = Compress::LZF::decompress($$rdata);
- return 1;
- }
- return undef;
- }
-
-#
-# This takes client object, and a reference to a scalar
-# And if it can, encrypts scalar, modifying the original, via the specified module in the client object
-# Returns true if successful, false if not
-#
-sub _encrypt() {
- my $client = shift;
- my $rdata = shift;
- my $modulekey = $client->{_encrypt} || return undef;
- my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
- my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
- my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
- my $temp;
- my $publickey = $client->{_remotepublickey} || return undef;
- my $cleanpassword;
- if (defined $client->{_password}) {
- $cleanpassword = $client->{_password};
- $cleanpassword =~ s/[^a-z0-9]//gi;
- }
- else {
- $cleanpassword = undef;
- }
- #
- # IF there is a password for the connection, and we're using Symmetric encryption, we include the password
- # in the encryption key used
- #
- if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
- if (length($cleanpassword) <= length($publickey)) {
- substr($publickey, 0, length($cleanpassword)) = $cleanpassword;
- }
- elsif (length($cleanpassword) > length($publickey)) {
- $publickey = substr($cleanpassword, 0, length($publickey));
- }
- else {
- $@ = "Failed to merge password with symmetric encryption key";
- return undef;
- }
- }
- if ($publickey =~ /^(\%[0-9A-F]{2})+$/) {
- #
- # In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them
- #
- $publickey = thaw(&_asc2bin($publickey)) || return undef;
- $client->{_remotepublickey} = $publickey;
- }
-
- if ($module eq 'Crypt::RSA') {
- $temp = Crypt::RSA->new();
- $$rdata = $temp->encrypt(
- Message => $$rdata,
- Key => $publickey,
- Armour => 0,
- )
- or return undef;
- return 1;
- }
- elsif ($module eq 'Crypt::CipherSaber') {
- $temp = Crypt::CipherSaber->new($publickey);
- $$rdata = $temp->encrypt($$rdata);
- return 1;
- }
- elsif ($cbc) {
- $temp = Crypt::CBC->new($publickey, $module);
- $$rdata = $temp->encrypt($$rdata);
- return 1;
- }
- return undef;
- }
-
-#
-# Does the opposite of _encrypt();
-#
-sub _decrypt() {
- my $client = shift;
- my $rdata = shift;
- my $modulekey = $client->{_encrypt} || return undef;
- my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
- my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
- my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
- my $temp;
- my $privatekey = $client->{_localprivatekey} || return undef;
- my $cleanpassword;
- if (defined $client->{_password}) {
- $cleanpassword = $client->{_password};
- $cleanpassword =~ s/[^a-z0-9]//gi;
- }
- else {
- $cleanpassword = undef;
- }
- #
- # IF there is a password for the connection, and we're using Symmetric encryption, we include the password
- # in the decryption key used
- #
- if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
- if (length($cleanpassword) <= length($privatekey)) {
- substr($privatekey, 0, length($cleanpassword)) = $cleanpassword;
- }
- elsif (length($cleanpassword) > length($privatekey)) {
- $privatekey = substr($cleanpassword, 0, length($privatekey));
- }
- else {
- $@ = "Failed to merge password with symmetric encryption key";
- return undef;
- }
- }
-
- if ($module eq 'Crypt::RSA') {
- $temp = Crypt::RSA->new();
- $$rdata = $temp->decrypt(
- Cyphertext => $$rdata,
- Key => $privatekey,
- Armour => 0,
- )
- or return undef;
- return 1;
- }
- elsif ($module eq 'Crypt::CipherSaber') {
- $temp = Crypt::CipherSaber->new($privatekey);
- $$rdata = $temp->decrypt($$rdata);
- return 1;
- }
- elsif ($cbc) {
- $temp = Crypt::CBC->new($privatekey, $module);
- $$rdata = $temp->decrypt($$rdata);
- return 1;
- }
- return undef;
- }
-
-#
-# This sub returns a random string
-# Expects an integer (length)
-#
-sub _genrandstring() {
- my $l = shift;
- my $key;
- my $avoid;
- my $module;
- my $version;
- #
- # First, we try one of the fancy randomness modules possibly in %_MISC_AVAILABLE
- #
- foreach (@{$_MISC_AVAILABLE{_order}}) {
- $module = $_MISC_AVAILABLE{$_}{name};
- $version = $_MISC_AVAILABLE{$_}{version};
- #
- # Note that Crypt::Random has the makerandom_octet function ONLY in 0.34 and higher
- #
- if ($module eq "Crypt::Random" && $version >= 0.34) {
- for (0..33,127..255) {
- $avoid .= chr($_);
- }
- $key = Crypt::Random::makerandom_octet(
- Length => $l,
- Skip => $avoid,
- );
- return $key;
- }
- }
- #
- # If we've reached here, then no modules were found. We'll use perl's builtin rand() to generate
- # the string
- #
- for (1..$l) {
- $key .= chr(int(rand(93))+33);
- }
- return $key;
- }
-
-#
-# Once a new client is connected it calls this to negotiate basics with the server
-# This must return true once all negotiations succeed or false if not
-#
-sub _client_negotiate() {
- my $client = shift;
- my $reply;
- my $timeout = 45;
- my @P;
- my $command;
- my $data;
- my $temp;
- my $temp2;
- my $version;
- my $evl;
- my $starttime = time;
- while ((time-$starttime) < $timeout) {
- $reply = $client->receive($timeout, 1);
- if (!defined $reply) {
- last;
- }
- @P = split(/\x00/, $reply);
- $command = shift (@P);
- $evl = undef;
- $data = undef;
- if (!$command) {
- $@ = "Error negotiating with server. No command received.";
- return undef;
- }
- if ($command eq "PF") {
- #
- # Password Failure
- #
- $client->{_authenticated} = 0;
- $@ = "Server rejected supplied password";
- return undef;
- }
- elsif ($command eq "CVF" && !$client->{_donotcheckversion}) {
- #
- # Compression Version Failure
- #
- $temp = $_COMPRESS_AVAILABLE{$client->{_compress}}{name};
- $version = $_COMPRESS_AVAILABLE{$client->{_compress}}{version};
- $@ = "Compression version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
- return undef;
- }
- elsif ($command eq "EVF" && !$client->{_donotcheckversion}) {
- #
- # Encryption Version Failure
- #
- $temp = $_ENCRYPT_AVAILABLE{$client->{_encrypt}}{name};
- $version = $_ENCRYPT_AVAILABLE{$client->{_encrypt}}{version};
- $@ = "Encryption version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
- return undef;
- }
- elsif ($command eq "EN") {
- #
- # End of negotiation
- #
- $data = "EN";
- $evl = 'return("RETURN1");';
- }
- elsif ($command eq "VE") {
- #
- # Version of module
- #
- $client->{_version} = $P[0];
- $data = "VE\x00$VERSION";
- }
- elsif ($command eq "SVE") {
- #
- # Version of the Storable module
- #
- $data = "SVE\x00" . $Storable::VERSION;
- }
- elsif ($command eq "SVF" && !$client->{_donotcheckversion}) {
- #
- # Storable Module Version Failure
- #
- $version = $Storable::VERSION;
- $@ = "Version mismatch for the Storable module : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
- return undef;
- }
- elsif ($command eq "CS") {
- #
- # Crypt Salt
- #
- # We assume that we've authenticated successfully
- $client->{_authenticated} = 1;
- $temp = &_munge($client, crypt($client->{_password}, $P[0]));
- $data = "CP\x00$temp";
- }
- elsif ($command eq "EK") {
- #
- # Encryption key
- #
- $client->{_remotepublickey} = &_munge($client, $P[0]);
- $data = "EK\x00";
- $data .= &_munge($client, $client->{_localpublickey});
- }
- elsif ($command eq "EA") {
- #
- # Encryption available
- #
- $temp2 = "";
- $version = "";
- if(!$client->{_donotencrypt}) {
- foreach (@P) {
- if ($_ENCRYPT_AVAILABLE{$_}) {
- $temp2 = $_;
- $version = $_ENCRYPT_AVAILABLE{$_}{version};
- last;
- }
- }
- $temp2 ||= "";
- $version ||= "";
- }
- $data = "EU\x00$temp2\x00$version";
- if ($temp2) {
- $evl = '$client->{_encrypt} = $temp2;';
- $evl .= '($client->{_localpublickey},$client->{_localprivatekey}) =';
- $evl .= ' &_genkey($client->{_encrypt}) or ';
- $evl .= ' return("RETURN0"); ';
- }
- }
- elsif ($command eq "CA") {
- #
- # Compression available
- #
- $temp2 = "";
- $version = "";
- if(!$client->{_donotcompress}) {
- foreach (@P) {
- if ($_COMPRESS_AVAILABLE{$_}) {
- $temp2 = $_;
- $version = $_COMPRESS_AVAILABLE{$_}{version};
- last;
- }
- }
- $temp2 ||= "";
- $version ||= "";
- }
- $data = "CU\x00$temp2\x00$version";
- if ($temp2) {
- $evl = '$client->{_compress} = $temp2;';
- }
- }
- else {
- #
- # No Operation (do nothing)
- #
- $data = "NO";
- }
- if (defined $data && !&_send($client, $data, 0)) {
- $@ = "Error negotiating with server: Could not send : $@";
- return undef;
- }
- #
- # NOW WE SEE IF WE NEED TO EVL ANYTHING
- # IF THE RESULT OF THE EVAL IS "RETURNx" WHERE X IS A NUMBER, WE RETURN
- # OTHERWISE WE KEEP GOING
- #
- if (defined $evl) {
- $evl = eval($evl);
- if ($evl =~ /^RETURN(.+)$/) {
- return (($1) ? $1 : undef);
- }
- }
- }
- $@ = "Client timed out while negotiating with server: $@";
- return undef;
- }
-
-#
-# Once the server accepts a new connection, it calls this to negotiate basics with the client
-# Unlike _client_negotiate() which does not return until negotiation is over, this sub
-# sends 1 command or parses one reply at a time then returns immediately
-# Although this is much more complicated, it needs to be done so
-# the server does not block when a client is negotiating with it
-#
-# Expects a client object
-#
-sub _serverclient_negotiate() {
- my $client = shift;
- my $reply;
- my $temp;
- my @P;
- my $command;
- my $version;
-
- if (!$client->{_negotiating}) {
- return 1;
- }
-
- $reply = $client->data(1);
-
- # Let's avoid some strict claimings
- if (!defined $reply) { $reply = "" };
- if (!defined $client->{_negotiating_lastevent}) { $client->{_negotiating_lastevent} = "" }
-
- if (length($reply)) {
- #
- # We're parsing a reply the other end sent us
- #
- @P = split(/\x00/, $reply);
- $command = shift(@P);
- if (!$command) {
- $@ = "Error negotiating. No command received from client : $@";
- return undef;
- }
- $client->{_negotiating_lastevent} = "received";
- if ($command eq "EU") {
- #
- # Encryption Use
- #
- $client->{_encrypt} = $P[0];
- if ($client->{_encrypt}) {
- $version = $_ENCRYPT_AVAILABLE{$P[0]}{version};
- if ($version ne $P[1]) {
- unshift(@{$client->{_negotiating_commands}}, "EVF\x00$version");
- }
- ($client->{_localpublickey}, $client->{_localprivatekey}) = &_genkey($client->{_encrypt}) or return undef;
- }
- $temp = "EK\x00";
- $temp .= &_munge($client, $client->{_localpublickey});
- unshift(@{$client->{_negotiating_commands}}, $temp);
- }
- elsif ($command eq "CP") {
- #
- # Crypt Password
- #
- if (&_munge($client, $P[0]) eq crypt($client->{_password}, $client->{_cryptsalt}) ) {
- $client->{_authenticated} = 1;
- }
- else {
- $client->{_authenticated} = 0;
- unshift(@{$client->{_negotiating_commands}}, "PF");
- }
- }
- elsif ($command eq "VE") {
- #
- # Version
- #
- $client->{_version} = $P[0];
- }
- elsif ($command eq "SVE") {
- #
- # Version of Storable
- #
- if ($P[0] ne $Storable::VERSION) {
- unshift(@{$client->{_negotiating_commands}}, "SVF\x00" . $Storable::VERSION);
- }
- }
- elsif ($command eq "CU") {
- #
- # Compression Use
- #
- $client->{_compress} = $P[0];
- if ($client->{_compress}) {
- $version = $_COMPRESS_AVAILABLE{$P[0]}{version};
- if ($version ne $P[1]) {
- unshift(@{$client->{_negotiating_commands}}, "CVF\x00$version");
- }
- }
- }
- elsif ($command eq "EK") {
- #
- # Encryption Key
- #
- $client->{_remotepublickey} = &_munge($client, $P[0]);
- }
- elsif ($command eq "EN") {
- #
- # End (of negotiation)
- #
- if ((defined $client->{_password} && length($client->{_password})) && !$client->{_authenticated}) {
- return undef;
- }
- else {
- $client->{_negotiating} = 0;
- delete $client->{_negotiating_lastevent};
- delete $client->{_negotiating_commands};
- return 1;
- }
- }
- else {
- # received unknown reply. so what..
- }
- }
- elsif ($client->{_negotiating_lastevent} ne "sent") {
- # We're sending a command to the other end, now we have to figure out which one
- &_serverclient_negotiate_sendnext($client);
- }
- return undef;
- }
-
-#
-# This is called by _serverclient_negotiate(). It's job is to figure out what's the next command to send
-# to the other end and send it.
-#
-# Expects a client object and a class
-#
-sub _serverclient_negotiate_sendnext() {
- my $client = shift;
- my $class = $client;
- my $data;
- $class =~ s/=.*//g;
-
- if (!defined $client->{_negotiating_commands}) {
- # Let's initialize the sequence of commands we send
- $data = "\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n";
- $data .= "-----BEGIN CLEARTEXT WELCOME MESSAGE-----\r\n";
- $data .= "::\r\n";
- $data .= ":: HELLO :: $class VERSION $VERSION :: SERVER READY ::\r\n";
- $data .= "::\r\n";
- if ($client->{_welcome}) {
- $data .= ":: $client->{_welcome}\r\n";
- $data .= "::\r\n";
- }
- $data .= "-----END CLEARTEXT WELCOME MESSAGE-----\r\n";
- push (@{$client->{_negotiating_commands}}, $data);
- $data = "VE\x00$VERSION";
- push (@{$client->{_negotiating_commands}}, $data);
- $data = "SVE";
- push (@{$client->{_negotiating_commands}}, $data);
- if (!$client->{_donotencrypt}) {
- $data = "EA";
- foreach (@{$_ENCRYPT_AVAILABLE{_order}}) {
- $data .= "\x00$_";
- }
- push (@{$client->{_negotiating_commands}}, $data);
- }
- if (!$client->{_donotcompress}) {
- $data = "CA";
- foreach (@{$_COMPRESS_AVAILABLE{_order}}) {
- $data .= "\x00$_";
- }
- push (@{$client->{_negotiating_commands}}, $data);
- }
- if (defined $client->{_password}) {
- if (!exists $client->{_cryptsalt}) {
- $client->{_cryptsalt} = &_genrandstring(2);
- }
- $data = "CS\x00" . $client->{_cryptsalt};
- push (@{$client->{_negotiating_commands}}, $data);
- }
- push (@{$client->{_negotiating_commands}}, "EN");
- }
-
- $data = shift @{$client->{_negotiating_commands}};
- if (!defined $data) {
- return undef;
- }
- if (!&_send($client, $data, 0)) {
- $@ = "Error negotiating with client. Could not send : $@";
- return undef;
- }
- $client->{_negotiating_lastevent} = "sent";
- return 1;
- }
-
-#
-# This is called whenever a client (true client or serverclient) receives data without the realdata bit set
-# It would parse the data and probably set variables inside the client object
-#
-sub _parseinternaldata() {
- my $client = shift;
- my $data;
- if ($client->{_mode} eq "serverclient" && $client->{_negotiating}) {
- # The serverclient is still negotiating
- if (&_serverclient_negotiate($client) ) {
- # Negotiation's complete and successful
- &_callback($client, "connect");
- }
- }
- else {
- # It's normal internal data
- $data = $client->data(1);
- }
- }
-
-
-
-#
-# This takes an integer, packs it as tightly as possible as a binary representation
-# and returns the binary value
-#
-sub _packint() {
- my $int = shift;
- my $bin;
- $bin = pack("N", $int);
- $bin =~ s/^\0+//;
- return $bin;
- }
-
-#
-# This does the opposite of _packint. It takes a packed binary produced by _packint and
-# returns the integer
-#
-sub _unpackint() {
- my $bin = shift;
- my $int;
- $int = "\0" x (4-length($bin)) . $bin;
- $int = unpack("N", $int);
- return $int;
- }
-
-#
-# This creates a new client object and outgoing connection and returns it as an object
-# , or returns undef if unsuccessful
-# If special parameter _sock is supplied, it will be taken as an existing connection
-# and not outgoing connection will be made
-#
-sub _new_client() {
- my $class = shift;
- my %para = @_;
- my $sock;
- my $self = {};
- my $temp;
- my $remoteip;
- my $remoteport;
- $class =~ s/=.*//g;
- if (!$para{_sock}) {
- if (!$para{host}) {
- $@ = "Invalid host";
- return undef;
- }
- elsif (!$para{port}) {
- $@ = "Invalid port";
- return undef;
- }
- $sock = new IO::Socket::INET(
- PeerAddr => $para{host},
- PeerPort => $para{port},
- Proto => 'tcp',
- Timeout => 30,
- );
- $self->{_mode} = "client";
- $self->{_negotiating} = time;
- }
- else {
- $sock = $para{_sock};
- $self->{_mode} = "serverclient";
- $self->{_negotiating} = time;
- $self->{_authenticated} = 0;
- }
- if (!$sock) {
- $@ = "Could not connect to $para{host}:$para{port}: $!";
- return undef;
- }
- $sock->autoflush(1);
- if ($para{_remoteport} && $para{_remoteip}) {
- $self->{_remoteport} = $para{_remoteport};
- $self->{_remoteip} = $para{_remoteip};
- }
- else {
- if (!($temp = getpeername($sock))) {
- $@ = "Error getting peername";
- return undef;
- }
- if (!(($remoteport, $remoteip) = sockaddr_in($temp))) {
- $@ = "Error getting socket address";
- return undef;
- }
- if (!($self->{_remoteip} = inet_ntoa($remoteip))) {
- $@ = "Error determing remote IP";
- return undef;
- }
- $self->{_remoteport} = $remoteport;
- }
- $self->{_sock} = $sock;
- $self->{_password} = $para{password};
- $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0;
- $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0;
- $self->{_donotcheckversion} = ($para{donotcheckversion}) ? 1 : 0;
- $self->{_localpublickey} = "";
- $self->{_data} = [];
- bless ($self, $class);
- if ($self->{_mode} eq "client") {
- if (!&_client_negotiate($self)) {
- # Bad server
- $self->close();
- $@ = "Error negotiating with server: $@";
- return undef;
- }
- else {
- $self->{_negotiating} = 0;
- }
- }
- return $self;
- }
-
-#
-# This creates a new listening server object and returns it, or returns undef if unsuccessful
-#
-# Expects a class
-#
-sub _new_server() {
- my $class = shift;
- my %para = @_;
- my $sock;
- my $self = {};
- if (!$para{port}) {
- $@ = "Invalid port";
- return undef;
- }
- $sock = new IO::Socket::INET(
- LocalPort => $para{port},
- Proto => 'tcp',
- Listen => SOMAXCONN,
- Reuse => 1,
- );
- if (!$sock) {
- $@ = "Could not create listening socket on port $para{port}: $!";
- return undef;
- }
- $sock->autoflush(1);
- $self->{_sock} = $sock;
- $self->{_selector} = new IO::Select;
- $self->{_selector}->add($sock);
- $self->{_mode} = "server";
- $self->{_welcome} = $para{welcome};
- $self->{_password} = $para{password};
- $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0;
- $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0;
- $self->{_clients} = {};
- $self->{_clientip} = {};
- #
- # To avoid key-gen delays while running, let's create global RSA keypairs right now
- #
- if (!$self->{_donotencrypt}) {
- if (!&_generateglobalkeypair('Crypt::RSA')) {
- $@ = "Could not generate global Crypt::RSA keypairs. $@";
- return undef;
- }
- }
- bless($self, $class);
- return $self;
- }
-
-#
-# This takes a client object and tries to extract a full packet out of it's received data buffer
-# If no valid data found, returns undef
-# If data found, it deletes it from the data buffer and pushes it into the data field
-# Then returns 1 if the data was real data, or 0 if the data was not real data (internal data)
-#
-sub _extractdata() {
- my $client = shift;
- my $key = (exists $client->{_databuffer}) ? substr($client->{_databuffer}, 0, 2) : '';
- my ($alwayson, $complexstructure, $realdata, $reserved, $encrypted, $compressed, $lenlen);
- my $lendata;
- my $len;
- my $data;
- if (length($key) != 2) {
- return undef;
- }
- $alwayson = vec($key, 0, 1);
- $complexstructure = vec($key, 1, 1);
- $realdata = vec($key, 2, 1);
- $encrypted = vec($key, 3, 1);
- $compressed = vec($key, 4, 1);
- $reserved = vec($key, 5, 1);
- $reserved = vec($key, 6, 1);
- $reserved = vec($key, 7, 1);
- $lenlen = vec($key, 1, 8);
- if (!$alwayson) {
- return undef;
- }
- $len = substr($client->{_databuffer}, 2, $lenlen);
- $lendata = &_unpackint($len);
- if (length($client->{_databuffer}) < (2+$lenlen+$lendata)) {
- return undef;
- }
- $data = substr($client->{_databuffer}, 2+$lenlen, $lendata);
- if (length($data) != $lendata) {
- return undef;
- }
- substr($client->{_databuffer}, 0, 2 + $lenlen + $lendata) = '';
- if ($encrypted) {
- &_decrypt($client, \$data) || return undef;
- }
- if ($compressed) {
- &_decompress($client, \$data) || return undef;
- }
- if ($complexstructure) {
- $data = thaw($data);
- if (!$data) {
- $@ = "Error decompressing complex structure: $!";
- return undef;
- }
- }
- push ( @{$client->{_data}} , $data );
- return ($realdata);
- }
-
-#
-# This takes a client object and data, serializes the data if necesary, constructs a proprietary protocol packet
-# containing the user's data in it, implements crypto and compression as needed, and sends the packet to the supplied socket
-# Returns 1 for success, undef on failure
-#
-sub _send() {
- my $client = shift;
- my $data = shift;
- my $realdata = shift;
- my $sock = $client->{_sock};
- my $encrypted;
- my $compressed;
- my $lendata;
- my $lenlen;
- my $len;
- my $key;
- my $finaldata;
- my $packet;
- my $packetsize = 4096;
- my $temp;
- my $complexstructure = ref($data);
- if (!$sock) {
- $@ = "Error sending data: Socket handle not supplied";
- return undef;
- }
- elsif (!defined $data) {
- $@ = "Error sending data: Data not supplied";
- return undef;
- }
- if ($complexstructure) {
- $data = nfreeze $data;
- }
- $compressed = ($client->{_donotcompress}) ? 0 : &_compress($client, \$data);
- $encrypted = ($client->{_donotencrypt}) ? 0 : &_encrypt($client, \$data);
- $lendata = length($data);
- $len = &_packint($lendata);
- $lenlen = length($len);
- # Reset the key byte into 0-filled bits
- $key = chr(0) x 2;
- vec($key, 0, 16) = 0;
- # 1 BIT: ALWAYSON :
- vec($key, 0, 1) = 1;
- # 1 BIT: COMPLEXSTRUCTURE :
- vec($key, 1, 1) = ($complexstructure) ? 1 : 0;
- # 1 BIT: REAL DATA:
- vec($key, 2, 1) = (defined $realdata && !$realdata) ? 0 : 1;
- # 1 BIT: ENCRYPTED :
- vec($key, 3, 1) = ($encrypted) ? 1 : 0;
- # 1 BIT: COMPRESSED :
- vec($key, 4, 1) = ($compressed) ? 1 : 0;
- # 1 BIT: RESERVED :
- vec($key, 5, 1) = 0;
- # 1 BIT: RESERVED :
- vec($key, 6, 1) = 0;
- # 1 BIT: RESERVED :
- vec($key, 7, 1) = 0;
- # 8 BITS: LENGTH OF "DATA LENGTH STRING"
- vec($key, 1, 8) = $lenlen;
- # Construct the final data and send it:
- $finaldata = $key . $len . $data;
- $len = length($finaldata);
- $temp = 0;
- while (length($finaldata)) {
- $packet = substr($finaldata, 0, $packetsize);
- substr($finaldata, 0, $packetsize) = '';
- $temp += syswrite($sock, $packet, length($packet));
- }
- if ($temp != $len) {
- $@ = "Error sending data: $!";
- return undef;
- }
- else {
- return 1;
- }
- }
-
-
-# Autoload methods go after =cut, and are processed by the autosplit program.
-
-1;
-__END__
-# Below is the stub of documentation for your module. You better edit it!
-
=head1 NAME
Net::EasyTCP - Easily create secure, bandwidth-friendly TCP/IP clients and servers
@@ -1193,22 +175,35 @@
use Net::EasyTCP;
+ #
+ # Create the server object
+ #
$server = new Net::EasyTCP(
mode => "server",
port => 2345,
- )
- || die "ERROR CREATING SERVER: $@\n";
+ )
+ || die "ERROR CREATING SERVER: $@\n";
+ #
+ # Tell it about the callbacks to call
+ # on known events
+ #
$server->setcallback(
data => \&gotdata,
connect => \&connected,
disconnect => \&disconnected,
- )
- || die "ERROR SETTING CALLBACKS: $@\n";
+ )
+ || die "ERROR SETTING CALLBACKS: $@\n";
+ #
+ # Start the server
+ #
$server->start() || die "ERROR STARTING SERVER: $@\n";
- sub gotdata() {
+ #
+ # This sub gets called when a client sends us data
+ #
+ sub gotdata {
my $client = shift;
my $serial = $client->serial();
my $data = $client->data();
@@ -1216,56 +211,74 @@
$client->send($data) || die "ERROR SENDING TO CLIENT: $@\n";
if ($data eq "QUIT") {
$client->close() || die "ERROR CLOSING CLIENT: $@\n";
- }
+ }
elsif ($data eq "DIE") {
$server->stop() || die "ERROR STOPPING SERVER: $@\n";
- }
}
+ }
- sub connected() {
+ #
+ # This sub gets called when a new client connects
+ #
+ sub connected {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just connected\n";
- }
+ }
- sub disconnected() {
+ #
+ # This sub gets called when an existing client disconnects
+ #
+ sub disconnected {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just disconnected\n";
- }
+ }
=item CLIENT EXAMPLE:
use Net::EasyTCP;
+ #
+ # Create a new client and connect to a server
+ #
$client = new Net::EasyTCP(
mode => "client",
host => 'localhost',
port => 2345,
- )
- || die "ERROR CREATING CLIENT: $@\n";
+ )
+ || die "ERROR CREATING CLIENT: $@\n";
- #Send and receive a simple string
+ #
+ # Send and receive a simple string
+ #
$client->send("HELLO THERE") || die "ERROR SENDING: $@\n";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
- #Send and receive complex objects/strings/arrays/hashes by reference
+ #
+ # Send and receive complex objects/strings/arrays/hashes by reference
+ #
%hash = ("to be or" => "not to be" , "just another" => "perl hacker");
$client->send(\%hash) || die "ERROR SENDING: $@\n";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
foreach (keys %{$reply}) {
print "Received key: $_ = $reply->{$_}\n";
- }
+ }
- #Send and receive large binary data
- for (1..4096) {
+ #
+ # Send and receive large binary data
+ #
+ for (1..8192) {
for (0..255) {
$largedata .= chr($_);
- }
}
+ }
$client->send($largedata) || die "ERROR SENDING: $@\n";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
+ #
+ # Cleanly disconnect from the server
+ #
$client->close();
=back
@@ -1293,6 +306,7 @@
=item donotcheckversion
Set to 1 to force a client to continue connecting even if an encryption/compression/Storable module version mismatch is detected. (Using this is highly unrecommended, you should upgrade the module in question to the same version on both ends)
+Note that as of Net::EasyTCP version 0.20, this parameter is fairly useless since that version (and higher) do not require external modules to have the same version anymore, but instead determine compatability between different versions dynamically. See the accompanying Changes file for more details.
(Optional and acceptable when mode is "client")
=item donotcompress
@@ -1300,11 +314,21 @@
Set to 1 to forcefully disable L<compression|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
(Optional)
+=item donotcompresswith
+
+Set to a scalar or an arrayref of compression module(s) you'd like to avoid compressing with. For example, if you do not want to use Compress::LZF, you can do so by utilizing this option.
+(Optional)
+
=item donotencrypt
Set to 1 to forcefully disable L<encryption|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
(Optional)
+=item donotencryptwith
+
+Set to a scalar or an arrayref of encryption module(s) you'd like to avoid encrypting with. For example, Crypt::RSA takes a long time to initialize keys and encrypt/decrypt, so you can avoid using it by utilizing this option.
+(Optional)
+
=item host
Must be set to the hostname/IP address to connect to.
@@ -1327,6 +351,10 @@
Must be set to the port the client connects to (if mode is "client") or to the port to listen to (if mode is "server"). If you're writing a client+server pair, they must both use the same port number.
(Mandatory)
+=item timeout
+
+Set to an integer (seconds) that a client attempting to establish a TCP/IP connection to a server will timeout after. If not supplied, the default is 30 seconds. (Optional and acceptable only when mode is "client")
+
=item welcome
If someone uses an interactive telnet program to telnet to the server, they will see this welcome message.
@@ -1340,6 +368,8 @@
B<[C] = Available to objects created as mode "client">
+B<[H] = Available to "hybrid" client objects, as in "the server-side client objects created when a new client connects". These are the objects passed to your server's callbacks. Such hybrid clients behave almost exactly like a normal "client" object you create yourself, except for a slight difference in the available methods to retrieve data.>
+
B<[S] = Available to objects created as mode "server">
=over 4
@@ -1360,15 +390,15 @@
=item close()
-B<[C]> Instructs a client object to close it's connection with a server.
+B<[C][H]> Instructs a client object to close it's connection with a server.
=item compression()
-B<[C]> Returns the name of the module used as the compression module for this connection, undef if no compression occurs.
+B<[C][H]> Returns the name of the module used as the compression module for this connection, undef if no compression occurs.
=item data()
-B<[C]> Retrieves the previously-retrieved data associated with a client object. This method is typically used from inside the callback sub associated with the "data" event, since the callback sub is passed nothing more than a client object.
+B<[H]> Retrieves the previously-retrieved data associated with a hybrid client object. This method is typically used from inside the callback sub associated with the "data" event, since the callback sub is passed nothing more than a client object.
=item deleteclientip(@array)
@@ -1386,11 +416,11 @@
=item encryption()
-B<[C]> Returns the name of the module used as the encryption module for this connection, undef if no encryption occurs.
+B<[C][H]> Returns the name of the module used as the encryption module for this connection, undef if no encryption occurs.
=item mode()
-B<[C][S]> Identifies the mode of the object. Returns either "client" or "server"
+B<[C][H][S]> Identifies the mode of the object. Returns either "client" or "server"
=item receive($timeout)
@@ -1400,11 +430,11 @@
=item remoteip()
-B<[C]> Returns the IP address of the host on the other end of the connection.
+B<[C][H]> Returns the IP address of the host on the other end of the connection.
=item remoteport()
-B<[C]> Returns the port of the host on the other end of the connection.
+B<[C][H]> Returns the port of the host on the other end of the connection.
=item running()
@@ -1412,13 +442,13 @@
=item send($data)
-B<[C]> Sends data to a server. It can be used on client objects you create with the new() constructor, clients objects returned by the clients() method, or with client objects passed to your callback subs by a running server.
+B<[C][H]> Sends data to a server. It can be used on client objects you create with the new() constructor, clients objects returned by the clients() method, or with client objects passed to your callback subs by a running server.
It accepts one parameter, and that is the data to send. The data can be a simple scalar or a reference to something more complex.
=item serial()
-B<[C]> Retrieves the serial number of a client object, This is a simple integer that allows your callback subs to easily differentiate between different clients.
+B<[H]> Retrieves the serial number of a client object, This is a simple integer that allows your callback subs to easily differentiate between different clients.
=item setcallback(%hash)
@@ -1449,7 +479,7 @@
=item socket()
-B<[C]> Returns the handle of the socket (actually an L<IO::Socket|IO::Socket> object) associated with the supplied object. This is useful if you're interested in using L<IO::Select|IO::Select> or select() and want to add a client object's socket handle to the select list.
+B<[C][H]> Returns the handle of the socket (actually an L<IO::Socket|IO::Socket> object) associated with the supplied object. This is useful if you're interested in using L<IO::Select|IO::Select> or select() and want to add a client object's socket handle to the select list.
Note that eventhough there's nothing stopping you from reading and writing directly to the socket handle you retrieve via this method, you should never do this since doing so would definately corrupt the internal protocol and may render your connection useless. Instead you should use the send() and receive() methods.
@@ -1457,7 +487,7 @@
B<[S]> Starts a server and does NOT return until the server is stopped via the stop() method. This method is a simple while() wrapper around the do_one_loop() method and should be used if your entire program is dedicated to being a server, and does not need to do anything else concurrently.
-If you need to concurrently do other things when the server is running, then you can supply to start() the optional reference to a subroutine (very similar to the callback() method). If that is supplied, it will be called every loop. This is very similar to the callback subs, except that the called sub will NOT be passed anything (unlike normal client callbacks which are passed a client object). The other alternative to performing other tasks concurrently is to not use the start() method at all and directly call do_one_loop() repeatedly in your own program.
+If you need to concurrently do other things when the server is running, then you can supply to start() the optional reference to a subroutine (very similar to the callback() method). If that is supplied, it will be called every loop. This is very similar to the callback subs, except that the called sub will be passed the server object that the start() method was called on (unlike normal client callbacks which are passed a client object). The other alternative to performing other tasks concurrently is to not use the start() method at all and directly call do_one_loop() repeatedly in your own program.
=item stop()
@@ -1473,13 +503,13 @@
As-symmetric encryption will be automatically enabled if L<Crypt::RSA|Crypt::RSA> is installed on both the client and the server.
-Symmetric encryption will be automatically enabled if one (or more) of: L<Crypt::Rijndael|Crypt::Rijndael>* or L<Crypt::RC6|Crypt::RC6>* or L<Crypt::Blowfish|Crypt::Blowfish>* or L<Crypt::DES_EDE3|Crypt::DES_EDE3>* or L<Crypt::DES|Crypt::DES>* or L<Crypt::CipherSaber|Crypt::CipherSaber> are installed on both the client and the server.
+Symmetric encryption will be automatically enabled if one (or more) of: L<Crypt::Rijndael|Crypt::Rijndael>* or L<Crypt::RC6|Crypt::RC6>* or L<Crypt::Blowfish|Crypt::Blowfish>* or L<Crypt::DES_EDE3|Crypt::DES_EDE3>* or L<Crypt::DES|Crypt::DES>* or L<Crypt::Twofish2|Crypt::Twofish2>* or L<Crypt::Twofish|Crypt::Twofish>* or L<Crypt::TEA|Crypt::TEA>* or L<Crypt::CipherSaber|Crypt::CipherSaber> are installed on both the client and the server.
Strong randomization will be automatically enabled if L<Crypt::Random|Crypt::Random> is installed; otherwise perl's internal rand() is used to generate random keys.
Preference to the compression/encryption method used is determind by availablity checking following the order in which they are presented in the above lists.
-Note that during the negotiation upon connection, the server and client will communicate the version of the selected encryption/compression modules. If a version mismatch is found, the client will report a connection failure stating the reason (module version mismatch). This behavior was necessary since it was observed that different versions of the same module could produce incompatible output. If this is encountered, it is strongly recommended you upgrade the module in question to the same version on both ends. However, if you wish to forcefully connect overlooking a version mismatch (risking instability/random problems/data corruption) you may supply the "donotcheckversion" key to the new() constructor of the client object.
+Note that during the negotiation upon connection, servers and clients written using Net::EasyTCP version lower than 0.20 communicated the version of the selected encryption/compression modules. If a version mismatch is found, the client reported a connection failure stating the reason (module version mismatch). This behavior was necessary since it was observed that different versions of the same module could produce incompatible output. If this is encountered, it is strongly recommended you upgrade the module in question to the same version on both ends, or more preferrably, Net::EasyTCP on both ends to the latest version, at a minimum 0.20. However, if you wish to forcefully connect overlooking a version mismatch (risking instability/random problems/data corruption) you may supply the "donotcheckversion" key to the new() constructor of the client object. This is no longer a requirement of Net::EasyTCP version 0.20 or higher since these newer versions have the ability to use different-version modules as long as their data was compatible, which was automatically determined at negotiation time.
To find out which module(s) have been negotiated for use you can use the compression() and encryption() methods.
@@ -1489,7 +519,7 @@
* Note that if symmetric cryptography is used, then it is highly recommended to also use the "password" feature on your servers and clients; since then the "password" will, aside from authentication, be also used in the "secret key" to encrypt the data. Without a password, the secret key has to be transmitted to the other side during the handshake, significantly lowering the overall security of the data.
-If the above modules are installed but you want to forcefully disable compression or encryption, supply the "donotcompress" and/or "donotencrypt" keys to the new() constructor.
+If the above modules are installed but you want to forcefully disable compression or encryption, supply the "donotcompress" and/or "donotencrypt" keys to the new() constructor. If you would like to forcefully disable the use of only some modules, supply the "donotcompresswith" and/or "donotencryptwith" keys to the new() constructor. This could be used for example to disable the use of Crypt::RSA if you cannot afford the time it takes to generate it's keypairs etc...
=head1 RETURN VALUES AND ERRORS
@@ -1543,138 +573,141 @@
=head1 AUTHOR
-Mina Naguib, <mnaguib at cpan.org>
+Mina Naguib
+http://www.topfx.com
+mnaguib at cpan.org
=head1 SEE ALSO
-Perl(1), L<IO::Socket>, L<IO::Select>, L<Compress::Zlib>, L<Compress::LZF>, L<Crypt::RSA>, L<Crypt::CBC>, L<Crypt::Rijndael>, L<Crypt::RC6>, L<Crypt::Blowfish>, L<Crypt::DES_EDE3>, L<Crypt::DES>, L<Crypt::CipherSaber>, L<Crypt::Random>, defined(), rand()
+Perl(1), L<IO::Socket>, L<IO::Select>, L<Compress::Zlib>, L<Compress::LZF>, L<Crypt::RSA>, L<Crypt::CBC>, L<Crypt::Rijndael>, L<Crypt::RC6>, L<Crypt::Blowfish>, L<Crypt::DES_EDE3>, L<Crypt::DES>, L<Crypt::Twofish2>, L<Crypt::Twofish>, L<Crypt::TEA>, L<Crypt::CipherSaber>, L<Crypt::Random>, defined(), rand()
=head1 COPYRIGHT
-Copyright (C) 2001-2002 Mina Naguib. All rights reserved. Use is subject to the Perl license.
+Copyright (C) 2001-2003 Mina Naguib. All rights reserved. Use is subject to the Perl license.
=cut
#
# The main constructor. This calls either _new_client or _new_server depending on the supplied mode
#
-sub new() {
+sub new {
my $class = shift;
- my %para = @_;
+ my %para = @_;
+
# Let's lowercase all keys in %para
foreach (keys %para) {
if ($_ ne lc($_)) {
- $para{lc($_)} = $para{$_};
+ $para{ lc($_) } = $para{$_};
delete $para{$_};
- }
}
+ }
if ($para{mode} =~ /^c/i) {
- return &_new_client($class, %para);
- }
+ return _new_client($class, %para);
+ }
elsif ($para{mode} =~ /^s/i) {
- return &_new_server($class, %para);
- }
+ return _new_server($class, %para);
+ }
else {
$@ = "Supplied mode '$para{mode}' unacceptable. Must be either 'client' or 'server'";
return undef;
- }
}
+}
#
# Make callback() a synonim to setcallback()
#
-sub callback() {
- return &setcallback(@_);
- }
+sub callback {
+ return setcallback(@_);
+}
#
-# This sub adds an ip address(es) to the list of valid IPs a server can accept connections
+# This method adds an ip address(es) to the list of valid IPs a server can accept connections
# from.
#
-sub addclientip() {
+sub addclientip {
my $self = shift;
- my @ips = @_;
+ my @ips = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method addclientip()";
return undef;
- }
+ }
foreach (@ips) {
$self->{_clientip}{$_} = 1;
- }
+ }
return 1;
- }
+}
-
#
-# This sub does the opposite of addclient(), it removes an ip address(es) from the list
+# This method does the opposite of addclient(), it removes an ip address(es) from the list
# of valid IPs a server can accept connections from.
#
-sub deleteclientip() {
+sub deleteclientip {
my $self = shift;
- my @ips = @_;
+ my @ips = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method deleteclientip()";
return undef;
- }
+ }
foreach (@ips) {
delete $self->{_clientip}{$_};
- }
+ }
return 1;
- }
+}
-
-#
#
+#
# This method modifies the _callback_XYZ in a server object. These are the routines
# the server calls when an event (data, connect, disconnect) happens
#
-sub setcallback() {
+sub setcallback {
my $self = shift;
my %para = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method setcallback()";
return undef;
- }
+ }
foreach (keys %para) {
if (ref($para{$_}) ne "CODE") {
$@ = "Callback $_ $para{$_} does not exist";
return 0;
- }
+ }
$self->{_callbacks}->{$_} = $para{$_};
- }
+ }
return 1;
- }
+}
#
# This method starts the server and does not return until stop() is called.
# All other behavior is delegated to do_one_loop()
#
-sub start() {
- my $self = shift;
+sub start {
+ my $self = shift;
my $callback = shift;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method start()";
return undef;
- }
- $self->{_running} = 1;
+ }
+ $self->{_running} = 1;
$self->{_requeststop} = 0;
+
#
# Let's loop until we're stopped:
#
while (!$self->{_requeststop}) {
$self->do_one_loop() || return undef;
if ($callback && ref($callback) eq "CODE") {
- &{$callback};
- }
+ &{$callback}($self);
}
+ }
+
#
# If we reach here the server's been stopped
#
- $self->{_running} = 0;
+ $self->{_running} = 0;
$self->{_requeststop} = 0;
return 1;
- }
+}
#
# This method does "one loop" of server work and returns ASAP
@@ -1683,7 +716,7 @@
#
# It accepts new clients, accepts data from them, and fires off any callback events as necessary
#
-sub do_one_loop() {
+sub do_one_loop {
my $self = shift;
my @ready;
my $clientsock;
@@ -1695,14 +728,16 @@
my $peername;
my $remoteport;
my $remoteip;
+
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method do_one_loop()";
return undef;
- }
+ }
$self->{_lastglobalkeygentime} ||= time;
- @ready = $self->{_selector}->can_read(1);
+ @ready = $self->{_selector}->can_read(0.01);
foreach (@ready) {
if ($_ == $self->{_sock}) {
+
#
# The SERVER SOCKET is ready for accepting a new client
#
@@ -1710,187 +745,218 @@
if (!$clientsock) {
$@ = "Error while accepting new connection: $!";
return undef;
- }
+ }
+
#
# We get remote IP and port, we'll need them to see if client is allowed or not
#
$peername = getpeername($clientsock) or next;
($remoteport, $remoteip) = sockaddr_in($peername) or next;
$remoteip = inet_ntoa($remoteip) or next;
+
#
# We create a new client object and
# We see if client is allowed to connect to us
#
- if (scalar(keys %{$self->{_clientip}}) && !$self->{_clientip}{$remoteip}) {
+ if (scalar(keys %{ $self->{_clientip} }) && !$self->{_clientip}{$remoteip}) {
+
#
# Client's IP is not allowed to connect to us
#
- close ($clientsock);
- }
+ close($clientsock);
+ }
else {
+
#
# We add it to our SELECTOR pool :
#
$self->{_selector}->add($clientsock);
+
#
# We create a new client object:
#
- $self->{_clients}->{$clientsock} = &_new_client(
+ $self->{_clients}->{$clientsock} = _new_client(
$self,
- "_sock" => $clientsock,
- "_remoteport" => $remoteport,
- "_remoteip" => $remoteip
- );
+ "_sock" => $clientsock,
+ "_remoteport" => $remoteport,
+ "_remoteip" => $remoteip
+ );
+
#
+ # We initialize some client variables:
+ #
+ $self->{_clients}->{$clientsock}->{_serial} = ++$_SERIAL;
+ $self->{_clients}->{$clientsock}->{_compatabilityscalar} = _genrandstring(129);
+ $self->{_clients}->{$clientsock}->{_compatabilityreference} = _gencompatabilityreference($self->{_clients}->{$clientsock}->{_compatabilityscalar});
+
+ #
# And we make it inherit some stuff from the server :
#
- $self->{_clients}->{$clientsock}->{_serial} = ++$_SERIAL;
- $self->{_clients}->{$clientsock}->{_donotencrypt} = $self->{_donotencrypt};
- $self->{_clients}->{$clientsock}->{_donotcompress} = $self->{_donotcompress};
- $self->{_clients}->{$clientsock}->{_password} = $self->{_password};
- $self->{_clients}->{$clientsock}->{_callbacks} = $self->{_callbacks};
- $self->{_clients}->{$clientsock}->{_welcome} = $self->{_welcome};
- $self->{_clients}->{$clientsock}->{_selector} = $self->{_selector};
- }
+ $self->{_clients}->{$clientsock}->{_donotencrypt} = $self->{_donotencrypt};
+ $self->{_clients}->{$clientsock}->{_donotencryptwith} = $self->{_donotencryptwith};
+ $self->{_clients}->{$clientsock}->{_donotcompress} = $self->{_donotcompress};
+ $self->{_clients}->{$clientsock}->{_donotcompresswith} = $self->{_donotcompresswith};
+ $self->{_clients}->{$clientsock}->{_password} = $self->{_password};
+ $self->{_clients}->{$clientsock}->{_callbacks} = $self->{_callbacks};
+ $self->{_clients}->{$clientsock}->{_welcome} = $self->{_welcome};
+ $self->{_clients}->{$clientsock}->{_selector} = $self->{_selector};
}
+ }
else {
+
#
# One of the CLIENT sockets are ready
#
- $result = sysread($_, $tempdata, 4096);
+ $result = sysread($_, $tempdata, $PACKETSIZE);
$serverclient = $self->{_clients}->{$_};
if (!defined $result) {
+
#
# Error somewhere during reading from that client
#
- &_callback($serverclient, "disconnect");
+ _callback($serverclient, "disconnect");
$serverclient->close();
delete $self->{_clients}->{$_};
- }
+ }
elsif ($result == 0) {
+
#
# Client closed connection
#
- &_callback($serverclient, "disconnect");
+ _callback($serverclient, "disconnect");
$serverclient->close();
delete $self->{_clients}->{$_};
- }
+ }
else {
+
#
# Client sent us some good data (not necessarily a full packet)
#
$serverclient->{_databuffer} .= $tempdata;
- while (defined ($realdata = &_extractdata($serverclient)) ) {
- if (!$realdata) {
- # It's internal protocol data
- &_parseinternaldata($serverclient);
- }
+
+ #
+ # Extract as many data buckets as possible out of the buffer
+ #
+ _extractdata($serverclient);
+
+ #
+ # Process all this client's data buckets
+ #
+ foreach (@{ $serverclient->{_databucket} }) {
+ if ($_->{realdata}) {
+
+ #
+ # This bucket is normal data
+ #
+ _callback($serverclient, "data");
+ }
else {
- # We found something and it's real data
- &_callback($serverclient, "data");
- }
+
+ #
+ # This bucket is internal data
+ #
+ _parseinternaldata($serverclient);
}
}
}
}
+ }
+
#
# Now we check on all the serverclients still negotiating and help them finish negotiating
# or weed out the ones timing out
#
- foreach (keys %{$self->{_clients}}) {
+ foreach (keys %{ $self->{_clients} }) {
$serverclient = $self->{_clients}->{$_};
if ($serverclient->{_negotiating}) {
- if (&_serverclient_negotiate($serverclient) ) {
- &_callback($serverclient, "connect");
- }
+ if (_serverclient_negotiate($serverclient)) {
+ _callback($serverclient, "connect");
+ }
elsif ((time - $serverclient->{_negotiating}) > $negotiatingtimeout) {
$serverclient->close();
delete $self->{_clients}->{$_};
- }
}
}
+ }
+
#
# Now we re-generate the RSA keys if it's been over an hour
#
- if (!$self->{_donotencrypt} && ((time-$self->{_lastglobalkeygentime}) >= 3600)) {
- if (!&_generateglobalkeypair('Crypt::RSA')) {
+ if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{"B"} && ((time - $self->{_lastglobalkeygentime}) >= 3600)) {
+ if (!_generateglobalkeypair('Crypt::RSA')) {
$@ = "Could not generate global Crypt::RSA keypairs. $@";
return undef;
- }
+ }
$self->{_lastglobalkeygentime} = time;
- }
+ }
return 1;
- }
+}
#
# This method stops the server and makes it return.
# Note: It doesn't stop the server immediately, it sets a flag
# and the flag should in a few seconds cause the infinite loop in start() method to stop
#
-sub stop() {
+sub stop {
my $self = shift;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot call method stop()";
return undef;
- }
+ }
$self->{_requeststop} = 1;
return 1;
- }
+}
#
# This method sends data to the socket associated with the object
#
-sub send() {
+sub send {
my $self = shift;
my $data = shift;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method send()";
return undef;
- }
- return &_send($self, $data);
}
+ return _send($self, $data);
+}
#
# This method returns the serial number associated with the object
#
-sub serial() {
+sub serial {
my $self = shift;
if (!$self->{_serial}) {
$self->{_serial} = ++$_SERIAL;
- }
+ }
return $self->{_serial};
- }
+}
#
-# This method returns the already-read data associated with the object
+# Takes nothing, returns the oldest entry from the data bucket for a client/serverclient
+# In array context returns data and realdata flag, otherwise just data
# (typically the code in the callback assigned to callback_data would access this method)
#
-sub data() {
+sub data {
my $self = shift;
- my $returnlatest = shift;
my $data;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method data()";
return undef;
- }
- if ($returnlatest) {
- $data = pop ( @{$self->{_data}} );
- }
- else {
- $data = shift ( @{$self->{_data}} );
- }
- return $data;
}
+ $data = shift(@{ $self->{_databucket} });
+
+ return wantarray ? ($data->{data}, $data->{realdata}) : $data->{data};
+}
+
#
# This method reads data from the socket associated with the object and returns it
# Accepts an optional timeout as a first parameter, otherwise defaults to timeout
-# Second parameter is internal and is used to haveit return non-realdata instead of passing it to _parseinternaldata()
# Returns the data if successful, undef if not
#
-sub receive() {
- my $self = shift;
- my $timeout = shift || 300;
+sub receive {
+ my $self = shift;
+ my $timeout = shift || 0;
my $returninternaldata = shift || 0;
my $temp;
my $realdata;
@@ -1898,203 +964,2118 @@
my $lastactivity = time;
my $selector;
my @ready;
+ my $fatalerror;
+
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method receive()";
return undef;
- }
+ }
+
$selector = new IO::Select;
$selector->add($self->{_sock});
- while ((time - $lastactivity) < $timeout) {
+
+ #
+ # Let's try to read from the socket
+ #
+ while ($timeout ? ((time - $lastactivity) < $timeout) : 1) {
@ready = $selector->can_read($timeout);
if (!@ready) {
- if (!$! || $! =~ /interrupt/i) {
- next;
+
+ #
+ # Socket is not ready for reading
+ #
+ if (!$!) {
+
+ #
+ # Because of timeout
+ #
+ if (!$timeout) {
+
+ #
+ # We're doing an initial reading without blocking
+ #
+ last;
}
- else {
- last;
+ else {
+
+ #
+ # We're blocking - let the while look take care of timeout
+ #
+ next;
}
}
- $result = sysread($self->{_sock}, $temp, 4096);
- if ($result == 0) {
- # Socket closed
- $@ = "Socket closed when attempted reading";
- return undef;
+ elsif ($! =~ /interrupt/i) {
+
+ #
+ # Because of select() interrupted - ignore that
+ #
+ next;
}
- elsif (!defined $result) {
- # Error in socket
- $@ = "Error reading from socket: $!";
- return undef;
+ else {
+
+ #
+ # Because of some unknown error
+ #
+ last;
}
+ }
else {
- # Read good data
- $lastactivity = time;
- $self->{_databuffer} .= $temp;
- while (1) {
- if (defined($realdata = &_extractdata($self)) ) {
- # We read something
- if ($realdata) {
- # It's real data that belongs to the application
- return $self->data(1);
- }
- elsif ($returninternaldata) {
- # It's internal but we've been instructed to return it
- return $self->data(1);
- }
- else {
- # It's internal data so we parse it
- &_parseinternaldata($self);
- }
- }
+
+ #
+ # Socket is ready for reading
+ #
+ $result = sysread($self->{_sock}, $temp, $PACKETSIZE);
+ if (!defined $result) {
+
+ #
+ # Error reading from socket
+ #
+ $fatalerror = "Failed to read from socket: $!";
+ if (!$timeout) {
+
+ #
+ # However we won't crap out right away, as we're doing a cursory, no-timeout read
+ #
+ last;
+ }
else {
- # There's no (more) data to be extracted
+ $@ = $fatalerror;
+ return undef;
+ }
+ }
+ elsif ($result == 0) {
+
+ #
+ # Socket closed while reading
+ #
+ $fatalerror = "Socket closed when attempted reading";
+ if (!$timeout) {
+
+ # However we won't crap out right away, as we're doing a cursory, no-timeout read
last;
- }
}
+ else {
+ $@ = $fatalerror;
+ return undef;
+ }
}
+ else {
+
+ #
+ # Read good data - add it to the databuffer
+ #
+ $self->{_databuffer} .= $temp;
+ $lastactivity = time;
+
+ if ($timeout && $result != $PACKETSIZE && _extractdata($self)) {
+
+ #
+ # We're doing blocking reads, we extracted something into the bucket, and there's probably nothing else at the end of the socket
+ # No point looping to block again
+ #
+ last;
+ }
+ }
}
- $@ = "Timed out waiting to receive data";
- return undef;
}
+ #
+ # Now there's nothing waiting to be received
+ # Try to extract all possible data buckets out of the data buffer
+ #
+ _extractdata($self);
+
+ #
+ # Now the databuffer has no full packets. If there's any data to be returned it's in the data buckets
+ #
+ while ((($result, $realdata) = $self->data()) && defined $result) {
+
+ #
+ # We got something from the bucket
+ #
+ if ($realdata) {
+
+ #
+ # And it's real data - return it
+ #
+ return $result;
+ }
+ else {
+
+ #
+ # It's internal data
+ #
+ if ($returninternaldata) {
+
+ #
+ # But we've been asked to return it
+ #
+ return $result;
+ }
+ else {
+
+ #
+ # Don't know what to do with the internal data
+ #
+ _parseinternaldata($self, $result);
+ }
+ }
+ }
+ if (defined($result = $self->data())) {
+
+ #
+ # We have good data to return
+ #
+ return $result;
+ }
+
+ #
+ # If we've reached here we have no data to return
+ #
+ if (!$timeout) {
+
+ #
+ # We were doing a quick no-block read
+ #
+ if ($fatalerror) {
+
+ #
+ # And we have a fatal error - don't attempt a blocking read
+ #
+ $@ = $fatalerror;
+ return undef;
+ }
+ else {
+
+ #
+ # Attempt a blocking read
+ #
+ return $self->receive(300);
+ }
+ }
+ else {
+
+ #
+ # We did a blocking read
+ #
+ $@ = "Timed out waiting to receive data";
+ return undef;
+ }
+}
+
#
# This method is a synonym for close()
#
-sub disconnect() {
- return &close(@_);
- }
+sub disconnect {
+ return close(@_);
+}
#
# This method closes the socket associated with the object
#
-sub close() {
+sub close {
my $self = shift;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method close()";
return undef;
- }
+ }
if ($self->{_selector} && $self->{_selector}->exists($self->{_sock})) {
+
# If the server selector reads this, let's make it not...
$self->{_selector}->remove($self->{_sock});
- }
- $self->{_sock}->close();
- $self->{_sock} = undef;
- $self->{_data} = [];
+ }
+ $self->{_sock}->close() if defined $self->{_sock};
+ $self->{_sock} = undef;
+ $self->{_databucket} = [];
$self->{_databuffer} = undef;
return 1;
- }
+}
#
# This method returns true or false, depending on if the server is running or not
#
-sub running() {
+sub running {
my $self = shift;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method running()";
return undef;
- }
+ }
return $self->{_running};
- }
+}
#
# This replies saying what type of object it's passed
#
-sub mode() {
+sub mode {
my $self = shift;
my $mode = ($self->{_mode} eq "server") ? "server" : "client";
return $mode;
- }
+}
#
# This method replies saying what type of encryption is used, undef if none
#
-sub encryption() {
- my $self = shift;
+sub encryption {
+ my $self = shift;
my $modulekey = $self->{_encrypt};
if ($self->{_donotencrypt} || !$modulekey) {
return undef;
- }
- return $_ENCRYPT_AVAILABLE{$modulekey}{name} || "Unknown module name";
}
+ return $_ENCRYPT_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]";
+}
-
#
# This method replies saying what type of compression is used, undef if none
#
-sub compression() {
- my $self = shift;
+sub compression {
+ my $self = shift;
my $modulekey = $self->{_compress};
if ($self->{_donotcompress} || !$modulekey) {
return undef;
- }
- return $_COMPRESS_AVAILABLE{$modulekey}{name} || "Unknown module name";
}
+ return $_COMPRESS_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]";
+}
#
# This returns the IO::Socket object associated with a connection
#
-sub socket() {
+sub socket {
my $self = shift;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method socket()";
return undef;
- }
+ }
return ($self->{_sock} || undef);
- }
+}
#
# This returns an array of all the clients connected to a server in array context
# or the number of clients in scalar context
# or undef if there are no clients or error
#
-sub clients() {
+sub clients {
my $self = shift;
my @clients;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method clients()";
return undef;
- }
- foreach ( values %{$self->{_clients}} ) {
+ }
+ foreach (values %{ $self->{_clients} }) {
if (!$_->{_negotiating}) {
- push (@clients, $_);
- }
+ push(@clients, $_);
}
+ }
if (@clients) {
- if (wantarray) {
- return (@clients);
- }
- else {
- return (scalar @clients);
- }
- }
+ return wantarray ? @clients : scalar @clients;
+ }
else {
return undef;
- }
}
+}
-
#
# This takes a client object and returns the IP address of the remote connection
#
-sub remoteip() {
+sub remoteip {
my $self = shift;
my $temp;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method remoteip()";
return undef;
- }
+ }
return $self->{_remoteip};
- }
+}
#
# This takes a client object and returns the PORT of the remote connection
#
-sub remoteport() {
+sub remoteport {
my $self = shift;
my $temp;
if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
$@ = "$self->{_mode} cannot use method remoteport()";
return undef;
- }
+ }
return $self->{_remoteport};
+}
+
+###########################################################
+###########################################################
+###########################################################
+#
+# The following are private functions (not object methods)
+#
+
+#
+# This takes 2 items (references to simple structures, or simple scalars)
+# And returns true if they're the same, false if they're not
+# It does NOT work for blessed objects. only scalars, hashrefs and arrayrefs
+#
+sub _comparereferences {
+ my $item1 = shift;
+ my $item2 = shift;
+ my $ref1 = ref($item1);
+ my $ref2 = ref($item2);
+ my $num1;
+ my $num2;
+ my @keys1;
+ my @keys2;
+ my $temp;
+
+ if ($ref1 ne $ref2) {
+ $@ = "References not same type [$ref1] [$ref2]";
+ return 0;
}
+ elsif (!$ref1 && $item1 ne $item2) {
+ #Scalars - do not match
+ $@ = "Values of two scalar values not same";
+ return 0;
+ }
+ elsif ($ref1 eq "ARRAY") {
+ $num1 = scalar @{$item1};
+ $num2 = scalar @{$item2};
+ if ($num1 != $num2) {
+
+ # Not same # of elements
+ $@ = "Number of array elements not equal";
+ return 0;
+ }
+ else {
+ for $temp (0 .. $num1 - 1) {
+ if (!_comparereferences($item1->[$temp], $item2->[$temp])) {
+ return 0;
+ }
+ }
+ }
+ }
+ elsif ($ref1 eq "HASH") {
+ @keys1 = sort keys %{$item1};
+ @keys2 = sort keys %{$item2};
+ if (scalar @keys1 != scalar @keys2) {
+
+ # Not same # of elements
+ $@ = "Number of hash keys not equal";
+ return 0;
+ }
+ else {
+ for $temp (0 .. $#keys1) {
+ if ($keys1[$temp] ne $keys2[$temp]) {
+ $@ = "Hash key names not equal";
+ return 0;
+ }
+ if (!_comparereferences($item1->{ $keys1[$temp] }, $item2->{ $keys2[$temp] })) {
+ return 0;
+ }
+ }
+ }
+ }
+ elsif ($ref1) {
+
+ # Unknown reference
+ $@ = "Unknown reference type [$ref1] [$ref2] [$item1] [$item2]";
+ return 0;
+ }
+
+ #
+ # Everything's good
+ #
+ return 1;
+}
+
+#
+# This generates a global keypair and stores it globally
+# Takes the name of a module, returns true or false
+#
+sub _generateglobalkeypair {
+ my $module = shift || return undef;
+ foreach (keys %_ENCRYPT_AVAILABLE) {
+ if ($_ ne "_order" && $_ENCRYPT_AVAILABLE{$_}{name} eq $module) {
+ ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = ();
+ ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = _genkey($_) or return undef;
+ last;
+ }
+ }
+ return 1;
+}
+
+#
+# This takes any string and returns it in ascii format
+#
+sub _bin2asc {
+ my $data = shift;
+ $data =~ s/(.)/ '%' . sprintf('%02x',ord($1)) /ges;
+ $data = uc($data);
+ return $data;
+}
+
+#
+# This does the opposite of _bin2asc
+#
+sub _asc2bin {
+ my $data = shift;
+ $data =~ s/\%([0-9A-F]{2})/ sprintf("%c",hex($1)) /ges;
+ return $data;
+}
+
+#
+# This does very very primitive 2-way encryption & decryption (kinda like ROT13.. works both ways)
+# Takes a client and a string, returns the enc/dec/rypted string
+#
+# This encryption is used to protect the encrypted password and the public key transmitted over the wire
+# It's a last resort of security in case none of the encryption modules were found
+#
+sub _munge {
+ my $client = shift || return undef;
+ my $data = shift;
+ my ($c, $t);
+
+ #
+ # Munge's tricky because is existed on and off in different versions
+ #
+ if (defined $data && ($client->{_version} == 0.07 || $client->{_version} == 0.08 || $client->{_version} >= 0.15)) {
+
+ #
+ # Peer supports munge
+ #
+ for (0 .. length($data) - 1) {
+ $c = substr($data, $_, 1);
+ $t = vec($c, 0, 4);
+ vec($c, 0, 4) = vec($c, 1, 4);
+ vec($c, 1, 4) = $t;
+ substr($data, $_, 1) = $c;
+ }
+ $data = reverse($data);
+ }
+ else {
+
+ # Our peer doesn't munge, so we won't either
+ }
+ return $data;
+}
+
+#
+# This takes a client object and a callback keyword and calls back the associated sub if possible
+#
+sub _callback {
+ my $client = shift;
+ my $type = shift;
+ if (!$client->{_negotiating} && $client->{_callbacks}->{$type}) {
+ &{ $client->{_callbacks}->{$type} }($client);
+ }
+}
+
+#
+# This sub takes a scalar key
+# Returns a reference to a compatability compex object made up of repeating
+# the scalar in different combinations
+#
+sub _gencompatabilityreference {
+ my $key = shift;
+ return [
+ $key,
+ {
+ $key => $key,
+ $key => $key,
+ },
+ [ $key, { $key => $key, }, $key, ],
+ ];
+}
+
+#
+# This takes in an encryption key id and an optional "forcompat" boolean flag
+# Generates a keypair (public, private) and returns them according to the type of encryption specified
+# Returns undef on error
+# The 2 returned keys are guaranteed to be: 1. Scalars and 2. Null-character-free. weather by their nature, or serialization or asci-fi-cation
+# If "forcompat" is not specified and there are already a keypair for the specified module stored globally,
+# it will return that instead of generating new ones.
+# If "forcompat" is supplied, you're guaranteed to receive a new key that wasn't given out in the past to
+# non-compat requests. It may be a repeat of a previous "forcompat" pair. However, the strength of that key
+# could be possibly reduced. Such keys are safe to reveal the private portion of publicly, as during the
+# compatability negotiation phase, however such keys must NEVER be used to encrypt any real data, as they
+# are no longer secret.
+#
+sub _genkey {
+ my $modulekey = shift;
+ my $forcompat = shift;
+ my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
+ my $key1 = undef;
+ my $key2 = undef;
+ my $temp;
+ $@ = undef;
+ if (!$forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}) {
+ $key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey};
+ $key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey};
+ }
+ elsif ($forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey}) {
+ $key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey};
+ $key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey};
+ }
+ elsif ($module eq 'Crypt::RSA') {
+ eval {
+ $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for key generation: $! $@\n";
+ ($key1, $key2) = $temp->keygen(
+ Size => 512,
+ Verbosity => 0,
+ )
+ or die "Failed to create RSA keypair: " . $temp->errstr() . "\n";
+ };
+ if ($key1 && $key2) {
+ $key1 = _bin2asc(nfreeze($key1));
+
+ # RSA private keys are NOT serializable with the Serialize module - we MUST use Crypt::RSA::Key::Private's undocumented serialize() method:
+ $key2 = $key2->serialize();
+ if ($forcompat) {
+ $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} = $key1;
+ $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey} = $key2;
+ }
+ }
+ }
+ elsif ($module eq 'Crypt::Rijndael') {
+ $key1 = _genrandstring(32);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::RC6') {
+ $key1 = _genrandstring(32);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::Blowfish') {
+ $key1 = _genrandstring(56);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::DES_EDE3') {
+ $key1 = _genrandstring(24);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::DES') {
+ $key1 = _genrandstring(8);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::Twofish2') {
+ $key1 = _genrandstring(32);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::Twofish') {
+ $key1 = _genrandstring(32);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::TEA') {
+ $key1 = _genrandstring(16);
+ $key2 = $key1;
+ }
+ elsif ($module eq 'Crypt::CipherSaber') {
+ $key1 = _genrandstring(32);
+ $key2 = $key1;
+ }
+ else {
+ $@ = "Unknown encryption module [$module] modulekey [$modulekey]";
+ }
+
+ if (!$key1 || !$key2) {
+ $@ = "Could not generate encryption keys. $@";
+ return undef;
+ }
+ else {
+ return ($key1, $key2);
+ }
+
+}
+
+#
+# This takes client object, and a reference to a scalar
+# And if it can, compresses scalar, modifying the original, via the specified module in the client object
+# Returns true if successful, false if not
+#
+sub _compress {
+ my $client = shift;
+ my $rdata = shift;
+ my $modulekey = $client->{_compress} || return undef;
+ my $module = $_COMPRESS_AVAILABLE{$modulekey}{name};
+ my $newdata;
+
+ #
+ # Compress the data
+ #
+ if ($module eq 'Compress::Zlib') {
+ $newdata = Compress::Zlib::compress($$rdata);
+ }
+ elsif ($module eq 'Compress::LZF') {
+ $newdata = Compress::LZF::compress($$rdata);
+ }
+ else {
+ $@ = "Unknown compression module [$module] modulekey [$modulekey]";
+ }
+
+ #
+ # Finally, override reference if compression succeeded
+ #
+ if ($newdata) {
+ $$rdata = $newdata;
+ return 1;
+ }
+ else {
+ return undef;
+ }
+
+}
+
+#
+# This does the opposite of _compress()
+#
+sub _decompress {
+ my $client = shift;
+ my $rdata = shift;
+ my $modulekey = $client->{_compress};
+ my $module = $_COMPRESS_AVAILABLE{$modulekey}{name};
+ my $newdata;
+
+ if ($module eq 'Compress::Zlib') {
+ $newdata = Compress::Zlib::uncompress($$rdata);
+ }
+ elsif ($module eq 'Compress::LZF') {
+ $newdata = Compress::LZF::decompress($$rdata);
+ }
+ else {
+ $@ = "Unknown decompression module [$module] modulekey [$modulekey]";
+ }
+
+ #
+ # Finally, override reference if decompression succeeded
+ #
+ if ($newdata) {
+ $$rdata = $newdata;
+ return 1;
+ }
+ else {
+ return undef;
+ }
+
+}
+
+#
+# This takes client object, and a reference to a scalar
+# And if it can, encrypts scalar, modifying the original, via the specified module in the client object
+# Returns true if successful, false if not
+#
+sub _encrypt {
+ my $client = shift;
+ my $rdata = shift;
+ my $modulekey = $client->{_encrypt} || return undef;
+ my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
+ my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
+ my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
+ my $newdata;
+ my $temp;
+ my $publickey = $client->{_remotepublickey} || return undef;
+ my $cleanpassword;
+
+ if (defined $client->{_password}) {
+ $cleanpassword = $client->{_password};
+ $cleanpassword =~ s/[^a-z0-9]//gi;
+ }
+ else {
+ $cleanpassword = undef;
+ }
+
+ #
+ # If there is a password for the connection, and we're using Symmetric encryption, we include the password
+ # in the encryption key used
+ #
+ if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
+ if (length($cleanpassword) <= length($publickey)) {
+ substr($publickey, 0, length($cleanpassword)) = $cleanpassword;
+ }
+ elsif (length($cleanpassword) > length($publickey)) {
+ $publickey = substr($cleanpassword, 0, length($publickey));
+ }
+ else {
+ $@ = "Failed to merge password with symmetric encryption key";
+ return undef;
+ }
+ }
+ if ($publickey =~ /^(\%[0-9A-F]{2})+$/) {
+
+ #
+ # In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them
+ #
+ $publickey = thaw(_asc2bin($publickey)) || return undef;
+ $client->{_remotepublickey} = $publickey;
+ }
+
+ #
+ # Encrypt the data into $newdata if possible
+ #
+ if ($module eq 'Crypt::RSA') {
+ eval {
+ $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for encryption: $! $@\n";
+ $newdata = $temp->encrypt(
+ Message => $$rdata,
+ Key => $publickey,
+ Armour => 0,
+ )
+ or die "Failed to encrypt data with Crypt::RSA: " . $temp->errstr() . "\n";
+ };
+ }
+ elsif ($module eq 'Crypt::CipherSaber') {
+ $temp = Crypt::CipherSaber->new($publickey);
+ $newdata = $temp->encrypt($$rdata);
+ }
+ elsif ($cbc) {
+ $temp = Crypt::CBC->new($publickey, $module);
+ $newdata = $temp->encrypt($$rdata);
+ }
+ else {
+ $@ = "Unknown encryption module [$module] modulekey [$modulekey]";
+ }
+
+ #
+ # Finally, override reference if encryption succeeded
+ #
+ if ($newdata) {
+ $$rdata = $newdata;
+ return 1;
+ }
+ else {
+ return undef;
+ }
+
+}
+
+#
+# Does the opposite of _encrypt();
+#
+sub _decrypt {
+ my $client = shift;
+ my $rdata = shift;
+ my $modulekey = $client->{_encrypt} || return undef;
+ my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
+ my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
+ my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
+ my $newdata;
+ my $temp;
+ my $privatekey = $client->{_localprivatekey} || return undef;
+ my $cleanpassword;
+
+ if (defined $client->{_password}) {
+ $cleanpassword = $client->{_password};
+ $cleanpassword =~ s/[^a-z0-9]//gi;
+ }
+ else {
+ $cleanpassword = undef;
+ }
+
+ #
+ # If there is a password for the connection, and we're using Symmetric encryption, we include the password
+ # in the decryption key used
+ #
+ if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
+ if (length($cleanpassword) <= length($privatekey)) {
+ substr($privatekey, 0, length($cleanpassword)) = $cleanpassword;
+ }
+ elsif (length($cleanpassword) > length($privatekey)) {
+ $privatekey = substr($cleanpassword, 0, length($privatekey));
+ }
+ else {
+ $@ = "Failed to merge password with symmetric encryption key";
+ return undef;
+ }
+ }
+ if ($privatekey =~ /^(\%[0-9A-F]{2})+$/) {
+
+ #
+ # In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them
+ #
+ $privatekey = _asc2bin($privatekey);
+ }
+
+ #
+ # Decrypt the data
+ #
+ if ($module eq 'Crypt::RSA') {
+ eval {
+ if (!ref($privatekey)) {
+ if ($privatekey =~ /bless/) {
+
+ # We need to deserialize the private key with Crypt::RSA::Key::Private's undocumented deserialize function
+ $temp = Crypt::RSA::Key::Private->new() or die "Failed to initialize empty Crypt::RSA::Key::Private object\n";
+ $privatekey = $temp->deserialize(String => [$privatekey]) or die "Failed to deserialize Crypt::RSA private key\n";
+ }
+ else {
+ die "The Crypt::RSA private key is absolutely unusable\n";
+ }
+ }
+ $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for decryption: $! $@\n";
+ $newdata = $temp->decrypt(
+ Cyphertext => $$rdata,
+ Key => $privatekey,
+ Armour => 0,
+ )
+ or die "Failed to decrypt data with Crypt::RSA : " . $temp->errstr() . "\n";
+ };
+ }
+ elsif ($module eq 'Crypt::CipherSaber') {
+ $temp = Crypt::CipherSaber->new($privatekey);
+ $newdata = $temp->decrypt($$rdata);
+ }
+ elsif ($cbc) {
+ $temp = Crypt::CBC->new($privatekey, $module);
+ $newdata = $temp->decrypt($$rdata);
+ }
+ else {
+ $@ = "Unknown encryption module [$module] modulekey [$modulekey]";
+ }
+
+ #
+ # Finally, override reference if decryption succeeded
+ #
+ if ($newdata) {
+ $$rdata = $newdata;
+ return 1;
+ }
+ else {
+ return undef;
+ }
+
+}
+
+#
+# This sub returns a random string
+# Expects an integer (length)
+# Accepts optional boolean that defines whether string should be made up of letters only or not
+#
+sub _genrandstring {
+ my $l = shift;
+ my $lettersonly = shift;
+ my ($minord, $maxord);
+ my $key;
+ my $avoid;
+ my $module;
+ my $version;
+
+ if ($lettersonly) {
+ $minord = 97;
+ $maxord = 122;
+ }
+ else {
+ $minord = 33;
+ $maxord = 126;
+ }
+
+ #
+ # First, we try one of the fancy randomness modules possibly in %_MISC_AVAILABLE
+ #
+ foreach (@{ $_MISC_AVAILABLE{_order} }) {
+ $module = $_MISC_AVAILABLE{$_}{name};
+ $version = $_MISC_AVAILABLE{$_}{version};
+
+ #
+ # Note that Crypt::Random has the makerandom_octet function ONLY in 0.34 and higher
+ #
+ if ($module eq "Crypt::Random" && $version >= 0.34) {
+ for (0 .. $minord - 1, $maxord + 1 .. 255) {
+ $avoid .= chr($_);
+ }
+ $key = Crypt::Random::makerandom_octet(
+ Length => $l,
+ Skip => $avoid,
+ );
+ return $key;
+ }
+ }
+
+ #
+ # If we've reached here, then no modules were found. We'll use perl's builtin rand() to generate
+ # the string
+ #
+ for (1 .. $l) {
+ $key .= chr(int(rand($maxord - $minord)) + $minord);
+ }
+ return $key;
+}
+
+#
+# Once a new client is connected it calls this to negotiate basics with the server
+# This must return true once all negotiations succeed or false if not
+#
+sub _client_negotiate {
+ my $client = shift;
+ my $reply;
+ my $timeout = 90;
+ my @P;
+ my $command;
+ my $data;
+ my $temp;
+ my $temp2;
+ my ($temppublic, $tempprivate, $tempscalar);
+ my $version;
+ my $evl;
+ my $starttime = time;
+
+ while ((time - $starttime) < $timeout) {
+ $reply = $client->receive($timeout, 1);
+ if (!defined $reply) {
+ last;
+ }
+ @P = split(/\x00/, $reply);
+ $command = shift(@P);
+ $evl = undef;
+ $data = undef;
+ if (!$command) {
+ $@ = "Error negotiating with server. No command received.";
+ return undef;
+ }
+ if ($command eq "PF") {
+
+ #
+ # Password Failure
+ #
+ $client->{_authenticated} = 0;
+ $@ = "Server rejected supplied password";
+ return undef;
+ }
+ elsif ($command eq "COS") {
+
+ #
+ # Compatability Scalar
+ #
+ $client->{_compatabilityscalar} = _asc2bin($P[0]);
+ $client->{_compatabilityreference} = _gencompatabilityreference($client->{_compatabilityscalar});
+ $data = "COS\x00" . $P[0];
+ }
+ elsif ($command eq "COF") {
+
+ #
+ # Compatability failure
+ #
+ $@ = "Compatability failure: The client and server could not negotiate compatability regarding: $P[0]";
+ return undef;
+ }
+ elsif ($command eq "CVF" && !$client->{_donotcheckversion}) {
+
+ #
+ # Compression Version Failure
+ #
+ $temp = $_COMPRESS_AVAILABLE{ $client->{_compress} }{name};
+ $version = $_COMPRESS_AVAILABLE{ $client->{_compress} }{version};
+ $@ = "Compression version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
+ return undef;
+ }
+ elsif ($command eq "EVF" && !$client->{_donotcheckversion}) {
+
+ #
+ # Encryption Version Failure
+ #
+ $temp = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{name};
+ $version = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{version};
+ $@ = "Encryption version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
+ return undef;
+ }
+ elsif ($command eq "EN") {
+
+ #
+ # End of negotiation
+ #
+ $data = "EN";
+ $evl = 'return("RETURN1");';
+ }
+ elsif ($command eq "VE") {
+
+ #
+ # Version of module
+ #
+ $client->{_version} = $P[0];
+ $data = "VE\x00$VERSION";
+ }
+ elsif ($command eq "SVE") {
+
+ #
+ # Version of the Storable module
+ #
+ $client->{_storableversion} = $P[0];
+ if ($P[1]) {
+
+ #
+ # New compatability method
+ #
+ eval { $temp = thaw(_asc2bin($P[1])); };
+ if (!$temp || $@) {
+ $@ = "Error thawing compatability reference: $! $@ -- This may be because you're using binary-image-incompatible versions of the Storable module. Please update the Storable module on both ends othe the connection to the same latest stable version.";
+ return undef;
+ }
+ if (!_comparereferences($temp, $client->{_compatabilityreference})) {
+ $@ = "Incompatible version mismatch for the Storable module: Local version " . $Storable::VERSION . " remote version $P[0] : Upgrade both to compatible (preferrably same) versions : $@";
+ return undef;
+ }
+ }
+ $data = "SVE\x00" . $Storable::VERSION;
+ if ($client->{_compatabilityreference}) {
+ $data .= "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference}));
+ }
+ }
+ elsif ($command eq "SVF" && !$client->{_donotcheckversion}) {
+
+ #
+ # Storable Module Version Failure
+ #
+ $version = $Storable::VERSION;
+ $@ = "Version mismatch for the Storable module : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem";
+ return undef;
+ }
+ elsif ($command eq "CS") {
+
+ #
+ # Crypt Salt
+ #
+ # We assume that we've authenticated successfully
+ $client->{_authenticated} = 1;
+ $temp = _munge($client, crypt($client->{_password}, $P[0]));
+ $data = "CP\x00$temp";
+ }
+ elsif ($command eq "EK") {
+
+ #
+ # Encryption key
+ #
+ $client->{_remotepublickey} = _munge($client, $P[0]);
+ $data = "EK\x00";
+ $data .= _munge($client, $client->{_localpublickey});
+ }
+ elsif ($command eq "EM") {
+
+ #
+ # Encryption module
+ #
+ if ($client->{_donotencryptwith}{ $P[0] }) {
+ $data = "NO\x00I do not encrypt with this module";
+ }
+ elsif (!$client->{_donotencrypt}) {
+
+ #
+ # Let's see if we can handle decrypting this module
+ #
+ $tempprivate = _asc2bin($P[2]);
+ $tempscalar = _asc2bin($P[3]);
+
+ #
+ # Sometimes the tempprivate is frozen. If we can thaw it, let's do it:
+ #
+ eval { $temp = thaw $tempprivate };
+ if (!$@) {
+ $tempprivate = $temp;
+ }
+ $client->{_encrypt} = $P[0];
+ $client->{_localprivatekey} = $tempprivate;
+ if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
+
+ #
+ # This is a viable module that we can decrypt.
+ #
+ ($temppublic, $tempprivate) = _genkey($P[0], 1);
+ if ($temppublic && $tempprivate) {
+
+ #
+ # I created a keypair with that module type successfully
+ #
+ $client->{_remotepublickey} = $temppublic;
+ if (_encrypt($client, \$tempscalar)) {
+ $data = "EM\x00$P[0]\x00" . $_ENCRYPT_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar);
+ }
+ delete $client->{_remotepublickey};
+ }
+ else {
+
+ #
+ # Failed to create a keypair - no way I could encrypt with that
+ #
+ $data = "NO\x00$@";
+ }
+ }
+ else {
+
+ #
+ # Failed to decrypt message from server
+ #
+ $data = "NO\x00$@";
+ }
+ delete $client->{_encrypt};
+ delete $client->{_localprivatekey};
+ }
+ else {
+
+ #
+ # I was told not to encrypt
+ #
+ $data = "NO\x00I do not encrypt";
+
+ }
+ }
+ elsif ($command eq "EU") {
+
+ #
+ # Encryption Use
+ #
+ if ($client->{_donotencryptwith}{ $P[0] }) {
+ $data = "NO\x00I do not encrypt with this module";
+ }
+ elsif (!$client->{_donotencrypt}) {
+ $temp2 = $P[0];
+ $data = "EU\x00$temp2";
+ $evl = '$client->{_encrypt} = $temp2;';
+ $evl .= '($client->{_localpublickey},$client->{_localprivatekey}) =';
+ $evl .= ' _genkey($client->{_encrypt}) or ';
+ $evl .= ' return("RETURN0"); ';
+ }
+ else {
+ $data = "NO\x00I do not encrypt";
+ }
+ }
+ elsif ($command eq "EA") {
+
+ #
+ # Encryption available
+ #
+ $temp2 = "";
+ $version = "";
+ if (!$client->{_donotencrypt}) {
+ foreach (@P) {
+ if ($_ENCRYPT_AVAILABLE{$_}) {
+ $temp2 = $_;
+ $version = $_ENCRYPT_AVAILABLE{$_}{version};
+ last;
+ }
+ }
+ $temp2 ||= "";
+ $version ||= "";
+ }
+ $data = "EU\x00$temp2\x00$version";
+ if ($temp2) {
+ $evl = '$client->{_encrypt} = $temp2;';
+ $evl .= '($client->{_localpublickey},$client->{_localprivatekey}) =';
+ $evl .= ' _genkey($client->{_encrypt}) or ';
+ $evl .= ' return("RETURN0"); ';
+ }
+ }
+ elsif ($command eq "CM") {
+
+ #
+ # Compression module
+ #
+ if ($client->{_donotcompresswith}{ $P[0] }) {
+ $data = "NO\x00I do not compress with this module";
+ }
+ elsif (!$client->{_donotcompress}) {
+
+ #
+ # Let's see if we can decompress this
+ #
+ $tempscalar = _asc2bin($P[2]);
+ $client->{_compress} = $P[0];
+ if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
+
+ #
+ # This is a viable module that we can decompress.
+ #
+ if (_compress($client, \$tempscalar)) {
+ $data = "CM\x00$P[0]\x00" . $_COMPRESS_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc($tempscalar);
+ }
+ }
+ else {
+
+ #
+ # Failed to decompress message from server
+ #
+ $data = "NO\x00$@";
+ }
+ delete $client->{_compress};
+ }
+ else {
+
+ #
+ # I was told not to compress
+ #
+ $data = "NO\x00I do not compress";
+ }
+ }
+ elsif ($command eq "CU") {
+
+ #
+ # Compression Use
+ #
+ if ($client->{_donotcompresswith}{ $P[0] }) {
+ $data = "NO\x00I do not compress with this module";
+ }
+ elsif (!$client->{_donotcompress}) {
+ $temp2 = $P[0];
+ $data = "CU\x00$temp2";
+ $evl = '$client->{_compress} = $temp2;';
+ }
+ else {
+ $data = "NO\x00I do not compress";
+ }
+ }
+ elsif ($command eq "CA") {
+
+ #
+ # Compression available
+ #
+ $temp2 = "";
+ $version = "";
+ if (!$client->{_donotcompress}) {
+ foreach (@P) {
+ if ($_COMPRESS_AVAILABLE{$_}) {
+ $temp2 = $_;
+ $version = $_COMPRESS_AVAILABLE{$_}{version};
+ last;
+ }
+ }
+ $temp2 ||= "";
+ $version ||= "";
+ }
+ $data = "CU\x00$temp2\x00$version";
+ if ($temp2) {
+ $evl = '$client->{_compress} = $temp2;';
+ }
+ }
+ else {
+
+ #
+ # No Operation (do nothing)
+ #
+ $data = "NO\x00I don't understand you";
+ }
+ if (defined $data && !_send($client, $data, 0)) {
+ $@ = "Error negotiating with server: Could not send : $@";
+ return undef;
+ }
+
+ #
+ # NOW WE SEE IF WE NEED TO EVL ANYTHING
+ # IF THE RESULT OF THE EVAL IS "RETURNx" WHERE X IS A NUMBER, WE RETURN
+ # OTHERWISE WE KEEP GOING
+ #
+ if (defined $evl) {
+ $evl = eval($evl);
+ if ($evl =~ /^RETURN(.+)$/) {
+ return (($1) ? $1 : undef);
+ }
+ }
+ }
+ $@ = "Client timed out while negotiating with server [" . (time - $starttime) . "/$timeout] : $@";
+ return undef;
+}
+
+#
+# Once the server accepts a new connection, it calls this to negotiate basics with the client
+# Unlike _client_negotiate() which does not return until negotiation is over, this sub
+# sends 1 command or parses one reply at a time then returns immediately
+# Although this is much more complicated, it needs to be done so
+# the server does not block when a client is negotiating with it
+#
+# Expects a client object
+#
+sub _serverclient_negotiate {
+ my $client = shift;
+ my ($tempprivate, $tempscalar);
+ my $reply;
+ my $temp;
+ my @P;
+ my $command;
+ my $version;
+
+ if (!$client->{_negotiating}) {
+ return 1;
+ }
+
+ $reply = $client->data();
+
+ # Let's avoid some strict claimings
+ if (!defined $reply) { $reply = "" }
+ if (!defined $client->{_negotiating_lastevent}) { $client->{_negotiating_lastevent} = "" }
+
+ if (length($reply)) {
+
+ #
+ # We're parsing a reply the other end sent us
+ #
+ @P = split(/\x00/, $reply);
+ $command = shift(@P);
+ if (!$command) {
+ $@ = "Error negotiating. No command received from client : $@";
+ return undef;
+ }
+ $client->{_negotiating_lastevent} = "received";
+ if ($command eq "EU") {
+
+ #
+ # Encryption Use
+ #
+ $client->{_encrypt} = $P[0];
+ if ($client->{_encrypt}) {
+ $version = $_ENCRYPT_AVAILABLE{ $P[0] }{version};
+ if ($version ne $P[1] && !$client->{_negotiatedencryptcompatability}) {
+ unshift(@{ $client->{_negotiating_commands} }, "EVF\x00$version");
+ }
+ ($client->{_localpublickey}, $client->{_localprivatekey}) = _genkey($client->{_encrypt}) or return undef;
+ }
+ $temp = "EK\x00";
+ $temp .= _munge($client, $client->{_localpublickey});
+ unshift(@{ $client->{_negotiating_commands} }, $temp);
+ }
+ elsif ($command eq "EM") {
+
+ #
+ # Encryption module
+ #
+ if ($client->{_donotencryptwith}{ $P[0] }) {
+
+ #
+ # I was told not to encrypt with this module
+ #
+ }
+ elsif (!$client->{_donotencrypt}) {
+
+ #
+ # Let's see if we can decrypt this module
+ #
+ $tempprivate = _asc2bin($P[2]);
+ $tempscalar = _asc2bin($P[3]);
+
+ #
+ # Sometimes the tempprivate is frozen. If we can thaw it, let's do it:
+ #
+ eval { $temp = thaw $tempprivate };
+ if (!$@) {
+ $tempprivate = $temp;
+ }
+ $client->{_encrypt} = $P[0];
+ $client->{_localprivatekey} = $tempprivate;
+ if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
+
+ #
+ # This is a viable module that I (the server) can decrypt
+ # Since this is the second-reply to my EM, I know that the client can also decrypt using this module
+ # So we use it !
+ #
+ unshift(@{ $client->{_negotiating_commands} }, "EU\x00$P[0]");
+
+ #
+ # Yank out any future EMs we were going to send the client since they're weaker
+ #
+ $client->{_negotiating_commands} = [ grep { $_ !~ /^EM\x00/ } @{ $client->{_negotiating_commands} } ];
+ }
+ delete $client->{_localprivatekey};
+ delete $client->{_encrypt};
+
+ #
+ # Don't try EAs after this - we know the client supports EMs
+ #
+ $client->{_negotiatedencryptcompatability} = 1;
+ }
+ else {
+
+ #
+ # I was told not to encrypt
+ #
+ }
+ }
+ elsif ($command eq "CP") {
+
+ #
+ # Crypt Password
+ #
+ if (_munge($client, $P[0]) eq crypt($client->{_password}, $client->{_cryptsalt})) {
+ $client->{_authenticated} = 1;
+ }
+ else {
+ $client->{_authenticated} = 0;
+ unshift(@{ $client->{_negotiating_commands} }, "PF");
+ }
+ }
+ elsif ($command eq "COS") {
+
+ #
+ # Compatability scalar
+ #
+ if ($client->{_compatabilityscalar} ne _asc2bin($P[0])) {
+ unshift(@{ $client->{_negotiating_commands} }, "COF\x00Initial scalar exchange");
+ }
+ }
+ elsif ($command eq "VE") {
+
+ #
+ # Version
+ #
+ $client->{_version} = $P[0];
+ }
+ elsif ($command eq "SVE") {
+
+ #
+ # Version of Storable
+ #
+ $client->{_storableversion} = $P[0];
+ if ($P[1]) {
+
+ #
+ # New method
+ #
+ $temp = thaw(_asc2bin($P[1]));
+ if (!$temp) {
+ unshift(@{ $client->{_negotiating_commands} }, "COF\x00Thawing compatability reference with the Storable module");
+ }
+ if (!_comparereferences($temp, $client->{_compatabilityreference})) {
+ unshift(@{ $client->{_negotiating_commands} }, "COF\x00Comparing compatability reference with the Storable module");
+ }
+ }
+ elsif ($P[0] ne $Storable::VERSION) {
+
+ #
+ # Old method
+ #
+ unshift(@{ $client->{_negotiating_commands} }, "SVF\x00" . $Storable::VERSION);
+ }
+ }
+ elsif ($command eq "CM") {
+
+ #
+ # Compression module
+ #
+ if ($client->{_donotcompresswith}{ $P[0] }) {
+
+ # I was told not to compress with this module
+ }
+ elsif (!$client->{_donotcompress}) {
+
+ #
+ # Let's see if we can decompress this module
+ #
+ $tempscalar = _asc2bin($P[2]);
+ $client->{_compress} = $P[0];
+ if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
+
+ #
+ # This is a viable module that I (the server) can decompress
+ # Since this is the second-reply to my CM, I know that the client can also decrypt using this module
+ # So we use it !
+ #
+ unshift(@{ $client->{_negotiating_commands} }, "CU\x00$P[0]");
+
+ #
+ # Yank out any future CMs we were going to send the client since they're weaker
+ #
+ $client->{_negotiating_commands} = [ grep { $_ !~ /^CM\x00/ } @{ $client->{_negotiating_commands} } ];
+ }
+ delete $client->{_compress};
+
+ #
+ # Don't try CAs after this - we know the client supports CMs
+ #
+ $client->{_negotiatedcompresscompatability} = 1;
+ }
+ else {
+
+ #
+ # I was told not to compress
+ #
+ }
+ }
+ elsif ($command eq "CU") {
+
+ #
+ # Compression Use
+ #
+ $client->{_compress} = $P[0];
+ if ($client->{_compress}) {
+ $version = $_COMPRESS_AVAILABLE{ $P[0] }{version};
+ if ($version ne $P[1] && !$client->{_negotiatedcompresscompatability}) {
+ unshift(@{ $client->{_negotiating_commands} }, "CVF\x00$version");
+ }
+ }
+ }
+ elsif ($command eq "EK") {
+
+ #
+ # Encryption Key
+ #
+ $client->{_remotepublickey} = _munge($client, $P[0]);
+ }
+ elsif ($command eq "EN") {
+
+ #
+ # End (of negotiation)
+ #
+ if ((defined $client->{_password} && length($client->{_password})) && !$client->{_authenticated}) {
+ return undef;
+ }
+ else {
+ $client->{_negotiating} = 0;
+ delete $client->{_negotiating_lastevent};
+ delete $client->{_negotiating_commands};
+ return 1;
+ }
+ }
+ else {
+
+ # received unknown reply. so what..
+ }
+ }
+ elsif ($client->{_negotiating_lastevent} ne "sent") {
+
+ # We're sending a command to the other end, now we have to figure out which one
+ _serverclient_negotiate_sendnext($client);
+ }
+ return undef;
+}
+
+#
+# This is called by _serverclient_negotiate(). It's job is to figure out what's the next command to send
+# to the other end and send it.
+#
+# Expects a client object
+#
+sub _serverclient_negotiate_sendnext {
+ my $client = shift;
+ my $data;
+ my $class = $client;
+ my ($temppublic, $tempprivate, $tempscalar);
+ my $key;
+ my @available;
+ $class =~ s/=.*//g;
+
+ if (!defined $client->{_negotiating_commands}) {
+
+ #
+ # Let's initialize the sequence of commands we send
+ #
+ $data = "\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n";
+ $data .= "-----BEGIN CLEARTEXT WELCOME MESSAGE-----\r\n";
+ $data .= "::\r\n";
+ $data .= ":: HELLO :: $class VERSION $VERSION :: SERVER READY ::\r\n";
+ $data .= "::\r\n";
+ if ($client->{_welcome}) {
+ $data .= ":: $client->{_welcome}\r\n";
+ $data .= "::\r\n";
+ }
+ $data .= "-----END CLEARTEXT WELCOME MESSAGE-----\r\n";
+ push(@{ $client->{_negotiating_commands} }, $data);
+ $data = "VE\x00$VERSION";
+ push(@{ $client->{_negotiating_commands} }, $data);
+ $data = "COS\x00" . _bin2asc($client->{_compatabilityscalar});
+ push(@{ $client->{_negotiating_commands} }, $data);
+ $data = "SVE\x00" . $Storable::VERSION . "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference}));
+ push(@{ $client->{_negotiating_commands} }, $data);
+
+ if (!$client->{_donotencrypt}) {
+
+ @available = ();
+
+ #
+ # New method
+ #
+ foreach $key (@{ $_ENCRYPT_AVAILABLE{_order} }) {
+ if ($client->{_donotencryptwith}{$key}) {
+
+ # I was told not to encrypt with this module
+ next;
+ }
+ ($temppublic, $tempprivate) = _genkey($key, 1) or next;
+ $client->{_remotepublickey} = $temppublic;
+ $client->{_encrypt} = $key;
+ $tempscalar = $client->{_compatabilityscalar};
+ if (_encrypt($client, \$tempscalar)) {
+ push(@available, $key);
+ $data = "EM\x00$key\x00" . $_ENCRYPT_AVAILABLE{$key}{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar);
+ push(@{ $client->{_negotiating_commands} }, $data);
+ }
+ delete $client->{_remotepublickey};
+ delete $client->{_encrypt};
+ }
+
+ #
+ # Old method
+ #
+ $data = "EA" . join("", map { "\x00$_" } @available);
+ push(@{ $client->{_negotiating_commands} }, $data);
+ }
+ if (!$client->{_donotcompress}) {
+
+ @available = ();
+
+ #
+ # New method
+ #
+ foreach $key (@{ $_COMPRESS_AVAILABLE{_order} }) {
+ if ($client->{_donotcompresswith}{$key}) {
+
+ # I was told not to compress with this module
+ next;
+ }
+ $client->{_compress} = $key;
+ $tempscalar = $client->{_compatabilityscalar};
+ if (_compress($client, \$tempscalar)) {
+ push(@available, $key);
+ $data = "CM\x00$_\x00" . $_COMPRESS_AVAILABLE{$_}{version} . "\x00" . _bin2asc($tempscalar);
+ push(@{ $client->{_negotiating_commands} }, $data);
+ }
+ delete $client->{_compress};
+ }
+
+ #
+ # Old method
+ #
+ $data = "CA" . join("", map { "\x00$_" } @available);
+ push(@{ $client->{_negotiating_commands} }, $data);
+ }
+ if (defined $client->{_password}) {
+ if (!exists $client->{_cryptsalt}) {
+ $client->{_cryptsalt} = _genrandstring(2, 1);
+ }
+ $data = "CS\x00" . $client->{_cryptsalt};
+ push(@{ $client->{_negotiating_commands} }, $data);
+ }
+ push(@{ $client->{_negotiating_commands} }, "EN");
+ }
+
+ $data = shift @{ $client->{_negotiating_commands} };
+ if (($data =~ /^EA\x00/ && $client->{_negotiatedencryptcompatability}) || ($data =~ /^CA\x00/ && $client->{_negotiatedcompresscompatability})) {
+
+ #
+ # We've already negotiated through compatability. No need to re-negotiate based on versions
+ #
+ $data = "NO\x00Already negotiated through compatability";
+ }
+ if (!defined $data) {
+ return undef;
+ }
+ if (!_send($client, $data, 0)) {
+ $@ = "Error negotiating with client. Could not send : $@";
+ return undef;
+ }
+ $client->{_negotiating_lastevent} = "sent";
+ return 1;
+}
+
+#
+# This is called whenever a client (true client or serverclient) receives data without the realdata bit set
+# Takes client as first argument
+# Takes optional data as second argument, otherwise calls data() method to get it
+# It would parse the data and probably set variables inside the client object
+#
+sub _parseinternaldata {
+ my $client = shift;
+ my $data = shift;
+ if ($client->{_mode} eq "serverclient" && $client->{_negotiating}) {
+
+ # The serverclient is still negotiating
+ if (_serverclient_negotiate($client)) {
+
+ # Negotiation's complete and successful
+ _callback($client, "connect");
+ }
+ }
+ else {
+
+ #
+ # It's normal internal data
+ #
+ if (!defined $data) {
+
+ #
+ # Data was not supplied - get it from bucket
+ #
+ $data = $client->data();
+ }
+
+ # Now do something with it
+ }
+}
+
+#
+# This takes an integer, packs it as tightly as possible as a binary representation
+# and returns the binary value
+#
+sub _packint {
+ my $int = shift;
+ my $bin;
+ $bin = pack("N", $int);
+ $bin =~ s/^\0+//;
+ return $bin;
+}
+
+#
+# This does the opposite of _packint. It takes a packed binary produced by _packint and
+# returns the integer
+#
+sub _unpackint {
+ my $bin = shift;
+ my $int;
+ $int = "\0" x (4 - length($bin)) . $bin;
+ $int = unpack("N", $int);
+ return $int;
+}
+
+#
+# This creates a new client object and outgoing connection and returns it as an object
+# , or returns undef if unsuccessful
+# If special parameter _sock is supplied, it will be taken as an existing connection
+# and no outgoing connection will be made
+#
+sub _new_client {
+ my $class = shift;
+ my %para = @_;
+ my $sock;
+ my $self = {};
+ my $temp;
+ my $remoteip;
+ my $remoteport;
+ my $key;
+ my $timeout = $para{timeout} || 30;
+ $class =~ s/=.*//g;
+
+ if (!$para{_sock}) {
+ if (!$para{host}) {
+ $@ = "Invalid host";
+ return undef;
+ }
+ elsif (!$para{port}) {
+ $@ = "Invalid port";
+ return undef;
+ }
+ $sock = new IO::Socket::INET(
+ PeerAddr => $para{host},
+ PeerPort => $para{port},
+ Proto => 'tcp',
+ Timeout => $timeout,
+ );
+ $self->{_mode} = "client";
+ $self->{_negotiating} = time;
+ }
+ else {
+ $sock = $para{_sock};
+ $self->{_mode} = "serverclient";
+ $self->{_negotiating} = time;
+ $self->{_authenticated} = 0;
+ }
+ if (!$sock) {
+ $@ = "Could not connect to $para{host}:$para{port}: $!";
+ return undef;
+ }
+ $sock->autoflush(1);
+ if ($para{_remoteport} && $para{_remoteip}) {
+ $self->{_remoteport} = $para{_remoteport};
+ $self->{_remoteip} = $para{_remoteip};
+ }
+ else {
+ if (!($temp = getpeername($sock))) {
+ $@ = "Error getting peername";
+ return undef;
+ }
+ if (!(($remoteport, $remoteip) = sockaddr_in($temp))) {
+ $@ = "Error getting socket address";
+ return undef;
+ }
+ if (!($self->{_remoteip} = inet_ntoa($remoteip))) {
+ $@ = "Error determing remote IP";
+ return undef;
+ }
+ $self->{_remoteport} = $remoteport;
+ }
+ $self->{_sock} = $sock;
+ $self->{_password} = $para{password};
+ $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0;
+ $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0;
+ $self->{_donotcheckversion} = ($para{donotcheckversion}) ? 1 : 0;
+ $self->{_localpublickey} = "";
+ $self->{_databucket} = [];
+
+ #
+ # Populate donotcompresswith with the keys of the supplied module names
+ #
+ $self->{_donotcompresswith} = {};
+ if (ref($para{donotcompresswith}) ne "ARRAY") {
+ $para{donotcompresswith} = [ $para{donotcompresswith} ];
+ }
+ foreach $key (keys %_COMPRESS_AVAILABLE) {
+ if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) {
+ $self->{_donotcompresswith}{$key} = 1;
+ }
+ }
+
+ #
+ # Populate donotencryptwith with the keys of the supplied module names
+ #
+ $self->{_donotencryptwith} = {};
+ if (ref($para{donotencryptwith}) ne "ARRAY") {
+ $para{donotencryptwith} = [ $para{donotencryptwith} ];
+ }
+ foreach $key (keys %_ENCRYPT_AVAILABLE) {
+ if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) {
+ $self->{_donotencryptwith}{$key} = 1;
+ }
+ }
+
+ bless($self, $class);
+
+ if ($self->{_mode} eq "client") {
+ if (!_client_negotiate($self)) {
+
+ # Bad server
+ $self->close();
+ $@ = "Error negotiating with server: $@";
+ return undef;
+ }
+ else {
+ $self->{_negotiating} = 0;
+ }
+ }
+ return $self;
+}
+
+#
+# This creates a new listening server object and returns it, or returns undef if unsuccessful
+#
+# Expects a class
+#
+sub _new_server {
+ my $class = shift;
+ my %para = @_;
+ my $sock;
+ my $key;
+ my $self = {};
+ if (!$para{port}) {
+ $@ = "Invalid port";
+ return undef;
+ }
+ $sock = new IO::Socket::INET(
+ LocalPort => $para{port},
+ Proto => 'tcp',
+ Listen => SOMAXCONN,
+ Reuse => 1,
+ );
+ if (!$sock) {
+ $@ = "Could not create listening socket on port $para{port}: $!";
+ return undef;
+ }
+ $sock->autoflush(1);
+ $self->{_sock} = $sock;
+ $self->{_selector} = new IO::Select;
+ $self->{_selector}->add($sock);
+ $self->{_mode} = "server";
+ $self->{_welcome} = $para{welcome};
+ $self->{_password} = $para{password};
+ $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0;
+ $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0;
+ $self->{_clients} = {};
+ $self->{_clientip} = {};
+
+ #
+ # Populate donotcompresswith with the keys of the supplied module names
+ #
+ $self->{_donotcompresswith} = {};
+ if (ref($para{donotcompresswith}) ne "ARRAY") {
+ $para{donotcompresswith} = [ $para{donotcompresswith} ];
+ }
+ foreach $key (keys %_COMPRESS_AVAILABLE) {
+ if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) {
+ $self->{_donotcompresswith}{$key} = 1;
+ }
+ }
+
+ #
+ # Populate donotencryptwith with the keys of the supplied module names
+ #
+ $self->{_donotencryptwith} = {};
+ if (ref($para{donotencryptwith}) ne "ARRAY") {
+ $para{donotencryptwith} = [ $para{donotencryptwith} ];
+ }
+ foreach $key (keys %_ENCRYPT_AVAILABLE) {
+ if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) {
+ $self->{_donotencryptwith}{$key} = 1;
+ }
+ }
+
+ #
+ # To avoid key-gen delays while running, let's create global RSA keypairs right now
+ #
+ if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{'B'}) {
+ if (!_generateglobalkeypair('Crypt::RSA')) {
+ $@ = "Could not generate global Crypt::RSA keypairs. $@";
+ return undef;
+ }
+ }
+
+ bless($self, $class);
+ return $self;
+}
+
+#
+# This takes a client object and tries to extract as many data buckets as possible out of it's data buffer
+# If no buckets were extracted, returns false
+# Otherwise returns true
+#
+sub _extractdata {
+ my $client = shift;
+ my ($alwayson, $complexstructure, $realdata, $reserved, $encrypted, $compressed, $lenlen);
+ my $lendata;
+ my $len;
+ my $data;
+ my $key = (defined $client->{_databuffer}) ? substr($client->{_databuffer}, 0, 2) : '';
+ if (length($key) != 2) {
+ return undef;
+ }
+ $alwayson = vec($key, 0, 1);
+ $complexstructure = vec($key, 1, 1);
+ $realdata = vec($key, 2, 1);
+ $encrypted = vec($key, 3, 1);
+ $compressed = vec($key, 4, 1);
+ $reserved = vec($key, 5, 1);
+ $reserved = vec($key, 6, 1);
+ $reserved = vec($key, 7, 1);
+ $lenlen = vec($key, 1, 8);
+
+ if (!$alwayson) {
+ return undef;
+ }
+ $len = substr($client->{_databuffer}, 2, $lenlen);
+ $lendata = _unpackint($len);
+ if (length($client->{_databuffer}) < (2 + $lenlen + $lendata)) {
+ return undef;
+ }
+ $data = substr($client->{_databuffer}, 2 + $lenlen, $lendata);
+ if (length($data) != $lendata) {
+ return undef;
+ }
+ substr($client->{_databuffer}, 0, 2 + $lenlen + $lendata) = '';
+ if ($encrypted) {
+ _decrypt($client, \$data) || return undef;
+ }
+ if ($compressed) {
+ _decompress($client, \$data) || return undef;
+ }
+ if ($complexstructure) {
+ $data = thaw($data);
+ if (!$data) {
+ $@ = "Error decompressing complex structure: $!";
+ return undef;
+ }
+ }
+
+ #
+ # We extracted it fine from the buffer, we add it in the data buckets
+ #
+ push(
+ @{ $client->{_databucket} },
+ {
+ data => $data,
+ realdata => $realdata,
+ }
+ );
+
+ #
+ # Let's push our luck and see if we can extract more :)
+ #
+ _extractdata($client);
+
+ #
+ # All is good, we know we extracted at least 1 bucket
+ #
+ return (1);
+}
+
+#
+# This takes a client object and data, serializes the data if necesary, constructs a proprietary protocol packet
+# containing the user's data in it, implements crypto and compression as needed, and sends the packet to the supplied socket
+# Returns 1 for success, undef on failure
+#
+sub _send {
+ local $SIG{'PIPE'} = 'IGNORE';
+ my $client = shift;
+ my $data = shift;
+ my $realdata = shift;
+ my $sock = $client->{_sock};
+ my $encrypted;
+ my $compressed;
+ my $lendata;
+ my $lenlen;
+ my $len;
+ my $key;
+ my $finaldata;
+ my $packet;
+ my $temp;
+ my $bytes_written;
+ my $complexstructure = ref($data);
+
+ if (!$sock) {
+ $@ = "Error sending data: Socket handle not supplied";
+ return undef;
+ }
+ elsif (!defined $data) {
+ $@ = "Error sending data: Data not supplied";
+ return undef;
+ }
+ if ($complexstructure) {
+ $data = nfreeze $data;
+ }
+ $compressed = ($client->{_donotcompress}) ? 0 : _compress($client, \$data);
+ $encrypted = ($client->{_donotencrypt}) ? 0 : _encrypt($client, \$data);
+ $lendata = length($data);
+ $len = _packint($lendata);
+ $lenlen = length($len);
+
+ # Reset the key byte into 0-filled bits
+ $key = chr(0) x 2;
+ vec($key, 0, 16) = 0;
+
+ # 1 BIT: ALWAYSON :
+ vec($key, 0, 1) = 1;
+
+ # 1 BIT: COMPLEXSTRUCTURE :
+ vec($key, 1, 1) = ($complexstructure) ? 1 : 0;
+
+ # 1 BIT: REAL DATA:
+ vec($key, 2, 1) = (defined $realdata && !$realdata) ? 0 : 1;
+
+ # 1 BIT: ENCRYPTED :
+ vec($key, 3, 1) = ($encrypted) ? 1 : 0;
+
+ # 1 BIT: COMPRESSED :
+ vec($key, 4, 1) = ($compressed) ? 1 : 0;
+
+ # 1 BIT: RESERVED :
+ vec($key, 5, 1) = 0;
+
+ # 1 BIT: RESERVED :
+ vec($key, 6, 1) = 0;
+
+ # 1 BIT: RESERVED :
+ vec($key, 7, 1) = 0;
+
+ # 8 BITS: LENGTH OF "DATA LENGTH STRING"
+ vec($key, 1, 8) = $lenlen;
+
+ # Construct the final data and send it:
+ $finaldata = $key . $len . $data;
+ $len = length($finaldata);
+ $temp = 0;
+ while (length($finaldata)) {
+ $packet = substr($finaldata, 0, $PACKETSIZE);
+ substr($finaldata, 0, $PACKETSIZE) = '';
+ $bytes_written = syswrite($sock, $packet, length($packet));
+ if (!defined $bytes_written) {
+ $@ = "Error writing to socket while sending data: $!";
+ return undef;
+ }
+ $temp += $bytes_written;
+ }
+ if ($temp != $len) {
+ $@ = "Error sending data: $!";
+ return undef;
+ }
+ else {
+ return 1;
+ }
+}
+
+#
+# Leave me alone:
+#
+1;
Modified: packages/libnet-easytcp-perl/trunk/MANIFEST
===================================================================
--- packages/libnet-easytcp-perl/trunk/MANIFEST 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/MANIFEST 2005-05-11 15:21:45 UTC (rev 977)
@@ -7,3 +7,4 @@
util/server.pl
util/attack.pl
+META.yml Module meta-data (added by MakeMaker)
Copied: packages/libnet-easytcp-perl/trunk/META.yml (from rev 976, packages/libnet-easytcp-perl/branches/upstream/current/META.yml)
Modified: packages/libnet-easytcp-perl/trunk/debian/changelog
===================================================================
--- packages/libnet-easytcp-perl/trunk/debian/changelog 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/debian/changelog 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,3 +1,12 @@
+libnet-easytcp-perl (0.26-1) unstable; urgency=low
+
+ * New upstream release
+ * Package taken over from MIA maintainer (see thread strting at
+ http://lists.debian.org/debian-devel/2005/05/msg00533.html)
+ * Bumped up standards-version to 3.6.1
+
+ -- Gunnar Wolf <gwolf at debian.org> Wed, 11 May 2005 10:07:52 -0500
+
libnet-easytcp-perl (0.17-1) unstable; urgency=low
* Initial Release.
Modified: packages/libnet-easytcp-perl/trunk/debian/control
===================================================================
--- packages/libnet-easytcp-perl/trunk/debian/control 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/debian/control 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,9 +1,10 @@
Source: libnet-easytcp-perl
-Section: interpreters
+Section: perl
Priority: optional
Build-Depends: debhelper (>= 3.0.5), perl (>= 5.8.0-7)
-Maintainer: Shiju p. Nair <shiju at infovillage.net>
-Standards-Version: 3.5.1
+Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
+Uploaders: Gunnar Wolf <gwolf at debian.org>
+Standards-Version: 3.6.1
Package: libnet-easytcp-perl
Architecture: all
Modified: packages/libnet-easytcp-perl/trunk/debian/copyright
===================================================================
--- packages/libnet-easytcp-perl/trunk/debian/copyright 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/debian/copyright 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,6 +1,9 @@
This package was debianized by Shiju p. Nair <shiju at infovillage.net> on
Mon, 25 Nov 2002 09:39:00 +0300
+It was taken over by Gunnar Wolf <gwolf at debian.org> for the Debian Perl Group
+on Wed, 11 May 2005 10:19:34 -0500
+
It was downloaded from:
http://search.cpan.org/CPAN/authors/id/M/MN/MNAGUIB/EasyTCP-0.17.tar.gz
@@ -11,7 +14,7 @@
Copyright:
- Copyright (C) 2001-2002 Mina Naguib
+ Copyright (C) 2001-2005 Mina Naguib
This is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Modified: packages/libnet-easytcp-perl/trunk/test.pl
===================================================================
--- packages/libnet-easytcp-perl/trunk/test.pl 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/test.pl 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,5 +1,5 @@
#
-# $Header: /cvsroot/Net::EasyTCP/test.pl,v 1.17 2002/11/05 02:37:57 mina Exp $
+# $Header: /cvsroot/Net::EasyTCP/test.pl,v 1.20 2003/07/11 19:23:42 mina Exp $
#
BEGIN {
@@ -8,8 +8,8 @@
$| = 1;
select(STDOUT);
print "1..7\n";
- }
-END {print "not ok 1\n" unless $loaded;}
+}
+END { print "not ok 1\n" unless $loaded; }
use Net::EasyTCP;
$loaded = 1;
print "ok 1\n";
@@ -20,119 +20,143 @@
# Because windows is such a crappy OS that does not support (well) a fork() or alarm(), we can not possibly
# run this test. (HOWEVER, THE MODULE STILL WORKS OK !) Sorry !
#
-if ($^O =~ /win32/i) {
- for (2..7) {
- print "ok $_\n";
+
+nowindows();
+
+my $num = 1;
+my $PORT = undef;
+my $SERVER = undef;
+
+prepareserver();
+
+startclient();
+
+startserver();
+
+sub nowindows {
+ if ($^O =~ /win32/i) {
+ for (2 .. 7) {
+ print "ok $_\n";
}
- warn ("\n\nWARNING: SINCE YOU'RE RUNNING WINDOWS, WE COULD NOT TRULY TEST CLIENT-SERVER FUNCTIONALITY WITHIN 1 PROCESS. ASSUMING TEST SUCCEEDED\n\n");
- warn ("\n\nTO PROPERLY TEST THIS MODULE, LOOK INTO THE /util/ SUBFOLDER OF THIS DISTRO AND MANYALLY RUN THE server.pl THERE, THEN CONCURRENTLY RUN THE client.pl\n\n");
- exit(0);
+ warn("\n\nWARNING: SINCE YOU'RE RUNNING WINDOWS, WE COULD NOT TRULY TEST CLIENT-SERVER FUNCTIONALITY WITHIN 1 PROCESS. ASSUMING TEST SUCCEEDED\n\n");
+ warn("\n\nTO PROPERLY TEST THIS MODULE, LOOK INTO THE /util/ SUBFOLDER OF THIS DISTRO AND MANYALLY RUN THE server.pl THERE, THEN CONCURRENTLY RUN THE client.pl\n\n");
+ exit(0);
}
+}
-
-my $num = 1;
-
-sub res() {
- my $res = shift;
+sub res {
+ my $res = shift;
my $desc = shift;
$num++;
if ($res) {
print "ok $num\n";
- }
+ }
else {
print "not ok $num\n";
warn "Error in test [$desc]: $@\n";
- die("ABORTING TEST\n");
- }
+ die ("ABORTING TEST\n");
}
+}
-&startclient();
-
-&startserver();
-
-sub startserver() {
+sub prepareserver {
my $temp;
- my $server;
+ my @tryports = qw(2345 65496 1025 2042);
- $server = new Net::EasyTCP(
- mode => "server",
- port => 2345,
- password => "just another perl hacker",
+ foreach (@tryports) {
+ $PORT = $_;
+ $SERVER = new Net::EasyTCP(
+ mode => "server",
+ port => $PORT,
+ password => "just another perl hacker",
);
- &res ($server, "Create new server");
+ if ($SERVER) {
- $temp = $server->setcallback(
- data => \&gotdata,
- connect => \&connected,
- disconnect => \&disconnected,
- );
- &res($temp, "Set callbacks");
-
- $server->start();
+ #
+ # We succeeded, no need to loop and try a different port
+ #
+ last;
+ }
}
+ res($SERVER, "Create new server");
-sub startclient() {
+ $temp = $SERVER->setcallback(
+ data => \&gotdata,
+ connect => \&connected,
+ disconnect => \&disconnected,
+ );
+ res($temp, "Set callbacks");
+
+}
+
+sub startserver {
+ $SERVER->start();
+}
+
+sub startclient {
my $temp;
my $pid;
my $starttime;
my $maxelapsed = "15";
- $pid= fork();
+ $pid = fork();
if ($pid) {
+
# I'm the parent
return;
- }
+ }
elsif ($pid == 0) {
+
# I'm the client
- }
+ undef $SERVER;
+ }
else {
die "ERROR: FAILED TO FORK A PROCESS FOR A CLIENT: $!\n";
- }
-
+ }
+
$starttime = time;
while ((time - $starttime) <= $maxelapsed) {
$client = new Net::EasyTCP(
- mode => "client",
- host => '127.0.0.1',
- port => 2345,
- password => "just another perl hacker",
- );
+ mode => "client",
+ host => '127.0.0.1',
+ port => $PORT,
+ password => "just another perl hacker",
+ );
if ($client) {
last;
- }
}
+ }
$client || die "ERROR: CLIENT FAILED TO BE CREATED WITHIN $maxelapsed SECONDS: $@\n";
$temp = $client->receive();
($temp eq "SEND ME COMPLEX") || die "ERROR: CLIENT RECEIVED [$temp] INSTEAD OF [SEND ME COMPLEX]\n";
- $temp = $client->send({"complex"=>"data"})
- || die "ERROR: CLIENT FAILED TO SEND HASH REFERENCE: $@\n";
+ $temp = $client->send({ "complex" => "data" })
+ || die "ERROR: CLIENT FAILED TO SEND HASH REFERENCE: $@\n";
$temp = $client->close()
- || die "ERROR: CLIENT FAILED TO CLOSE CONNECTION: $@\n";
+ || die "ERROR: CLIENT FAILED TO CLOSE CONNECTION: $@\n";
exit(0);
- }
+}
-sub connected() {
+sub connected {
my $client = shift;
my $temp;
- &res($client, "Server received connection");
+ res($client, "Server received connection");
$temp = $client->send("SEND ME COMPLEX");
- &res($temp, "Server send data from callback");
- }
+ res($temp, "Server send data from callback");
+}
-sub gotdata() {
+sub gotdata {
my $client = shift;
- my $data = $client->data();
- &res($data->{complex} eq "data", "Server receive complex data");
- }
+ my $data = $client->data();
+ res($data->{complex} eq "data", "Server receive complex data");
+}
-sub disconnected() {
+sub disconnected {
my $client = shift;
- &res($client, "Server received client disconnection");
+ res($client, "Server received client disconnection");
exit(0);
- }
+}
Modified: packages/libnet-easytcp-perl/trunk/util/attack.pl
===================================================================
--- packages/libnet-easytcp-perl/trunk/util/attack.pl 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/util/attack.pl 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,28 +1,27 @@
-#!/usr/bin/perl
+#!/usr/local/bin/perl
#
-# $Header: /cvsroot/Net::EasyTCP/util/attack.pl,v 1.2 2002/11/03 09:06:18 mina Exp $
+# $Header: /cvsroot/Net::EasyTCP/util/attack.pl,v 1.4 2003/03/02 05:41:48 mina Exp $
#
-$|=1;
+$| = 1;
use Net::EasyTCP;
-$|=1;
-for (1..1000) {
+for (1 .. 1000) {
print "Launching client [$_}\n";
- $client = new Net::EasyTCP(
- mode => "client",
- host => 'localhost',
- port => 2345,
- password => "byteme",
- donotencrypt => 1,
- )
- || die "ERROR CREATING CLIENT: $@\n";
+ $client = new Net::EasyTCP(
+ mode => "client",
+ host => 'localhost',
+ port => 2345,
+ password => "byteme",
+ donotencrypt => 1,
+ )
+ || die "ERROR CREATING CLIENT: $@\n";
push (@clients, $client);
- }
+}
foreach $client (@clients) {
print "Closing ...\n";
$client->close() || die "ERROR CLOSING: $@\n";
- }
+}
Modified: packages/libnet-easytcp-perl/trunk/util/client.pl
===================================================================
--- packages/libnet-easytcp-perl/trunk/util/client.pl 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/util/client.pl 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,23 +1,23 @@
#!/usr/local/bin/perl
#
-# $Header: /cvsroot/Net::EasyTCP/util/client.pl,v 1.4 2002/11/03 09:06:18 mina Exp $
+# $Header: /cvsroot/Net::EasyTCP/util/client.pl,v 1.5 2003/02/28 19:50:10 mina Exp $
#
-$|=1;
+$| = 1;
use Net::EasyTCP;
$hostname = shift || "localhost";
$client = new Net::EasyTCP(
- mode => "client",
- host => $hostname,
- port => 2345,
- )
- || die "ERROR CREATING CLIENT: $@\n";
+ mode => "client",
+ host => $hostname,
+ port => 2345,
+ )
+ || die "ERROR CREATING CLIENT: $@\n";
-$encryption = $client->encryption() || "NO";
+$encryption = $client->encryption() || "NO";
$compression = $client->compression() || "NO";
print "Using $encryption encryption and $compression compression\n\n";
@@ -30,33 +30,33 @@
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
if ($reply ne $string) {
print "ERROR: REPLY MISMATCHED SENT . . . ";
- }
+}
print "done\n\n";
#Send and receive complex objects/strings/arrays/hashes by reference
print "Sending hashref . . . ";
-%hash = ("to be or" => "not to be" , "just another" => "perl hacker");
+%hash = ("to be or" => "not to be", "just another" => "perl hacker");
$client->send(\%hash) || die "ERROR SENDING: $@\n";
print "receiving . . . ";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
foreach (keys %{$reply}) {
- print "Received key: $_ = $reply->{$_}\n";
- }
+ print "Received key: $_ = $reply->{$_}\n";
+}
print "done\n\n";
#Send and receive large binary data
print "Sending large binary data . . . ";
-for (1..4096) {
- for (0..255) {
- $largedata .= chr($_);
- }
- }
+for (1 .. 4096) {
+ for (0 .. 255) {
+ $largedata .= chr($_);
+ }
+}
$client->send($largedata) || die "ERROR SENDING: $@\n";
print "receiving . . . ";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
if ($largedata ne $reply) {
print "WARNING : RECEIVED DATA MISMATCHED MISMATCH . . . ";
- }
+}
print "done\n\n";
$client->close();
Modified: packages/libnet-easytcp-perl/trunk/util/server.pl
===================================================================
--- packages/libnet-easytcp-perl/trunk/util/server.pl 2005-05-11 15:08:03 UTC (rev 976)
+++ packages/libnet-easytcp-perl/trunk/util/server.pl 2005-05-11 15:21:45 UTC (rev 977)
@@ -1,27 +1,27 @@
#!/usr/local/bin/perl
#
-# $Header: /cvsroot/Net::EasyTCP/util/server.pl,v 1.4 2002/11/03 09:06:18 mina Exp $
+# $Header: /cvsroot/Net::EasyTCP/util/server.pl,v 1.5 2003/02/28 19:50:10 mina Exp $
#
use Net::EasyTCP;
-$|=1;
+$| = 1;
print "Creating server ...\n";
$server = new Net::EasyTCP(
- mode => "server",
- port => 2345,
- welcome => "Welcome to my first little echo server",
- )
- || die "ERROR CREATING SERVER: $@\n";
+ mode => "server",
+ port => 2345,
+ welcome => "Welcome to my first little echo server",
+ )
+ || die "ERROR CREATING SERVER: $@\n";
print "Setting callbacks ...\n";
$server->setcallback(
- data => \&gotdata,
- connect => \&connected,
- disconnect => \&disconnected,
- )
- || die "ERROR SETTING CALLBACKS: $@\n";
+ data => \&gotdata,
+ connect => \&connected,
+ disconnect => \&disconnected,
+ )
+ || die "ERROR SETTING CALLBACKS: $@\n";
print "Starting server ...\n\n";
$server->start() || die "ERROR STARTING SERVER: $@\n";
@@ -29,28 +29,28 @@
sub gotdata() {
my $client = shift;
my $serial = $client->serial();
- my $data = $client->data();
+ my $data = $client->data();
print "Client $serial sent me some data, sending it right back to them again\n";
$client->send($data) || die "ERROR SENDING TO CLIENT: $@\n";
if ($data eq "QUIT") {
$client->close() || die "ERROR CLOSING CLIENT: $@\n";
- }
+ }
elsif ($data eq "DIE") {
$server->stop() || die "ERROR STOPPING SERVER: $@\n";
- }
}
+}
sub connected() {
my $client = shift;
my $serial = $client->serial();
- my $ip = $client->remoteip();
- my $port = $client->remoteport();
+ my $ip = $client->remoteip();
+ my $port = $client->remoteport();
print "Client $serial [$ip:$port] just connected\n";
- }
+}
sub disconnected() {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just disconnected\n";
- }
+}
More information about the Pkg-perl-cvs-commits
mailing list