1package Net::EasyTCP;
2
3#
4# $Header: /cvsroot/Net::EasyTCP/EasyTCP.pm,v 1.144 2004/03/17 14:14:31 mina Exp $
5#
6
7use strict;
8use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $_SERIAL %_COMPRESS_AVAILABLE %_ENCRYPT_AVAILABLE %_MISC_AVAILABLE $PACKETSIZE);
9
10use IO::Socket;
11use IO::Select;
12use Storable qw(nfreeze thaw);
13
14#
15# This block's purpose is to:
16# Put the list of available modules in %_COMPRESS_AVAILABLE and %_ENCRYPT_AVAILABLE and %_MISC_AVAILABLE
17#
18BEGIN {
19	my $version;
20	my $hasCBC;
21	my @_compress_modules = (
22
23		#
24		# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
25		#
26		# HIGHEST EVER USED: 2
27		#
28		[ '1', 'Compress::Zlib' ],
29		[ '2', 'Compress::LZF' ],
30	);
31	my @_encrypt_modules = (
32
33		#
34		# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
35		#
36		# HIGHEST EVER USED: E
37		#
38		[ 'B', 'Crypt::RSA',         0, 0 ],
39		[ '3', 'Crypt::CBC',         0, 0 ],
40		[ 'A', 'Crypt::Rijndael',    1, 1 ],
41		[ '9', 'Crypt::RC6',         1, 1 ],
42		[ '4', 'Crypt::Blowfish',    1, 1 ],
43		[ '6', 'Crypt::DES_EDE3',    1, 1 ],
44		[ '5', 'Crypt::DES',         1, 1 ],
45		[ 'C', 'Crypt::Twofish2',    1, 1 ],
46		[ 'D', 'Crypt::Twofish',     1, 1 ],
47		[ 'E', 'Crypt::TEA',         1, 1 ],
48		[ '2', 'Crypt::CipherSaber', 0, 1 ],
49	);
50	my @_misc_modules = (
51
52		#
53		# MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST
54		# (this is not as necessary as compress and encrypt since it's not transmitted to peers, but just in case...)
55		#
56		# HIGHEST EVER USED: 1
57		#
58		[ '1', 'Crypt::Random' ],
59	);
60
61	#
62	# Let's reset some variables:
63	#
64	$hasCBC                      = 0;
65	$_COMPRESS_AVAILABLE{_order} = [];
66	$_ENCRYPT_AVAILABLE{_order}  = [];
67	$_MISC_AVAILABLE{_order}     = [];
68
69	#
70	# Now we check the compress array for existing modules
71	#
72	foreach (@_compress_modules) {
73		$@ = undef;
74		eval {
75			eval("require $_->[1];") || die "$_->[1] not found\n";
76			$version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
77		};
78		if (!$@) {
79			push(@{ $_COMPRESS_AVAILABLE{_order} }, $_->[0]);
80			$_COMPRESS_AVAILABLE{ $_->[0] }{name}    = $_->[1];
81			$_COMPRESS_AVAILABLE{ $_->[0] }{version} = $version;
82		}
83	}
84
85	#
86	# Now we check the encrypt array for existing modules
87	#
88	foreach (@_encrypt_modules) {
89		$@ = undef;
90		eval {
91			eval("require $_->[1];") || die "$_->[1] not found\n";
92			$version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
93		};
94		if (!$@) {
95			if ($_->[1] eq 'Crypt::CBC') {
96				$hasCBC = 1;
97			}
98			elsif (($hasCBC && $_->[2]) || !$_->[2]) {
99				push(@{ $_ENCRYPT_AVAILABLE{_order} }, $_->[0]);
100				$_ENCRYPT_AVAILABLE{ $_->[0] }{name}              = $_->[1];
101				$_ENCRYPT_AVAILABLE{ $_->[0] }{cbc}               = $_->[2];
102				$_ENCRYPT_AVAILABLE{ $_->[0] }{mergewithpassword} = $_->[3];
103				$_ENCRYPT_AVAILABLE{ $_->[0] }{version}           = $version;
104			}
105		}
106	}
107
108	#
109	# Now we check the misc array for existing modules
110	#
111	foreach (@_misc_modules) {
112		$@ = undef;
113		eval {
114			eval("require $_->[1];") || die "$_->[1] not found\n";
115			$version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
116		};
117		if (!$@) {
118			push(@{ $_MISC_AVAILABLE{_order} }, $_->[0]);
119			$_MISC_AVAILABLE{ $_->[0] }{name}    = $_->[1];
120			$_MISC_AVAILABLE{ $_->[0] }{version} = $version;
121		}
122	}
123}
124
125require Exporter;
126
127@ISA        = qw(Exporter);
128@EXPORT     = qw();
129$VERSION    = '0.26';
130$PACKETSIZE = 4096;
131
132#
133# POD DOCUMENTATION:
134#
135
136=head1 NAME
137
138Net::EasyTCP - Easily create secure, bandwidth-friendly TCP/IP clients and servers
139
140=head1 FEATURES
141
142=over 4
143
144=item *
145
146One easy module to create both clients and servers
147
148=item *
149
150Object Oriented interface
151
152=item *
153
154Event-based callbacks in server mode
155
156=item *
157
158Internal protocol to take care of all the common transport problems
159
160=item *
161
162Transparent encryption
163
164=item *
165
166Transparent compression
167
168=back
169
170=head1 SYNOPSIS
171
172=over 4
173
174=item SERVER EXAMPLE:
175
176	use Net::EasyTCP;
177
178	#
179	# Create the server object
180	#
181	$server = new Net::EasyTCP(
182		mode            =>      "server",
183		port            =>      2345,
184	)
185	|| die "ERROR CREATING SERVER: $@\n";
186
187	#
188	# Tell it about the callbacks to call
189	# on known events
190	#
191	$server->setcallback(
192		data            =>      \&gotdata,
193		connect         =>      \&connected,
194		disconnect	=>	\&disconnected,
195	)
196	|| die "ERROR SETTING CALLBACKS: $@\n";
197
198	#
199	# Start the server
200	#
201	$server->start() || die "ERROR STARTING SERVER: $@\n";
202
203	#
204	# This sub gets called when a client sends us data
205	#
206	sub gotdata {
207		my $client = shift;
208		my $serial = $client->serial();
209		my $data = $client->data();
210		print "Client $serial sent me some data, sending it right back to them again\n";
211		$client->send($data) || die "ERROR SENDING TO CLIENT: $@\n";
212		if ($data eq "QUIT") {
213			$client->close() || die "ERROR CLOSING CLIENT: $@\n";
214		}
215		elsif ($data eq "DIE") {
216			$server->stop() || die "ERROR STOPPING SERVER: $@\n";
217		}
218	}
219
220	#
221	# This sub gets called when a new client connects
222	#
223	sub connected {
224		my $client = shift;
225		my $serial = $client->serial();
226		print "Client $serial just connected\n";
227	}
228
229	#
230	# This sub gets called when an existing client disconnects
231	#
232	sub disconnected {
233		my $client = shift;
234		my $serial = $client->serial();
235		print "Client $serial just disconnected\n";
236	}
237
238=item CLIENT EXAMPLE:
239
240	use Net::EasyTCP;
241
242	#
243	# Create a new client and connect to a server
244	#
245	$client = new Net::EasyTCP(
246		mode            =>      "client",
247		host            =>      'localhost',
248		port            =>      2345,
249	)
250	|| die "ERROR CREATING CLIENT: $@\n";
251
252	#
253	# Send and receive a simple string
254	#
255	$client->send("HELLO THERE") || die "ERROR SENDING: $@\n";
256	$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
257
258	#
259	# Send and receive complex objects/strings/arrays/hashes by reference
260	#
261	%hash = ("to be or" => "not to be" , "just another" => "perl hacker");
262	$client->send(\%hash) || die "ERROR SENDING: $@\n";
263	$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
264	foreach (keys %{$reply}) {
265		print "Received key: $_ = $reply->{$_}\n";
266	}
267
268	#
269	# Send and receive large binary data
270	#
271	for (1..8192) {
272		for (0..255) {
273			$largedata .= chr($_);
274		}
275	}
276	$client->send($largedata) || die "ERROR SENDING: $@\n";
277	$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
278
279	#
280	# Cleanly disconnect from the server
281	#
282	$client->close();
283
284=back
285
286=head1 DESCRIPTION
287
288This class allows you to easily create TCP/IP clients and servers and provides an OO interface to manage the connection(s).  This allows you to concentrate on the application rather than on the transport.
289
290You still have to engineer your high-level protocol. For example, if you're writing an SMTP client-server pair, you will have to teach your client to send "HELO" when it connects, and you will have to teach your server what to do once it receives the "HELO" command, and so forth.
291
292What you won't have to do is worry about how the command will get there, about line termination, about binary data, complex-structure serialization, encryption, compression, or about fragmented packets on the received end.  All of these will be taken care of by this class.
293
294=head1 CONSTRUCTOR
295
296=over 4
297
298=item new(%hash)
299
300Constructs and returns a new Net::EasyTCP object.  Such an object behaves in one of two modes (that needs to be supplied to new() on creation time).  You can create either a server object (which accepts connections from several clients) or a client object (which initiates a connection to a server).
301
302new() expects to be passed a hash. The following keys are accepted:
303
304=over 4
305
306=item donotcheckversion
307
308Set 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)
309Note 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.
310(Optional and acceptable when mode is "client")
311
312=item donotcompress
313
314Set to 1 to forcefully disable L<compression|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
315(Optional)
316
317=item donotcompresswith
318
319Set 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.
320(Optional)
321
322=item donotencrypt
323
324Set to 1 to forcefully disable L<encryption|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
325(Optional)
326
327=item donotencryptwith
328
329Set 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.
330(Optional)
331
332=item host
333
334Must be set to the hostname/IP address to connect to.
335(Mandatory when mode is "client")
336
337=item mode
338
339Must be set to either "client" or "server" according to the type of object you want returned.
340(Mandatory)
341
342=item password
343
344Defines a password to use for the connection.  When mode is "server" this password will be required from clients before the full connection is accepted .  When mode is "client" this is the password that the server connecting to requires.
345
346Also, when encryption using a symmetric encryption module is used, this password is included as part of the secret "key" for encrypting the data.
347(Optional)
348
349=item port
350
351Must 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.
352(Mandatory)
353
354=item timeout
355
356Set 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")
357
358=item welcome
359
360If someone uses an interactive telnet program to telnet to the server, they will see this welcome message.
361(Optional and acceptable only when mode is "server")
362
363=back
364
365=back
366
367=head1 METHODS
368
369B<[C] = Available to objects created as mode "client">
370
371B<[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.>
372
373B<[S] = Available to objects created as mode "server">
374
375=over 4
376
377=item addclientip(@array)
378
379B<[S]> Adds an IP address (or IP addresses) to the list of allowed clients to a server.  If this is done, the server will not accept connections from clients not in it's list.
380
381The compliment of this function is deleteclientip() .
382
383=item callback(%hash)
384
385See setcallback()
386
387=item clients()
388
389B<[S]> Returns all the clients currently connected to the server.  If called in array context will return an array of client objects.  If called in scalar context will return the number of clients connected.
390
391=item close()
392
393B<[C][H]> Instructs a client object to close it's connection with a server.
394
395=item compression()
396
397B<[C][H]> Returns the name of the module used as the compression module for this connection, undef if no compression occurs.
398
399=item data()
400
401B<[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.
402
403=item deleteclientip(@array)
404
405B<[S]> Deletes an IP address (or IP addresses) from the list of allowed clients to a server.  The IP address (or IP addresses) supplied will no longer be able to connect to the server.
406
407The compliment of this function is addclientip() .
408
409=item disconnect()
410
411See close()
412
413=item do_one_loop()
414
415B<[S]> Instructs a server object to "do one loop" and return ASAP.  This method needs to be called VERY frequently for a server object to function as expected (either through some sort of loop inside your program if you need to do other things beside serve clients, or via the start() method if your entire program is dedicated to serving clients).  Each one loop will help the server do it's job, including accepting new clients, receiving data from them, firing off the appropriate callbacks etc.
416
417=item encryption()
418
419B<[C][H]> Returns the name of the module used as the encryption module for this connection, undef if no encryption occurs.
420
421=item mode()
422
423B<[C][H][S]> Identifies the mode of the object.  Returns either "client" or "server"
424
425=item receive($timeout)
426
427B<[C]> Receives data sent to the client by a server and returns it.  It will block until data is received or until a certain timeout of inactivity (no data transferring) has occurred.
428
429It accepts an optional parameter, a timeout value in seconds.  If none is supplied it will default to 300.
430
431=item remoteip()
432
433B<[C][H]> Returns the IP address of the host on the other end of the connection.
434
435=item remoteport()
436
437B<[C][H]> Returns the port of the host on the other end of the connection.
438
439=item running()
440
441B<[S]> Returns true if the server is running (started), false if it is not.
442
443=item send($data)
444
445B<[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.
446
447It accepts one parameter, and that is the data to send.  The data can be a simple scalar or a reference to something more complex.
448
449=item serial()
450
451B<[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.
452
453=item setcallback(%hash)
454
455B<[S]> Tells the server which subroutines to call when specific events happen. For example when a client sends the server data, the server calls the "data" callback sub.
456
457setcallback() expects to be passed a hash. Each key in the hash is the callback type identifier, and the value is a reference to a sub to call once that callback type event occurs.
458
459Valid keys in that hash are:
460
461=over 4
462
463=item connect
464
465Called when a new client connects to the server
466
467=item data
468
469Called when an existing client sends data to the server
470
471=item disconnect
472
473Called when an existing client disconnects
474
475=back
476
477Whenever a callback sub is called, it is passed a single parameter, a CLIENT OBJECT. The callback code may then use any of the methods available to client objects to do whatever it wants to do (Read data sent from the client, reply to the client, close the client connection etc...)
478
479
480=item socket()
481
482B<[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.
483
484Note 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.
485
486=item start(subref)
487
488B<[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.
489
490If 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.
491
492=item stop()
493
494B<[S]> Instructs a running server to stop and returns immediately (does not wait for the server to actually stop, which may be a few seconds later).  To check if the server is still running or not use the running() method.
495
496=back
497
498=head1 COMPRESSION AND ENCRYPTION
499
500Clients and servers written using this class will automatically compress and/or encrypt the transferred data if the appropriate modules are found.
501
502Compression will be automatically enabled if one (or more) of: L<Compress::Zlib|Compress::Zlib> or L<Compress::LZF|Compress::LZF> are installed on both the client and the server.
503
504As-symmetric encryption will be automatically enabled if L<Crypt::RSA|Crypt::RSA> is installed on both the client and the server.
505
506Symmetric 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.
507
508Strong randomization will be automatically enabled if L<Crypt::Random|Crypt::Random> is installed; otherwise perl's internal rand() is used to generate random keys.
509
510Preference to the compression/encryption method used is determind by availablity checking following the order in which they are presented in the above lists.
511
512Note 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.
513
514To find out which module(s) have been negotiated for use you can use the compression() and encryption() methods.
515
516* Note that for this class's purposes, L<Crypt::CBC|Crypt::CBC> is a requirement to use any of the encryption modules with a * next to it's name in the above list.  So eventhough you may have these modules installed on both the client and the server, they will not be used unless L<Crypt::CBC|Crypt::CBC> is also installed on both ends.
517
518* Note that the nature of symmetric cryptography dictates sharing the secret keys somehow.  It is therefore highly recommend to use an As-symmetric cryptography module (such as Crypt::RSA) for serious encryption needs; as a determined hacker might find it trivial to decrypt your data with other symmetric modules.
519
520* 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.
521
522If 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...
523
524=head1 RETURN VALUES AND ERRORS
525
526The constructor and all methods return something that evaluates to true when successful, and to false when not successful.
527
528There are a couple of exceptions to the above rule and they are the following methods:
529
530=over 4
531
532=item *
533
534clients()
535
536=item *
537
538data()
539
540=back
541
542The above methods may return something that evaluates to false (such as an empty string, an empty array, or the string "0") eventhough there was no error.  In that case check if the returned value is defined or not, using the defined() Perl function.
543
544If not successful, the variable $@ will contain a description of the error that occurred.
545
546=head1 NOTES
547
548=over 4
549
550=item Incompatability with Net::EasyTCP version 0.01
551
552Version 0.02 and later have had their internal protocol modified to a fairly large degree.  This has made compatability with version 0.01 impossible.  If you're going to use version 0.02 or later (highly recommended), then you will need to make sure that none of the clients/servers are still using version 0.01.  It is highly recommended to use the same version of this module on both sides.
553
554=item Internal Protocol
555
556This class implements a miniature protocol when it sends and receives data between it's clients and servers.  This means that a server created using this class cannot properly communicate with a normal client of any protocol (pop3/smtp/etc..) unless that client was also written using this class.  It also means that a client written with this class will not properly communicate with a different server (telnet/smtp/pop3 server for example, unless that server is implemented using this class also).  This limitation will not change in future releases due to the plethora of advantages the internal protocol gives us.
557
558In other words, if you write a server using this class, write the client using this class also, and vice versa.
559
560=item Delays
561
562This class does not use the fork() method whatsoever.  This means that all it's input/output and multi-socket handling is done via select().
563
564This leads to the following limitation:  When a server calls one of your callback subs, it waits for it to return and therefore cannot do anything else.  If your callback sub takes 5 minutes to return, then the server will not be able to do anything for 5 minutes, such as acknowledge new clients, or process input from other clients.
565
566In other words, make the code in your callbacks' subs' minimal and strive to make it return as fast as possible.
567
568=item Deadlocks
569
570As with any client-server scenario, make sure you engineer how they're going to talk to each other, and the order they're going to talk to each other in, quite carefully.  If both ends of the connection are waiting for the other end to say something, you've got a deadlock.
571
572=back
573
574=head1 AUTHOR
575
576Mina Naguib
577http://www.topfx.com
578mnaguib@cpan.org
579
580=head1 SEE ALSO
581
582Perl(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()
583
584=head1 COPYRIGHT
585
586Copyright (C) 2001-2003 Mina Naguib.  All rights reserved.  Use is subject to the Perl license.
587
588=cut
589
590#
591# The main constructor. This calls either _new_client or _new_server depending on the supplied mode
592#
593sub new {
594	my $class = shift;
595	my %para  = @_;
596
597	# Let's lowercase all keys in %para
598	foreach (keys %para) {
599		if ($_ ne lc($_)) {
600			$para{ lc($_) } = $para{$_};
601			delete $para{$_};
602		}
603	}
604	if ($para{mode} =~ /^c/i) {
605		return _new_client($class, %para);
606	}
607	elsif ($para{mode} =~ /^s/i) {
608		return _new_server($class, %para);
609	}
610	else {
611		$@ = "Supplied mode '$para{mode}' unacceptable. Must be either 'client' or 'server'";
612		return undef;
613	}
614}
615
616#
617# Make callback() a synonim to setcallback()
618#
619
620sub callback {
621	return setcallback(@_);
622}
623
624#
625# This method adds an ip address(es) to the list of valid IPs a server can accept connections
626# from.
627#
628sub addclientip {
629	my $self = shift;
630	my @ips  = @_;
631	if ($self->{_mode} ne "server") {
632		$@ = "$self->{_mode} cannot use method addclientip()";
633		return undef;
634	}
635	foreach (@ips) {
636		$self->{_clientip}{$_} = 1;
637	}
638	return 1;
639}
640
641#
642# This method does the opposite of addclient(), it removes an ip address(es) from the list
643# of valid IPs a server can accept connections from.
644#
645sub deleteclientip {
646	my $self = shift;
647	my @ips  = @_;
648	if ($self->{_mode} ne "server") {
649		$@ = "$self->{_mode} cannot use method deleteclientip()";
650		return undef;
651	}
652	foreach (@ips) {
653		delete $self->{_clientip}{$_};
654	}
655	return 1;
656}
657
658#
659#
660# This method modifies the _callback_XYZ in a server object. These are the routines
661# the server calls when an event (data, connect, disconnect) happens
662#
663sub setcallback {
664	my $self = shift;
665	my %para = @_;
666	if ($self->{_mode} ne "server") {
667		$@ = "$self->{_mode} cannot use method setcallback()";
668		return undef;
669	}
670	foreach (keys %para) {
671		if (ref($para{$_}) ne "CODE") {
672			$@ = "Callback $_ $para{$_} does not exist";
673			return 0;
674		}
675		$self->{_callbacks}->{$_} = $para{$_};
676	}
677	return 1;
678}
679
680#
681# This method starts the server and does not return until stop() is called.
682# All other behavior is delegated to do_one_loop()
683#
684sub start {
685	my $self     = shift;
686	my $callback = shift;
687	if ($self->{_mode} ne "server") {
688		$@ = "$self->{_mode} cannot use method start()";
689		return undef;
690	}
691	$self->{_running}     = 1;
692	$self->{_requeststop} = 0;
693
694	#
695	# Let's loop until we're stopped:
696	#
697	while (!$self->{_requeststop}) {
698		$self->do_one_loop() || return undef;
699		if ($callback && ref($callback) eq "CODE") {
700			&{$callback}($self);
701		}
702	}
703
704	#
705	# If we reach here the server's been stopped
706	#
707	$self->{_running}     = 0;
708	$self->{_requeststop} = 0;
709	return 1;
710}
711
712#
713# This method does "one loop" of server work and returns ASAP
714# It should be called very frequently, either through a while() loop in the program
715# or through the start() method
716#
717# It accepts new clients, accepts data from them, and fires off any callback events as necessary
718#
719sub do_one_loop {
720	my $self = shift;
721	my @ready;
722	my $clientsock;
723	my $tempdata;
724	my $serverclient;
725	my $realdata;
726	my $result;
727	my $negotiatingtimeout = 45;
728	my $peername;
729	my $remoteport;
730	my $remoteip;
731
732	if ($self->{_mode} ne "server") {
733		$@ = "$self->{_mode} cannot use method do_one_loop()";
734		return undef;
735	}
736	$self->{_lastglobalkeygentime} ||= time;
737	@ready = $self->{_selector}->can_read(0.01);
738	foreach (@ready) {
739		if ($_ == $self->{_sock}) {
740
741			#
742			# The SERVER SOCKET is ready for accepting a new client
743			#
744			$clientsock = $self->{_sock}->accept();
745			if (!$clientsock) {
746				$@ = "Error while accepting new connection: $!";
747				return undef;
748			}
749
750			#
751			# We get remote IP and port, we'll need them to see if client is allowed or not
752			#
753			$peername = getpeername($clientsock) or next;
754			($remoteport, $remoteip) = sockaddr_in($peername) or next;
755			$remoteip = inet_ntoa($remoteip) or next;
756
757			#
758			# We create a new client object and
759			# We see if client is allowed to connect to us
760			#
761			if (scalar(keys %{ $self->{_clientip} }) && !$self->{_clientip}{$remoteip}) {
762
763				#
764				# Client's IP is not allowed to connect to us
765				#
766				close($clientsock);
767			}
768			else {
769
770				#
771				# We add it to our SELECTOR pool :
772				#
773				$self->{_selector}->add($clientsock);
774
775				#
776				# We create a new client object:
777				#
778				$self->{_clients}->{$clientsock} = _new_client(
779					$self,
780					"_sock"       => $clientsock,
781					"_remoteport" => $remoteport,
782					"_remoteip"   => $remoteip
783				);
784
785				#
786				# We initialize some client variables:
787				#
788				$self->{_clients}->{$clientsock}->{_serial}                 = ++$_SERIAL;
789				$self->{_clients}->{$clientsock}->{_compatabilityscalar}    = _genrandstring(129);
790				$self->{_clients}->{$clientsock}->{_compatabilityreference} = _gencompatabilityreference($self->{_clients}->{$clientsock}->{_compatabilityscalar});
791
792				#
793				# And we make it inherit some stuff from the server :
794				#
795				$self->{_clients}->{$clientsock}->{_donotencrypt}      = $self->{_donotencrypt};
796				$self->{_clients}->{$clientsock}->{_donotencryptwith}  = $self->{_donotencryptwith};
797				$self->{_clients}->{$clientsock}->{_donotcompress}     = $self->{_donotcompress};
798				$self->{_clients}->{$clientsock}->{_donotcompresswith} = $self->{_donotcompresswith};
799				$self->{_clients}->{$clientsock}->{_password}          = $self->{_password};
800				$self->{_clients}->{$clientsock}->{_callbacks}         = $self->{_callbacks};
801				$self->{_clients}->{$clientsock}->{_welcome}           = $self->{_welcome};
802				$self->{_clients}->{$clientsock}->{_selector}          = $self->{_selector};
803			}
804		}
805		else {
806
807			#
808			# One of the CLIENT sockets are ready
809			#
810			$result = sysread($_, $tempdata, $PACKETSIZE);
811			$serverclient = $self->{_clients}->{$_};
812			if (!defined $result) {
813
814				#
815				# Error somewhere during reading from that client
816				#
817				_callback($serverclient, "disconnect");
818				$serverclient->close();
819				delete $self->{_clients}->{$_};
820			}
821			elsif ($result == 0) {
822
823				#
824				# Client closed connection
825				#
826				_callback($serverclient, "disconnect");
827				$serverclient->close();
828				delete $self->{_clients}->{$_};
829			}
830			else {
831
832				#
833				# Client sent us some good data (not necessarily a full packet)
834				#
835				$serverclient->{_databuffer} .= $tempdata;
836
837				#
838				# Extract as many data buckets as possible out of the buffer
839				#
840				_extractdata($serverclient);
841
842				#
843				# Process all this client's data buckets
844				#
845				foreach (@{ $serverclient->{_databucket} }) {
846					if ($_->{realdata}) {
847
848						#
849						# This bucket is normal data
850						#
851						_callback($serverclient, "data");
852					}
853					else {
854
855						#
856						# This bucket is internal data
857						#
858						_parseinternaldata($serverclient);
859					}
860				}
861			}
862		}
863	}
864
865	#
866	# Now we check on all the serverclients still negotiating and help them finish negotiating
867	# or weed out the ones timing out
868	#
869	foreach (keys %{ $self->{_clients} }) {
870		$serverclient = $self->{_clients}->{$_};
871		if ($serverclient->{_negotiating}) {
872			if (_serverclient_negotiate($serverclient)) {
873				_callback($serverclient, "connect");
874			}
875			elsif ((time - $serverclient->{_negotiating}) > $negotiatingtimeout) {
876				$serverclient->close();
877				delete $self->{_clients}->{$_};
878			}
879		}
880	}
881
882	#
883	# Now we re-generate the RSA keys if it's been over an hour
884	#
885	if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{"B"} && ((time - $self->{_lastglobalkeygentime}) >= 3600)) {
886		if (!_generateglobalkeypair('Crypt::RSA')) {
887			$@ = "Could not generate global Crypt::RSA keypairs. $@";
888			return undef;
889		}
890		$self->{_lastglobalkeygentime} = time;
891	}
892	return 1;
893}
894
895#
896# This method stops the server and makes it return.
897# Note: It doesn't stop the server immediately, it sets a flag
898# and the flag should in a few seconds cause the infinite loop in start() method to stop
899#
900sub stop {
901	my $self = shift;
902	if ($self->{_mode} ne "server") {
903		$@ = "$self->{_mode} cannot call method stop()";
904		return undef;
905	}
906	$self->{_requeststop} = 1;
907	return 1;
908}
909
910#
911# This method sends data to the socket associated with the object
912#
913sub send {
914	my $self = shift;
915	my $data = shift;
916	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
917		$@ = "$self->{_mode} cannot use method send()";
918		return undef;
919	}
920	return _send($self, $data);
921}
922
923#
924# This method returns the serial number associated with the object
925#
926sub serial {
927	my $self = shift;
928	if (!$self->{_serial}) {
929		$self->{_serial} = ++$_SERIAL;
930	}
931	return $self->{_serial};
932}
933
934#
935# Takes nothing, returns the oldest entry from the data bucket for a client/serverclient
936# In array context returns data and realdata flag, otherwise just data
937# (typically the code in the callback assigned to callback_data would access this method)
938#
939sub data {
940	my $self = shift;
941	my $data;
942	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
943		$@ = "$self->{_mode} cannot use method data()";
944		return undef;
945	}
946
947	$data = shift(@{ $self->{_databucket} });
948
949	return wantarray ? ($data->{data}, $data->{realdata}) : $data->{data};
950}
951
952#
953# This method reads data from the socket associated with the object and returns it
954# Accepts an optional timeout as a first parameter, otherwise defaults to timeout
955# Returns the data if successful, undef if not
956#
957sub receive {
958	my $self               = shift;
959	my $timeout            = shift || 0;
960	my $returninternaldata = shift || 0;
961	my $temp;
962	my $realdata;
963	my $result;
964	my $lastactivity = time;
965	my $selector;
966	my @ready;
967	my $fatalerror;
968
969	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
970		$@ = "$self->{_mode} cannot use method receive()";
971		return undef;
972	}
973
974	$selector = new IO::Select;
975	$selector->add($self->{_sock});
976
977	#
978	# Let's try to read from the socket
979	#
980	while ($timeout ? ((time - $lastactivity) < $timeout) : 1) {
981		@ready = $selector->can_read($timeout);
982		if (!@ready) {
983
984			#
985			# Socket is not ready for reading
986			#
987			if (!$!) {
988
989				#
990				# Because of timeout
991				#
992				if (!$timeout) {
993
994					#
995					# We're doing an initial reading without blocking
996					#
997					last;
998				}
999				else {
1000
1001					#
1002					# We're blocking - let the while look take care of timeout
1003					#
1004					next;
1005				}
1006			}
1007			elsif ($! =~ /interrupt/i) {
1008
1009				#
1010				# Because of select() interrupted - ignore that
1011				#
1012				next;
1013			}
1014			else {
1015
1016				#
1017				# Because of some unknown error
1018				#
1019				last;
1020			}
1021		}
1022		else {
1023
1024			#
1025			# Socket is ready for reading
1026			#
1027			$result = sysread($self->{_sock}, $temp, $PACKETSIZE);
1028			if (!defined $result) {
1029
1030				#
1031				# Error reading from socket
1032				#
1033				$fatalerror = "Failed to read from socket: $!";
1034				if (!$timeout) {
1035
1036					#
1037					# However we won't crap out right away, as we're doing a cursory, no-timeout read
1038					#
1039					last;
1040				}
1041				else {
1042					$@ = $fatalerror;
1043					return undef;
1044				}
1045			}
1046			elsif ($result == 0) {
1047
1048				#
1049				# Socket closed while reading
1050				#
1051				$fatalerror = "Socket closed when attempted reading";
1052				if (!$timeout) {
1053
1054					# However we won't crap out right away, as we're doing a cursory, no-timeout read
1055					last;
1056				}
1057				else {
1058					$@ = $fatalerror;
1059					return undef;
1060				}
1061			}
1062			else {
1063
1064				#
1065				# Read good data - add it to the databuffer
1066				#
1067				$self->{_databuffer} .= $temp;
1068				$lastactivity = time;
1069
1070				if ($timeout && $result != $PACKETSIZE && _extractdata($self)) {
1071
1072					#
1073					# We're doing blocking reads, we extracted something into the bucket, and there's probably nothing else at the end of the socket
1074					# No point looping to block again
1075					#
1076					last;
1077				}
1078			}
1079		}
1080	}
1081
1082	#
1083	# Now there's nothing waiting to be received
1084	# Try to extract all possible data buckets out of the data buffer
1085	#
1086	_extractdata($self);
1087
1088	#
1089	# Now the databuffer has no full packets.  If there's any data to be returned it's in the data buckets
1090	#
1091	while ((($result, $realdata) = $self->data()) && defined $result) {
1092
1093		#
1094		# We got something from the bucket
1095		#
1096		if ($realdata) {
1097
1098			#
1099			# And it's real data - return it
1100			#
1101			return $result;
1102		}
1103		else {
1104
1105			#
1106			# It's internal data
1107			#
1108			if ($returninternaldata) {
1109
1110				#
1111				# But we've been asked to return it
1112				#
1113				return $result;
1114			}
1115			else {
1116
1117				#
1118				# Don't know what to do with the internal data
1119				#
1120				_parseinternaldata($self, $result);
1121			}
1122		}
1123	}
1124	if (defined($result = $self->data())) {
1125
1126		#
1127		# We have good data to return
1128		#
1129		return $result;
1130	}
1131
1132	#
1133	# If we've reached here we have no data to return
1134	#
1135	if (!$timeout) {
1136
1137		#
1138		# We were doing a quick no-block read
1139		#
1140		if ($fatalerror) {
1141
1142			#
1143			# And we have a fatal error - don't attempt a blocking read
1144			#
1145			$@ = $fatalerror;
1146			return undef;
1147		}
1148		else {
1149
1150			#
1151			# Attempt a blocking read
1152			#
1153			return $self->receive(300);
1154		}
1155	}
1156	else {
1157
1158		#
1159		# We did a blocking read
1160		#
1161		$@ = "Timed out waiting to receive data";
1162		return undef;
1163	}
1164}
1165
1166#
1167# This method is a synonym for close()
1168#
1169sub disconnect {
1170	return close(@_);
1171}
1172
1173#
1174# This method closes the socket associated with the object
1175#
1176sub close {
1177	my $self = shift;
1178	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
1179		$@ = "$self->{_mode} cannot use method close()";
1180		return undef;
1181	}
1182	if ($self->{_selector} && $self->{_selector}->exists($self->{_sock})) {
1183
1184		# If the server selector reads this, let's make it not...
1185		$self->{_selector}->remove($self->{_sock});
1186	}
1187	$self->{_sock}->close() if defined $self->{_sock};
1188	$self->{_sock}       = undef;
1189	$self->{_databucket} = [];
1190	$self->{_databuffer} = undef;
1191	return 1;
1192}
1193
1194#
1195# This method returns true or false, depending on if the server is running or not
1196#
1197sub running {
1198	my $self = shift;
1199	if ($self->{_mode} ne "server") {
1200		$@ = "$self->{_mode} cannot use method running()";
1201		return undef;
1202	}
1203	return $self->{_running};
1204}
1205
1206#
1207# This replies saying what type of object it's passed
1208#
1209sub mode {
1210	my $self = shift;
1211	my $mode = ($self->{_mode} eq "server") ? "server" : "client";
1212	return $mode;
1213}
1214
1215#
1216# This method replies saying what type of encryption is used, undef if none
1217#
1218sub encryption {
1219	my $self      = shift;
1220	my $modulekey = $self->{_encrypt};
1221	if ($self->{_donotencrypt} || !$modulekey) {
1222		return undef;
1223	}
1224	return $_ENCRYPT_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]";
1225}
1226
1227#
1228# This method replies saying what type of compression is used, undef if none
1229#
1230sub compression {
1231	my $self      = shift;
1232	my $modulekey = $self->{_compress};
1233	if ($self->{_donotcompress} || !$modulekey) {
1234		return undef;
1235	}
1236	return $_COMPRESS_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]";
1237}
1238
1239#
1240# This returns the IO::Socket object associated with a connection
1241#
1242sub socket {
1243	my $self = shift;
1244	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
1245		$@ = "$self->{_mode} cannot use method socket()";
1246		return undef;
1247	}
1248	return ($self->{_sock} || undef);
1249}
1250
1251#
1252# This returns an array of all the clients connected to a server in array context
1253# or the number of clients in scalar context
1254# or undef if there are no clients or error
1255#
1256sub clients {
1257	my $self = shift;
1258	my @clients;
1259	if ($self->{_mode} ne "server") {
1260		$@ = "$self->{_mode} cannot use method clients()";
1261		return undef;
1262	}
1263	foreach (values %{ $self->{_clients} }) {
1264		if (!$_->{_negotiating}) {
1265			push(@clients, $_);
1266		}
1267	}
1268	if (@clients) {
1269		return wantarray ? @clients : scalar @clients;
1270	}
1271	else {
1272		return undef;
1273	}
1274}
1275
1276#
1277# This takes a client object and returns the IP address of the remote connection
1278#
1279sub remoteip {
1280	my $self = shift;
1281	my $temp;
1282	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
1283		$@ = "$self->{_mode} cannot use method remoteip()";
1284		return undef;
1285	}
1286	return $self->{_remoteip};
1287}
1288
1289#
1290# This takes a client object and returns the PORT of the remote connection
1291#
1292sub remoteport {
1293	my $self = shift;
1294	my $temp;
1295	if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") {
1296		$@ = "$self->{_mode} cannot use method remoteport()";
1297		return undef;
1298	}
1299	return $self->{_remoteport};
1300}
1301
1302###########################################################
1303###########################################################
1304###########################################################
1305#
1306# The following are private functions (not object methods)
1307#
1308
1309#
1310# This takes 2 items (references to simple structures, or simple scalars)
1311# And returns true if they're the same, false if they're not
1312# It does NOT work for blessed objects. only scalars, hashrefs and arrayrefs
1313#
1314sub _comparereferences {
1315	my $item1 = shift;
1316	my $item2 = shift;
1317	my $ref1  = ref($item1);
1318	my $ref2  = ref($item2);
1319	my $num1;
1320	my $num2;
1321	my @keys1;
1322	my @keys2;
1323	my $temp;
1324
1325	if ($ref1 ne $ref2) {
1326		$@ = "References not same type [$ref1] [$ref2]";
1327		return 0;
1328	}
1329	elsif (!$ref1 && $item1 ne $item2) {
1330
1331		#Scalars  - do not match
1332		$@ = "Values of two scalar values not same";
1333		return 0;
1334	}
1335	elsif ($ref1 eq "ARRAY") {
1336		$num1 = scalar @{$item1};
1337		$num2 = scalar @{$item2};
1338		if ($num1 != $num2) {
1339
1340			# Not same # of elements
1341			$@ = "Number of array elements not equal";
1342			return 0;
1343		}
1344		else {
1345			for $temp (0 .. $num1 - 1) {
1346				if (!_comparereferences($item1->[$temp], $item2->[$temp])) {
1347					return 0;
1348				}
1349			}
1350		}
1351	}
1352	elsif ($ref1 eq "HASH") {
1353		@keys1 = sort keys %{$item1};
1354		@keys2 = sort keys %{$item2};
1355		if (scalar @keys1 != scalar @keys2) {
1356
1357			# Not same # of elements
1358			$@ = "Number of hash keys not equal";
1359			return 0;
1360		}
1361		else {
1362			for $temp (0 .. $#keys1) {
1363				if ($keys1[$temp] ne $keys2[$temp]) {
1364					$@ = "Hash key names not equal";
1365					return 0;
1366				}
1367				if (!_comparereferences($item1->{ $keys1[$temp] }, $item2->{ $keys2[$temp] })) {
1368					return 0;
1369				}
1370			}
1371		}
1372	}
1373	elsif ($ref1) {
1374
1375		# Unknown reference
1376		$@ = "Unknown reference type [$ref1] [$ref2] [$item1] [$item2]";
1377		return 0;
1378	}
1379
1380	#
1381	# Everything's good
1382	#
1383	return 1;
1384}
1385
1386#
1387# This generates a global keypair and stores it globally
1388# Takes the name of a module, returns true or false
1389#
1390sub _generateglobalkeypair {
1391	my $module = shift || return undef;
1392	foreach (keys %_ENCRYPT_AVAILABLE) {
1393		if ($_ ne "_order" && $_ENCRYPT_AVAILABLE{$_}{name} eq $module) {
1394			($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = ();
1395			($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = _genkey($_) or return undef;
1396			last;
1397		}
1398	}
1399	return 1;
1400}
1401
1402#
1403# This takes any string and returns it in ascii format
1404#
1405sub _bin2asc {
1406	my $data = shift;
1407	$data =~ s/(.)/ '%' . sprintf('%02x',ord($1)) /ges;
1408	$data = uc($data);
1409	return $data;
1410}
1411
1412#
1413# This does the opposite of _bin2asc
1414#
1415sub _asc2bin {
1416	my $data = shift;
1417	$data =~ s/\%([0-9A-F]{2})/ sprintf("%c",hex($1)) /ges;
1418	return $data;
1419}
1420
1421#
1422# This does very very primitive 2-way encryption & decryption (kinda like ROT13.. works both ways)
1423# Takes a client and a string, returns the enc/dec/rypted string
1424#
1425# This encryption is used to protect the encrypted password and the public key transmitted over the wire
1426# It's a last resort of security in case none of the encryption modules were found
1427#
1428sub _munge {
1429	my $client = shift || return undef;
1430	my $data = shift;
1431	my ($c, $t);
1432
1433	#
1434	# Munge's tricky because is existed on and off in different versions
1435	#
1436	if (defined $data && ($client->{_version} == 0.07 || $client->{_version} == 0.08 || $client->{_version} >= 0.15)) {
1437
1438		#
1439		# Peer supports munge
1440		#
1441		for (0 .. length($data) - 1) {
1442			$c = substr($data, $_, 1);
1443			$t = vec($c, 0, 4);
1444			vec($c, 0, 4) = vec($c, 1, 4);
1445			vec($c, 1, 4) = $t;
1446			substr($data, $_, 1) = $c;
1447		}
1448		$data = reverse($data);
1449	}
1450	else {
1451
1452		# Our peer doesn't munge, so we won't either
1453	}
1454	return $data;
1455}
1456
1457#
1458# This takes a client object and a callback keyword and calls back the associated sub if possible
1459#
1460sub _callback {
1461	my $client = shift;
1462	my $type   = shift;
1463	if (!$client->{_negotiating} && $client->{_callbacks}->{$type}) {
1464		&{ $client->{_callbacks}->{$type} }($client);
1465	}
1466}
1467
1468#
1469# This sub takes a scalar key
1470# Returns a reference to a compatability compex object made up of repeating
1471# the scalar in different combinations
1472#
1473sub _gencompatabilityreference {
1474	my $key = shift;
1475	return [
1476		$key,
1477		{
1478			$key => $key,
1479			$key => $key,
1480		},
1481		[ $key, { $key => $key, }, $key, ],
1482	];
1483}
1484
1485#
1486# This takes in an encryption key id and an optional "forcompat" boolean flag
1487# Generates a keypair (public, private) and returns them according to the type of encryption specified
1488# Returns undef on error
1489# 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
1490# If "forcompat" is not specified and there are already a keypair for the specified module stored globally,
1491# it will return that instead of generating new ones.
1492# If "forcompat" is supplied, you're guaranteed to receive a new key that wasn't given out in the past to
1493# non-compat requests. It may be a repeat of a previous "forcompat" pair. However, the strength of that key
1494# could be possibly reduced.  Such keys are safe to reveal the private portion of publicly, as during the
1495# compatability negotiation phase, however such keys must NEVER be used to encrypt any real data, as they
1496# are no longer secret.
1497#
1498sub _genkey {
1499	my $modulekey = shift;
1500	my $forcompat = shift;
1501	my $module    = $_ENCRYPT_AVAILABLE{$modulekey}{name};
1502	my $key1      = undef;
1503	my $key2      = undef;
1504	my $temp;
1505	$@ = undef;
1506	if (!$forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}) {
1507		$key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey};
1508		$key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey};
1509	}
1510	elsif ($forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey}) {
1511		$key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey};
1512		$key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey};
1513	}
1514	elsif ($module eq 'Crypt::RSA') {
1515		eval {
1516			$temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for key generation: $! $@\n";
1517			($key1, $key2) = $temp->keygen(
1518				Size      => 512,
1519				Verbosity => 0,
1520			  )
1521			  or die "Failed to create RSA keypair: " . $temp->errstr() . "\n";
1522		};
1523		if ($key1 && $key2) {
1524			$key1 = _bin2asc(nfreeze($key1));
1525
1526			# RSA private keys are NOT serializable with the Serialize module - we MUST use Crypt::RSA::Key::Private's undocumented serialize() method:
1527			$key2 = $key2->serialize();
1528			if ($forcompat) {
1529				$_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey}  = $key1;
1530				$_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey} = $key2;
1531			}
1532		}
1533	}
1534	elsif ($module eq 'Crypt::Rijndael') {
1535		$key1 = _genrandstring(32);
1536		$key2 = $key1;
1537	}
1538	elsif ($module eq 'Crypt::RC6') {
1539		$key1 = _genrandstring(32);
1540		$key2 = $key1;
1541	}
1542	elsif ($module eq 'Crypt::Blowfish') {
1543		$key1 = _genrandstring(56);
1544		$key2 = $key1;
1545	}
1546	elsif ($module eq 'Crypt::DES_EDE3') {
1547		$key1 = _genrandstring(24);
1548		$key2 = $key1;
1549	}
1550	elsif ($module eq 'Crypt::DES') {
1551		$key1 = _genrandstring(8);
1552		$key2 = $key1;
1553	}
1554	elsif ($module eq 'Crypt::Twofish2') {
1555		$key1 = _genrandstring(32);
1556		$key2 = $key1;
1557	}
1558	elsif ($module eq 'Crypt::Twofish') {
1559		$key1 = _genrandstring(32);
1560		$key2 = $key1;
1561	}
1562	elsif ($module eq 'Crypt::TEA') {
1563		$key1 = _genrandstring(16);
1564		$key2 = $key1;
1565	}
1566	elsif ($module eq 'Crypt::CipherSaber') {
1567		$key1 = _genrandstring(32);
1568		$key2 = $key1;
1569	}
1570	else {
1571		$@ = "Unknown encryption module [$module] modulekey [$modulekey]";
1572	}
1573
1574	if (!$key1 || !$key2) {
1575		$@ = "Could not generate encryption keys. $@";
1576		return undef;
1577	}
1578	else {
1579		return ($key1, $key2);
1580	}
1581
1582}
1583
1584#
1585# This takes client object, and a reference to a scalar
1586# And if it can, compresses scalar, modifying the original, via the specified module in the client object
1587# Returns true if successful, false if not
1588#
1589sub _compress {
1590	my $client    = shift;
1591	my $rdata     = shift;
1592	my $modulekey = $client->{_compress} || return undef;
1593	my $module    = $_COMPRESS_AVAILABLE{$modulekey}{name};
1594	my $newdata;
1595
1596	#
1597	# Compress the data
1598	#
1599	if ($module eq 'Compress::Zlib') {
1600		$newdata = Compress::Zlib::compress($$rdata);
1601	}
1602	elsif ($module eq 'Compress::LZF') {
1603		$newdata = Compress::LZF::compress($$rdata);
1604	}
1605	else {
1606		$@ = "Unknown compression module [$module] modulekey [$modulekey]";
1607	}
1608
1609	#
1610	# Finally, override reference if compression succeeded
1611	#
1612	if ($newdata) {
1613		$$rdata = $newdata;
1614		return 1;
1615	}
1616	else {
1617		return undef;
1618	}
1619
1620}
1621
1622#
1623# This does the opposite of _compress()
1624#
1625sub _decompress {
1626	my $client    = shift;
1627	my $rdata     = shift;
1628	my $modulekey = $client->{_compress};
1629	my $module    = $_COMPRESS_AVAILABLE{$modulekey}{name};
1630	my $newdata;
1631
1632	if ($module eq 'Compress::Zlib') {
1633		$newdata = Compress::Zlib::uncompress($$rdata);
1634	}
1635	elsif ($module eq 'Compress::LZF') {
1636		$newdata = Compress::LZF::decompress($$rdata);
1637	}
1638	else {
1639		$@ = "Unknown decompression module [$module] modulekey [$modulekey]";
1640	}
1641
1642	#
1643	# Finally, override reference if decompression succeeded
1644	#
1645	if ($newdata) {
1646		$$rdata = $newdata;
1647		return 1;
1648	}
1649	else {
1650		return undef;
1651	}
1652
1653}
1654
1655#
1656# This takes client object, and a reference to a scalar
1657# And if it can, encrypts scalar, modifying the original, via the specified module in the client object
1658# Returns true if successful, false if not
1659#
1660sub _encrypt {
1661	my $client            = shift;
1662	my $rdata             = shift;
1663	my $modulekey         = $client->{_encrypt} || return undef;
1664	my $module            = $_ENCRYPT_AVAILABLE{$modulekey}{name};
1665	my $cbc               = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
1666	my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
1667	my $newdata;
1668	my $temp;
1669	my $publickey = $client->{_remotepublickey} || return undef;
1670	my $cleanpassword;
1671
1672	if (defined $client->{_password}) {
1673		$cleanpassword = $client->{_password};
1674		$cleanpassword =~ s/[^a-z0-9]//gi;
1675	}
1676	else {
1677		$cleanpassword = undef;
1678	}
1679
1680	#
1681	# If there is a password for the connection, and we're using Symmetric encryption, we include the password
1682	# in the encryption key used
1683	#
1684	if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
1685		if (length($cleanpassword) <= length($publickey)) {
1686			substr($publickey, 0, length($cleanpassword)) = $cleanpassword;
1687		}
1688		elsif (length($cleanpassword) > length($publickey)) {
1689			$publickey = substr($cleanpassword, 0, length($publickey));
1690		}
1691		else {
1692			$@ = "Failed to merge password with symmetric encryption key";
1693			return undef;
1694		}
1695	}
1696	if ($publickey =~ /^(\%[0-9A-F]{2})+$/) {
1697
1698		#
1699		# In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them
1700		#
1701		$publickey = thaw(_asc2bin($publickey)) || return undef;
1702		$client->{_remotepublickey} = $publickey;
1703	}
1704
1705	#
1706	# Encrypt the data into $newdata if possible
1707	#
1708	if ($module eq 'Crypt::RSA') {
1709		eval {
1710			$temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for encryption: $! $@\n";
1711			$newdata = $temp->encrypt(
1712				Message => $$rdata,
1713				Key     => $publickey,
1714				Armour  => 0,
1715			  )
1716			  or die "Failed to encrypt data with Crypt::RSA: " . $temp->errstr() . "\n";
1717		};
1718	}
1719	elsif ($module eq 'Crypt::CipherSaber') {
1720		$temp    = Crypt::CipherSaber->new($publickey);
1721		$newdata = $temp->encrypt($$rdata);
1722	}
1723	elsif ($cbc) {
1724		$temp = Crypt::CBC->new($publickey, $module);
1725		$newdata = $temp->encrypt($$rdata);
1726	}
1727	else {
1728		$@ = "Unknown encryption module [$module] modulekey [$modulekey]";
1729	}
1730
1731	#
1732	# Finally, override reference if encryption succeeded
1733	#
1734	if ($newdata) {
1735		$$rdata = $newdata;
1736		return 1;
1737	}
1738	else {
1739		return undef;
1740	}
1741
1742}
1743
1744#
1745# Does the opposite of _encrypt();
1746#
1747sub _decrypt {
1748	my $client            = shift;
1749	my $rdata             = shift;
1750	my $modulekey         = $client->{_encrypt} || return undef;
1751	my $module            = $_ENCRYPT_AVAILABLE{$modulekey}{name};
1752	my $cbc               = $_ENCRYPT_AVAILABLE{$modulekey}{cbc};
1753	my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword};
1754	my $newdata;
1755	my $temp;
1756	my $privatekey = $client->{_localprivatekey} || return undef;
1757	my $cleanpassword;
1758
1759	if (defined $client->{_password}) {
1760		$cleanpassword = $client->{_password};
1761		$cleanpassword =~ s/[^a-z0-9]//gi;
1762	}
1763	else {
1764		$cleanpassword = undef;
1765	}
1766
1767	#
1768	# If there is a password for the connection, and we're using Symmetric encryption, we include the password
1769	# in the decryption key used
1770	#
1771	if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) {
1772		if (length($cleanpassword) <= length($privatekey)) {
1773			substr($privatekey, 0, length($cleanpassword)) = $cleanpassword;
1774		}
1775		elsif (length($cleanpassword) > length($privatekey)) {
1776			$privatekey = substr($cleanpassword, 0, length($privatekey));
1777		}
1778		else {
1779			$@ = "Failed to merge password with symmetric encryption key";
1780			return undef;
1781		}
1782	}
1783	if ($privatekey =~ /^(\%[0-9A-F]{2})+$/) {
1784
1785		#
1786		# In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them
1787		#
1788		$privatekey = _asc2bin($privatekey);
1789	}
1790
1791	#
1792	# Decrypt the data
1793	#
1794	if ($module eq 'Crypt::RSA') {
1795		eval {
1796			if (!ref($privatekey)) {
1797				if ($privatekey =~ /bless/) {
1798
1799					# We need to deserialize the private key with Crypt::RSA::Key::Private's undocumented deserialize function
1800					$temp = Crypt::RSA::Key::Private->new() or die "Failed to initialize empty Crypt::RSA::Key::Private object\n";
1801					$privatekey = $temp->deserialize(String => [$privatekey]) or die "Failed to deserialize Crypt::RSA private key\n";
1802				}
1803				else {
1804					die "The Crypt::RSA private key is absolutely unusable\n";
1805				}
1806			}
1807			$temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for decryption: $! $@\n";
1808			$newdata = $temp->decrypt(
1809				Cyphertext => $$rdata,
1810				Key        => $privatekey,
1811				Armour     => 0,
1812			  )
1813			  or die "Failed to decrypt data with Crypt::RSA : " . $temp->errstr() . "\n";
1814		};
1815	}
1816	elsif ($module eq 'Crypt::CipherSaber') {
1817		$temp    = Crypt::CipherSaber->new($privatekey);
1818		$newdata = $temp->decrypt($$rdata);
1819	}
1820	elsif ($cbc) {
1821		$temp = Crypt::CBC->new($privatekey, $module);
1822		$newdata = $temp->decrypt($$rdata);
1823	}
1824	else {
1825		$@ = "Unknown encryption module [$module] modulekey [$modulekey]";
1826	}
1827
1828	#
1829	# Finally, override reference if decryption succeeded
1830	#
1831	if ($newdata) {
1832		$$rdata = $newdata;
1833		return 1;
1834	}
1835	else {
1836		return undef;
1837	}
1838
1839}
1840
1841#
1842# This sub returns a random string
1843# Expects an integer (length)
1844# Accepts optional boolean that defines whether string should be made up of letters only or not
1845#
1846sub _genrandstring {
1847	my $l           = shift;
1848	my $lettersonly = shift;
1849	my ($minord, $maxord);
1850	my $key;
1851	my $avoid;
1852	my $module;
1853	my $version;
1854
1855	if ($lettersonly) {
1856		$minord = 97;
1857		$maxord = 122;
1858	}
1859	else {
1860		$minord = 33;
1861		$maxord = 126;
1862	}
1863
1864	#
1865	# First, we try one of the fancy randomness modules possibly in %_MISC_AVAILABLE
1866	#
1867	foreach (@{ $_MISC_AVAILABLE{_order} }) {
1868		$module  = $_MISC_AVAILABLE{$_}{name};
1869		$version = $_MISC_AVAILABLE{$_}{version};
1870
1871		#
1872		# Note that Crypt::Random has the makerandom_octet function ONLY in 0.34 and higher
1873		#
1874		if ($module eq "Crypt::Random" && $version >= 0.34) {
1875			for (0 .. $minord - 1, $maxord + 1 .. 255) {
1876				$avoid .= chr($_);
1877			}
1878			$key = Crypt::Random::makerandom_octet(
1879				Length => $l,
1880				Skip   => $avoid,
1881			);
1882			return $key;
1883		}
1884	}
1885
1886	#
1887	# If we've reached here, then no modules were found. We'll use perl's builtin rand() to generate
1888	# the string
1889	#
1890	for (1 .. $l) {
1891		$key .= chr(int(rand($maxord - $minord)) + $minord);
1892	}
1893	return $key;
1894}
1895
1896#
1897# Once a new client is connected it calls this to negotiate basics with the server
1898# This must return true once all negotiations succeed or false if not
1899#
1900sub _client_negotiate {
1901	my $client = shift;
1902	my $reply;
1903	my $timeout = 90;
1904	my @P;
1905	my $command;
1906	my $data;
1907	my $temp;
1908	my $temp2;
1909	my ($temppublic, $tempprivate, $tempscalar);
1910	my $version;
1911	my $evl;
1912	my $starttime = time;
1913
1914	while ((time - $starttime) < $timeout) {
1915		$reply = $client->receive($timeout, 1);
1916		if (!defined $reply) {
1917			last;
1918		}
1919		@P       = split(/\x00/, $reply);
1920		$command = shift(@P);
1921		$evl     = undef;
1922		$data    = undef;
1923		if (!$command) {
1924			$@ = "Error negotiating with server. No command received.";
1925			return undef;
1926		}
1927		if ($command eq "PF") {
1928
1929			#
1930			# Password Failure
1931			#
1932			$client->{_authenticated} = 0;
1933			$@ = "Server rejected supplied password";
1934			return undef;
1935		}
1936		elsif ($command eq "COS") {
1937
1938			#
1939			# Compatability Scalar
1940			#
1941			$client->{_compatabilityscalar}    = _asc2bin($P[0]);
1942			$client->{_compatabilityreference} = _gencompatabilityreference($client->{_compatabilityscalar});
1943			$data                              = "COS\x00" . $P[0];
1944		}
1945		elsif ($command eq "COF") {
1946
1947			#
1948			# Compatability failure
1949			#
1950			$@ = "Compatability failure: The client and server could not negotiate compatability regarding: $P[0]";
1951			return undef;
1952		}
1953		elsif ($command eq "CVF" && !$client->{_donotcheckversion}) {
1954
1955			#
1956			# Compression Version Failure
1957			#
1958			$temp    = $_COMPRESS_AVAILABLE{ $client->{_compress} }{name};
1959			$version = $_COMPRESS_AVAILABLE{ $client->{_compress} }{version};
1960			$@       = "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";
1961			return undef;
1962		}
1963		elsif ($command eq "EVF" && !$client->{_donotcheckversion}) {
1964
1965			#
1966			# Encryption Version Failure
1967			#
1968			$temp    = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{name};
1969			$version = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{version};
1970			$@       = "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";
1971			return undef;
1972		}
1973		elsif ($command eq "EN") {
1974
1975			#
1976			# End of negotiation
1977			#
1978			$data = "EN";
1979			$evl  = 'return("RETURN1");';
1980		}
1981		elsif ($command eq "VE") {
1982
1983			#
1984			# Version of module
1985			#
1986			$client->{_version} = $P[0];
1987			$data = "VE\x00$VERSION";
1988		}
1989		elsif ($command eq "SVE") {
1990
1991			#
1992			# Version of the Storable module
1993			#
1994			$client->{_storableversion} = $P[0];
1995			if ($P[1]) {
1996
1997				#
1998				# New compatability method
1999				#
2000				eval { $temp = thaw(_asc2bin($P[1])); };
2001				if (!$temp || $@) {
2002					$@ = "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.";
2003					return undef;
2004				}
2005				if (!_comparereferences($temp, $client->{_compatabilityreference})) {
2006					$@ = "Incompatible version mismatch for the Storable module: Local version " . $Storable::VERSION . " remote version $P[0] : Upgrade both to compatible (preferrably same) versions : $@";
2007					return undef;
2008				}
2009			}
2010			$data = "SVE\x00" . $Storable::VERSION;
2011			if ($client->{_compatabilityreference}) {
2012				$data .= "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference}));
2013			}
2014		}
2015		elsif ($command eq "SVF" && !$client->{_donotcheckversion}) {
2016
2017			#
2018			# Storable Module Version Failure
2019			#
2020			$version = $Storable::VERSION;
2021			$@       = "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";
2022			return undef;
2023		}
2024		elsif ($command eq "CS") {
2025
2026			#
2027			# Crypt Salt
2028			#
2029			# We assume that we've authenticated successfully
2030			$client->{_authenticated} = 1;
2031			$temp = _munge($client, crypt($client->{_password}, $P[0]));
2032			$data = "CP\x00$temp";
2033		}
2034		elsif ($command eq "EK") {
2035
2036			#
2037			# Encryption key
2038			#
2039			$client->{_remotepublickey} = _munge($client, $P[0]);
2040			$data = "EK\x00";
2041			$data .= _munge($client, $client->{_localpublickey});
2042		}
2043		elsif ($command eq "EM") {
2044
2045			#
2046			# Encryption module
2047			#
2048			if ($client->{_donotencryptwith}{ $P[0] }) {
2049				$data = "NO\x00I do not encrypt with this module";
2050			}
2051			elsif (!$client->{_donotencrypt}) {
2052
2053				#
2054				# Let's see if we can handle decrypting this module
2055				#
2056				$tempprivate = _asc2bin($P[2]);
2057				$tempscalar  = _asc2bin($P[3]);
2058
2059				#
2060				# Sometimes the tempprivate is frozen. If we can thaw it, let's do it:
2061				#
2062				eval { $temp = thaw $tempprivate };
2063				if (!$@) {
2064					$tempprivate = $temp;
2065				}
2066				$client->{_encrypt}         = $P[0];
2067				$client->{_localprivatekey} = $tempprivate;
2068				if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
2069
2070					#
2071					# This is a viable module that we can decrypt.
2072					#
2073					($temppublic, $tempprivate) = _genkey($P[0], 1);
2074					if ($temppublic && $tempprivate) {
2075
2076						#
2077						# I created a keypair with that module type successfully
2078						#
2079						$client->{_remotepublickey} = $temppublic;
2080						if (_encrypt($client, \$tempscalar)) {
2081							$data = "EM\x00$P[0]\x00" . $_ENCRYPT_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar);
2082						}
2083						delete $client->{_remotepublickey};
2084					}
2085					else {
2086
2087						#
2088						# Failed to create a keypair - no way I could encrypt with that
2089						#
2090						$data = "NO\x00$@";
2091					}
2092				}
2093				else {
2094
2095					#
2096					# Failed to decrypt message from server
2097					#
2098					$data = "NO\x00$@";
2099				}
2100				delete $client->{_encrypt};
2101				delete $client->{_localprivatekey};
2102			}
2103			else {
2104
2105				#
2106				# I was told not to encrypt
2107				#
2108				$data = "NO\x00I do not encrypt";
2109
2110			}
2111		}
2112		elsif ($command eq "EU") {
2113
2114			#
2115			# Encryption Use
2116			#
2117			if ($client->{_donotencryptwith}{ $P[0] }) {
2118				$data = "NO\x00I do not encrypt with this module";
2119			}
2120			elsif (!$client->{_donotencrypt}) {
2121				$temp2 = $P[0];
2122				$data  = "EU\x00$temp2";
2123				$evl   = '$client->{_encrypt} = $temp2;';
2124				$evl .= '($client->{_localpublickey},$client->{_localprivatekey}) =';
2125				$evl .= ' _genkey($client->{_encrypt}) or ';
2126				$evl .= ' return("RETURN0"); ';
2127			}
2128			else {
2129				$data = "NO\x00I do not encrypt";
2130			}
2131		}
2132		elsif ($command eq "EA") {
2133
2134			#
2135			# Encryption available
2136			#
2137			$temp2   = "";
2138			$version = "";
2139			if (!$client->{_donotencrypt}) {
2140				foreach (@P) {
2141					if ($_ENCRYPT_AVAILABLE{$_}) {
2142						$temp2   = $_;
2143						$version = $_ENCRYPT_AVAILABLE{$_}{version};
2144						last;
2145					}
2146				}
2147				$temp2   ||= "";
2148				$version ||= "";
2149			}
2150			$data = "EU\x00$temp2\x00$version";
2151			if ($temp2) {
2152				$evl = '$client->{_encrypt} = $temp2;';
2153				$evl .= '($client->{_localpublickey},$client->{_localprivatekey}) =';
2154				$evl .= ' _genkey($client->{_encrypt}) or ';
2155				$evl .= ' return("RETURN0"); ';
2156			}
2157		}
2158		elsif ($command eq "CM") {
2159
2160			#
2161			# Compression module
2162			#
2163			if ($client->{_donotcompresswith}{ $P[0] }) {
2164				$data = "NO\x00I do not compress with this module";
2165			}
2166			elsif (!$client->{_donotcompress}) {
2167
2168				#
2169				# Let's see if we can decompress this
2170				#
2171				$tempscalar = _asc2bin($P[2]);
2172				$client->{_compress} = $P[0];
2173				if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
2174
2175					#
2176					# This is a viable module that we can decompress.
2177					#
2178					if (_compress($client, \$tempscalar)) {
2179						$data = "CM\x00$P[0]\x00" . $_COMPRESS_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc($tempscalar);
2180					}
2181				}
2182				else {
2183
2184					#
2185					# Failed to decompress message from server
2186					#
2187					$data = "NO\x00$@";
2188				}
2189				delete $client->{_compress};
2190			}
2191			else {
2192
2193				#
2194				# I was told not to compress
2195				#
2196				$data = "NO\x00I do not compress";
2197			}
2198		}
2199		elsif ($command eq "CU") {
2200
2201			#
2202			# Compression Use
2203			#
2204			if ($client->{_donotcompresswith}{ $P[0] }) {
2205				$data = "NO\x00I do not compress with this module";
2206			}
2207			elsif (!$client->{_donotcompress}) {
2208				$temp2 = $P[0];
2209				$data  = "CU\x00$temp2";
2210				$evl   = '$client->{_compress} = $temp2;';
2211			}
2212			else {
2213				$data = "NO\x00I do not compress";
2214			}
2215		}
2216		elsif ($command eq "CA") {
2217
2218			#
2219			# Compression available
2220			#
2221			$temp2   = "";
2222			$version = "";
2223			if (!$client->{_donotcompress}) {
2224				foreach (@P) {
2225					if ($_COMPRESS_AVAILABLE{$_}) {
2226						$temp2   = $_;
2227						$version = $_COMPRESS_AVAILABLE{$_}{version};
2228						last;
2229					}
2230				}
2231				$temp2   ||= "";
2232				$version ||= "";
2233			}
2234			$data = "CU\x00$temp2\x00$version";
2235			if ($temp2) {
2236				$evl = '$client->{_compress} = $temp2;';
2237			}
2238		}
2239		else {
2240
2241			#
2242			# No Operation (do nothing)
2243			#
2244			$data = "NO\x00I don't understand you";
2245		}
2246		if (defined $data && !_send($client, $data, 0)) {
2247			$@ = "Error negotiating with server: Could not send : $@";
2248			return undef;
2249		}
2250
2251		#
2252		# NOW WE SEE IF WE NEED TO EVL ANYTHING
2253		# IF THE RESULT OF THE EVAL IS "RETURNx" WHERE X IS A NUMBER, WE RETURN
2254		# OTHERWISE WE KEEP GOING
2255		#
2256		if (defined $evl) {
2257			$evl = eval($evl);
2258			if ($evl =~ /^RETURN(.+)$/) {
2259				return (($1) ? $1 : undef);
2260			}
2261		}
2262	}
2263	$@ = "Client timed out while negotiating with server [" . (time - $starttime) . "/$timeout] : $@";
2264	return undef;
2265}
2266
2267#
2268# Once the server accepts a new connection, it calls this to negotiate basics with the client
2269# Unlike _client_negotiate() which does not return until negotiation is over, this sub
2270# sends 1 command or parses one reply at a time then returns immediately
2271# Although this is much more complicated, it needs to be done so
2272# the server does not block when a client is negotiating with it
2273#
2274# Expects a client object
2275#
2276sub _serverclient_negotiate {
2277	my $client = shift;
2278	my ($tempprivate, $tempscalar);
2279	my $reply;
2280	my $temp;
2281	my @P;
2282	my $command;
2283	my $version;
2284
2285	if (!$client->{_negotiating}) {
2286		return 1;
2287	}
2288
2289	$reply = $client->data();
2290
2291	# Let's avoid some strict claimings
2292	if (!defined $reply) { $reply = "" }
2293	if (!defined $client->{_negotiating_lastevent}) { $client->{_negotiating_lastevent} = "" }
2294
2295	if (length($reply)) {
2296
2297		#
2298		# We're parsing a reply the other end sent us
2299		#
2300		@P = split(/\x00/, $reply);
2301		$command = shift(@P);
2302		if (!$command) {
2303			$@ = "Error negotiating. No command received from client : $@";
2304			return undef;
2305		}
2306		$client->{_negotiating_lastevent} = "received";
2307		if ($command eq "EU") {
2308
2309			#
2310			# Encryption Use
2311			#
2312			$client->{_encrypt} = $P[0];
2313			if ($client->{_encrypt}) {
2314				$version = $_ENCRYPT_AVAILABLE{ $P[0] }{version};
2315				if ($version ne $P[1] && !$client->{_negotiatedencryptcompatability}) {
2316					unshift(@{ $client->{_negotiating_commands} }, "EVF\x00$version");
2317				}
2318				($client->{_localpublickey}, $client->{_localprivatekey}) = _genkey($client->{_encrypt}) or return undef;
2319			}
2320			$temp = "EK\x00";
2321			$temp .= _munge($client, $client->{_localpublickey});
2322			unshift(@{ $client->{_negotiating_commands} }, $temp);
2323		}
2324		elsif ($command eq "EM") {
2325
2326			#
2327			# Encryption module
2328			#
2329			if ($client->{_donotencryptwith}{ $P[0] }) {
2330
2331				#
2332				# I was told not to encrypt with this module
2333				#
2334			}
2335			elsif (!$client->{_donotencrypt}) {
2336
2337				#
2338				# Let's see if we can decrypt this module
2339				#
2340				$tempprivate = _asc2bin($P[2]);
2341				$tempscalar  = _asc2bin($P[3]);
2342
2343				#
2344				# Sometimes the tempprivate is frozen. If we can thaw it, let's do it:
2345				#
2346				eval { $temp = thaw $tempprivate };
2347				if (!$@) {
2348					$tempprivate = $temp;
2349				}
2350				$client->{_encrypt}         = $P[0];
2351				$client->{_localprivatekey} = $tempprivate;
2352				if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
2353
2354					#
2355					# This is a viable module that I (the server) can decrypt
2356					# Since this is the second-reply to my EM, I know that the client can also decrypt using this module
2357					# So we use it !
2358					#
2359					unshift(@{ $client->{_negotiating_commands} }, "EU\x00$P[0]");
2360
2361					#
2362					# Yank out any future EMs we were going to send the client since they're weaker
2363					#
2364					$client->{_negotiating_commands} = [ grep { $_ !~ /^EM\x00/ } @{ $client->{_negotiating_commands} } ];
2365				}
2366				delete $client->{_localprivatekey};
2367				delete $client->{_encrypt};
2368
2369				#
2370				# Don't try EAs after this - we know the client supports EMs
2371				#
2372				$client->{_negotiatedencryptcompatability} = 1;
2373			}
2374			else {
2375
2376				#
2377				# I was told not to encrypt
2378				#
2379			}
2380		}
2381		elsif ($command eq "CP") {
2382
2383			#
2384			# Crypt Password
2385			#
2386			if (_munge($client, $P[0]) eq crypt($client->{_password}, $client->{_cryptsalt})) {
2387				$client->{_authenticated} = 1;
2388			}
2389			else {
2390				$client->{_authenticated} = 0;
2391				unshift(@{ $client->{_negotiating_commands} }, "PF");
2392			}
2393		}
2394		elsif ($command eq "COS") {
2395
2396			#
2397			# Compatability scalar
2398			#
2399			if ($client->{_compatabilityscalar} ne _asc2bin($P[0])) {
2400				unshift(@{ $client->{_negotiating_commands} }, "COF\x00Initial scalar exchange");
2401			}
2402		}
2403		elsif ($command eq "VE") {
2404
2405			#
2406			# Version
2407			#
2408			$client->{_version} = $P[0];
2409		}
2410		elsif ($command eq "SVE") {
2411
2412			#
2413			# Version of Storable
2414			#
2415			$client->{_storableversion} = $P[0];
2416			if ($P[1]) {
2417
2418				#
2419				# New method
2420				#
2421				$temp = thaw(_asc2bin($P[1]));
2422				if (!$temp) {
2423					unshift(@{ $client->{_negotiating_commands} }, "COF\x00Thawing compatability reference with the Storable module");
2424				}
2425				if (!_comparereferences($temp, $client->{_compatabilityreference})) {
2426					unshift(@{ $client->{_negotiating_commands} }, "COF\x00Comparing compatability reference with the Storable module");
2427				}
2428			}
2429			elsif ($P[0] ne $Storable::VERSION) {
2430
2431				#
2432				# Old method
2433				#
2434				unshift(@{ $client->{_negotiating_commands} }, "SVF\x00" . $Storable::VERSION);
2435			}
2436		}
2437		elsif ($command eq "CM") {
2438
2439			#
2440			# Compression module
2441			#
2442			if ($client->{_donotcompresswith}{ $P[0] }) {
2443
2444				# I was told not to compress with this module
2445			}
2446			elsif (!$client->{_donotcompress}) {
2447
2448				#
2449				# Let's see if we can decompress this module
2450				#
2451				$tempscalar = _asc2bin($P[2]);
2452				$client->{_compress} = $P[0];
2453				if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) {
2454
2455					#
2456					# This is a viable module that I (the server) can decompress
2457					# Since this is the second-reply to my CM, I know that the client can also decrypt using this module
2458					# So we use it !
2459					#
2460					unshift(@{ $client->{_negotiating_commands} }, "CU\x00$P[0]");
2461
2462					#
2463					# Yank out any future CMs we were going to send the client since they're weaker
2464					#
2465					$client->{_negotiating_commands} = [ grep { $_ !~ /^CM\x00/ } @{ $client->{_negotiating_commands} } ];
2466				}
2467				delete $client->{_compress};
2468
2469				#
2470				# Don't try CAs after this - we know the client supports CMs
2471				#
2472				$client->{_negotiatedcompresscompatability} = 1;
2473			}
2474			else {
2475
2476				#
2477				# I was told not to compress
2478				#
2479			}
2480		}
2481		elsif ($command eq "CU") {
2482
2483			#
2484			# Compression Use
2485			#
2486			$client->{_compress} = $P[0];
2487			if ($client->{_compress}) {
2488				$version = $_COMPRESS_AVAILABLE{ $P[0] }{version};
2489				if ($version ne $P[1] && !$client->{_negotiatedcompresscompatability}) {
2490					unshift(@{ $client->{_negotiating_commands} }, "CVF\x00$version");
2491				}
2492			}
2493		}
2494		elsif ($command eq "EK") {
2495
2496			#
2497			# Encryption Key
2498			#
2499			$client->{_remotepublickey} = _munge($client, $P[0]);
2500		}
2501		elsif ($command eq "EN") {
2502
2503			#
2504			# End (of negotiation)
2505			#
2506			if ((defined $client->{_password} && length($client->{_password})) && !$client->{_authenticated}) {
2507				return undef;
2508			}
2509			else {
2510				$client->{_negotiating} = 0;
2511				delete $client->{_negotiating_lastevent};
2512				delete $client->{_negotiating_commands};
2513				return 1;
2514			}
2515		}
2516		else {
2517
2518			# received unknown reply. so what..
2519		}
2520	}
2521	elsif ($client->{_negotiating_lastevent} ne "sent") {
2522
2523		# We're sending a command to the other end, now we have to figure out which one
2524		_serverclient_negotiate_sendnext($client);
2525	}
2526	return undef;
2527}
2528
2529#
2530# This is called by _serverclient_negotiate(). It's job is to figure out what's the next command to send
2531# to the other end and send it.
2532#
2533# Expects a client object
2534#
2535sub _serverclient_negotiate_sendnext {
2536	my $client = shift;
2537	my $data;
2538	my $class = $client;
2539	my ($temppublic, $tempprivate, $tempscalar);
2540	my $key;
2541	my @available;
2542	$class =~ s/=.*//g;
2543
2544	if (!defined $client->{_negotiating_commands}) {
2545
2546		#
2547		# Let's initialize the sequence of commands we send
2548		#
2549		$data = "\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n";
2550		$data .= "-----BEGIN CLEARTEXT WELCOME MESSAGE-----\r\n";
2551		$data .= "::\r\n";
2552		$data .= "::  HELLO  ::  $class VERSION $VERSION  ::  SERVER READY  ::\r\n";
2553		$data .= "::\r\n";
2554		if ($client->{_welcome}) {
2555			$data .= "::  $client->{_welcome}\r\n";
2556			$data .= "::\r\n";
2557		}
2558		$data .= "-----END CLEARTEXT WELCOME MESSAGE-----\r\n";
2559		push(@{ $client->{_negotiating_commands} }, $data);
2560		$data = "VE\x00$VERSION";
2561		push(@{ $client->{_negotiating_commands} }, $data);
2562		$data = "COS\x00" . _bin2asc($client->{_compatabilityscalar});
2563		push(@{ $client->{_negotiating_commands} }, $data);
2564		$data = "SVE\x00" . $Storable::VERSION . "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference}));
2565		push(@{ $client->{_negotiating_commands} }, $data);
2566
2567		if (!$client->{_donotencrypt}) {
2568
2569			@available = ();
2570
2571			#
2572			# New method
2573			#
2574			foreach $key (@{ $_ENCRYPT_AVAILABLE{_order} }) {
2575				if ($client->{_donotencryptwith}{$key}) {
2576
2577					# I was told not to encrypt with this module
2578					next;
2579				}
2580				($temppublic, $tempprivate) = _genkey($key, 1) or next;
2581				$client->{_remotepublickey} = $temppublic;
2582				$client->{_encrypt}         = $key;
2583				$tempscalar                 = $client->{_compatabilityscalar};
2584				if (_encrypt($client, \$tempscalar)) {
2585					push(@available, $key);
2586					$data = "EM\x00$key\x00" . $_ENCRYPT_AVAILABLE{$key}{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar);
2587					push(@{ $client->{_negotiating_commands} }, $data);
2588				}
2589				delete $client->{_remotepublickey};
2590				delete $client->{_encrypt};
2591			}
2592
2593			#
2594			# Old method
2595			#
2596			$data = "EA" . join("", map { "\x00$_" } @available);
2597			push(@{ $client->{_negotiating_commands} }, $data);
2598		}
2599		if (!$client->{_donotcompress}) {
2600
2601			@available = ();
2602
2603			#
2604			# New method
2605			#
2606			foreach $key (@{ $_COMPRESS_AVAILABLE{_order} }) {
2607				if ($client->{_donotcompresswith}{$key}) {
2608
2609					# I was told not to compress with this module
2610					next;
2611				}
2612				$client->{_compress} = $key;
2613				$tempscalar = $client->{_compatabilityscalar};
2614				if (_compress($client, \$tempscalar)) {
2615					push(@available, $key);
2616					$data = "CM\x00$_\x00" . $_COMPRESS_AVAILABLE{$_}{version} . "\x00" . _bin2asc($tempscalar);
2617					push(@{ $client->{_negotiating_commands} }, $data);
2618				}
2619				delete $client->{_compress};
2620			}
2621
2622			#
2623			# Old method
2624			#
2625			$data = "CA" . join("", map { "\x00$_" } @available);
2626			push(@{ $client->{_negotiating_commands} }, $data);
2627		}
2628		if (defined $client->{_password}) {
2629			if (!exists $client->{_cryptsalt}) {
2630				$client->{_cryptsalt} = _genrandstring(2, 1);
2631			}
2632			$data = "CS\x00" . $client->{_cryptsalt};
2633			push(@{ $client->{_negotiating_commands} }, $data);
2634		}
2635		push(@{ $client->{_negotiating_commands} }, "EN");
2636	}
2637
2638	$data = shift @{ $client->{_negotiating_commands} };
2639	if (($data =~ /^EA\x00/ && $client->{_negotiatedencryptcompatability}) || ($data =~ /^CA\x00/ && $client->{_negotiatedcompresscompatability})) {
2640
2641		#
2642		# We've already negotiated through compatability. No need to re-negotiate based on versions
2643		#
2644		$data = "NO\x00Already negotiated through compatability";
2645	}
2646	if (!defined $data) {
2647		return undef;
2648	}
2649	if (!_send($client, $data, 0)) {
2650		$@ = "Error negotiating with client. Could not send : $@";
2651		return undef;
2652	}
2653	$client->{_negotiating_lastevent} = "sent";
2654	return 1;
2655}
2656
2657#
2658# This is called whenever a client (true client or serverclient) receives data without the realdata bit set
2659# Takes client as first argument
2660# Takes optional data as second argument, otherwise calls data() method to get it
2661# It would parse the data and probably set variables inside the client object
2662#
2663sub _parseinternaldata {
2664	my $client = shift;
2665	my $data   = shift;
2666	if ($client->{_mode} eq "serverclient" && $client->{_negotiating}) {
2667
2668		# The serverclient is still negotiating
2669		if (_serverclient_negotiate($client)) {
2670
2671			# Negotiation's complete and successful
2672			_callback($client, "connect");
2673		}
2674	}
2675	else {
2676
2677		#
2678		# It's normal internal data
2679		#
2680		if (!defined $data) {
2681
2682			#
2683			# Data was not supplied - get it from bucket
2684			#
2685			$data = $client->data();
2686		}
2687
2688		# Now do something with it
2689	}
2690}
2691
2692#
2693# This takes an integer, packs it as tightly as possible as a binary representation
2694# and returns the binary value
2695#
2696sub _packint {
2697	my $int = shift;
2698	my $bin;
2699	$bin = pack("N", $int);
2700	$bin =~ s/^\0+//;
2701	return $bin;
2702}
2703
2704#
2705# This does the opposite of _packint. It takes a packed binary produced by _packint and
2706# returns the integer
2707#
2708sub _unpackint {
2709	my $bin = shift;
2710	my $int;
2711	$int = "\0" x (4 - length($bin)) . $bin;
2712	$int = unpack("N", $int);
2713	return $int;
2714}
2715
2716#
2717# This creates a new client object and outgoing connection and returns it as an object
2718# , or returns undef if unsuccessful
2719# If special parameter _sock is supplied, it will be taken as an existing connection
2720# and no outgoing connection will be made
2721#
2722sub _new_client {
2723	my $class = shift;
2724	my %para  = @_;
2725	my $sock;
2726	my $self = {};
2727	my $temp;
2728	my $remoteip;
2729	my $remoteport;
2730	my $key;
2731	my $timeout = $para{timeout} || 30;
2732	$class =~ s/=.*//g;
2733
2734	if (!$para{_sock}) {
2735		if (!$para{host}) {
2736			$@ = "Invalid host";
2737			return undef;
2738		}
2739		elsif (!$para{port}) {
2740			$@ = "Invalid port";
2741			return undef;
2742		}
2743		$sock = new IO::Socket::INET(
2744			PeerAddr => $para{host},
2745			PeerPort => $para{port},
2746			Proto    => 'tcp',
2747			Timeout  => $timeout,
2748		);
2749		$self->{_mode}        = "client";
2750		$self->{_negotiating} = time;
2751	}
2752	else {
2753		$sock                   = $para{_sock};
2754		$self->{_mode}          = "serverclient";
2755		$self->{_negotiating}   = time;
2756		$self->{_authenticated} = 0;
2757	}
2758	if (!$sock) {
2759		$@ = "Could not connect to $para{host}:$para{port}: $!";
2760		return undef;
2761	}
2762	$sock->autoflush(1);
2763	if ($para{_remoteport} && $para{_remoteip}) {
2764		$self->{_remoteport} = $para{_remoteport};
2765		$self->{_remoteip}   = $para{_remoteip};
2766	}
2767	else {
2768		if (!($temp = getpeername($sock))) {
2769			$@ = "Error getting peername";
2770			return undef;
2771		}
2772		if (!(($remoteport, $remoteip) = sockaddr_in($temp))) {
2773			$@ = "Error getting socket address";
2774			return undef;
2775		}
2776		if (!($self->{_remoteip} = inet_ntoa($remoteip))) {
2777			$@ = "Error determing remote IP";
2778			return undef;
2779		}
2780		$self->{_remoteport} = $remoteport;
2781	}
2782	$self->{_sock}              = $sock;
2783	$self->{_password}          = $para{password};
2784	$self->{_donotcompress}     = ($para{donotcompress}) ? 1 : 0;
2785	$self->{_donotencrypt}      = ($para{donotencrypt}) ? 1 : 0;
2786	$self->{_donotcheckversion} = ($para{donotcheckversion}) ? 1 : 0;
2787	$self->{_localpublickey}    = "";
2788	$self->{_databucket}        = [];
2789
2790	#
2791	# Populate donotcompresswith with the keys of the supplied module names
2792	#
2793	$self->{_donotcompresswith} = {};
2794	if (ref($para{donotcompresswith}) ne "ARRAY") {
2795		$para{donotcompresswith} = [ $para{donotcompresswith} ];
2796	}
2797	foreach $key (keys %_COMPRESS_AVAILABLE) {
2798		if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) {
2799			$self->{_donotcompresswith}{$key} = 1;
2800		}
2801	}
2802
2803	#
2804	# Populate donotencryptwith with the keys of the supplied module names
2805	#
2806	$self->{_donotencryptwith} = {};
2807	if (ref($para{donotencryptwith}) ne "ARRAY") {
2808		$para{donotencryptwith} = [ $para{donotencryptwith} ];
2809	}
2810	foreach $key (keys %_ENCRYPT_AVAILABLE) {
2811		if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) {
2812			$self->{_donotencryptwith}{$key} = 1;
2813		}
2814	}
2815
2816	bless($self, $class);
2817
2818	if ($self->{_mode} eq "client") {
2819		if (!_client_negotiate($self)) {
2820
2821			# Bad server
2822			$self->close();
2823			$@ = "Error negotiating with server: $@";
2824			return undef;
2825		}
2826		else {
2827			$self->{_negotiating} = 0;
2828		}
2829	}
2830	return $self;
2831}
2832
2833#
2834# This creates a new listening server object and returns it, or returns undef if unsuccessful
2835#
2836# Expects a class
2837#
2838sub _new_server {
2839	my $class = shift;
2840	my %para  = @_;
2841	my $sock;
2842	my $key;
2843	my $self = {};
2844	if (!$para{port}) {
2845		$@ = "Invalid port";
2846		return undef;
2847	}
2848	$sock = new IO::Socket::INET(
2849		LocalPort => $para{port},
2850		Proto     => 'tcp',
2851		Listen    => SOMAXCONN,
2852		Reuse     => 1,
2853	);
2854	if (!$sock) {
2855		$@ = "Could not create listening socket on port $para{port}: $!";
2856		return undef;
2857	}
2858	$sock->autoflush(1);
2859	$self->{_sock}     = $sock;
2860	$self->{_selector} = new IO::Select;
2861	$self->{_selector}->add($sock);
2862	$self->{_mode}          = "server";
2863	$self->{_welcome}       = $para{welcome};
2864	$self->{_password}      = $para{password};
2865	$self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0;
2866	$self->{_donotencrypt}  = ($para{donotencrypt}) ? 1 : 0;
2867	$self->{_clients}       = {};
2868	$self->{_clientip}      = {};
2869
2870	#
2871	# Populate donotcompresswith with the keys of the supplied module names
2872	#
2873	$self->{_donotcompresswith} = {};
2874	if (ref($para{donotcompresswith}) ne "ARRAY") {
2875		$para{donotcompresswith} = [ $para{donotcompresswith} ];
2876	}
2877	foreach $key (keys %_COMPRESS_AVAILABLE) {
2878		if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) {
2879			$self->{_donotcompresswith}{$key} = 1;
2880		}
2881	}
2882
2883	#
2884	# Populate donotencryptwith with the keys of the supplied module names
2885	#
2886	$self->{_donotencryptwith} = {};
2887	if (ref($para{donotencryptwith}) ne "ARRAY") {
2888		$para{donotencryptwith} = [ $para{donotencryptwith} ];
2889	}
2890	foreach $key (keys %_ENCRYPT_AVAILABLE) {
2891		if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) {
2892			$self->{_donotencryptwith}{$key} = 1;
2893		}
2894	}
2895
2896	#
2897	# To avoid key-gen delays while running, let's create global RSA keypairs right now
2898	#
2899	if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{'B'}) {
2900		if (!_generateglobalkeypair('Crypt::RSA')) {
2901			$@ = "Could not generate global Crypt::RSA keypairs. $@";
2902			return undef;
2903		}
2904	}
2905
2906	bless($self, $class);
2907	return $self;
2908}
2909
2910#
2911# This takes a client object and tries to extract as many data buckets as possible out of it's data buffer
2912# If no buckets were extracted, returns false
2913# Otherwise returns true
2914#
2915sub _extractdata {
2916	my $client = shift;
2917	my ($alwayson, $complexstructure, $realdata, $reserved, $encrypted, $compressed, $lenlen);
2918	my $lendata;
2919	my $len;
2920	my $data;
2921	my $key = (defined $client->{_databuffer}) ? substr($client->{_databuffer}, 0, 2) : '';
2922	if (length($key) != 2) {
2923		return undef;
2924	}
2925	$alwayson         = vec($key, 0, 1);
2926	$complexstructure = vec($key, 1, 1);
2927	$realdata         = vec($key, 2, 1);
2928	$encrypted        = vec($key, 3, 1);
2929	$compressed       = vec($key, 4, 1);
2930	$reserved         = vec($key, 5, 1);
2931	$reserved         = vec($key, 6, 1);
2932	$reserved         = vec($key, 7, 1);
2933	$lenlen           = vec($key, 1, 8);
2934
2935	if (!$alwayson) {
2936		return undef;
2937	}
2938	$len = substr($client->{_databuffer}, 2, $lenlen);
2939	$lendata = _unpackint($len);
2940	if (length($client->{_databuffer}) < (2 + $lenlen + $lendata)) {
2941		return undef;
2942	}
2943	$data = substr($client->{_databuffer}, 2 + $lenlen, $lendata);
2944	if (length($data) != $lendata) {
2945		return undef;
2946	}
2947	substr($client->{_databuffer}, 0, 2 + $lenlen + $lendata) = '';
2948	if ($encrypted) {
2949		_decrypt($client, \$data) || return undef;
2950	}
2951	if ($compressed) {
2952		_decompress($client, \$data) || return undef;
2953	}
2954	if ($complexstructure) {
2955		$data = thaw($data);
2956		if (!$data) {
2957			$@ = "Error decompressing complex structure: $!";
2958			return undef;
2959		}
2960	}
2961
2962	#
2963	# We extracted it fine from the buffer, we add it in the data buckets
2964	#
2965	push(
2966		@{ $client->{_databucket} },
2967		{
2968			data     => $data,
2969			realdata => $realdata,
2970		}
2971	);
2972
2973	#
2974	# Let's push our luck and see if we can extract more :)
2975	#
2976	_extractdata($client);
2977
2978	#
2979	# All is good, we know we extracted at least 1 bucket
2980	#
2981	return (1);
2982}
2983
2984#
2985# This takes a client object and data, serializes the data if necesary, constructs a proprietary protocol packet
2986# containing the user's data in it, implements crypto and compression as needed, and sends the packet to the supplied socket
2987# Returns 1 for success, undef on failure
2988#
2989sub _send {
2990	local $SIG{'PIPE'} = 'IGNORE';
2991	my $client   = shift;
2992	my $data     = shift;
2993	my $realdata = shift;
2994	my $sock     = $client->{_sock};
2995	my $encrypted;
2996	my $compressed;
2997	my $lendata;
2998	my $lenlen;
2999	my $len;
3000	my $key;
3001	my $finaldata;
3002	my $packet;
3003	my $temp;
3004	my $bytes_written;
3005	my $complexstructure = ref($data);
3006
3007	if (!$sock) {
3008		$@ = "Error sending data: Socket handle not supplied";
3009		return undef;
3010	}
3011	elsif (!defined $data) {
3012		$@ = "Error sending data: Data not supplied";
3013		return undef;
3014	}
3015	if ($complexstructure) {
3016		$data = nfreeze $data;
3017	}
3018	$compressed = ($client->{_donotcompress}) ? 0 : _compress($client, \$data);
3019	$encrypted  = ($client->{_donotencrypt})  ? 0 : _encrypt($client,  \$data);
3020	$lendata    = length($data);
3021	$len        = _packint($lendata);
3022	$lenlen     = length($len);
3023
3024	# Reset the key byte into 0-filled bits
3025	$key = chr(0) x 2;
3026	vec($key, 0, 16) = 0;
3027
3028	# 1 BIT: ALWAYSON :
3029	vec($key, 0, 1) = 1;
3030
3031	# 1 BIT: COMPLEXSTRUCTURE :
3032	vec($key, 1, 1) = ($complexstructure) ? 1 : 0;
3033
3034	# 1 BIT: REAL DATA:
3035	vec($key, 2, 1) = (defined $realdata && !$realdata) ? 0 : 1;
3036
3037	# 1 BIT: ENCRYPTED :
3038	vec($key, 3, 1) = ($encrypted) ? 1 : 0;
3039
3040	# 1 BIT: COMPRESSED :
3041	vec($key, 4, 1) = ($compressed) ? 1 : 0;
3042
3043	# 1 BIT: RESERVED :
3044	vec($key, 5, 1) = 0;
3045
3046	# 1 BIT: RESERVED :
3047	vec($key, 6, 1) = 0;
3048
3049	# 1 BIT: RESERVED :
3050	vec($key, 7, 1) = 0;
3051
3052	# 8 BITS: LENGTH OF "DATA LENGTH STRING"
3053	vec($key, 1, 8) = $lenlen;
3054
3055	# Construct the final data and send it:
3056	$finaldata = $key . $len . $data;
3057	$len       = length($finaldata);
3058	$temp      = 0;
3059	while (length($finaldata)) {
3060		$packet = substr($finaldata, 0, $PACKETSIZE);
3061		substr($finaldata, 0, $PACKETSIZE) = '';
3062		$bytes_written = syswrite($sock, $packet, length($packet));
3063		if (!defined $bytes_written) {
3064			$@ = "Error writing to socket while sending data: $!";
3065			return undef;
3066		}
3067		$temp += $bytes_written;
3068	}
3069	if ($temp != $len) {
3070		$@ = "Error sending data: $!";
3071		return undef;
3072	}
3073	else {
3074		return 1;
3075	}
3076}
3077
3078#
3079# Leave me alone:
3080#
30811;
3082