Ticket #107: Proxy.pm

File Proxy.pm, 28.9 KB (added by naoki iimura, 14 years ago)

Replacement of Proxy.pm

Line 
1package 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 ([email protected])
25#
26# ----------------------------------------------------------------------------
27
28use POPFile::Module;
29@ISA = ( "POPFile::Module" );
30
31use IO::Handle;
32use IO::Socket;
33use IO::Select;
34
35# A handy variable containing the value of an EOL for networks
36my $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#----------------------------------------------------------------------------
46sub 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# ----------------------------------------------------------------------------
102sub 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# ----------------------------------------------------------------------------
133sub 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
161listen port $port. This could be because there is another service
162using that port or because you do not have the right privileges on
163your system (On Unix systems this can happen if you are not root
164and the port you specified is less than 1024).
165The original error message: $!
166
167EOM
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
189unix socket $unix_socket. This could be because there is another
190service using that socket or because you do not have the right
191privileges on your system.
192The original error message: $!
193
194EOM
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# ----------------------------------------------------------------------------
224sub 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# ----------------------------------------------------------------------------
252sub 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# ----------------------------------------------------------------------------
346sub 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# ----------------------------------------------------------------------------
363sub 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# ----------------------------------------------------------------------------
385sub 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# ----------------------------------------------------------------------------
418sub 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# ----------------------------------------------------------------------------
443sub 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# ----------------------------------------------------------------------------
516sub 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# ----------------------------------------------------------------------------
552sub 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# ----------------------------------------------------------------------------
793sub 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# ----------------------------------------------------------------------------
814sub 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
839sub classifier
840{
841 my ( $self, $classifier ) = @_;
842
843 $self->{classifier__} = $classifier;
844}
845
846sub history
847{
848 my ( $self, $history ) = @_;
849
850 $self->{history__} = $history;
851}
852
8531;