Ticket #107: Proxy.pm

File Proxy.pm, 28.9 kB (added by amatubu, 3 years ago)

Replacement of Proxy.pm

Line 
1 package Proxy::Proxy;
2
3 # ----------------------------------------------------------------------------
4 #
5 # This module implements the base class for all POPFile proxy Modules
6 #
7 # Copyright (c) 2001-2009 John Graham-Cumming
8 #
9 #   This file is part of POPFile
10 #
11 #   POPFile is free software; you can redistribute it and/or modify it
12 #   under the terms of version 2 of the GNU General Public License as
13 #   published by the Free Software Foundation.
14 #
15 #   POPFile is distributed in the hope that it will be useful,
16 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
17 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 #   GNU General Public License for more details.
19 #
20 #   You should have received a copy of the GNU General Public License
21 #   along with POPFile; if not, write to the Free Software
22 #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 #
24 #   Modified by     Sam Schinke (sschinke@users.sourceforge.net)
25 #
26 # ----------------------------------------------------------------------------
27
28 use POPFile::Module;
29 @ISA = ( "POPFile::Module" );
30
31 use IO::Handle;
32 use IO::Socket;
33 use IO::Select;
34
35 # A handy variable containing the value of an EOL for networks
36 my $eol = "\015\012";
37
38 #----------------------------------------------------------------------------
39 # new
40 #
41 #   Class new() function, all real work gets done by initialize and
42 #   the things set up here are more for documentation purposes than
43 #   anything so that you know that they exists
44 #
45 #----------------------------------------------------------------------------
46 sub new
47 {
48     my $type = shift;
49     my $self = POPFile::Module->new();
50
51     # A reference to the classifier and history
52
53     $self->{classifier__}     = 0;
54     $self->{history__}        = 0;
55
56     # Reference to a child() method called to handle a proxy
57     # connection
58
59     $self->{child_}            = 0;
60
61     # Holding variable for MSWin32 pipe handling
62
63     $self->{pipe_cache__} = {};
64
65     # This is where we keep the session with the Classifier::Bayes
66     # module
67
68     $self->{api_session__} = '';
69
70     # This is the error message returned if the connection at any
71     # time times out while handling a command
72     #
73     # $self->{connection_timeout_error_} = '';
74
75     # This is the error returned (with the host and port appended)
76     # if contacting the remote server fails
77     #
78     # $self->{connection_failed_error_}  = '';
79
80     # This is a regular expression used by get_response_ to determine
81     # if a response from the remote server is good or not (good being
82     # that the last command succeeded)
83     #
84     # $self->{good_response_}            = '';
85
86     $self->{ssl_not_supported_error_}  = '-ERR SSL connection is not supported since required modules are not installed';
87
88     # Connect Banner returned by the real server
89     $self->{connect_banner__} = '';
90
91     return bless $self, $type;
92 }
93
94 # ----------------------------------------------------------------------------
95 #
96 # initialize
97 #
98 # Called to initialize the Proxy, most of this is handled by a subclass of this
99 # but here we set the 'enabled' flag
100 #
101 # ----------------------------------------------------------------------------
102 sub initialize
103 {
104     my ( $self ) = @_;
105
106     $self->config_( 'enabled', 1 );
107
108     # The following parameters are for SOCKS proxy handling on outbound
109     # connections
110
111     $self->config_( 'socks_server', '' );
112     $self->config_( 'socks_port',   1080 );
113
114     # The name of the unix socket used for proxy service
115     # If it is '', inet sockets are used.
116     # If it is not '', unix sockets are used.
117
118     $self->config_( 'unix_socket', '' );
119
120     return 1;
121 }
122
123 # ----------------------------------------------------------------------------
124 #
125 # start
126 #
127 # Called when all configuration information has been loaded from disk.
128 #
129 # The method should return 1 to indicate that it started correctly, if it returns
130 # 0 then POPFile will abort loading immediately
131 #
132 # ----------------------------------------------------------------------------
133 sub start
134 {
135     my ( $self ) = @_;
136
137     my $name = $self->name();
138     my $unix_socket = $self->config_( 'unix_socket' );
139
140     if ( !$unix_socket ) {
141
142         my $port = $self->config_( 'port' );
143         my $local = ( ( $self->config_( 'local' ) || 0 ) == 1 );
144
145         # Open the inet socket used to receive request for proxy service
146
147         $self->log_( 1, "Opening listening socket for $name proxy on port $port." );
148
149         $self->{server__} = IO::Socket::INET->new(  # PROFILE BLOCK START
150                 Proto     => 'tcp',
151                 ( $local ? ( LocalAddr => 'localhost' ) : () ),
152                 LocalPort => $port,
153                 Listen    => SOMAXCONN,
154                 Reuse     => 1
155         );                                          # PROFILE BLOCK STOP
156
157         if ( !defined( $self->{server__} ) ) {
158             print STDERR <<EOM; # PROFILE BLOCK START
159
160 \nCouldn\'t start the $name proxy because POPFile could not bind to the
161 listen port $port. This could be because there is another service
162 using that port or because you do not have the right privileges on
163 your system (On Unix systems this can happen if you are not root
164 and the port you specified is less than 1024).
165 The original error message: $!
166
167 EOM
168 # PROFILE BLOCK STOP
169             return 0;
170         }
171     } else {
172
173         unlink $unix_socket if ( -e $unix_socket );
174
175         # Open the unix socket to receive request for proxy service
176
177         $self->log_( 1, "Opening listening socket for $name proxy on unix socket $unix_socket." );
178
179         $self->{server__} = IO::Socket::UNIX->new(  # PROFILE BLOCK START
180                 Type      => SOCK_STREAM,
181                 Local     => $unix_socket,
182                 Listen    => SOMAXCONN,
183         );                                          # PROFILE BLOCK STOP
184
185         if ( !defined( $self->{server__} ) ) {
186             print STDERR <<EOM; # PROFILE BLOCK START
187
188 \nCouldn\'t start the $name proxy because POPFile could not bind to the
189 unix socket $unix_socket. This could be because there is another
190 service using that socket or because you do not have the right
191 privileges on your system.
192 The original error message: $!
193
194 EOM
195 # PROFILE BLOCK STOP
196             return 0;
197         }
198     }
199
200     # This is used to perform select calls on the $server socket so that we can decide when there is
201     # a call waiting an accept it without having to block
202
203     $self->{selector__} = new IO::Select( $self->{server__} );
204
205     # Tell the UI about the SOCKS parameters
206
207     $self->register_configuration_item_( 'configuration',  # PROFILE BLOCK START
208                                          $name . '_socks_configuration',
209                                          'socks-widget.thtml',
210                                          $self );          # PROFILE BLOCK STOP
211
212     return 1;
213 }
214
215 # ----------------------------------------------------------------------------
216 #
217 # stop
218 #
219 # Called when POPFile is closing down, this is the last method that
220 # will get called before the object is destroyed.  There is no return
221 # value from stop().
222 #
223 # ----------------------------------------------------------------------------
224 sub stop
225 {
226     my ( $self ) = @_;
227
228     if ( $self->{api_session__} ne '' ) {
229         $self->{classifier__}->release_session_key( $self->{api_session__} );
230     }
231
232     # Need to close all the duplicated file handles, this include the
233     # POP3 listener and all the reading ends of pipes to active
234     # children
235
236     close $self->{server__} if ( defined( $self->{server__} ) );
237 }
238
239 # ----------------------------------------------------------------------------
240 #
241 # service
242 #
243 # service() is a called periodically to give the module a chance to do
244 # housekeeping work.
245 #
246 # If any problem occurs that requires POPFile to shutdown service()
247 # should return 0 and the top level process will gracefully terminate
248 # POPFile including calling all stop() methods.  In normal operation
249 # return 1.
250 #
251 # ----------------------------------------------------------------------------
252 sub service
253 {
254     my ( $self ) = @_;
255
256     # Accept a connection from a client trying to use us as the mail
257     # server.  We service one client at a time and all others get
258     # queued up to be dealt with later.  We check the alive boolean
259     # here to make sure we are still allowed to operate. See if
260     # there's a connection waiting on the $server by getting the list
261     # of handles with data to read, if the handle is the server then
262     # we're off.
263
264     if ( ( defined( $self->{selector__}->can_read(0) ) ) && # PROFILE BLOCK START
265          ( $self->{alive_} ) ) {                            # PROFILE BLOCK STOP
266         if ( my $client = $self->{server__}->accept() ) {
267
268             # Check to see if we have obtained a session key yet
269
270             if ( $self->{api_session__} eq '' ) {
271                 $self->{api_session__} =                                   # PROFILE BLOCK START
272                     $self->{classifier__}->get_session_key( 'admin', '' ); # PROFILE BLOCK STOP
273             }
274
275             # Check that this is a connection from the local machine,
276             # if it's not then we drop it immediately without any
277             # further processing.  We don't want to act as a proxy for
278             # just anyone's email
279
280             my $acceptable = 0;
281
282             if ( ref $client eq 'IO::Socket::UNIX' ) {
283
284                 # Connection to the unix socket is always acceptable
285                 # because unix sockets are connected from localhost
286                 # only
287
288                 $acceptable = 1;
289             } else {
290
291                 my ( $remote_port, $remote_host ) = sockaddr_in(           # PROFILE BLOCK START
292                                                     $client->peername() ); # PROFILE BLOCK STOP
293
294                 $acceptable = ( ( ( $self->config_( 'local' ) || 0 ) == 0 ) ||  # PROFILE BLOCK START
295                                 ( $remote_host eq inet_aton( "127.0.0.1" ) ) ); # PROFILE BLOCK STOP
296             }
297
298             if ( $acceptable ) {
299
300                 # If we have force_fork turned on then we will do a
301                 # fork, otherwise we will handle this inline, in the
302                 # inline case we need to create the two ends of a pipe
303                 # that will be used as if there was a child process
304
305                 binmode( $client );
306
307                 if ( $self->config_( 'force_fork' ) ) {
308                     my ( $pid, $pipe ) = &{$self->{forker_}};
309
310                     # If we fail to fork, or are in the child process
311                     # then process this request
312
313                     if ( !defined( $pid ) || ( $pid == 0 ) ) {
314                         $self->{child_}( $self, $client,        # PROFILE BLOCK START
315                             $self->{api_session__} );           # PROFILE BLOCK STOP
316                         if ( defined( $pid ) ) {
317                             &{$self->{childexit_}}( 0 );
318                         }
319                     }
320                 } else {
321                     pipe my $reader, my $writer;
322
323                     $self->{child_}( $self, $client, $self->{api_session__} );
324                     close $reader;
325                 }
326             }
327
328             close $client;
329         }
330     }
331
332     return 1;
333 }
334
335 # ----------------------------------------------------------------------------
336 #
337 # forked
338 #
339 # This is called when some module forks POPFile and is within the
340 # context of the child process so that this module can close any
341 # duplicated file handles that are not needed.
342 #
343 # There is no return value from this method
344 #
345 # ----------------------------------------------------------------------------
346 sub forked
347 {
348     my ( $self ) = @_;
349
350     close $self->{server__};
351 }
352
353 # ----------------------------------------------------------------------------
354 #
355 # tee_
356 #
357 # $socket   The stream (created with IO::) to send the string to
358 # $text     The text to output
359 #
360 # Sends $text to $socket and sends $text to debug output
361 #
362 # ----------------------------------------------------------------------------
363 sub tee_
364 {
365     my ( $self, $socket, $text ) = @_;
366
367     # Send the message to the debug output and then send it to the appropriate socket
368     $self->log_( 1, $text );
369     print $socket $text; # don't print if $socket undef
370 }
371
372 # ----------------------------------------------------------------------------
373 #
374 # echo_to_regexp_
375 #
376 # $mail     The stream (created with IO::) to send the message to (the remote mail server)
377 # $client   The local mail client (created with IO::) that needs the response
378 # $regexp   The pattern match to terminate echoing, compile using qr/pattern/
379 # $log      (OPTIONAL) log output if 1, defaults to 0 if unset
380 # $suppress (OPTIONAL) suppress any lines that match, compile using qr/pattern/
381 #
382 # echo all information from the $mail server until a single line matching $regexp is seen
383 #
384 # ----------------------------------------------------------------------------
385 sub echo_to_regexp_
386 {
387     my ( $self, $mail, $client, $regexp, $log, $suppress ) = @_;
388
389     $log = 0 if (!defined($log));
390
391     while ( my $line = $self->slurp_( $mail ) ) {
392         if (!defined($suppress) || !( $line =~ $suppress )) {
393             if ( !$log ) {
394                 print $client $line;
395             } else {
396                 $self->tee_( $client, $line );
397             }
398         } else {
399             $self->log_( 2, "Suppressed: $line" );
400         }
401
402         if ( $line =~ $regexp ) {
403             last;
404         }
405     }
406 }
407
408 # ----------------------------------------------------------------------------
409 #
410 # echo_to_dot_
411 #
412 # $mail     The stream (created with IO::) to send the message to (the remote mail server)
413 # $client   The local mail client (created with IO::) that needs the response
414 #
415 # echo all information from the $mail server until a single line with a . is seen
416 #
417 # ----------------------------------------------------------------------------
418 sub echo_to_dot_
419 {
420     my ( $self, $mail, $client ) = @_;
421
422     # The termination has to be a single line with exactly a dot on it and nothing
423     # else other than line termination characters.  This is vital so that we do
424     # not mistake a line beginning with . as the end of the block
425
426     $self->echo_to_regexp_( $mail, $client, qr/^\.(\r\n|\r|\n)$/);
427 }
428
429 # ----------------------------------------------------------------------------
430 #
431 # get_response_
432 #
433 # $mail     The stream (created with IO::) to send the message to (the remote mail server)
434 # $client   The local mail client (created with IO::) that needs the response
435 # $command  The text of the command to send (we add an EOL)
436 # $null_resp Allow a null response
437 # $suppress If set to 1 then the response does not go to the client
438 #
439 # Send $command to $mail, receives the response and echoes it to the $client and the debug
440 # output.  Returns the response and a failure code indicating false if there was a timeout
441 #
442 # ----------------------------------------------------------------------------
443 sub get_response_
444 {
445     my ( $self, $mail, $client, $command, $null_resp, $suppress ) = @_;
446
447     $null_resp = 0 if (!defined $null_resp);
448     $suppress  = 0 if (!defined $suppress);
449
450     unless ( defined($mail) && $mail->connected ) {
451        # $mail is undefined - return an error intead of crashing
452        $self->tee_(  $client, "$self->{connection_timeout_error_}$eol" );
453        return ( $self->{connection_timeout_error_}, 0 );
454     }
455
456     # Send the command (followed by the appropriate EOL) to the mail server
457     $self->tee_( $mail, $command. $eol );
458
459     my $response;
460
461     # Retrieve a single string containing the response
462
463     my $can_read = 0;
464     if ( $mail =~ /ssl/i ) {
465         $can_read = ( $mail->pending() > 0 );
466     }
467     if ( !$can_read ) {
468         my $selector = new IO::Select( $mail );
469         my ( $ready ) = $selector->can_read(                             # PROFILE BLOCK START
470             ( !$null_resp ? $self->global_config_( 'timeout' ) : .5 ) ); # PROFILE BLOCK STOP
471         $can_read = defined( $ready ) && ( $ready == $mail );
472     }
473
474     if ( $can_read ) {
475         $response = $self->slurp_( $mail );
476
477         if ( $response ) {
478
479             # Echo the response up to the mail client
480
481             $self->tee_( $client, $response ) if ( !$suppress );
482             return ( $response, 1 );
483         }
484     }
485
486     if ( !$null_resp ) {
487         # An error has occurred reading from the mail server
488
489         $self->tee_(  $client, "$self->{connection_timeout_error_}$eol" );
490         return ( $self->{connection_timeout_error_}, 0 );
491     } else {
492         $self->tee_($client, "");
493         return ( "", 1 );
494     }
495 }
496
497 # ----------------------------------------------------------------------------
498 #
499 # echo_response_
500 #
501 # $mail     The stream (created with IO::) to send the message to (the remote mail server)
502 # $client   The local mail client (created with IO::) that needs the response
503 # $command  The text of the command to send (we add an EOL)
504 # $suppress If set to 1 then the response does not go to the client
505 #
506 # Send $command to $mail, receives the response and echoes it to the $client and the debug
507 # output.
508 #
509 # Returns one of three values
510 #
511 # 0 Successfully sent the command and got a positive response
512 # 1 Sent the command and got a negative response
513 # 2 Failed to send the command (e.g. a timeout occurred)
514 #
515 # ----------------------------------------------------------------------------
516 sub echo_response_
517 {
518     my ( $self, $mail, $client, $command, $suppress ) = @_;
519
520     # Determine whether the response began with the string +OK.  If it did then return 1
521     # else return 0
522
523     my ( $response, $ok ) = $self->get_response_( $mail, $client, $command, 0, $suppress );
524
525     if ( $ok == 1 ) {
526         if ( $response =~ /$self->{good_response_}/ ) {
527             return 0;
528         } else {
529             return 1;
530         }
531     } else {
532         return 2;
533     }
534 }
535
536 # ----------------------------------------------------------------------------
537 #
538 # verify_connected_
539 #
540 # $mail        The handle of the real mail server
541 # $client      The handle to the mail client
542 # $hostname    The host name of the remote server
543 # $port        The port
544 # $ssl         If set to 1 then the connection to the remote is established
545 #              using SSL
546 # $unix_socket If it is not '', connect to the unix socket
547 #
548 # Check that we are connected to $hostname on port $port putting the
549 # open handle in $mail.  Any messages need to be sent to $client
550 #
551 # ----------------------------------------------------------------------------
552 sub verify_connected_
553 {
554     my ( $self, $mail, $client, $hostname, $port, $ssl, $unix_socket ) = @_;
555
556     $ssl = 0 if ( !defined( $ssl ) );
557
558     # Check to see if we are already connected
559
560     return $mail if ( $mail && $mail->connected );
561
562     # Connect to the real mail server on the standard port, if we are using
563     # SOCKS then go through the proxy server
564
565     if ( $self->config_( 'socks_server' ) ne '' ) {
566         require IO::Socket::Socks;
567         $self->log_( 0, "Attempting to connect to socks server at " # PROFILE BLOCK START
568                     . $self->config_( 'socks_server' ) . ":"
569                     . $self->config_( 'socks_port' ) );             # PROFILE BLOCK STOP
570
571         $mail = IO::Socket::Socks->new(      # PROFILE BLOCK START
572                     ProxyAddr => $self->config_( 'socks_server' ),
573                     ProxyPort => $self->config_( 'socks_port' ),
574                     ConnectAddr  => $hostname,
575                     ConnectPort  => $port ); # PROFILE BLOCK STOP
576     } else {
577         if ( $ssl ) {
578             eval {
579                 require IO::Socket::SSL;
580             };
581             if ( $@ ) {
582                 # Cannot load IO::Socket::SSL
583
584                 $self->tee_( $client, "$self->{ssl_not_supported_error_}$eol" );
585                 return undef;
586             }
587
588             $self->log_( 0, "Attempting to connect to SSL server at " # PROFILE BLOCK START
589                         . "$hostname:$port" );                        # PROFILE BLOCK STOP
590
591             if ( $^O eq 'MSWin32' ) { # PROFILE PLATFORM START MSWin32
592
593                 # Workaround for avoiding intermittent password problem when
594                 # using SSL. The problem occurs because IO::Socket->blocking
595                 # is not supported on Windows.
596                 # IO::Socket 1.30_01 which is included in Perl 5.10 seems to
597                 # support blocking() on Windows. So we may remove this
598                 # workaround when we move to Perl 5.10.
599
600                 my $timeout = $self->global_config_( 'timeout' );
601                 my $tt = time + $timeout;
602
603                 $mail = IO::Socket::INET->new( # PROFILE BLOCK START
604                             Proto    => "tcp",
605                             PeerAddr => $hostname,
606                             PeerPort => $port,
607                             Timeout  => $timeout,
608                 ); # PROFILE BLOCK STOP
609
610                 if ( $mail ) {
611                     # Change the socket to non-blocking mode
612
613                     my $non_blocking = 1;
614                     ioctl( $mail, 0x8004667e, pack( 'L!', $non_blocking ) );
615
616                     $self->log_( 2, "Trying to upgrade socket $mail to SSL" );
617
618                     while ( $tt > time ) {
619                         # Upgrade the socket to SSL
620
621                         IO::Socket::SSL->start_SSL( # PROFILE BLOCK START
622                                 $mail,
623                                 Timeout  => $timeout,
624                         ); # PROFILE BLOCK STOP
625
626                         my $err = IO::Socket::SSL->errstr;
627                         last if ( $err eq '' );
628
629                         $self->log_( 1, "Got an error $err from start_SSL" );
630
631                         last if ( !defined $mail );
632
633                         my $vec = '';
634                         vec( $vec, $mail->fileno, 1 ) = 1;
635                         my $rv =  # PROFILE BLOCK START
636                             ( $err eq IO::Socket::SSL->SSL_WANT_READ )  ? select( $vec, undef, undef, $timeout ) :
637                             ( $err eq IO::Socket::SSL->SSL_WANT_WRITE ) ? select( undef, $vec, undef, $timeout ) :
638                             undef; # PROFILE BLOCK STOP
639
640                         last if ( !$rv );
641                     }
642
643                     if ( !defined $mail || ( ref $mail ne 'IO::Socket::SSL' ) ) {
644                         $self->log_( 0, "Failed to upgrade the socket to SSL" );
645                         $mail->close if defined $mail;
646                         undef $mail;
647                     } else {
648                         $self->log_( 2, "The socket $mail has successfully been upgraded" );
649
650                         # Restore to blocking mode
651
652                         $non_blocking = 0;
653                         ioctl( $mail, 0x8004667e, pack( 'L!', $non_blocking ) );
654                     }
655                 }
656             } # PROFILE PLATFORM BLOCK STOP MSWin32
657             else {
658                 $mail = IO::Socket::SSL->new( # PROFILE BLOCK START
659                             Proto    => "tcp",
660                             PeerAddr => $hostname,
661                             PeerPort => $port,
662                             Timeout  => $self->global_config_( 'timeout' ),
663                             Domain   => AF_INET,
664                 ); # PROFILE BLOCK STOP
665             }
666
667         } else {
668             if ( $unix_socket ) {
669
670                 $self->log_( 0, "Attempting to connect to unix socket at $unix_socket" );
671
672                 $mail = IO::Socket::UNIX->new(  # PROFILE BLOCK START
673                         Type     => SOCK_STREAM,
674                         Peer     => $unix_socket,
675                         Timeout  => $self->global_config_( 'timeout' ),
676                 );                              # PROFILE BLOCK STOP
677
678             } else {
679
680                 $self->log_( 0, "Attempting to connect to POP server at " # PROFILE BLOCK START
681                             . "$hostname:$port" ); # PROFILE BLOCK STOP
682
683                 $mail = IO::Socket::INET->new( # PROFILE BLOCK START
684                         Proto    => "tcp",
685                         PeerAddr => $hostname,
686                         PeerPort => $port,
687                         Timeout  => $self->global_config_( 'timeout' ),
688                 ); # PROFILE BLOCK STOP
689
690             }
691         }
692     }
693
694     # Check that the connect succeeded for the remote server
695     if ( $mail ) {
696         if ( $mail->connected )  {
697
698             if ( $unix_socket ) {
699                 $self->log_( 0, "Connected to $unix_socket timeout " . $self->global_config_( 'timeout' ) );
700             } else {
701                 $self->log_( 0, "Connected to $hostname:$port timeout " . $self->global_config_( 'timeout' ) );
702             }
703
704             # Set binmode on the socket so that no translation of CRLF
705             # occurs
706
707             if ( !$ssl ) {
708                 binmode( $mail );
709             }
710
711             if ( !$ssl || ( $mail->pending() == 0 ) ) {
712                 # Wait 'timeout' seconds for a response from the remote server and
713                 # if there isn't one then give up trying to connect
714
715                 my $selector = new IO::Select( $mail );
716                 last unless $selector->can_read($self->global_config_( 'timeout' ));
717             }
718
719             # Read the response from the real server and say OK
720
721             my $buf        = '';
722             my $max_length = 8192;
723             my $n          = sysread( $mail, $buf, $max_length, length $buf );
724
725             if ( !( $buf =~ /[\r\n]/ ) ) {
726                 my $hit_newline = 0;
727                 my $temp_buf;
728
729                 # If we are on Windows, we will have to wait ourselves as
730                 # we are not going to call IO::Select::can_read.
731                 my $wait = ( ($^O eq 'MSWin32') && !($mail =~ /socket/i) ) ? 1 : 0;
732
733                 # Read until timeout or a newline (newline _should_ be immediate)
734
735                 for my $i ( 0..($self->global_config_( 'timeout' ) * 100) ) {
736                     if ( !$hit_newline ) {
737                         $temp_buf = $self->flush_extra_( $mail, $client, 1 );
738                         $hit_newline = ( $temp_buf =~ /[\r\n]/ );
739                         $buf .= $temp_buf;
740                         if ( $wait && ! length $temp_buf ) {
741                             select undef, undef, undef, 0.01;
742                         }
743                     }
744                     else {
745                         last;
746                     }
747                 }
748             }
749
750             $self->log_( 1, "Connection returned: $buf" );
751
752             # If we cannot read any response from server, close the connection
753
754             if ( $buf eq '' ) {
755                 close $mail;
756                 last;
757             }
758
759             $self->{connect_banner__} = $buf;
760
761             # Clean up junk following a newline
762
763             for my $i ( 0..4 ) {
764                 $self->flush_extra_( $mail, $client, 1 );
765             }
766
767             return $mail;
768         }
769     }
770
771     $self->log_( 0, "IO::Socket::* gets an error: $!" );
772
773     # Tell the client we failed
774     if ( $unix_socket ) {
775         $self->tee_( $client, "$self->{connection_failed_error_} $unix_socket$eol" );
776     } else {
777         $self->tee_( $client, "$self->{connection_failed_error_} $hostname:$port$eol" );
778     }
779
780     return undef;
781 }
782
783 # ----------------------------------------------------------------------------
784 #
785 # configure_item
786 #
787 #    $name            The name of the item being configured, was passed in by
788 #                     the call
789 #                     to register_configuration_item
790 #    $templ           The loaded template
791 #
792 # ----------------------------------------------------------------------------
793 sub configure_item
794 {
795     my ( $self, $name, $templ ) = @_;
796
797     $templ->param( 'Socks_Widget_Name' => $self->name() );
798     $templ->param( 'Socks_Server'      => $self->config_( 'socks_server' ) );
799     $templ->param( 'Socks_Port'        => $self->config_( 'socks_port'   ) );
800 }
801
802 # ----------------------------------------------------------------------------
803 #
804 # validate_item
805 #
806 #    $name            The name of the item being configured, was passed in by the call
807 #                     to register_configuration_item
808 #    $templ           The loaded template
809 #    $language        Reference to the hash holding the current language
810 #    $form            Hash containing all form items
811 #
812 #  Must return the HTML for this item
813 # ----------------------------------------------------------------------------
814 sub validate_item
815 {
816     my ( $self, $name, $templ, $language, $form ) = @_;
817
818     my $me = $self->name();
819
820     if ( defined($$form{"$me" . "_socks_port"}) ) {
821         if ( ( $$form{"$me" . "_socks_port"} >= 1 ) && ( $$form{"$me" . "_socks_port"} < 65536 ) ) {
822             $self->config_( 'socks_port', $$form{"$me" . "_socks_port"} );
823             $templ->param( 'Socks_Widget_If_Port_Updated' => 1 );
824             $templ->param( 'Socks_Widget_Port_Updated' => sprintf( $$language{Configuration_SOCKSPortUpdate}, $self->config_( 'socks_port' ) ) );
825         } else {
826             $templ->param( 'Socks_Widget_If_Port_Error' => 1 );
827         }
828     }
829
830     if ( defined($$form{"$me" . "_socks_server"}) ) {
831         $self->config_( 'socks_server', $$form{"$me" . "_socks_server"} );
832         $templ->param( 'Socks_Widget_If_Server_Updated' => 1 );
833         $templ->param( 'Socks_Widget_Server_Updated' => sprintf( $$language{Configuration_SOCKSServerUpdate}, $self->config_( 'socks_server' ) ) );
834     }
835 }
836
837 # SETTERS
838
839 sub classifier
840 {
841     my ( $self, $classifier ) = @_;
842
843     $self->{classifier__} = $classifier;
844 }
845
846 sub history
847 {
848     my ( $self, $history ) = @_;
849
850     $self->{history__} = $history;
851 }
852
853 1;